gnat-1.67-src/ 755 10015 7640 0 5506244524 6245 gnat-1.67-src/rtl/ 755 10015 7640 0 5506244270 7044 gnat-1.67-src/rtl/Makefile 444 10015 7640 1121 5506244250 10560 CC = gcc CFLAGS = -O2 GNAT_RTL_OBJS = \ ada.o ada-io_exceptions.ads ada-tags.o ada-text_io.o ada-text_io-aux.o \ io_exceptions.ads system-img_b.o system-img_c.o system-img_f.o \ system-img_i.o system-img_lf.o system-img_llf.o system-img_lli.o \ system-img_sf.o system-storage_elements.o system-xp.o system-xp_f.o \ system-xp_i.o system-xp_lf.o system-xp_li.o system-xp_llf.o \ system-xp_lli.o system-xp_sf.o system-xp_si.o system-xp_ssi.o system.o \ text_io.ads ttypes.o .SUFFIXES: .adb .ads .adb.o: $(CC) -c $(CFLAGS) $< .ads.o: $(CC) -c $(CFLAGS) $< gnatrtl: $(GNAT_RTL_OBJS) ¡ io_exceptions.adsn¡io-aux.c 4¡$system-assertions.adsghP¡ system-img_b.adb.–l¡ system-img_b.adsnarˆ¡ system-img_c.adbrc-¤¡` system-img_c.adsÀ¡a system-img_f.adb Ü¡b system-img_f.adsL.pø¡c system-img_i.adbÜ¡d system-img_i.adsncl0¡e system-img_lf.adbL¡f system-img_lf.adsh¡g system-img_lgnat-1.67-src/rtl/ada.ads 444 10015 7640 3514 5506244250 10346 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- A D A -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ package Ada is -- pragma Pure (Ada); end Ada; db¡‚(unchecked_deallocation.adsÐ.Â.rnlastà.Ã.rnsoftì.Ä.syü.Å.twmrc$.Æ.xerrors<.Ç .xinitrc.mwmT.Égnat-1.67-src/rtl/ada-direct_io.ads 444 10015 7640 10355 5506244250 12326 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- A D A . D I R E C T _ I O -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; with Ada.IO_Exceptions; generic type Element_Type is private; package Ada.Direct_IO is type File_Type is limited private; type File_Mode is (In_File, Inout_File, Out_File); type Count is range 0 .. Long_Long_Integer'Last; subtype Positive_Count is Count range 1 .. Count'Last; --------------------- -- File Management -- --------------------- procedure Create (File : in out File_Type; Mode : in File_Mode := Inout_File; Name : in String := ""; Form : in String := ""); procedure Open (File : in out File_Type; Mode : in File_Mode; Name : in String; Form : in String := ""); procedure Close (File : in out File_Type); procedure Delete (File : in out File_Type); procedure Reset (File : in out File_Type; Mode : in File_Mode); procedure Reset (File : in out File_Type); function Mode (File : in File_Type) return File_Mode; function Name (File : in File_Type) return String; function Form (File : in File_Type) return String; function Is_Open (File : in File_Type) return Boolean; --------------------------------- -- Input and Output Operations -- --------------------------------- procedure Read (File : in File_Type; Item : out Element_Type; From : Positive_Count); procedure Read (File : in File_Type; Item : out Element_Type); procedure Write (File : in File_Type; Item : in Element_Type; To : Positive_Count); procedure Write (File : in File_Type; Item : in Element_Type); procedure Set_Index (File : in File_Type; To : in Positive_Count); function Index (File : in File_Type) return Positive_Count; function Size (File : in File_Type) return Count; function End_Of_File (File : in File_Type) return Boolean; ---------------- -- Exceptions -- ---------------- Status_Error : exception renames IO_Exceptions.Status_Error; Mode_Error : exception renames IO_Exceptions.Mode_Error; Name_Error : exception renames IO_Exceptions.Name_Error; Use_Error : exception renames IO_Exceptions.Use_Error; Device_Error : exception renames IO_Exceptions.Device_Error; End_Error : exception renames IO_Exceptions.End_Error; Data_Error : exception renames IO_Exceptions.Data_Error; private -- Dummy definition (body not yet implemented) ??? type File_Type is new Integer; end Ada.Direct_IO; ------------------------------------------- pragma Ada_9X; with Ada.IO_Exceptions; generic type Element_Type is private; package Ada.Direct_IO is type File_Type is limited private; type File_Mode is (In_File, Inout_File, Out_File); type Count is range 0gnat-1.67-src/rtl/ada-exceptions.ads 444 10015 7640 4615 5506244251 12531 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- A D A . E X C E P T I O N S -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; package Ada.Exceptions is type Exception_Occurrence is private; Null_Occurrence : constant Exception_Occurrence; function Exception_Name (X : Exception_Occurrence) return String; function Exception_Message (X : Exception_Occurrence) return String; function Exception_Information (X : Exception_Occurrence) return String; procedure Reraise_Occurrence (X : Exception_Occurrence); private -- Dummy definitions for now (body not implemented yet) ??? type Exception_Occurrence is new Integer; Null_Occurrence : constant Exception_Occurrence := 0; end Ada.Exceptions; Type; Mode : in File_Mode; Name : in String; Form : gnat-1.67-src/rtl/ada-finalization.ads 444 10015 7640 5045 5506244251 13035 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- A D A . F I N A L I Z A T I O N -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; with System.Finalization_Implementation; use System; package Ada.Finalization is type Controlled is abstract new Finalization_Implementation.Root_Controlled with null record; procedure Initialize (Object : in out Controlled); procedure Split (Object : in out Controlled) is abstract; procedure Finalize (Object : in out Controlled) is abstract; Root_Part : Finalization_Implementation.Root_Controlled renames Finalization_Implementation.Root_Part; type Limited_Controlled is abstract new Finalization_Implementation.Root_Limited_Controlled with null record; procedure Initialize (Object : in out Limited_Controlled); procedure Finalize (Object : in out Limited_Controlled) is abstract; end Ada.Finalization; ----------------------------------------- -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- A D A . F I N A L I Z A T I O N -- -- -- -- S pgnat-1.67-src/rtl/ada-io_exceptions.ads 444 10015 7640 4107 5506244251 13214 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- A D A . I O _ E X C E P T I O N S -- -- -- -- S p e c -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; package Ada.IO_Exceptions is Status_Error : exception; Mode_Error : exception; Name_Error : exception; Use_Error : exception; Device_Error : exception; End_Error : exception; Data_Error : exception; Layout_Error : exception; end Ada.IO_Exceptions; olled) is abstract; procedure Finalize (Object : in out Controlled) is abstract; Root_Part : Finalization_Implementation.Root_Controlled renames Finalization_Implementation.Root_Part; type Limited_Controlled is abstract new Finalization_Implementation.Root_Limited_Controlled with null record; procedure Initialize (Object : in out Limited_Controlled); procedure Finalize (Object : in out Limited_Controlled) gnat-1.67-src/rtl/ada-sequential_io.ads 444 10015 7640 7414 5506244251 13211 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- A D A . S E Q U E N T I A L _ I O -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; with Ada.IO_Exceptions; generic type Element_Type (<>) is private; package Ada.Sequential_IO is type File_Type is limited private; type File_Mode is (In_File, Out_File, Append_File); --------------------- -- File management -- --------------------- procedure Create (File : in out File_Type; Mode : in File_Mode := Out_File; Name : in String := ""; Form : in String := ""); procedure Open (File : in out File_Type; Mode : in File_Mode; Name : in String; Form : in String := ""); procedure Close (File : in out File_Type); procedure Delete (File : in out File_Type); procedure Reset (File : in out File_Type; Mode : in File_Mode); procedure Reset (File : in out File_Type); function Mode (File : in File_Type) return File_Mode; function Name (File : in File_Type) return String; function Form (File : in File_Type) return String; function Is_Open (File : in File_Type) return Boolean; --------------------------------- -- Input and output operations -- --------------------------------- procedure Read (File : in File_Type; Item : out Element_Type); procedure Write (File : in File_Type; Item : in Element_Type); function End_Of_File (File : in File_Type) return Boolean; ---------------- -- Exceptions -- ---------------- Status_Error : exception renames IO_Exceptions.Status_Error; Mode_Error : exception renames IO_Exceptions.Mode_Error; Name_Error : exception renames IO_Exceptions.Name_Error; Use_Error : exception renames IO_Exceptions.Use_Error; Device_Error : exception renames IO_Exceptions.Device_Error; End_Error : exception renames IO_Exceptions.End_Error; Data_Error : exception renames IO_Exceptions.Data_Error; private -- Dummy definition for now (body not yet implemented) type File_Type is new Integer; end Ada.Sequential_IO; gnat-1.67-src/rtl/ada-storage_io.ads 444 10015 7640 5042 5506244251 12476 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- A D A . S T O R A G E _ I O -- -- -- -- S p e c -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; with Ada.IO_Exceptions; with System.Storage_Elements; generic type Element_Type is private; package Ada.Storage_IO is Buffer_Size : constant System.Storage_Elements.Storage_Count := (Element_Type'Size + System.Storage_Unit - 1) / System.Storage_Unit; subtype Buffer_Type is System.Storage_Elements.Storage_Array (1 .. Buffer_Size); --------------------------------- -- Input and Output Operations -- --------------------------------- procedure Read (Buffer : in Buffer_Type; Item : out Element_Type); procedure Write (Buffer : out Buffer_Type; Item : in Element_Type); ---------------- -- Exceptions -- ---------------- Data_Error : exception renames IO_Exceptions.Data_Error; end Ada.Storage_IO; in out File_Type; Mode : in File_Mode); procedure Reset (File : in out File_Type); function Mode (File : in File_Type) return File_Mode; function Name (File : in File_Type) return String; function Form (File : in File_Type) return String; function Is_Open (File : in File_Type) return Boolean; --------------------------------- -- Input and output operations -- --------------------------------- procedure Read (File : in File_Type; Ignat-1.67-src/rtl/ada-storage_io.adb 444 10015 7640 5070 5506244252 12457 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- A D A . S T O R A G E _ I O -- -- -- -- B o d y -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; with Unchecked_Conversion; package body Ada.Storage_IO is package Buffer_Ops is new System.Storage_Elements.Address_To_Access_Conversions (Buffer_Type); package Element_Ops is new System.Storage_Elements.Address_To_Access_Conversions (Element_Type); ---------- -- Read -- ---------- procedure Read (Buffer : in Buffer_Type; Item : out Element_Type) is begin Element_Ops.To_Pointer (Item'Address).all := Element_Ops.To_Pointer (Buffer'Address).all; end Read; ----------- -- Write -- ----------- procedure Write (Buffer : out Buffer_Type; Item : in Element_Type) is begin Element_Ops.To_Pointer (Buffer'Address).all := Element_Ops.To_Pointer (Item'Address).all; end Write; end Ada.Storage_IO; e : in File_Mode); procedure Reset (File : in out File_Type); function Mode (File : in File_Type) return File_Mode; function Name (File : in File_Type) return String; function Form (File : in File_Type) return String; function Is_Open (File : in File_Type) return Boolean; --------------------------------- -- Input and output operations -- --------------------------------- procedure Read (File : in File_Type; Ignat-1.67-src/rtl/ada-streams.ads 444 10015 7640 6175 5506244252 12032 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- A D A . S T R E A M S -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; with System.Storage_Elements; with Ada.Tags; with Ada.Exceptions; package Ada.Streams is pragma Pure (Streams); type Root_Stream_Type is abstract tagged limited private; procedure Read ( Stream : in out Root_Stream_Type; Item : out System.Storage_Elements.Storage_Array; Last : out System.Storage_Elements.Storage_Offset) is abstract; procedure Write ( Stream : in out Root_Stream_Type; Item : in System.Storage_Elements.Storage_Array) is abstract; private -- Dummy definition for now (body not implemented yet) ??? type Root_Stream_Type is tagged null record; end Ada.Streams; function Mode (File : in File_Type) return File_Mode; function Name (File : in File_Type) return String; function Form (File : in File_Type) return String; function Is_Open (File : in File_Type) return Boolean; --------------------------------- -- Input and output operations -- --------------------------------- procedure Read (File : in File_Type; Ignat-1.67-src/rtl/ada-streams-stream_io.ads 444 10015 7640 11525 5506244252 14025 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- A D A . S T R E A M S . S T R E A M _ I O -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; with Ada.IO_Exceptions; package Ada.Streams.Stream_IO is type Stream_Access is access Root_Stream_Type'Class; type File_Type is limited private; type File_Mode is (In_File, Out_File, Append_File); type Count is range 0 .. Long_Long_Integer'Last; subtype Positive_Count is Count range 1 .. Count'Last; --------------------- -- File Management -- --------------------- procedure Create (File : in out File_Type; Mode : in File_Mode := Out_File; Name : in String := ""; Form : in String := ""); procedure Open (File : in out File_Type; Mode : in File_Mode; Name : in String; Form : in String := ""); procedure Close (File : in out File_Type); procedure Delete (File : in out File_Type); procedure Reset (File : in out File_Type; Mode : in File_Mode); procedure Reset (File : in out File_Type); function Mode (File : in File_Type) return File_Mode; function Name (File : in File_Type) return String; function Form (File : in File_Type) return String; function Is_Open (File : in File_Type) return Boolean; function Stream (File : in File_Type) return Stream_Access; ----------------------------- -- Input-Output Operations -- ----------------------------- procedure Read ( File : in File_Type; Item : out System.Storage_Elements.Storage_Array; Last : out System.Storage_Elements.Storage_Offset; From : in Positive_Count); procedure Read ( File : in File_Type; Item : out System.Storage_Elements.Storage_Array; Last : out System.Storage_Elements.Storage_Offset); procedure Write ( File : in File_Type; Item : in System.Storage_Elements.Storage_Array; To : in Positive_Count); procedure Write ( File : in File_Type; Item : in System.Storage_Elements.Storage_Array); ---------------------------------------- -- Operations on Position within File -- ---------------------------------------- procedure Set_Index (File : in File_Type; To : in Positive_Count); function Index (File : in File_Type) return Positive_Count; function Size (File : in File_Type) return Count; function End_Of_File (File : in File_Type) return Boolean; procedure Set_Mode (File : in out File_Type; Mode : in File_Mode); procedure Flush (File : in out File_Type); ---------------- -- Exceptions -- ---------------- Status_Error : exception renames IO_Exceptions.Status_Error; Mode_Error : exception renames IO_Exceptions.Mode_Error; Name_Error : exception renames IO_Exceptions.Name_Error; Use_Error : exception renames IO_Exceptions.Use_Error; Device_Error : exception renames IO_Exceptions.Device_Error; End_Error : exception renames IO_Exceptions.End_Error; Data_Error : exception renames IO_Exceptions.Data_Error; private -- Dummy definition (body not writen yet) ??? type File_Type is new Integer; end Ada.Streams.Stream_IO; S T R E A M S . S T R E A M _ I O -- -- -- -- S pgnat-1.67-src/rtl/ada-tags.adb 444 10015 7640 4625 5506244252 11267 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- A D A . T A G S -- -- -- -- B o d y -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; package body Ada.Tags is ------------------- -- Expanded_Name -- ------------------- function Expanded_Name (T : Tag) return String is begin raise Program_Error; -- TBSL return ""; end; ------------------ -- External_Tag -- ------------------ function External_Tag (T : Tag) return String is begin raise Program_Error; -- TBSL return ""; end; ------------------ -- Internal_Tag -- ------------------ function Internal_Tag (External : String) return Tag is begin raise Program_Error; -- TBSL return null; end; end Ada.Tags; (File : in out File_Type; Mode : in File_Mode; Name : in Stringnat-1.67-src/rtl/ada-tags.ads 444 10015 7640 4112 5506244253 11300 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- A D A . T A G S -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; package Ada.Tags is type Tag is private; function Expanded_Name (T : Tag) return String; function External_Tag (T : Tag) return String; function Internal_Tag (External : String) return Tag; Tag_Error : exception; private type Tag is access Integer; end Ada.Tags; function External_Tag (T : Tag) return String is begin raise Program_Error; -- TBSL return ""; end; ------------------ -- Internal_Tag -- ------------------ function Internal_Tag (External : String) return Tag is begin raise Program_Error; -- TBSL return null; end; end Ada.Tags; (File : in out File_Type; Mode : in File_Mode; Name : in Stringnat-1.67-src/rtl/ada-text_io.ads 444 10015 7640 35312 5506244253 12043 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- A D A . T E X T _ I O -- -- -- -- S p e c -- -- -- -- $Revision: 1.9 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; with Ada.IO_Exceptions; package Ada.Text_IO is type File_Type is limited private; type File_Mode is (In_File, Out_File, Append_File); type Count is range 0 .. Integer'Last; -- implementation defined; subtype Positive_Count is Count range 1 .. Count'Last; Unbounded : constant Count := 0; -- line and page length subtype Field is Integer range 0 .. 100; -- implementation defined subtype Number_Base is Integer range 2 .. 16; type Type_Set is (Lower_Case, Upper_Case); --------------------- -- File Management -- --------------------- procedure Create (File : in out File_Type; Mode : in File_Mode := Out_File; Name : in String := ""; Form : in String := ""); procedure Open (File : in out File_Type; Mode : in File_Mode; Name : in String; Form : in String := ""); procedure Close (File : in out File_Type); procedure Delete (File : in out File_Type); procedure Reset (File : in out File_Type; Mode : in File_Mode); procedure Reset (File : in out File_Type); function Mode (File : in File_Type) return File_Mode; function Name (File : in File_Type) return String; function Form (File : in File_Type) return String; function Is_Open (File : in File_Type) return Boolean; ------------------------------------------------------ -- Control of default input, output and error files -- ------------------------------------------------------ procedure Set_Input (File : in File_Type); procedure Set_Output (File : in File_Type); procedure Set_Error (File : in File_Type); function Standard_Input return File_Type; function Standard_Output return File_Type; function Standard_Error return File_Type; function Current_Input return File_Type; function Current_Output return File_Type; function Current_Error return File_Type; -------------------------------------------- -- Specification of line and page lengths -- -------------------------------------------- procedure Set_Line_Length (File : in File_Type; To : in Count); procedure Set_Line_Length (To : in Count); procedure Set_Page_Length (File : in File_Type; To : in Count); procedure Set_Page_Length (To : in Count); function Line_Length (File : in File_Type) return Count; function Line_Length return Count; function Page_Length (File : in File_Type) return Count; function Page_Length return Count; ------------------------------------ -- Column, Line, and Page Control -- ------------------------------------ procedure New_Line (File : in File_Type; Spacing : in Positive_Count := 1); procedure New_Line (Spacing : in Positive_Count := 1); procedure Skip_Line (File : in File_Type; Spacing : in Positive_Count := 1); procedure Skip_Line (Spacing : in Positive_Count := 1); function End_Of_Line (File : in File_Type) return Boolean; function End_Of_Line return Boolean; procedure New_Page (File : in File_Type); procedure New_Page; procedure Skip_Page (File : in File_Type); procedure Skip_Page; function End_Of_Page (File : in File_Type) return Boolean; function End_Of_Page return Boolean; function End_Of_File (File : in File_Type) return Boolean; function End_Of_File return Boolean; procedure Set_Col (File : in File_Type; To : in Positive_Count); procedure Set_Col (To : in Positive_Count); procedure Set_Line (File : in File_Type; To : in Positive_Count); procedure Set_Line (To : in Positive_Count); function Col (File : in File_Type) return Positive_Count; function Col return Positive_Count; function Line (File : in File_Type) return Positive_Count; function Line return Positive_Count; function Page (File : in File_Type) return Positive_Count; function Page return Positive_Count; ----------------------------- -- Characters Input-Output -- ----------------------------- procedure Get (File : in File_Type; Item : out Character); procedure Get (Item : out Character); procedure Put (File : in File_Type; Item : in Character); procedure Put (Item : in Character); -------------------------- -- Strings Input-Output -- -------------------------- procedure Get (File : in File_Type; Item : out String); procedure Get (Item : out String); procedure Put (File : in File_Type; Item : in String); procedure Put (Item : in String); procedure Get_Line (File : in File_Type; Item : out String; Last : out Natural); procedure Get_Line (Item : out String; Last : out Natural); procedure Put_Line (File : in File_Type; Item : in String); procedure Put_Line (Item : in String); ----------------------------------- -- Input-Output of Integer Types -- ----------------------------------- generic type Num is range <>; package Integer_Io is Default_Width : Field := 10; -- Num'Width Default_Base : Number_Base := 10; procedure Get (File : in File_Type; Item : out Num; Width : in Field := 0); procedure Get (Item : out Num; Width : in Field := 0); procedure Put (File : in File_Type; Item : in Num; Width : in Field := Default_Width; Base : in Number_Base := Default_Base); procedure Put (Item : in Num; Width : in Field := Default_Width; Base : in Number_Base := Default_Base); procedure Get (From : in String; Item : out Num; Last : out Positive); procedure Put (To : out String; Item : in Num; Base : in Number_Base := Default_Base); end Integer_Io; ----------------------------------- -- Input-Output of Modular Types -- ----------------------------------- -- Not yet implemented ??? -- generic -- type Num is mod <>; -- package Modular_IO is -- Default_Width : Field := Num'Width; -- Default_Base : Number_Base := 10; -- procedure Get (File : in File_Type; -- Item : out Num; -- Width : in Field := 0); -- procedure Get (Item : out Num; -- Width : in Field := 0); -- procedure Put (File : in File_Type; -- Item : in Num; -- Width : in Field := Default_Width; -- Base : in Number_Base := Default_Base); -- procedure Put (Item : in Num; -- Width : in Field := Default_Width; -- Base : in Number_Base := Default_Base); -- procedure Get (From : in String; -- Item : out Num; -- Last : out Positive); -- procedure Put (To : out String; -- Item : in Num; -- Base : in Number_Base := Default_Base); -- -- end Modular_IO; -------------------------------- -- Input-Output of Real Types -- -------------------------------- generic type Num is digits <>; package Float_Io is Default_Fore : Field := 2; Default_Aft : Field := 5; -- Num'Digits - 1; Default_Exp : Field := 3; procedure Get (File : in File_Type; Item : out Num; Width : in Field := 0); procedure Get (Item : out Num; Width : in Field := 0); procedure Put (File : in File_Type; Item : in Num; Fore : in Field := Default_Fore; Aft : in Field := Default_Aft; Exp : in Field := Default_Exp); procedure Put (Item : in Num; Fore : in Field := Default_Fore; Aft : in Field := Default_Aft; Exp : in Field := Default_Exp); procedure Get (From : in String; Item : out Num; Last : out Positive); procedure Put (To : out String; Item : in Num; Aft : in Field := Default_Aft; Exp : in Field := Default_Exp); end Float_Io; -- Fixed point I/O not yet implemented ??? -- generic -- type Num is delta <>; -- package Fixed_Io is -- Default_Fore : Field := Num'For; -- Default_Aft : Field := Num'Aft; -- Default_Exp : Field := 0; -- procedure Get (File : in File_Type; -- Item : out Num; -- Width : in Field := 0); -- procedure Get (Item : out Num; Width : in Field := 0); -- procedure Put (File : in File_Type; -- Item : in Num; -- Fore : in Field := Default_Fore; -- Aft : in Field := Default_Aft; -- Exp : in Field := Default_Exp); -- procedure Put (Item : in Num; -- Fore : in Field := Default_Fore; -- Aft : in Field := Default_Aft; -- Exp : in Field := Default_Expr); -- procedure Get (From : in String; Item : out Num; Last : out Positive); -- procedure Put (To : out String; -- Item : in Num; -- Aft : in Field := Default_Aft; -- Exp : in Field := Default_Exp); -- end Fixed_Io; -- generic -- type Num is delta <> digits <>; -- package Decimal_IO is -- -- Default_Fore : Field := Num'Fore; -- Default_Aft : Field := Num'Aft; -- Default_Exp : Field := 0; -- procedure Get (File : in File_Type; -- Item : out Num; -- Width : in Field := 0); -- procedure Get (Item : out Num; -- Width : in Field := 0); -- procedure Put (File : in File_Type; -- Item : in Num; -- Fore : in Field := Default_Fore; -- Aft : in Field := Default_Aft; -- Exp : in Field := Default_Exp); -- procedure Put (Item : in Num; -- Fore : in Field := Default_Fore; -- Aft : in Field := Default_Aft; -- Exp : in Field := Default_Exp); -- procedure Get (From : in String; -- Item : out Num; -- Last : out Positive); -- procedure Put (To : out String; -- Item : in Num; -- Aft : in Field := Default_Aft; -- Exp : in Field := Default_Exp); -- end Decimal_IO; --------------------------------------- -- Input-Output of Enumeration Types -- --------------------------------------- generic type Enum is ( <> ); package Enumeration_Io is Default_Width : Field := 0; Default_Setting : Type_Set := Upper_Case; procedure Get (File : in File_Type; Item : out Enum); procedure Get (Item : out Enum); procedure Put (File : in File_Type; Item : in Enum; Width : in Field := Default_Width; Set : in Type_Set := Default_Setting); procedure Put (Item : in Enum; Width : in Field := Default_Width; Set : in Type_Set := Default_Setting); procedure Get (From : in String; Item : out Enum; Last : out positive); procedure Put (To : out String; Item : in Enum; Set : in Type_Set := Default_Setting); end Enumeration_Io; -- Exceptions Status_Error : exception renames IO_Exceptions.Status_Error; Mode_Error : exception renames IO_Exceptions.Mode_Error; Name_Error : exception renames IO_Exceptions.Name_Error; Use_Error : exception renames IO_Exceptions.Use_Error; Device_Error : exception renames IO_Exceptions.Device_Error; End_Error : exception renames IO_Exceptions.End_Error; Data_Error : exception renames IO_Exceptions.Data_Error; Layout_Error : exception renames IO_Exceptions.Layout_Error; private type File_Ptr is mod 2#1#E32; type Pstring is access String; -- Ada File Control Block (Afcb) type AFCB is record AFCB_In_Use : Boolean; Desc : File_Ptr; Name : Pstring; Form : Pstring; Mode : File_Mode; Page : Count; Line : Count; Col : Positive_Count; Line_Length : Count; Page_Length : Count; Count : Integer; Look_Ahead : String (1 .. 3); end record; type File_Type is access AFCB; end Ada.Text_IO; of Integer Types -- ----------------------------------- generic type Num is range <>; package Integer_Io is Default_Width : Field := 10; -- Num'Width Default_Base : Number_Base := 10; procedure Get (File : in File_Type; Item : out Num; gnat-1.67-src/rtl/ada-text_io.adb 444 10015 7640 34617 5506244253 12031 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- A D A . T E X T _ I O -- -- -- -- B o d y -- -- -- -- $Revision: 1.10 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO.Aux; package body Ada.Text_IO is procedure Unimplemented (Message : String) is begin Put (Message); Put_Line (" not implemented yet"); end Unimplemented; --------------------- -- File Management -- --------------------- procedure Create (File : in out File_Type; Mode : in File_Mode := Out_File; Name : in String := ""; Form : in String := "") renames Text_IO.Aux.Create; procedure Open (File : in out File_Type; Mode : in File_Mode; Name : in String; Form : in String := "") renames Text_IO.Aux.Open; procedure Close (File : in out File_Type) renames Text_IO.Aux.Close; procedure Delete (File : in out File_Type) renames Text_IO.Aux.Delete; procedure Reset (File : in out File_Type; Mode : in File_Mode) renames Text_IO.Aux.Reset; procedure Reset (File : in out File_Type) is begin Text_IO.Aux.Reset (File, Text_IO.Aux.Mode (File)); end Reset; function Mode (File : in File_Type) return File_Mode renames Text_IO.Aux.Mode; function Name (File : in File_Type) return String renames Text_IO.Aux.Name; function Form (File : in File_Type) return String renames Text_IO.Aux.Form; function Is_Open (File : in File_Type) return Boolean renames Text_IO.Aux.Is_Open; procedure Set_Input (File : in File_Type) renames Text_IO.Aux.Set_Input; procedure Set_Output (File : in File_Type) renames Text_IO.Aux.Set_Output; procedure Set_Error (File : in File_Type) renames Text_IO.Aux.Set_Error; function Standard_Input return File_Type renames Text_IO.Aux.Standard_Input; function Standard_Output return File_Type renames Text_IO.Aux.Standard_Output; function Standard_Error return File_Type renames Text_IO.Aux.Standard_Error; function Current_Input return File_Type renames Text_IO.Aux.Current_Input; function Current_Output return File_Type renames Text_IO.Aux.Current_Output; function Current_Error return File_Type renames Text_IO.Aux.Current_Error; -------------------------------------------- -- specification of line and page lengths -- -------------------------------------------- procedure Set_Line_Length (File : in File_Type; To : in Count) renames Text_IO.Aux.Set_Line_Length; procedure Set_Line_Length (To : in Count) is begin Text_IO.Aux.Set_Line_Length (Current_Output, To); end Set_Line_Length; function Line_Length (File : in File_Type) return Count renames Text_IO.Aux.Line_Length; function Line_Length return Count is begin return Text_IO.Aux.Line_Length (Current_Output); end Line_Length; procedure Set_Page_Length (File : in File_Type; To : in Count) renames Text_IO.Aux.Set_Page_Length; procedure Set_Page_Length (To : in Count) is begin Text_IO.Aux.Set_Page_Length (Current_Output, To); end Set_Page_Length; function Page_Length (File : in File_Type) return Count renames Text_IO.Aux.Page_Length; function Page_Length return Count is begin return Page_Length (Current_Output); end Page_Length; ------------------------------------ -- Column, Line, and Page Control -- ------------------------------------ procedure New_Line (File : in File_Type; Spacing : in Positive_Count := 1) renames Text_IO.Aux.New_Line; procedure New_Line (Spacing : in Positive_Count := 1) is begin New_Line (Current_Output, Spacing); end New_Line; procedure Skip_Line (File : in File_Type; Spacing : in Positive_Count := 1) renames Text_IO.Aux.Skip_Line; procedure Skip_Line (Spacing : in Positive_Count := 1) is begin Skip_Line (Current_Input, Spacing); end Skip_Line; function End_Of_Line (File : in File_Type) return Boolean renames Text_IO.Aux.End_Of_Line; function End_Of_Line return Boolean is begin return End_Of_Line (Current_Input); end End_Of_Line; procedure New_Page (File : in File_Type) renames Text_IO.Aux.New_Page; procedure New_Page is begin New_Page (Current_Output); end New_Page; procedure Skip_Page (File : in File_Type) renames Text_IO.Aux.Skip_Page; procedure Skip_Page is begin Skip_Page (Current_Input); end Skip_Page; function End_Of_Page (File : in File_Type) return Boolean renames Text_IO.Aux.End_Of_Page; function End_Of_Page return Boolean is begin return End_Of_Page (Current_Input); end End_Of_Page; function End_Of_File (File : in File_Type) return Boolean renames Text_IO.Aux.End_Of_File; function End_Of_File return Boolean is begin return End_Of_File (Current_Input); end End_Of_File; procedure Set_Col (File : in File_Type; To : in Positive_Count) renames Text_IO.Aux.Set_Col; procedure Set_Col (To : in Positive_Count) is begin Set_Col (Current_Output, To); end Set_Col; procedure Set_Line (File : in File_Type; To : in Positive_Count) renames Text_IO.Aux.Set_Line; procedure Set_Line (To : in Positive_Count) is begin Set_Line (Current_Output, To); end Set_Line; function Col (File : in File_Type) return Positive_Count renames Text_IO.Aux.Col; function Col return Positive_Count is begin return Col (Current_Output); end Col; function Line (File : in File_Type) return Positive_Count renames Text_IO.Aux.Line; function Line return Positive_Count is begin return Line (Current_Output); end Line; function Page (File : in File_Type) return Positive_Count renames Text_IO.Aux.Page; function Page return Positive_Count is begin return Page (Current_Output); end Page; ------------------------------- -- Characters Input-Output -- ------------------------------- procedure Get (File : in File_Type; Item : out Character) is begin Text_IO.Aux.The_File := File; Text_IO.Aux.Get (Item); end Get; procedure Get (Item : out Character) is begin Get (Current_Input, Item); end Get; procedure Put (File : in File_Type; Item : in Character) is begin Text_IO.Aux.The_File := File; Text_IO.Aux.Put (Item); end Put; procedure Put (Item : in Character) is begin Put (Current_Output, Item); end Put; ---------------------------- -- Strings Input-Output -- ---------------------------- procedure Get (File : in File_Type; Item : out String) is begin Text_IO.Aux.The_File := File; Text_IO.Aux.Get (Item); end Get; procedure Get (Item : out String) is begin Get (Current_Input, Item); end Get; procedure Put (File : in File_Type; Item : in String) is begin Text_IO.Aux.The_File := File; Text_IO.Aux.Put (Item); end Put; procedure Put (Item : in String) is begin Put (Current_Output, Item); end Put; procedure Get_Line (File : in File_Type; Item : out String; Last : out Natural) renames Text_IO.Aux.Get_Line; procedure Get_Line (Item : out String; Last : out Natural) is begin Get_Line (Current_Input, Item, Last); end Get_Line; procedure Put_Line (File : in File_Type; Item : in String) renames Text_IO.Aux.Put_Line; procedure Put_Line (Item : in String) is begin Put_Line (Current_Output, Item); end Put_Line; ------------------------------------- -- Input-Output of Integer Types -- ------------------------------------- package body Integer_Io is procedure Get (File : in File_Type; Item : out Num; Width : in Field := 0) is X : Integer; begin Text_IO.Aux.The_File := File; -- Some type of check against Integer'Last is necessary Text_IO.Aux.Get_Int (X, Width); if X < Integer (Num'First) or else X > Integer (Num'Last) then raise Data_Error; end if; Item := Num (X); end Get; procedure Get (Item : out Num; Width : in Field := 0) is begin Get (Current_Input, Item, Width); end Get; procedure Put (File : in File_Type; Item : in Num; Width : in Field := Default_Width; Base : in Number_Base := Default_Base) is begin Text_IO.Aux.The_File := File; Text_IO.Aux.Put_Int (Integer (Item), Width, Base); end Put; procedure Put (Item : in Num; Width : in Field := Default_Width; Base : in Number_Base := Default_Base) is begin Put (Current_Output, Item, Width, Base); end Put; procedure Get (From : in String; Item : out Num; Last : out positive) is X : Integer; begin -- Some type of check against Integer'Last is necessary Text_IO.Aux.Get_Int (From, X, Last); if X < Integer (Num'First) or else X > Integer (Num'Last) then raise Data_Error; end if; Item := Num (X); end Get; procedure Put (To : out String; Item : in Num; Base : in Number_Base := Default_Base) is begin Text_IO.Aux.Put_Int (To, Integer (Item), Base); end Put; end Integer_Io; ------------------------------------ -- Input-Output of Float Types -- ------------------------------------ package body Float_Io is procedure Get (File : in File_Type; Item : out Num; Width : in Field := 0) is begin Text_IO.Aux.The_File := File; -- Some type of check against Float'Last is necessary Text_IO.Aux.Get_Float (Float (Item), Width); end Get; procedure Get (Item : out Num; Width : in Field := 0) is begin Get (Current_Input, Item, Width); end Get; procedure Put (File : in File_Type; Item : in Num; Fore : in Field := Default_Fore; Aft : in Field := Default_Aft; Exp : in Field := Default_Exp) is begin Text_IO.Aux.The_File := File; Text_IO.Aux.Put_Float (Float (Item), Fore, Aft, Exp); end Put; procedure Put (Item : in Num; Fore : in Field := Default_Fore; Aft : in Field := Default_Aft; Exp : in Field := Default_Exp) is begin Put (Current_Output, Item, Fore, Aft, Exp); end Put; procedure Get (From : in String; Item : out Num; Last : out Positive) is begin Text_IO.Aux.Get_Float (From, Float (Item), Last); end Get; procedure Put (To : out String; Item : in Num; Aft : in Field := Default_Aft; Exp : in Field := Default_Exp) is begin Text_IO.Aux.Put_Float (To, Float (Item), Aft, Exp); end Put; end Float_Io; --------------------------------------- -- Input-Output of Enumeration Types -- --------------------------------------- package body Enumeration_Io is procedure Get (File : in File_Type; Item : out Enum) is use Text_IO.Aux; begin Unimplemented ("Enumeration_IO.Get"); end Get; procedure Get (Item : out Enum) is begin Unimplemented ("Enumeration_IO.Get"); end Get; procedure Put (File : in File_Type; Item : in Enum; Width : in Field := Default_Width; Set : in Type_Set := Default_Setting) is begin Unimplemented ("Enumeration_IO.Put"); end Put; procedure Put (Item : in Enum; Width : in Field := Default_Width; Set : in Type_Set := Default_Setting) is begin Unimplemented ("Enumeration_IO.Put"); end Put; procedure Get (From : in String; Item : out Enum; Last : out positive) is use Text_IO.Aux; begin Unimplemented ("Enumeration_IO.Get"); end Get; procedure Put (To : out String; Item : in Enum; Set : in Type_Set := Default_Setting) is begin Unimplemented ("Enumeration_IO.Put"); end Put; end Enumeration_Io; end Ada.Text_IO; tion End_Of_File return Boolean is begin return End_Of_File (Current_Input); end End_Of_File; prognat-1.67-src/rtl/ada-text_io-aux.ads 444 10015 7640 15702 5506244254 12640 ------------------------------------------------------------------------------ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- -- A D A . T E X T _ I O . A U X -- -- -- -- S p e c -- -- -- -- $Revision: 1.9 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ private package Ada.Text_Io.Aux is Current_In : File_Type; Current_Out : File_Type; Current_Err : File_Type; The_File : File_Type; procedure Create (File : in out File_Type; Mode : in File_Mode := Out_File; Name : in String := ""; Form : in String := ""); procedure Open (File : in out File_Type; Mode : in File_Mode; Name : in String; Form : in String := ""); procedure Close (File : in out File_Type); procedure Delete (File : in out File_Type); procedure Reset (File : in out File_Type; Mode : in File_Mode); function Mode (File : in File_Type) return File_Mode; function Name (File : in File_Type) return String; function Form (File : in File_Type) return String; function Is_Open (File : in File_Type) return Boolean; ------------------------------------------------------ -- Control of default input, output and error files -- ------------------------------------------------------ procedure Set_Input (File : in File_Type); procedure Set_Output (File : in File_Type); procedure Set_Error (File : in File_Type); function Standard_Input return File_Type; function Standard_Output return File_Type; function Standard_Error return File_Type; function Current_Input return File_Type; function Current_Output return File_Type; function Current_Error return File_Type; -------------------------------------------- -- Specification of line and page lengths -- -------------------------------------------- procedure Set_Line_Length (File : in File_Type; To : in Count); procedure Set_Page_Length (File : in File_Type; To : in Count); function Line_Length (File : in File_Type) return Count; function Page_Length (File : in File_Type) return Count; ------------------------------------ -- Column, Line, and Page Control -- ------------------------------------ procedure New_Line (File : in File_Type; Spacing : in Positive_Count := 1); procedure Skip_Line (File : in File_Type; Spacing : in Positive_Count := 1); function End_Of_Line (File : in File_Type) return Boolean; procedure New_Page (File : in File_Type); procedure Skip_Page (File : in File_Type); function End_Of_Page (File : in File_Type) return boolean; function End_Of_File (File : in File_Type) return boolean; procedure Set_Col (File : in File_Type; To : in Positive_Count); procedure Set_Line (File : in File_Type; To : in Positive_Count); function Col (File : in File_Type) return Positive_Count; function Line (File : in File_Type) return Positive_Count; function Page (File : in File_Type) return Positive_Count; ----------------------------- -- Characters Input-Output -- ----------------------------- procedure Get (Item : out Character); procedure Put (Item : in Character); -------------------------- -- Strings Input-Output -- -------------------------- procedure Get (Item : out String); procedure Put (Item : in String); procedure Get_Line (File : in File_Type; Item : out String; Last : out Natural); procedure Put_Line (File : in File_Type; Item : in String); ----------------------------------- -- Input-Output of Integer Types -- ----------------------------------- Default_Width_Int : Field := 11; Default_Base_Int : Number_Base := 10; procedure Get_Int (Item : out Integer; Width : in Field := 0); procedure Put_Int (Item : in Integer; Width : in Field; Base : in Number_Base); procedure Get_Int (From : in String; Item : out Integer; Last : out Positive); procedure Put_Int (To : out String; Item : in Integer; Base : in Number_Base); ----------------------------------- -- Input-Output of Float Types -- ----------------------------------- procedure Get_Float (Item : out Float; Width : in Field); procedure Put_Float (Item : in Float; Fore : in Field; Aft : in Field; Exp : in Field); procedure Get_Float (From : in String; Item : out Float; Last : out Positive); procedure Put_Float (To : out String; Item : in Float; Aft : in Field; Exp : in Field); procedure Text_IO_Finalization; -- Finialization cleanup routine for Text_IO files ---------------------------------------------------------------- -- Variables used to share information with body of Text_IO -- ---------------------------------------------------------------- type Work_String_Type is array (0 .. 1023) of Character; Work_String : Work_String_Type; WS_Length : Natural := 0; WS_Index1 : Natural := 0; WS_Index2 : Natural := 0; WS_Index3 : Natural := 0; end Ada.Text_Io.Aux; t (From : in String; Item : out Enum; gnat-1.67-src/rtl/ada-text_io-aux.adb 444 10015 7640 201701 5506244255 12634 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- A D A . T E X T _ I O . A U X -- -- -- -- B o d y -- -- -- -- $Revision: 1.10 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with System; use System; package body Ada.Text_IO.Aux is Max_Num_Of_Files : constant := 60; Line_Feed : constant Character := Ascii.Lf; -- Character'Val (16#0A#); Nul : constant Character := Ascii.Nul; -- Character'Val (16#00#); Page_Mark : constant Character := Ascii.Ff; -- Character'Val (16#0C#); -- The term "file" here is used in the same way as in the Ada Reference -- Manual, that is it refers to an object of some "file_type". Otherwise -- "external file" is used. Open_Files : array (1 .. Max_Num_Of_Files) of File_Type; -- Used to make sure we don't open too many files and that we do not -- open the same file twice. Standard_In : File_Type; Standard_Out : File_Type; Standard_Err : File_Type; Scanning_From_File : Boolean; -- Determines if characters are read from a File (True) or String (False). type Temp_File_Rec; type Link is access Temp_File_Rec; type Temp_File_Rec is record File_Name : Pstring; Next : Link; end record; Temp_Files : Link; ------------------------ -- Local Subprograms -- ------------------------- procedure Allocate_AFCB; -- Determine which AFCB in the Open_Files table is available to be used -- for the current file. function Alpha (C : Character) return Boolean; -- Predicate to test if Character argument is an upper or lower case -- letter, returns True if the argument is a letter, False if not. function Alphanum (C : Character) return Boolean; -- Predicate to test if Character is an upper or lower case letter -- or a digit. Returns True if the arguement is a letter or a digit, -- False if not. procedure Check_Digit; -- Assert that the next Character is a digit otherwise raise Data_Error. procedure Check_Extended_Digit; -- Assert that the next Character is an extended digit otherwise raise -- Data_Error. procedure Check_File_Open; -- Check if the current file is open or not. If the file is not open, -- then Status_Error is raised. Otherwise control returns normally. procedure Check_Hash (C : Character); -- Determine if next Character is matching hash, raise Data_Error if not. -- Stores '#' in Work_String. procedure Check_Multiple_File_Opens; procedure Check_Opened_Ok; -- Check that an Fopen succeeded, raise Name_Error if not procedure Check_Status_And_Mode (C_Mode : File_Mode); -- If the current file is not open, then Status_Error is raised. If -- the file is open, then the mode is checked against the argument which -- is the desired mode for the operation. If it does not match, then -- Mode_Error is raised, otherwise control returns normally. procedure Check_Status_And_Mode (C_Mode1, C_Mode2 : File_Mode); -- If the current file is not open, then Status_Error is raised. If -- the file is open, then the mode is checked against the arguments which -- are the desired modes for the operation. If it does not match either -- one of them, Mode_Error is raised, otherwise control returns normally. procedure Close_File; -- Close file and deallocate the AFCB back to the pool. procedure Copy_Integer; -- This procedure copies a string with the syntax of "based_Integer" from -- the input to the Work_String. Underscores are allowed but not copied. procedure Copy_Based_Integer; -- This procedure copies a string with the syntax of "based_Integer" from -- the input to the Work_String. Underscores are allowed but not copied. procedure Copyc; -- Copy the next input Character to Work_String using WS_Index2 function Digit (C : Character) return Boolean; -- Predicate if C corresponds to the digits 0 thru 9. function Extended_Digit (C : Character) return Boolean; -- Predicate if C corresponds to the digits 0 thru 9 or letters A thru F. function Graphic (C : Character) return Boolean; -- Predicate to test if the Character is an Ascii graphic letter. -- True if the argument is an Ascii graphic character, False otherwise. function Getcp return Character; -- Gets the next Character from the string or file being scanned according -- to the setting of Scanning_From_File. In string mode, WS_Index1 is -- updated. If no more Characters remain to be scanned, End_Error is -- raised. function Get_Char return Character; -- Get the next character from the current text input file. If no -- character is available, End_Error is raised. procedure Image_Float (Item : Float; Aft, Exp : Field); -- Creates a string image of Item where Aft and Exp control the format -- according to the rules in 14.3.8. The result is placed in Work_String. procedure Image_Integer (Item : Integer; Base : Integer); -- Creates a string image of Item using the given Base and places it -- Work_String. If an out of range value or a bad character is -- encountered, Data_Error is raised. procedure Make_Temp_File_Name; -- Generate a unique file name and use it for the name of the current file. function Nextc return Character; -- Return the next Character to be read from the string file being -- scanned, according to the setting of Scanning_From_File. In string -- mode WS_Index1 is updated. If we are currently at the end of string -- then a line feed is returned. function Page_Is_Not_Terminated return Boolean; -- Indicates whether the current page of current file is not terminated. procedure Put_Blanks (N : Integer); -- Write N blanks to the output. There is no check for line overflow, it -- is assumed that the caller has already checked for this. procedure Put_Buffer (Width : Integer; Pad_Type : Character; Length : Integer); procedure Put_Line1; -- Outputs a line feed to the current text file procedure Put_Page; -- Write a page mark to current text file. procedure Load_Look_Ahead (End_Of_File_Flag : Boolean); -- This procedure loads the lookahead for a TEXT_IO input file, leaving -- CHARS set to 3 (unless the file is less than 3 bytes long), and CHAR1 -- CHAR2 and CHAR3 containing the initial characters of the file. A special -- exception occurs when the standard input file is the keyboard in which -- case we only read 1 character because of interactive I/O except when -- load_look_ahead is called in the case of END_OF_FILE where we want to -- read 2 characters to check for the EOT character. The parameter to this -- routine end_of_file_flag is TRUE when processing for and END_OF_FILE -- situation and is FALSE otherwise. procedure Range_Error; -- Procedure called if scanned number is out of range. function Scan_Based_Int (Base : Integer) return Integer; function Scan_Int return Integer; -- This routine scans an Integer value from the string pointed by the -- global Integer WS_Index2. On exit WS_Index2 is updated to point to -- the first -- non-digit. The result returned is always negative. This allows the -- largest negative Integer value to be properly stored and converted. -- A value of +1 returned indicated that overflow occured. procedure Scan_Integer (Width : Integer; Result : out Integer); -- Procedure to scan an Ada Integer value and return the Integer result -- The parameter Width specifies the width of the field (zero means an -- unlimited scan). The input is from the current TEXT_IO input file. procedure Scan_Integer_String (Last : out Integer; Result : out Integer); -- Procedure to scan an ada integer value and store it in Result. -- The input is from the string stored in Work_String. Last is set to -- the count of Characters scanned. procedure Scan_Integer_Val (Fixed_Field : Boolean; Result : out Integer); -- Procedure to scan an Ada Integer value and return the Integer result. procedure Scan_Blanks; -- Routine to scan past leading blanks to find first non-blank. -- Leaves WS_Index1 pointing to first non-blank character. procedure Setup_Fixed_Field (Width : Integer); -- This procedure is used for numeric conversions where the field to be -- scanned has a fixed width (i.e. width parameter is non-zero). -- It acquires the field from the input file and copies it to Work_String. -- It returns to the caller ready to scan the data from work_string. function Sign (C : Character) return Boolean; -- Predicate indicating whether character C is '+' or '-' procedure Skipc; -- This procedure skips the next input Character. procedure Test_Fixed_Field_End; -- this procedure is called after scanning an item from a fixed length -- field to ensure that only blanks remain in the field. An exception -- is raised if there are any unexpected non-blank Characters left in -- the field. function Upper_Case (C : Character) return Character; -- Converts character C to upper case if necessary procedure Unimplemented (Message : String) is begin Text_IO.Put (Message); Text_IO.Put_Line (" not implemented yet"); end Unimplemented; procedure Word_Mul (A : Integer; B : Integer; O : out Boolean; R : out Integer); -- Multiply with overflow check (use until trapping arithmetic works). procedure Word_Sub (A : Integer; B : Integer; O : out Boolean; R : out Integer); -- Subtraction with overflow check (use until trapping arithmetic works) -- -- Interface with system calls -- procedure C_Fgetc (F : Text_IO.File_Ptr; C : out Character; Is_Eof : out Boolean); procedure Fclose (P : Text_IO.File_Ptr); function Fopen (Name : String; Typ : File_Mode) return Text_IO.File_Ptr; procedure Fputc (F : Text_IO.File_Ptr; C : Character); function Isatty (F : Text_IO.File_Ptr) return Boolean; function Stdin return Text_IO.File_Ptr; function Stdout return Text_IO.File_Ptr; function Stderr return Text_IO.File_Ptr; procedure Unlink (Name : String); ----------- -- Chars -- ----------- function Chars return Integer is begin return The_File.Count; end Chars; --------------- -- Set_Chars -- --------------- procedure Set_Chars (Val : Integer) is begin The_File.Count := Val; end Set_Chars; ----------- -- Char1 -- ----------- function Char1 return Character is begin return The_File.Look_Ahead (1); end Char1; --------------- -- Set_Char1 -- --------------- procedure Set_Char1 (Val : Character) is begin The_File.Look_Ahead (1) := Val; end Set_Char1; ----------- -- Char2 -- ----------- function Char2 return Character is begin return The_File.Look_Ahead (2); end Char2; --------------- -- Set_Char2 -- --------------- procedure Set_Char2 (Val : Character) is begin The_File.Look_Ahead (2) := Val; end Set_Char2; ----------- -- Char3 -- ----------- function Char3 return Character is begin return The_File.Look_Ahead (3); end Char3; --------------- -- Set_Char3 -- --------------- procedure Set_Char3 (Val : Character) is begin The_File.Look_Ahead (3) := Val; end Set_Char3; ------------ -- Create -- ------------ procedure Create (File : in out File_Type; Mode : in File_Mode := Out_File; Name : in String := ""; Form : in String := "") is begin The_File := File; if The_File /= null then raise Status_Error; -- File already open elsif Mode = In_File then raise Use_Error; -- Unsupported file access end if; Allocate_AFCB; The_File.Name := new String'(Name); The_File.Form := new String'(Form); The_File.Mode := Mode; if Name'Length = 0 then Make_Temp_File_Name; end if; Check_Multiple_File_Opens; The_File.AFCB_In_Use := True; The_File.Desc := Fopen (The_File.Name.all, Out_File); Check_Opened_Ok; The_File.Page := 1; The_File.Line := 1; The_File.Col := 1; The_File.Line_Length := 0; The_File.Page_Length := 0; File := The_File; end Create; ---------- -- Open -- ---------- procedure Open (File : in out File_Type; Mode : in File_Mode; Name : in String; Form : in String := "") is begin The_File := File; if The_File /= null then raise Status_Error; -- File already open end if; Allocate_AFCB; The_File.Name := new String'(Name); The_File.Form := new String'(Form); The_File.Mode := Mode; if Name'Length = 0 then Make_Temp_File_Name; end if; Check_Multiple_File_Opens; The_File.AFCB_In_Use := True; if Mode = In_File then The_File.Desc := Fopen (Name, In_File); Check_Opened_Ok; Set_Chars (0); else The_File.Desc := Fopen (Name, Out_File); Check_Opened_Ok; end if; The_File.Page := 1; The_File.Line := 1; The_File.Col := 1; The_File.Line_Length := 0; The_File.Page_Length := 0; File := The_File; end Open; ----------- -- Close -- ----------- procedure Close (File : in out File_Type) is begin The_File := File; Check_File_Open; if The_File.Mode = Out_File or else The_File.Mode = Append_File then -- Simulate effect of NEW_PAGE unless current page is terminated if Page_Is_Not_Terminated then if The_File.Col > 1 or else (The_File.Col = 1 and then The_File.Line = 1) then Put_Line1; end if; Put_Page; end if; end if; -- If the file being closed is one of the default files, set the default -- file indicator to null to indicate that the file is closed. if The_File = Current_In then Current_In := null; elsif The_File = Current_Out then Current_Out := null; elsif The_File = Current_Err then Current_Err := null; end if; -- Sever the association between the given file and its associated -- external file. The given file is left closed. Do not perform system -- closes on the standard input, output and error files. if The_File /= Standard_In and then The_File /= Standard_Out and then The_File /= Standard_Err then Close_File; end if; The_File := null; File := The_File; end Close; ------------ -- Delete -- ------------ procedure Delete (File : in out File_Type) is File_Name_To_Delete : Pstring; begin The_File := File; Check_File_Open; File_Name_To_Delete := new String'(The_File.Name.all); Close (The_File); Unlink (File_Name_To_Delete.all); File := The_File; end Delete; ----------- -- Reset -- ----------- procedure Reset (File : in out File_Type; Mode : in File_Mode) is begin The_File := File; Check_File_Open; if (The_File = Current_In or else The_File = Current_Out) and then The_File.Mode /= Mode then raise Mode_Error; -- "Cannot change mode" end if; if The_File.Mode = Out_File or else The_File.Mode = Append_File then -- Simulate NEW_PAGE unless current page already terminated if Page_Is_Not_Terminated then if The_File.Col > 1 or else (The_File.Col = 1 and then The_File.Line = 1) then Put_Line1; end if; Put_Page; end if; end if; Fclose (The_File.Desc); if Mode = In_File then The_File.Desc := Fopen (The_File.Name.all, In_File); Check_Opened_Ok; else The_File.Desc := Fopen (The_File.Name.all, Out_File); Check_Opened_Ok; The_File.Line_Length := 0; The_File.Page_Length := 0; end if; The_File.Mode := Mode; Set_Chars (0); The_File.Col := 1; The_File.Line := 1; The_File.Page := 1; File := The_File; end Reset; ---------- -- Mode -- ---------- function Mode (File : in File_Type) return File_Mode is begin The_File := File; Check_File_Open; return The_File.Mode; end Mode; ---------- -- Name -- ---------- function Name (File : in File_Type) return String is begin The_File := File; Check_File_Open; return The_File.Name.all; end Name; ---------- -- Form -- ---------- function Form (File : in File_Type) return String is begin The_File := File; Check_File_Open; return The_File.Form.all; end Form; ------------- -- Is_Open -- ------------- function Is_Open (File : in File_Type) return Boolean is begin The_File := File; return The_File /= null; end Is_Open; --------------- -- Set_Input -- --------------- procedure Set_Input (File : in File_Type) is begin The_File := File; Check_Status_And_Mode (In_File); Current_In := The_File; end Set_Input; ---------------- -- Set_Output -- ---------------- procedure Set_Output (File : in File_Type) is begin The_File := File; Check_Status_And_Mode (Out_File, Append_File); Current_Out := The_File; end Set_Output; --------------- -- Set_Error -- --------------- procedure Set_Error (File : in File_Type) is begin The_File := File; Check_Status_And_Mode (Out_File, Append_File); Current_Err := The_File; end Set_Error; -------------------- -- Standard_Input -- -------------------- function Standard_Input return File_Type is begin return Standard_In; end Standard_Input; --------------------- -- Standard_Output -- --------------------- function Standard_Output return File_Type is begin return Standard_Out; end Standard_Output; -------------------- -- Standard_Error -- -------------------- function Standard_Error return File_Type is begin return Standard_Err; end Standard_Error; ------------------- -- Current_Input -- ------------------- function Current_Input return File_Type is begin return Current_In; end Current_Input; -------------------- -- Current_Output -- -------------------- function Current_Output return File_Type is begin return Current_Out; end Current_Output; ------------------- -- Current_Error -- ------------------- function Current_Error return File_Type is begin return Current_Err; end Current_Error; --------------------- -- Set_Line_Length -- --------------------- procedure Set_Line_Length (File : in File_Type; To : in Count) is begin The_File := File; Check_Status_And_Mode (Out_File, Append_File); The_File.Line_Length := To; end Set_Line_Length; ----------------- -- Line_Length -- ----------------- function Line_Length (File : in File_Type) return Count is begin The_File := File; Check_Status_And_Mode (Out_File, Append_File); return The_File.Line_Length; end Line_Length; --------------------- -- Set_Page_Length -- --------------------- procedure Set_Page_Length (File : in File_Type; To : in Count) is begin The_File := File; Check_Status_And_Mode (Out_File, Append_File); The_File.Page_Length := To; end Set_Page_Length; ----------------- -- Page_Length -- ----------------- function Page_Length (File : in File_Type) return Count is begin The_File := File; Check_Status_And_Mode (Out_File, Append_File); return The_File.Page_Length; end Page_Length; -------------- -- New_Line -- -------------- procedure New_Line (File : in File_Type; Spacing : in Positive_Count := 1) is begin The_File := File; Check_Status_And_Mode (Out_File, Append_File); for I in 1 .. Spacing loop Put_Line1; end loop; end New_Line; --------------- -- Skip_Line -- --------------- procedure Skip_Line (File : in File_Type; Spacing : in Positive_Count := 1) is C : Character; begin The_File := File; Check_Status_And_Mode (In_File); for I in 1 .. Spacing loop loop Load_Look_Ahead (False); exit when Get_Char = Line_Feed; end loop; -- ignore page marks for standard input. -- if The_File = Standard_In then return; end if; loop Load_Look_Ahead (False); exit when Char1 /= Page_Mark; C := Get_Char; end loop; end loop; end Skip_Line; ----------------- -- End_Of_Line -- ----------------- function End_Of_Line (File : in File_Type) return boolean is begin The_File := File; Check_Status_And_Mode (In_File); Load_Look_Ahead (False); return Chars = 0 or else Char1 = Line_Feed; end End_Of_Line; -------------- -- New_Page -- -------------- procedure New_Page (File : in File_Type) is begin The_File := File; Check_Status_And_Mode (Out_File, Append_File); if The_File.Col > 1 or else (The_File.Col = 1 and then The_File.Line = 1) then Put_Line1; end if; Put_Page; end New_Page; --------------- -- Skip_Page -- --------------- procedure Skip_Page (File : in File_Type) is begin The_File := File; Check_Status_And_Mode (In_File); while Get_Char /= Page_Mark loop null; end loop; end Skip_Page; ----------------- -- End_Of_Page -- ----------------- function End_Of_Page (File : in File_Type) return Boolean is begin The_File := File; Check_Status_And_Mode (In_File); if Isatty (The_File.Desc) then return False; end if; Load_Look_Ahead (False); if Chars > 1 then return Char1 = Line_Feed and then Char2 = Page_Mark; elsif Chars = 1 then return Char1 = Line_Feed; else return True; end if; end End_Of_Page; ----------------- -- End_Of_File -- ----------------- function End_Of_File (File : in File_Type) return Boolean is begin The_File := File; Check_Status_And_Mode (In_File); Load_Look_Ahead (True); if Isatty (The_File.Desc) then if Chars = 2 then return False; elsif Chars = 1 then return Char1 = Line_Feed; elsif Chars = 0 then return True; end if; else if Chars = 2 then return Char1 = Line_Feed and then Char2 = Page_Mark; elsif Chars = 1 then return Char1 = Line_Feed; elsif Chars = 0 then return True; else -- Chars = 3 return False; end if; end if; end End_Of_File; ------------- -- Set_Col -- ------------- procedure Set_Col (File : in File_Type; To : in Positive_Count) is C : Character; begin The_File := File; Check_File_Open; if The_File.Mode = In_File then -- SET_COL for file of mode In_File Load_Look_Ahead (False); while The_File.Col /= To or else Char1 = Line_Feed or else Char1 = Page_Mark loop C := Get_Char; end loop; else -- SET_COL for file of mode Out_File or Append_File if The_File.Line_Length > 0 and then To > The_File.Line_Length then raise Layout_Error; -- "SET_COL past end of line" end if; if To > The_File.Col then Put_Blanks (Integer (To - The_File.Col)); The_File.Col := To; elsif To < The_File.Col then Put_Line1; Put_Blanks (Integer (To - 1)); The_File.Col := To; end if; end if; end Set_Col; -------------- -- Set_Line -- -------------- procedure Set_Line (File : in File_Type; To : in Positive_Count) is C : Character; begin The_File := File; Check_File_Open; if The_File.Mode = In_File then -- SET_LINE for file of mode In_File Load_Look_Ahead (False); while The_File.Line /= To or else Char1 = Page_Mark loop C := Get_Char; end loop; else -- SET_LINE for file of mode Out_File or Append_File if The_File.Page_Length > 0 and then To > The_File.Page_Length then raise Layout_Error; -- "Set_Line > Page_Length" end if; if To > The_File.Line then for I in 1 .. To - The_File.Line loop Put_Line1; end loop; elsif To < The_File.Line then if The_File.Col > 1 or else (The_File.Col = 1 and then The_File.Line = 1) then Put_Line1; end if; Put_Page; for I in 1 .. To - 1 loop Put_Line1; end loop; end if; end if; end Set_Line; --------- -- Col -- --------- function Col (File : in File_Type) return Positive_Count is begin The_File := File; Check_File_Open; if (The_File.Col > Count'Last) then raise Layout_Error; -- "Col > Count'Last" end if; return The_File.Col; end Col; ---------- -- Line -- ---------- function Line (File : in File_Type) return Positive_Count is begin The_File := File; Check_File_Open; if (The_File.Line > Count'Last) then raise Layout_Error; -- "Line > Count'Last" end if; return The_File.Line; end Line; ---------- -- Page -- ---------- function Page (File : in File_Type) return Positive_Count is begin The_File := File; Check_File_Open; if (The_File.Page > Count'Last) then raise Layout_Error; -- "Page > Count'Last" end if; return The_File.Page; end Page; --------- -- Get -- --------- procedure Get (Item : out Character) is begin Check_Status_And_Mode (In_File); loop Item := Get_Char; exit when Item /= Page_Mark and then Item /= Line_Feed; end loop; end Get; --------- -- Put -- --------- procedure Put (Item : in Character) is begin Check_Status_And_Mode (Out_File, Append_File); if The_File.Line_Length /= 0 and then The_File.Col > The_File.Line_Length then Put_Line1; end if; Fputc (The_File.Desc, Item); The_File.Col := The_File.Col + 1; end Put; --------- -- Get -- --------- procedure Get (Item : out String) is I : Integer := 0; C : Character; begin Check_Status_And_Mode (In_File); while I < Item'Length loop C := Get_Char; if C /= Line_Feed and then C /= Page_Mark then Item (Item'First + I) := C; I := I + 1; end if; end loop; end Get; --------- -- Put -- --------- procedure Put (Item : in String) is begin for I in Item'range loop Put (Item (I)); end loop; end Put; -------------- -- Put_Line -- -------------- procedure Put_Line (File : in File_Type; Item : in String) is begin The_File := File; Put (Item); New_Line (File, 1); end Put_Line; -------------- -- Get_Line -- -------------- procedure Get_Line (File : in File_Type; Item : out String; Last : out Natural) is I_Length : Integer := Item'Length; Nstore : Integer := 0; begin The_File := File; Check_Status_And_Mode (In_File); loop Load_Look_Ahead (False); exit when Nstore = I_Length; if Char1 = Line_Feed then Skip_Line (File, 1); exit; end if; Item (Item'First + Nstore) := Get_Char; Nstore := Nstore + 1; end loop; Last := Item'First + Nstore - 1; end Get_Line; ------------- -- Get_Int -- ------------- procedure Get_Int (Item : out Integer; Width : in Field := 0) is begin Check_Status_And_Mode (In_File); Scan_Integer (Width, Item); end Get_Int; ------------- -- Put_Int -- ------------- procedure Put_Int (Item : in Integer; Width : in Field; Base : in Number_Base) is begin Check_Status_And_Mode (Out_File, Append_File); Image_Integer (Item, Base); Put_Buffer (Width, 'L', WS_Length); end Put_Int; ------------- -- Get_Int -- ------------- procedure Get_Int (From : in String; Item : out Integer; Last : out Positive) is begin WS_Length := From'Length; for I in 0 .. WS_Length - 1 loop Work_String (I) := From (From'First + I); end loop; Work_String (WS_Length) := ' '; WS_Index1 := 0; Scan_Integer_String (Last, Item); Last := From'First + Last - 1; end Get_Int; ------------- -- Put_Int -- ------------- procedure Put_Int (To : out String; Item : in Integer; Base : in Number_Base) is To_Length : Integer := To'Length; begin Image_Integer (Item, Base); if WS_Length > To_Length then raise Layout_Error; end if; for I in 0 .. To_Length - WS_Length - 1 loop To (To'First + I) := ' '; end loop; for I in To_Length - WS_Length .. To_Length - 1 loop To (To'First + I) := Work_String (I - To_Length + WS_Length); end loop; end Put_Int; --------------- -- Get_Float -- --------------- procedure Get_Float (Item : out Float; Width : in Field) is begin Check_Status_And_Mode (In_File); Unimplemented ("Float_IO.Get"); end Get_Float; --------------- -- Put_Float -- --------------- procedure Put_Float (Item : in Float; Fore : in Field; Aft : in Field; Exp : in Field) is begin Check_Status_And_Mode (Out_File, Append_File); Image_Float (Item, Aft, Exp); if Exp = 0 then Put_Buffer (Aft + Fore + 1, 'L', WS_Length + 1); else Put_Buffer (Aft + Fore + Exp + 2, 'L', WS_Length + 1); end if; end Put_Float; --------------- -- Get_Float -- --------------- procedure Get_Float (From : in String; Item : out Float; Last : out Positive) is begin Unimplemented ("Float_IO.Get with String parameter"); end Get_Float; --------------- -- Put_Float -- --------------- procedure Put_Float (To : out String; Item : in Float; Aft : in Field; Exp : in Field) is To_Length : Natural := To'Length; begin Image_Float (Item, Aft, Exp); if WS_Length > To_Length then raise Layout_Error; end if; for I in 0 .. To_Length - WS_Length - 1 loop To (To'First + I) := ' '; end loop; for I in To_Length - WS_Length .. To_Length - 1 loop To (To'First + I) := Work_String (I - To_Length + WS_Length); end loop; end Put_Float; -------------- -- Put_Page -- -------------- procedure Put_Page is begin Fputc (The_File.Desc, Page_Mark); The_File.Page := The_File.Page + 1; The_File.Line := 1; The_File.Col := 1; end Put_Page; --------------- -- Put_Line1 -- --------------- procedure Put_Line1 is begin Fputc (The_File.Desc, Line_Feed); The_File.Col := 1; if The_File.Page_Length > 0 and The_File.Line >= The_File.Page_Length then Put_Page; else The_File.Line := The_File.Line + 1; end if; end Put_Line1; --------------------- -- Check_Opened_Ok -- --------------------- procedure Check_Opened_Ok is begin if The_File.Desc = 0 then raise Name_Error; -- Error opening file due to invalid name end if; end Check_Opened_Ok; --------------------- -- Check_File_Open -- --------------------- procedure Check_File_Open is begin -- There are two ways a file can appear closed. Either it is null -- which indicates that it was not used as an argument of an Open_Create -- call or it is not null but its Is_Open field is False which indicates -- that the file was used in an Open/Create but subsequently was closed. if The_File = null then raise Status_Error; -- File not open end if; end Check_File_Open; --------------------------- -- Check_Status_And_Mode -- --------------------------- procedure Check_Status_And_Mode (C_Mode : File_Mode) is begin Check_File_Open; if The_File.Mode /= C_Mode then raise Mode_Error; end if; end Check_Status_And_Mode; --------------------------- -- Check_Status_And_Mode -- --------------------------- procedure Check_Status_And_Mode (C_Mode1, C_Mode2 : File_Mode) is begin Check_File_Open; if The_File.Mode /= C_Mode1 and then The_File.Mode /= C_Mode2 then raise Mode_Error; end if; end Check_Status_And_Mode; ------------------- -- Allocate_AFCB -- -------------------- procedure Allocate_AFCB is File_Num : Integer := Open_Files'First; begin -- Loop thorugh the array of AFCBs stopping at the first vacate spot -- that is not currently being used. while File_Num <= Max_Num_Of_Files and then Open_Files (File_Num) /= null and then Open_Files (File_Num).AFCB_In_Use loop File_Num := File_Num + 1; end loop; -- No vacate spots were available since too many file are open if File_Num > Max_Num_Of_Files then raise Use_Error; -- Too many files open end if; if Open_Files (File_Num) = null then Open_Files (File_Num) := new AFCB; end if; The_File := Open_Files (File_Num); end Allocate_AFCB; ------------------------- -- Make_Temp_File_Name -- ------------------------- procedure Make_Temp_File_Name is Temp_File_Name : String (1 .. 14); -- The template for temporary file name creation using Mktemp. procedure mktemp (S : Address); -- mktemp creates a unique temporary file name given the address of -- a null terminated template. pragma Import (C, mktemp); begin -- Create a template string which the call to mktemp will fill in to -- generate unique name file name. Temp_File_Name (1 .. 13) := "ADATEMPXXXXXX"; Temp_File_Name (14) := Ascii.Nul; mktemp (Temp_File_Name'Address); The_File.Name := new String'(Temp_File_Name (1 .. 13)); -- Append the name of the temporary file to the end of the Temp_File -- list which will be used for deleting all the temporary files after -- completion of the main program. if Temp_Files = null then Temp_Files := new Temp_File_Rec'(The_File.Name, null); else Temp_Files.Next := new Temp_File_Rec'(The_File.Name, null); end if; end Make_Temp_File_Name; ------------------------------- -- Check_Multiple_File_Opens -- ------------------------------- procedure Check_Multiple_File_Opens is begin -- Allow a several opens to read an external file, but not one open to -- read and another open to write a external file. for I in Open_Files'range loop if Open_Files (I) /= null and then Open_Files (I).AFCB_In_Use then if The_File.Name.all = Open_Files (I).Name.all and then (The_File.Mode /= In_File or else Open_Files (I).Mode /= In_File) then raise Use_Error; -- File already open end if; end if; end loop; end Check_Multiple_File_Opens; ----------------------------- -- Page_Is_Not_Terminated -- ----------------------------- function Page_Is_Not_Terminated return Boolean is begin return not (The_File.Col = 1 and then The_File.Line = 1 and then The_File.Page /= 1); end Page_Is_Not_Terminated; ---------------- -- Close_File -- ---------------- procedure Close_File is procedure Fclose (F : Text_IO.File_Ptr); pragma Import (C, fclose); File_Num : Integer := Open_Files'First; begin while File_Num <= Max_Num_Of_Files and then Open_Files (File_Num) /= The_File loop File_Num := File_Num + 1; end loop; if File_Num > Max_Num_Of_Files then raise Status_Error; end if; Fclose (The_File.Desc); The_File.AFCB_In_Use := False; end Close_File; --------------------- -- Load_Look_Ahead -- --------------------- procedure Load_Look_Ahead (End_Of_File_Flag : Boolean) is C : Character; Is_Eof : Boolean; begin -- Load first character of look ahead if Chars = 0 then Set_Char2 (Nul); Set_Char3 (Nul); C_Fgetc (The_File.Desc, C, Is_Eof); if Is_Eof then Set_Char1 (Nul); return; else Set_Char1 (C); Set_Chars (1); end if; end if; -- In the case where reading from the keyboard do not read more than -- 1 character unless you are processing an end_of_file test. if Isatty (The_File.Desc) and then not End_Of_File_Flag then return; end if; -- Load second character of look ahead if Chars = 1 then Set_Char3 (Nul); C_Fgetc (The_File.Desc, C, Is_Eof); if Is_Eof then Set_Char2 (Nul); return; else Set_Char2 (C); Set_Chars (2); end if; end if; -- Leave lookahead with at most two characters loaded if standard -- input is the keyboard. if not Isatty (The_File.Desc) then -- Load third character of look ahead if Chars = 2 then C_Fgetc (The_File.Desc, C, Is_Eof); if Is_Eof then Set_Char3 (Nul); return; else Set_Char3 (C); Set_Chars (3); end if; end if; end if; end Load_Look_Ahead; -------------- -- Get_Char -- -------------- function Get_Char return Character is C : Character; begin Load_Look_Ahead (False); if Chars = 0 then raise End_Error; -- End of file on TEXT_IO input end if; C := Char1; -- Update lookahead Set_Char1 (Char2); Set_Char2 (Char3); Set_Char3 (Nul); Set_Chars (Chars - 1); -- Update PAGE and LINE counters if page mark or line feed read if C = Page_Mark then The_File.Page := The_File.Page + 1; The_File.Line := 1; The_File.Col := 1; elsif C = Line_Feed then The_File.Line := The_File.Line + 1; The_File.Col := 1; else The_File.Col := The_File.Col + 1; end if; if Character'Pos (C) > 127 then raise Data_Error; -- Character > 127 for TEXT_IO input" end if; return C; end Get_Char; ---------------- -- Upper_Case -- ---------------- function Upper_Case (C : Character) return Character is V : constant Integer := 32; begin if C in 'a' .. 'z' then return Character'Val (Character'Pos (C) - V); else return C; end if; end Upper_Case; -------------- -- Word_Sub -- -------------- procedure Word_Sub (A : Integer; B : Integer; O : out Boolean; R : out Integer) is begin R := A - B; O := ((A < 0 and then B > 0) or else (A > 0 and then B < 0)) and then ((A < 0 and then R > 0) or else (A > 0 and then R < 0)); end Word_Sub; -------------- -- Word_Mul -- -------------- procedure Word_Mul (A : Integer; B : Integer; O : out Boolean; R : out Integer) is begin if A /= 0 then R := A * B; O := (B /= R / A) or else (A = -1 and then B < 0 and then R < 0); else R := 0; O := False; end if; end Word_Mul; ---------------- -- Put_Blanks -- ---------------- procedure Put_Blanks (N : Integer) is begin for I in 1 .. N loop Fputc (The_File.Desc, ' '); end loop; end Put_Blanks; ---------------- -- Put_Buffer -- ---------------- procedure Put_Buffer (Width : Integer; Pad_Type : Character; Length : Integer) is Pad : Character := Pad_Type; Target_Length : Integer; begin if Length >= Width then Target_Length := Length; Pad := ' '; else Target_Length := Width; end if; -- Ensure the buffer size does not exceed the line length if The_File.Line_Length > 0 then if Count (Target_Length) > The_File.Line_Length then raise Layout_Error; -- "Line too big" end if; end if; -- New line if does not fit on current line if The_File.Col + Count (Target_Length) - 1 > The_File.Line_Length then Put_Line1; end if; -- Output data with the required padding if Pad = 'L' then Put_Blanks (Width - Length); end if; for N in 0 .. Length - 1 loop Fputc (The_File.Desc, Work_String (N)); end loop; The_File.Col := The_File.Col + Count (Target_Length); if Pad = 'T' then Put_Blanks (Width - Length); end if; end Put_Buffer; ----------------- -- Image_Float -- ----------------- procedure Image_Float (Item : Float; Aft, Exp : Field) is procedure sprintf (Target : Address; Fmt : Address; Precision : Natural; Value : Long_Float; Length_Ptr : Address); pragma Import (C, sprintf); Fmt_E : constant String := "%.*E%n" & Ascii.NUL; Fmt_F : constant String := "%.*F%n" & Ascii.NUL; Fmt_Ptr : Address; E_Pos : Natural; Exp_Len : Natural; Length : aliased Natural; Precision : Natural; begin -- The value of Exp controls whether an exponent part is to appear. Use -- E or F format in the call to sprintf appropriately. if Exp = 0 then Fmt_Ptr := Fmt_F'Address; else Fmt_Ptr := Fmt_E'Address; end if; -- The number of digits of the fractional part is given by AFT, or is -- one if AFT equals zero. [RM 14.3.8] if Aft = 0 then Precision := 1; else Precision := Aft; end if; sprintf (Target => Work_String'Address, Fmt => Fmt_Ptr, Precision => Precision, Value => Long_Float (Item), Length_Ptr => Length'Address); WS_Length := Length - 1; -- A certain amount of correction to the exponent part of the image -- string is necessary since the semantics of sprintf do not allow the -- specification of the number of digits in the exponent as Ada allows. -- Find the index of the 'E' in the image string. E_Pos := WS_Length; while Work_String (E_Pos) /= 'E' loop E_Pos := E_Pos - 1; end loop; Exp_Len := WS_Length - E_Pos; -- Since sprintf always use a minimum of two digits for the exponent -- if there is a leading zero in the exponent and Exp is specified as -- one it is necessary to trim the extra zero off and slide the -- remaining digit over one. if Exp = 1 then if Work_String (E_Pos + 2) = '0' then Work_String (E_Pos + 2) := Work_String (E_Pos + 3); WS_Length := WS_Length - 1; end if; -- Extra leading zeroes may need to be added in front of the exponent -- if the value of Exp is greater than the number of digits necessary -- to portray the tru exponent value. elsif Exp > Exp_Len then for I in reverse E_Pos + 2 .. WS_Length loop Work_String (I + Exp_Len - Exp) := Work_String (I); end loop; for I in E_Pos + 2 .. E_Pos + 1 + Exp - Exp_Len loop Work_String (I) := '0'; end loop; WS_Length := WS_Length + Exp - Exp_Len; end if; end Image_Float; ------------------- -- Image_Integer -- ------------------- procedure Image_Integer (Item : Integer; Base : Integer) is P, Q : Integer; Digit : Integer; Buffer : Integer := Item; begin P := 0; if Base /= 10 then if Base > 10 then Work_String (P) := '1'; Work_String (P + 1) := Character'Val (Character'Pos ('0') + Base - 10); Work_String (P + 2) := '#'; P := P + 3; else Work_String (P) := Character'Val (Character'Pos ('0') + Base); Work_String (P + 1) := '#'; P := P + 2; end if; end if; -- Deal with the sign. Note we work with the negative of the absolute -- value of the number so that we do not have to make special checks -- for the largest negative number ion the twos complement case. if Buffer < 0 then Work_String (P) := '-'; P := P + 1; else Buffer := - Buffer; end if; -- Convert value to digit string in specified base if Buffer = 0 then Work_String (P) := '0'; P := P + 1; else Q := 15; while Buffer /= 0 loop Digit := - (Buffer rem Base); Buffer := Buffer / Base; if Digit > 9 then Work_String (Q) := Character'Val (Character'Pos ('A') + Digit - 10); else Work_String (Q) := Character'Val (Character'Pos ('0') + Digit); end if; Q := Q - 1; end loop; for I in 1 .. 15 - Q loop Work_String (P) := Work_String (Q + I); P := P + 1; end loop; end if; if Base /= 10 then Work_String (P) := '#'; P := P + 1; end if; WS_Length := P; end Image_Integer; ----------- -- Getcp -- ----------- function Getcp return Character is C : Character; begin if Scanning_From_File then return Get_Char; else if WS_Index1 > WS_Length then raise End_Error; end if; WS_Index1 := WS_Index1 + 1; return Work_String (WS_Index1); end if; end Getcp; ----------- -- Nextc -- ----------- function Nextc return Character is begin if Scanning_From_File then Load_Look_Ahead (False); return Char1; else if WS_Index1 < WS_Length then return Work_String (WS_Index1); else return Line_Feed; end if; end if; end Nextc; ----------- -- Skipc -- ----------- procedure Skipc is C : Character; begin if Scanning_From_File then C := Get_Char; else WS_Index1 := WS_Index1 + 1; end if; end Skipc; ----------- -- Copyc -- ----------- procedure Copyc is C : Character; begin if Scanning_From_File then C := Get_Char; else if WS_Index1 > WS_Length then raise Program_Error; else C := Work_String (WS_Index1); WS_Index1 := WS_Index1 + 1; end if; end if; Work_String (WS_Index2) := Upper_Case (C); WS_Index2 := WS_Index2 + 1; end Copyc; ------------------ -- Copy_Integer -- ------------------ procedure Copy_Integer is begin Check_Digit; while Digit (Nextc) loop Copyc; if Nextc = '_' then Skipc; Check_Digit; end if; end loop; end Copy_Integer; ------------------------ -- Copy_Based_Integer -- ------------------------ procedure Copy_Based_Integer is begin Check_Extended_Digit; while Extended_Digit (Nextc) loop Copyc; if Nextc = '_' then Skipc; Check_Extended_Digit; end if; end loop; end Copy_Based_Integer; ----------------- -- Scan_Blanks -- ----------------- procedure Scan_Blanks is C : Character; begin if Scanning_From_File then loop Load_Look_Ahead (False); if Chars = 0 then raise End_Error; end if; C := Nextc; if C = ' ' or else C = Ascii.HT or else C = Line_Feed or else C = Page_Mark then C := Getcp; else exit; end if; end loop; else while WS_Index1 <= WS_Length - 1 loop if Work_String (WS_Index1) = ' ' or else Work_String (WS_Index1) = Ascii.HT then WS_Index1 := WS_Index1 + 1; else exit; end if; end loop; end if; end Scan_Blanks; ------------------------ -- Setup_Fixed_Field -- ------------------------ procedure Setup_Fixed_Field (Width : Integer) is I : Integer := 0; begin loop Load_Look_Ahead (False); if Width /= I and then Chars /= 0 and then Char1 /= Page_Mark and then Char1 /= Line_Feed then Work_String (I) := Get_Char; I := I + 1; else exit; end if; end loop; WS_Length := I; Scanning_From_File := False; WS_Index1 := 0; end Setup_Fixed_Field; -------------------------- -- Test_Fixed_Field_End -- -------------------------- procedure Test_Fixed_Field_End is begin Scan_Blanks; if WS_Index1 < WS_Length then raise Data_Error; end if; end Test_Fixed_Field_End; ----------- -- Alpha -- ----------- function Alpha (C : Character) return Boolean is begin return C in 'A' .. 'Z' or else C in 'a' .. 'z'; end Alpha; -------------- -- Alphanum -- -------------- function Alphanum (C : Character) return Boolean is begin return Alpha (C) or else C in '0' .. '9'; end Alphanum; ------------- -- Graphic -- ------------- function Graphic (C : Character) return Boolean is Low : constant Integer := 32; High : constant Integer := 127; begin return Character'Pos (C) in Low .. High; end Graphic; ----------- -- Digit -- ----------- function Digit (C : Character) return Boolean is begin return C in '0' .. '9'; end Digit; -------------------- -- Extended_Digit -- -------------------- function Extended_Digit (C : Character) return Boolean is begin return C in '0' .. '9' or else C in 'a' .. 'f' or else C in 'A' .. 'F'; end Extended_Digit; ---------- -- Sign -- ---------- function Sign (C : Character) return Boolean is begin return C = '-' or C = '+'; end Sign; ----------------- -- Check_Digit -- ----------------- procedure Check_Digit is begin if not (Nextc in '0' .. '9') then raise Data_Error; end if; end Check_Digit; ---------------- -- Check_Hash -- ---------------- procedure Check_Hash (C : Character) is begin if Nextc /= C then raise Data_Error; end if; Skipc; Work_String (WS_Index2) := '#'; WS_Index2 := WS_Index2 + 1; end Check_Hash; -------------------------- -- Check_Extended_Digit -- -------------------------- procedure Check_Extended_Digit is begin if not Extended_Digit (Nextc) then raise Data_Error; end if; end Check_Extended_Digit; ----------------- -- Range_Error -- ----------------- procedure Range_Error is begin raise Data_Error; end Range_Error; -------------- -- Scan_Int -- -------------- function Scan_Int return Integer is Ival : Integer := 0; Digit_Value : Integer; Overflow1, Overflow2 : Boolean; begin while WS_Index2 < WS_Length and then Digit (Work_String (WS_Index2)) loop Digit_Value := Character'Pos (Work_String (WS_Index2)) - Character'Pos ('0'); WS_Index2 := WS_Index2 + 1; Word_Mul (Ival, 10, Overflow1, Ival); Word_Sub (Ival, Digit_Value, Overflow2, Ival); if Overflow1 or else Overflow2 then while WS_Index2 < WS_Length and then Digit (Work_String (WS_Index2)) loop WS_Index2 := WS_Index2 + 1; end loop; return 1; end if; end loop; return Ival; end Scan_Int; -------------------- -- Scan_Based_Int -- -------------------- function Scan_Based_Int (Base : Integer) return Integer is -- this routine scans a based Integer value fromt the string pointed by -- the global Integer WS_Index2. On exit WS_Index2 is updated to point -- to the -- first non-digit. The result returned is always negative. This allows -- the largest negative Integer value to be properly stored and converted. -- If overflow is detected, then the value +1 is returned to signal -- overflow. Ival : Integer := 0; Digit_Value : Integer; Overflow1, Overflow2 : Boolean; begin while WS_Index2 < WS_Length and then Extended_Digit (Work_String (WS_Index2)) loop Word_Mul (Ival, Base, Overflow1, Ival); Digit_Value := Character'Pos (Work_String (WS_Index2)) - Character'Pos ('0'); WS_Index2 := WS_Index2 + 1; if Digit_Value > 9 then Digit_Value := Digit_Value - 7; end if; if Digit_Value >= Base then raise Data_Error; end if; Word_Sub (Ival, Digit_Value, Overflow2, Ival); if Overflow1 or else Overflow2 then while WS_Index2 < WS_Length and then Extended_Digit (Work_String (WS_Index2)) loop WS_Index2 := WS_Index2 + 1; end loop; return 1; end if; end loop; return Ival; end Scan_Based_Int; ---------------------- -- Scan_Integer_Val -- ---------------------- procedure Scan_Integer_Val (Fixed_Field : Boolean; Result : out Integer) is Ival : Integer; Sign_Val : Character; C : Character; Base : Integer; Based : Boolean; Exponent : Integer; Overflow : Boolean; begin -- First scan out item with the proper syntax and put it in Work_String WS_Index2 := 0; if Sign (Nextc) then Copyc; end if; Copy_Integer; C := Nextc; if C = '#' or else C = ':' then Skipc; Work_String (WS_Index2) := '#'; WS_Index2 := WS_Index2 + 1; Copy_Based_Integer; Check_Hash (C); Based := True; else Based := False; end if; C := Nextc; if C = 'e' or else C = 'E' then Copyc; C := Nextc; if C = '+' or else C = '-' then Skipc; end if; Copy_Integer; if C = '-' then raise Data_Error; -- Negative exponent in integer value end if; end if; if Fixed_Field then Test_Fixed_Field_End; end if; WS_Length := WS_Index2; Work_String (WS_Index2) := ' '; -- Now we have the Integer literal stored in Work_String WS_Index2 := 0; if Sign (Work_String (WS_Index2)) then Sign_Val := Work_String (WS_Index2); WS_Index2 := WS_Index2 + 1; else Sign_Val := '+'; end if; if Based then Base := - Scan_Int; if not (Base in 2 .. 16) then raise Data_Error; end if; WS_Index2 := WS_Index2 + 1; Ival := Scan_Based_Int (Base); WS_Index2 := WS_Index2 + 1; else Ival := Scan_Int; Base := 10; end if; -- Number is in Ival (in negative form), deal with exponent. if Ival = 1 then Range_Error; end if; if Work_String (WS_Index2) = 'E' then WS_Index2 := WS_Index2 + 1; Exponent := Scan_Int; if Exponent < -64 or else Exponent = 1 then Range_Error; end if; while Exponent /= 0 loop Exponent := Exponent + 1; Word_Mul (Ival, Base, Overflow, Ival); if Overflow then Range_Error; end if; end loop; else WS_Index2 := WS_Index2 + 1; end if; if Sign_Val = '+' then Ival := -Ival; if Ival < 0 then Range_Error; end if; end if; Result := Ival; end Scan_Integer_Val; ------------------ -- Scan_Integer -- ------------------ procedure Scan_Integer (Width : Integer; Result : out Integer) is begin if Width /= 0 then Setup_Fixed_Field (Width); Scan_Blanks; if WS_Index1 = WS_Length then raise Data_Error; -- String is all blanks end if; Scan_Integer_Val (True, Result); else Scanning_From_File := True; Scan_Blanks; Scan_Integer_Val (False, Result); end if; end Scan_Integer; ------------------------- -- Scan_Integer_String -- ------------------------- procedure Scan_Integer_String (Last : out Integer; Result : out Integer) is begin Scanning_From_File := False; Scan_Blanks; if WS_Index1 = WS_Length then raise End_Error; end if; Scan_Integer_Val (False, Result); Last := WS_Index1; end Scan_Integer_String; --------------------------- -- Text_IO_Finialization -- --------------------------- procedure Text_IO_Finalization is begin -- Close all open files except stdin, stdout and stderr for I in 4 .. Open_Files'Last loop if Open_Files (I) /= null and then Open_Files (I).AFCB_In_Use and then Open_Files (I).Mode /= In_File then Close_File; end if; end loop; -- Delete temporary files upon completion of the main program while (Temp_Files /= null) loop Unlink (Temp_Files.File_Name.all); Temp_Files := Temp_Files.Next; end loop; end Text_IO_Finalization; ----------- -- Fopen -- ----------- function Fopen (Name : String; Typ : File_Mode) return Text_IO.File_Ptr is function C_Fopen (Name, Typ : Address) return Text_IO.File_Ptr; pragma Import (C, C_Fopen, "fopen"); Name1 : String (Name'First .. Name'Last + 1); Read_Only : String (1 .. 3) := "rt"; Write_Only : String (1 .. 3) := "wt"; begin Name1 (Name'range) := Name; Name1 (Name1'Last) := Nul; Read_Only (3) := Nul; Write_Only (3) := Nul; if Typ = In_File then return C_Fopen (Name1'Address, Read_Only'Address); else return C_Fopen (Name1'Address, Write_Only'Address); end if; end Fopen; ------------ -- Fclose -- ------------ procedure Fclose (P : Text_IO.File_Ptr) is procedure C_Fclose (P : Text_IO.File_Ptr); pragma Import (C, C_Fclose, "fclose"); begin C_Fclose (P); end Fclose; ------------ -- Unlink -- ------------ procedure Unlink (Name : String) is procedure C_Unlink (Name : Address); pragma Import (C, C_Unlink, "unlink"); Name1 : String (Name'First .. Name'Last + 1); begin Name1 (Name'range) := Name; Name1 (Name1'Last) := Nul; C_Unlink (Name1'Address); end Unlink; ------------ -- Isatty -- ------------ function Isatty (F : Text_IO.File_Ptr) return Boolean is function C_Isatty (I : Integer) return Boolean; pragma Import (C, C_Isatty, "isatty"); function C_Fileno (F : Text_IO.File_Ptr) return Integer; pragma Import (C, C_Fileno, "fileno"); begin return C_Isatty (C_Fileno (F)); end Isatty; ------------- -- C_Fgetc -- ------------- procedure C_Fgetc (F : Text_IO.File_Ptr; C : out Character; Is_Eof : out Boolean) is I : Integer; function Fgetc (F : Text_IO.File_Ptr) return Integer; pragma Import (C, Fgetc, "fgetc"); begin I := Fgetc (F); Is_Eof := I = -1; if not Is_Eof then C := Character'Val (I); end if; end C_Fgetc; ------------- -- C_Fputc -- ------------- procedure Fputc (F : Text_IO.File_Ptr; C : Character) is procedure C_Fputc (C : Character; F : Text_IO.File_Ptr); pragma Import (C, C_Fputc, "fputc"); begin C_Fputc (C, F); end Fputc; ----------- -- Stdin -- ------------ function Stdin return Text_IO.File_Ptr is function C_Stdin return Text_IO.File_Ptr; pragma Import (C, C_Stdin); begin return C_Stdin; end Stdin; ------------ -- Stdout -- ------------ function Stdout return Text_IO.File_Ptr is function C_Stdout return Text_IO.File_Ptr; pragma Import (C, C_Stdout); begin return C_Stdout; end Stdout; ------------ -- Stderr -- ------------ function Stderr return Text_IO.File_Ptr is function C_Stderr return Text_IO.File_Ptr; pragma Import (C, C_Stderr); begin return C_Stderr; end Stderr; begin -- Initialization of Standard Input Standard_In := new AFCB'(AFCB_In_Use => True, Desc => Stdin, Name => new String'("Standard_Input"), Form => new String'("rt"), Mode => In_File, Col => 1, Line => 1, Page => 1, Line_Length => 80, Page_Length => 24, Count => 0, Look_Ahead => " "); -- Initialization of Standard Output Standard_Out := new AFCB'(AFCB_In_Use => True, Desc => Stdout, Name => new String'("Standard_Output"), Form => new String'("wt"), Mode => Out_File, Col => 1, Line => 1, Page => 1, Line_Length => 80, Page_Length => 24, Count => 0, Look_Ahead => " "); -- Initialization of Standard Error Standard_Err := new AFCB'(AFCB_In_Use => True, Desc => Stderr, Name => new String'("Standard_Error"), Form => new String'("wt"), Mode => Out_File, Col => 1, Line => 1, Page => 1, Line_Length => 80, Page_Length => 24, Count => 0, Look_Ahead => " "); Current_In := Standard_In; Current_Out := Standard_Out; Current_Err := Standard_Err; Open_Files (Open_Files'First + 0) := Standard_In; Open_Files (Open_Files'First + 1) := Standard_Out; Open_Files (Open_Files'First + 2) := Standard_Err; end Ada.Text_IO.Aux; Copyc; end if; Copy_Integer; C := Negnat-1.67-src/rtl/io_exceptions.ads 444 10015 7640 3543 5506244255 12500 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- I O _ E X C E P T I O N S -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Ada.IO_Exceptions; package IO_Exceptions renames Ada.IO_Exceptions; P T I O N S -- -- -- -- S pgnat-1.67-src/rtl/io-aux.c 444 10015 7640 3332 5506244255 10501 /****************************************************************************/ /* */ /* GNAT RUN-TIME COMPONENTS */ /* */ /* Text_IO Auxiliary C functions */ /* */ /* Body */ /* */ /* $Revision: 1.1 $ */ /* */ /* Copyright (c) 1992,1993, NYU, All Rights Reserved */ /* */ /* 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 */ /* Software Foundation; either version 2, or (at your option) any later */ /* version. GNAT is distributed in the hope that it will be useful, but */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- */ /* ABILITY 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 GNAT; see file COPYING. If not, write */ /* to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* */ /****************************************************************************/ #include FILE *c_stdin () { return stdin;} FILE *c_stdout () { return stdout;} FILE *c_stderr () { return stderr;} ing; Typ : File_Mode) return Text_IO.File_Ptr is function C_Fopen (Name, Typ : Address) return Text_IO.File_Ptr; pragma Import (C, C_Fopen, "fopen"); Name1 : String (Name'First .. Name'Last + 1); Read_Only : String (1 .. 3) := "rt"; Write_Only : String (1 .. 3) :gnat-1.67-src/rtl/system-assertions.ads 444 10015 7640 4134 5506244256 13342 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . A S S E R T I O N S -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This module contains the definition of the exception that is raised -- when an assertion made using pragma Assert fails (i.e. the given -- expression evaluates to False. pragma Ada_9X; package System.Assertions is Assert_Failure : exception; -- Exception raised when assertion fails end System.Assertions; Read_Only (3) := Nul; Write_Only (3) := Nul; if Typ = In_File then return C_Fopen (Name1'Address, Read_Only'Address); else return C_Fopen (Name1'Address, Write_Only'Address); end if; end Fopen; ------------ -- Fclose -- ------------ procedure Fclose (P : Text_IO.File_Ptr) is procedure C_Fclose (P : Text_IO.File_Ptr); pragma Import (C, C_Fclose, "fgnat-1.67-src/rtl/system-img_b.adb 444 10015 7640 4257 5506244256 12212 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . I M G _ B -- -- -- -- B o d y -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; function System.Img_B (V : Boolean; B : Address) return Natural is F : constant String := "FALSE"; T : constant String := "TRUE"; procedure strncpy (target, source : Address; count : Natural); pragma Import (C, strncpy); begin if V then strncpy (B, T'Address, 4); return 4; else strncpy (B, F'Address, 5); return 5; end if; end System.Img_B; -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under gnat-1.67-src/rtl/system-img_b.ads 444 10015 7640 4577 5506244256 12240 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . I M G _ B -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Boolean'Image pragma Ada_9X; function System.Img_B (V : Boolean; B : Address) return Natural; pragma Inline (System.Img_B); -- Computes Boolean'Image (V) and stores the resulting string into the -- buffer B, followed by a possible NUL character (the NUL character may -- or may not be present depending on the implementation of the body, but -- the caller must allow for its possible presence). The returned result is -- the number of characters stored, excluding the possible NUL character. -- The caller must ensure that the buffer provided is long enough to hold -- the longest possible result. procedure Fclose (P : Text_IO.File_Ptr) is procedure C_Fclose (P : Text_IO.File_Ptr); pragma Import (C, C_Fclose, "fgnat-1.67-src/rtl/system-img_c.adb 444 10015 7640 4732 5506244256 12211 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . I M G _ C -- -- -- -- B o d y -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; with System.Storage_Elements; use System.Storage_Elements; function System.Img_C (V : Character; B : Address) return Natural is package Cnv is new Address_To_Access_Conversions (Character); use Cnv; begin -- TBSL, the code in the case of control characters is dubious. The result -- returned in these cases is a three character string '?' where ? is the -- control character in question. This is not actually wrong, but is not -- the most desirable implementation dependent result To_Pointer (B + Storage_Offset (0)).all := '''; To_Pointer (B + Storage_Offset (1)).all := V; To_Pointer (B + Storage_Offset (2)).all := '''; return 3; end System.Img_C; ; pragma Import (C, C_Fclose, "fgnat-1.67-src/rtl/system-img_c.ads 444 10015 7640 4604 5506244256 12230 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . I M G _ C -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Character'Image pragma Ada_9X; function System.Img_C (V : Character; B : Address) return Natural; pragma Inline (System.Img_C); -- Computes Character'Image (V) and stores the resulting string into the -- buffer B, followed by a possible NUL character (the NUL character may -- or may not be present depending on the implementation of the body, but -- the caller must allow for its possible presence). The returned result is -- the number of characters stored, excluding the possible NUL character. -- The caller must ensure that the buffer provided is long enough to hold -- the longest possible result. cter; B : Address) return Natural is package Cnv is new Address_To_Access_Conversions (Character); use Cnv; begin gnat-1.67-src/rtl/system-img_f.adb 444 10015 7640 4463 5506244257 12216 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . I M G _ F -- -- -- -- B o d y -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; with Ttypes; use Ttypes; function System.Img_F (V : Float; B : Address) return Natural is procedure sprintf (Target, Fmt : Address; Prec : Natural; Value : Long_Float; Length_Ptr : Address); pragma Import (C, sprintf); Fmt : constant String := "% .*e%n" & Ascii.NUL; Length : aliased Natural; begin sprintf (B, Fmt'Address, Standard_Float_Digits, Long_Float (V), Length'Address); return Length; end System.Img_F; + Storage_Offset (0)).all := '''; To_Pointer (B + Storage_Offset (1)).all := V; To_Pointer (B + Storage_Offset (2)).all := '''; return 3; end System.Img_C; ; pragma Import (C, C_Fclose, "fgnat-1.67-src/rtl/system-img_f.ads 444 10015 7640 4532 5506244257 12234 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . I M G _ F -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Float'Image pragma Ada_9X; function System.Img_F (V : Float; B : Address) return Natural; -- Computes Float'Image (V) and stores the resulting string into the -- buffer B, followed by a possible NUL character (the NUL character may -- or may not be present depending on the implementation of the body, but -- the caller must allow for its possible presence). The returned result is -- the number of characters stored, excluding the possible NUL character. -- The caller must ensure that the buffer provided is long enough to hold -- the longest possible result. o_Pointer (B + Storage_Offset (1)).all := V; To_Pointer (B + Storage_Offset (2)).all := '''; return 3; end System.Img_C; ; pragma Import (C, C_Fclose, "fgnat-1.67-src/rtl/system-img_i.adb 444 10015 7640 4300 5506244257 12207 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . I M G _ I -- -- -- -- B o d y -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; function System.Img_I (V : Integer; B : Address) return Natural is procedure sprintf (Target, Fmt : Address; Value : Integer; Length_Ptr : Address); pragma Import (C, sprintf); Fmt : constant String := "% d%n" & Ascii.NUL; Length : aliased Natural; begin sprintf (B, Fmt'Address, V, Length'Address); return Length; end System.Img_I; stored, excluding the possible NUL character. -- The caller must ensure that the buffer provided is long enough to hold -- the longest possible result. o_Pointer (B + Storage_Offset (1)).all := V; To_Pointer (B + Storage_Offset (2)).all := '''; return 3; end System.Img_C; ; pragma Import (C, C_Fclose, "fgnat-1.67-src/rtl/system-img_i.ads 444 10015 7640 4577 5506244260 12242 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . I M G _ I -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Integer'Image pragma Ada_9X; function System.Img_I (V : Integer; B : Address) return Natural; pragma Inline (System.Img_I); -- Computes Integer'Image (V) and stores the resulting string into the -- buffer B, followed by a possible NUL character (the NUL character may -- or may not be present depending on the implementation of the body, but -- the caller must allow for its possible presence). The returned result is -- the number of characters stored, excluding the possible NUL character. -- The caller must ensure that the buffer provided is long enough to hold -- the longest possible result. l := V; To_Pointer (B + Storage_Offset (2)).all := '''; return 3; end System.Img_C; ; pragma Import (C, C_Fclose, "fgnat-1.67-src/rtl/system-img_lf.adb 444 10015 7640 4455 5506244260 12365 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . I M G _ L F -- -- -- -- B o d y -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; with Ttypes; use Ttypes; function System.Img_LF (V : Long_Float; B : Address) return Natural is procedure sprintf (Target, Fmt : Address; Prec : Natural; Value : Long_Float; Length_Ptr : Address); pragma Import (C, sprintf); Fmt : constant String := "% .*e%n" & Ascii.NUL; Length : aliased Natural; begin sprintf (B, Fmt'Address, Standard_Long_Float_Digits, V, Length'Address); return Length; end System.Img_LF; t (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under gnat-1.67-src/rtl/system-img_lf.ads 444 10015 7640 4610 5506244260 12377 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . I M G _ L F -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Long_Float'Image pragma Ada_9X; function System.Img_LF (V : Long_Float; B : Address) return Natural; pragma Inline (System.Img_LF); -- Computes Long_Float'Image (V) and stores the resulting string into the -- buffer B, followed by a possible NUL character (the NUL character may -- or may not be present depending on the implementation of the body, but -- the caller must allow for its possible presence). The returned result is -- the number of characters stored, excluding the possible NUL character. -- The caller must ensure that the buffer provided is long enough to hold -- the longest possible result. To_Pointer (B + Storage_Offset (2)).all := '''; return 3; end System.Img_C; ; pragma Import (C, C_Fclose, "fgnat-1.67-src/rtl/system-img_llf.adb 444 10015 7640 5273 5506244261 12541 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . I M G _ L L F -- -- -- -- B o d y -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This is a little messed up for now, since we can't assume that the -- accessible sprintf routine handles long long float. We print the right -- number of digits, but the precision may get degraded. On almost all -- machines Long_Long_Float is the same as Long_Float so it doesn't matter -- but notably for the Intel x86, this will need fixing later on (TBSL). pragma Ada_9X; with Ttypes; use Ttypes; function System.Img_LLF (V : Long_Long_Float; B : Address) return Natural is procedure sprintf (Target, Fmt : Address; Prec : Natural; Val : Long_Float; Length_Ptr : Address); pragma Import (C, sprintf); Fmt : constant String := "% .*e%n" & Ascii.NUL; Length : aliased Natural; begin sprintf (B, Fmt'Address, Standard_Long_Long_Float_Digits, Long_Float (V), Length'Address); return Length; end System.Img_LLF; s); pragma Import (C, C_Unlink, "unlink"); Name1 : String (Name'First .. Name'Last + 1); begin Name1 (Name'range) := Name; Name1 (Name1'Last) := Nul; C_Unlink (Name1'Address); end Unlink; ------------ -- Isatty -- ------------ function Isatty (F : Text_IO.File_Ptr) return Bgnat-1.67-src/rtl/system-img_llf.ads 444 10015 7640 4632 5506244261 12560 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . I M G _ L L F -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Long_Long_Float'Image pragma Ada_9X; function System.Img_LLF (V : Long_Long_Float; B : Address) return Natural; pragma Inline (System.Img_LLF); -- Computes Long_Long_Float'Image (V) and stores the resulting string into -- the buffer B, followed by a possible NUL character (the NUL character may -- or may not be present depending on the implementation of the body, but -- the caller must allow for its possible presence). The returned result is -- the number of characters stored, excluding the possible NUL character. -- The caller must ensure that the buffer provided is long enough to hold -- the longest possible result. Length_Ptr : Address); pragma Import (C, sprintf); Fmt : constant String := "% .*e%ngnat-1.67-src/rtl/system-img_lli.adb 444 10015 7640 5201 5506244261 12533 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . I M G _ L L I -- -- -- -- B o d y -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Note that we can't use printf for this function, because we don't know -- that the accessible version of printf supports GCC long long types. pragma Ada_9X; with System.Storage_Elements; use System.Storage_Elements; function System.Img_LLI (V : Long_Long_Integer; B : Address) return Natural is package Cnv is new Address_To_Access_Conversions (Character); use Cnv; Ptr : Address := B; procedure Putc (C : Character) is begin To_Pointer (Ptr).all := C; Ptr := Ptr + Storage_Offset (1); end Putc; procedure Digs (V : Long_Long_Integer) is begin if V >= 10 then Digs (V / 10); end if; Putc (Character'Val (V mod 10 + 48)); end Digs; begin if V < 0 then Putc ('-'); Digs (-V); else Putc (' '); Digs (V); end if; return Natural (Ptr - B); end System.Img_LLI; Length'Address); return Length; end System.Img_LLF; s); pragma Import (C, C_Unlink, "unlink"); Name1 : String (Name'First .. Name'Last + 1); begin Name1 (Name'range) := Name; Name1 (Name1'Last) := Nul; C_Unlink (Name1'Address); end Unlink; ------------ -- Isatty -- ------------ function Isatty (F : Text_IO.File_Ptr) return Bgnat-1.67-src/rtl/system-img_lli.ads 444 10015 7640 4650 5506244261 12563 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . I M G _ L L I -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Long_Long_Integer'Image pragma Ada_9X; function System.Img_LLI (V : Long_Long_Integer; B : Address) return Natural; pragma Inline (System.Img_LLI); -- Computes Long_Long_Integer'Image (V) and stores the resulting string into -- buffer B, followed by a possible NUL character (the NUL character may -- or may not be present depending on the implementation of the body, but -- the caller must allow for its possible presence). The returned result is -- the number of characters stored, excluding the possible NUL character. -- The caller must ensure that the buffer provided is long enough to hold -- the longest possible result. -- -- GNAT is free software; you can redistribute it and/or modify it under gnat-1.67-src/rtl/system-img_sf.adb 444 10015 7640 4457 5506244262 12400 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . I M G _ S F -- -- -- -- B o d y -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; with Ttypes; use Ttypes; function System.Img_SF (V : Short_Float; B : Address) return Natural is procedure sprintf (Target, Fmt : Address; Prec : Natural; Val : Long_Float; Length_Ptr : Address); pragma Import (C, sprintf); Fmt : constant String := "% .*e%n" & Ascii.NUL; Length : aliased Natural; begin sprintf (B, Fmt'Address, Standard_Short_Float_Digits, Long_Float (V), Length'Address); end System.Img_SF; ; procedure Digs (V : Long_Long_Integer) is begin if V >= 10 then Digs (V / 10); end if; Putc (Character'Val (V mod 10 + 48)); end Digs; begin if V < 0 then Putcgnat-1.67-src/rtl/system-img_sf.ads 444 10015 7640 4613 5506244262 12413 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . I M G _ S F -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Short_Float'Image pragma Ada_9X; function System.Img_SF (V : Short_Float; B : Address) return Natural; pragma Inline (System.Img_SF); -- Computes Short_Float'Image (V) and stores the resulting string into the -- buffer B, followed by a possible NUL character (the NUL character may -- or may not be present depending on the implementation of the body, but -- the caller must allow for its possible presence). The returned result is -- the number of characters stored, excluding the possible NUL character. -- The caller must ensure that the buffer provided is long enough to hold -- the longest possible result. (V / 10); end if; Putc (Character'Val (V mod 10 + 48)); end Digs; begin if V < 0 then Putcgnat-1.67-src/rtl/system-storage_elements.adb 444 10015 7640 5567 5506244262 14477 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S Y S T E M . S T O R A G E _ E L E M E N T S -- -- -- -- B o d y -- -- -- -- $Revision: 1.3 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; package body System.Storage_Elements is -- Address arithmetic function "+" (Left : Address; Right : Storage_Offset) return Address is begin return Left + Address (Right); end "+"; function "+" (Left : Storage_Offset; Right : Address) return Address is begin return Address (Left) + Right; end "+"; function "-" (Left : Address; Right : Storage_Offset) return Address is begin return Left - Address (Right); end "-"; function "-" (Left, Right : Address) return Storage_Offset is begin return Storage_Offset (Left) - Storage_Offset (Right); end "-"; function "mod" (Left : Address; Right : Storage_Offset) return Storage_Offset is begin return Storage_Offset (Left) mod Right; end "mod"; -- Conversion to/from integers function To_Address (Value : Integer_Address) return Address is begin return Address (Value); end To_Address; function To_Integer (Value : Address) return Integer_Address is begin return Integer_Address (Value); end To_Integer; end System.Storage_Elements; st possible result. (V / 10); end if; Putc (Character'Val (V mod 10 + 48)); end Digs; begin if V < 0 then Putcgnat-1.67-src/rtl/system-storage_elements.ads 444 10015 7640 7606 5506244263 14515 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S Y S T E M . S T O R A G E _ E L E M E N T S -- -- -- -- S p e c -- -- -- -- $Revision: 1.4 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; with Unchecked_Conversion; package System.Storage_Elements is -- pragma Pure (System.Storage_Elements); type Storage_Offset is new Integer; subtype Storage_Count is Storage_Offset range 0 .. Storage_Offset'Last; subtype Storage_Index is Storage_Offset range 1 .. Storage_Offset'Last; type Storage_Element is mod 2 ** 8; for Storage_Element'Size use Storage_Unit; type Storage_Array is array (Storage_Index range <>) of aliased Storage_Element; -- for Storage_Array'Component_Size use Storage_Unit; -- Address arithmetic function "+" (Left : Address; Right : Storage_Offset) return Address; pragma Convention (Intrinsic, "+"); pragma Inline ("+"); function "+" (Left : Storage_Offset; Right : Address) return Address; pragma Convention (Intrinsic, "+"); pragma Inline ("+"); function "-" (Left : Address; Right : Storage_Offset) return Address; pragma Convention (Intrinsic, "-"); pragma Inline ("-"); function "-" (Left, Right : Address) return Storage_Offset; pragma Convention (Intrinsic, "-"); pragma Inline ("-"); function "mod" (Left : Address; Right : Storage_Offset) return Storage_Offset; pragma Convention (Intrinsic, "mod"); pragma Inline ("mod"); -- Conversion to/from integers type Integer_Address is mod 2 ** 32; function To_Address (Value : Integer_Address) return Address; pragma Convention (Intrinsic, To_Address); pragma Inline (To_Address); function To_Integer (Value : Address) return Integer_Address; pragma Convention (Intrinsic, To_Integer); pragma Inline (To_Integer); -- Peek/poke functionality generic type Object (<>) is limited private; package Address_To_Access_Conversions is type Object_Pointer is access all Object; function To_Pointer is new Unchecked_Conversion (Address, Object_Pointer); pragma Convention (Intrinsic, To_Pointer); function To_Address is new Unchecked_Conversion (Object_Pointer, Address); pragma Convention (Intrinsic, To_Address); end Address_To_Access_Conversions; end System.Storage_Elements; ); pragma Import (C, C_Fputc, "fputc"); begin C_Fputc (C, F); end Fputc; ----------- -- Stdin -- gnat-1.67-src/rtl/system-traceback.ads 444 10015 7640 5313 5506244263 13065 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . T R A C E B A C K -- -- -- -- S p e c -- -- -- -- $Revision: 1.4 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This module provides the software traceback facility. An internal buffer -- is maintained which stores the last N entries made (N is an internal -- constant defined in the body). pragma Ada_9X; package System.Traceback is -- The following type is used to pass traceback name information subtype Line_Num is Natural; -- Line numbers in traceback buffer Tracebacks_Stored : Boolean := False; -- Set True if any entries made in traceback buffer procedure Store_TB (N : Line_Num; F : Address; S : Address); -- Store a traceback entry in the traceback buffer. N is the line number, -- F is the address of the null terminated file name, and S is the address -- of the null terminated subprogram name, with Null_Address indicating -- that no subprogram name is available. procedure Output_Traceback; -- Output a traceback dump. Does not affect the contents of the buffer. end System.Traceback; ay (Storage_Index range <>) of aliased Storage_Element; -- for Storage_Array'Component_Size use Storage_Unit; -- Address arithmetic function "+" (Left : Address; Right : Storage_Offset) return Address; pragma Convention (Intrinsic, "+"); pragma Inline ("+"); function "+" (Left : Storaggnat-1.67-src/rtl/system-traceback.adb 444 10015 7640 15576 5506244263 13100 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . T R A C E B A C K -- -- -- -- B o d y -- -- -- -- $Revision: 1.9 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Debug; use Debug; pragma Ada_9X; package body System.Traceback is ----------------------- -- Local Subprograms -- ----------------------- procedure Output_Traceback_Entry (L : Line_Num; F : Address; S : Address); -- Outputs one traceback entry line, where L is the line number, F is -- the file name address, and S is the subprogram name address. -------------------------- -- C Library procedures -- -------------------------- procedure puts (S : Address); pragma Interface (C, puts); procedure printf (F : Address; S : Address); pragma Interface (C, printf); procedure putchar (C : Character); pragma Interface (C, putchar); function strlen (S : Address) return Natural; pragma Interface (C, strlen); --------------------- -- Local Variables -- --------------------- Bufsize : constant := 256; -- Number of entries in traceback buffer, must be a power of 2 subtype Bufptr is Natural range 0 .. Bufsize - 1; Lines : array (Bufptr) of Line_Num := (others => 0); -- Lines entries in traceback buffer. Zero indicates an unused entry Fnams : array (Bufptr) of Address; -- File name entries in traceback buffer Snams : array (Bufptr) of Address; -- Subprogram name entries in traceback buffer Buffer_Ptr : Bufptr := 0; -- Traceback buffer pointer: next location to be set. The entries are used -- in a circular manner. P_String : constant String := "%s" & Ascii.NUL; -- Format for printing string with printf -------------- -- Store_TB -- -------------- procedure Store_TB (N : Line_Num; F : Address; S : Address) is begin -- If no debug flag J, then just store the traceback table entry if not Debug_Flag_J then Lines (Buffer_Ptr) := N; Fnams (Buffer_Ptr) := F; Snams (Buffer_Ptr) := S; Buffer_Ptr := (Buffer_Ptr + 1) mod Bufsize; Tracebacks_Stored := True; -- If debug flag J is set, otuput the trace message now else Output_Traceback_Entry (N, F, S); end if; end Store_TB; ---------------------- -- Output_Traceback -- ---------------------- procedure Output_Traceback is Header : constant String := "Abort: traceback follows" & Ascii.Nul; L : Natural; I : Bufptr; begin putchar (Ascii.LF); puts (Header'Address); putchar (Ascii.LF); I := Buffer_Ptr; loop if Lines (I) /= 0 then Output_Traceback_Entry (Lines (I), Fnams (I), Snams (I)); end if; I := (I + 1) mod Bufsize; exit when I = Buffer_Ptr; end loop; putchar (Ascii.LF); putchar (Ascii.LF); end Output_Traceback; ---------------------------- -- Output_Traceback_Entry -- ---------------------------- procedure Output_Traceback_Entry (L : Line_Num; F : Address; S : Address) is D : Natural; begin -- Output line number (5 digits, leading zero suppressed) D := 10000; for J in 1 .. 5 loop if D > 1 and then L < D then putchar (' '); else putchar (Character'Val (48 + (L / D) mod 10)); end if; D := D / 10; end loop; putchar ('.'); putchar (' '); -- Output the file name printf (P_String'Address, F); -- Following test should really use Null_Address, but that wasn't -- working in GNAT version 1.62, so zero was substituted ???. if S /= 0 then putchar (' '); for I in strlen (F) .. 18 loop putchar (' '); end loop; printf (P_String'Address, S); end if; putchar (Ascii.LF); end Output_Traceback_Entry; end System.Traceback; -- Local Subprograms -- ----------------------- procedure Output_Traceback_Entry (L : Line_Num; F : Address; S : Addressgnat-1.67-src/rtl/system-xp.adb 444 10015 7640 11277 5506244263 11602 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . X P -- -- -- -- B o d y -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; package body System.Xp is -------------------------- -- Exponentiate_Integer -- -------------------------- -- Note that negative exponents get a constraint error because the -- subtype of the Right argument (the exponent) is Natural. function Exponentiate_Integer (Left : Type_Of_Base; Right : Natural) return Type_Of_Base is Result : Type_Of_Base := 1; Factor : Type_Of_Base := Left; Exp : Natural := Right; begin -- We use the standard logarithmic approach, Exp gets shifted right -- testing successive low order bits and Factor is the value of the -- base raised to the next power of 2. -- Note: it is not worth special casing the cases of base values -1,0,+1 -- since the expander does this when the base is a literal, and other -- cases will be extremely rare. while Exp /= 0 loop if Exp rem 2 /= 0 then Result := Result * Factor; end if; Factor := Factor * Factor; Exp := Exp / 2; end loop; return Result; end Exponentiate_Integer; ------------------------ -- Exponentiate_Float -- ------------------------ function Exponentiate_Float (Left : Type_Of_Base; Right : Integer) return Type_Of_Base is Result : Type_Of_Base := 1.0; Factor : Type_Of_Base := Left; Exp : Natural := Right; begin -- We use the standard logarithmic approach, Exp gets shifted right -- testing successive low order bits and Factor is the value of the -- base raised to the next power of 2. For positive exponents we -- multiply the result by this factor, for negative exponents, we -- divide by this factor. if Exp >= 0 then -- For a positive exponent, if we get a constraint error during -- this loop, it is an overflow, and the constraint error will -- simply be passed on to the caller. while Exp /= 0 loop if Exp rem 2 /= 0 then Result := Result * Factor; end if; Factor := Factor * Factor; Exp := Exp / 2; end loop; return Result; else -- Exp < 0 then -- For the negative exponent case, a constraint error during this -- calculation happens if Factor gets too large, and the proper -- response is to return 0.0, since what we essenmtially have is -- 1.0 / infinity, and the closest model number will be zero. begin while Exp /= 0 loop if Exp rem 2 /= 0 then Result := Result * Factor; end if; Factor := Factor * Factor; Exp := Exp / 2; end loop; return 1.0 / Result; exception when Constraint_Error => return 0.0; end; end if; end Exponentiate_Float; end System.Xp; s; S : Address) is D : Natural; begin -- Output line number (5 dignat-1.67-src/rtl/system-xp.ads 444 10015 7640 4677 5506244264 11612 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . X P -- -- -- -- S p e c -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This package contains the generic functions which are instantiated with -- predefined integer and real types to generate the runtime exponentiation -- functions called by expanded code generated by Expand_Op_Expon. pragma Ada_9X; package System.Xp is -- pragma Pure (System.Xp); -- Exponentiation for integer base generic type Type_Of_Base is range <>; function Exponentiate_Integer (Left : Type_Of_Base; Right : Natural) return Type_Of_Base; -- Exponentiation for float base generic type Type_Of_Base is digits <>; function Exponentiate_Float (Left : Type_Of_Base; Right : Integer) return Type_Of_Base; end System.Xp; f 2. -- Note: it is not worth special casing the cases ofgnat-1.67-src/rtl/system-xp_f.ads 444 10015 7640 3633 5506244264 12106 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . X P _ F -- -- -- -- S p e c -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Float exponentiation pragma Ada_9X; with System.Xp; use System.Xp; function System.Xp_F is new Exponentiate_Float (Float); runtime exponentiation -- functions called by expanded code generated by Expand_Op_Expon. pragma Agnat-1.67-src/rtl/system-xp_i.ads 444 10015 7640 3640 5506244264 12107 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . X P _ I -- -- -- -- S p e c -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Integer exponentiation pragma Ada_9X; with System.Xp; use System.Xp; function System.Xp_I is new Exponentiate_Integer (Integer); ime exponentiation -- functions called by expanded code generated by Expand_Op_Expon. pragma Agnat-1.67-src/rtl/system-xp_lf.ads 444 10015 7640 3645 5506244264 12265 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . X P _ L F -- -- -- -- S p e c -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Long_Float exponentiation pragma Ada_9X; with System.Xp; use System.Xp; function System.Xp_LF is new Exponentiate_Float (Long_Float); xponentiation -- functions called by expanded code generated by Expand_Op_Expon. pragma Agnat-1.67-src/rtl/system-xp_li.ads 444 10015 7640 3654 5506244265 12271 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . X P _ L I -- -- -- -- S p e c -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Long_Integer exponentiation pragma Ada_9X; with System.Xp; use System.Xp; function System.Xp_LI is new Exponentiate_Integer (Long_Integer); iation -- functions called by expanded code generated by Expand_Op_Expon. pragma Agnat-1.67-src/rtl/system-xp_llf.ads 444 10015 7640 3660 5506244265 12437 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . X P _ L L F -- -- -- -- S p e c -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Long_Long_Float exponentiation pragma Ada_9X; with System.Xp; use System.Xp; function System.Xp_LLF is new Exponentiate_Float (Long_Long_Float); on -- functions called by expanded code generated by Expand_Op_Expon. pragma Agnat-1.67-src/rtl/system-xp_lli.ads 444 10015 7640 3666 5506244265 12450 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . X P _ L L I -- -- -- -- S p e c -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Long_Long_Integer exponentiation pragma Ada_9X; with System.Xp; use System.Xp; function System.Xp_LLI is new Exponentiate_Integer (Long_Long_Integer); ld have received a copy of the GNU -- -- General Public License along witgnat-1.67-src/rtl/system-xp_sf.ads 444 10015 7640 3647 5506244265 12277 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . X P _ S F -- -- -- -- S p e c -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Short_Float exponentiation pragma Ada_9X; with System.Xp; use System.Xp; function System.Xp_SF is new Exponentiate_Float (Short_Float); _Float); on -- functions called by expanded code generated by Expand_Op_Expon. pragma Agnat-1.67-src/rtl/system-xp_si.ads 444 10015 7640 3655 5506244266 12302 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . X P _ S I -- -- -- -- S p e c -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Short_Integer exponentiation pragma Ada_9X; with System.Xp; use System.Xp; function System.Xp_SI is new Exponentiate_Integer (Short_Integer); ); on -- functions called by expanded code generated by Expand_Op_Expon. pragma Agnat-1.67-src/rtl/system-xp_ssi.ads 444 10015 7640 3672 5506244266 12464 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . X P _ S S I -- -- -- -- S p e c -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Short_Short_Integer exponentiation pragma Ada_9X; with System.Xp; use System.Xp; function System.Xp_SSI is new Exponentiate_Integer (Short_Short_Integer); T is free software; you can redistribute it and/or modify it under gnat-1.67-src/rtl/system.ads 444 10015 7640 7104 5506244266 11153 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S Y S T E M -- -- -- -- S p e c -- -- -- -- $Revision: 1.11 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; package System is -- pragma Pure (System); type Name is (GNAT); System_Name : constant Name := GNAT; -- System-Dependent Named Numbers Min_Int : constant := - (2#1#E63); Max_Int : constant := (2#1#E63) - 1; Max_Binary_Modulus : constant := 2#1#E32; Max_Nonbinary_Modulus : constant := 2#1#E16 - 1; Max_Base_Digits : constant := 15; Max_Digits : constant := 15; Max_Mantissa : constant := 31; Fine_Delta : constant := 2#1.0#E-31; Tick : constant := 1.0; -- Storage related Declarations type Address is private; Null_Address : constant Address; Storage_Unit : constant := 8; Word_Size : constant := 32; Memory_Size : constant := 2#1#E32; -- Address comparison function "<" (Left, Right : Address) return Boolean; function "<=" (Left, Right : Address) return Boolean; function ">" (Left, Right : Address) return Boolean; function ">=" (Left, Right : Address) return Boolean; function "=" (Left, Right : Address) return Boolean; pragma Import (Intrinsic, "<"); pragma Import (Intrinsic, "<="); pragma Import (Intrinsic, ">"); pragma Import (Intrinsic, ">="); pragma Import (Intrinsic, "="); -- Declarations for real time Annexe (Annexe H) subtype Any_Priority is Integer range 0 .. 31; subtype Priority is Any_Priority range 0 .. 30; subtype Interrupt_Priority is Any_Priority range 31 .. 31; Default_Priority : constant Priority := (Priority'First + Priority'Last) / 2; private type Address is mod 2#1#E32; Null_Address : constant Address := 0; end System; traint error during -- this loop, it is an overflow, and the constraint error will -- simply be passed on to the caller. while Exp /= 0 loop if Exp rem 2 /= 0 then Result := Result * Factor; end if; Factor := Factor * Factor; Exp := Exp / 2; end loop; return Result; else -- Exp < 0 then -- For the negative expongnat-1.67-src/rtl/text_io.ads 444 10015 7640 3540 5506244267 11303 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- T E X T _ I O -- -- -- -- S p e c -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; with Ada.Text_IO; package Text_IO renames Ada.Text_IO; Name is (GNAT); System_Name : constant Name := GNAT; -- System-Dependent Named Numbers Min_Int : constant := - (2#1#E63); gnat-1.67-src/rtl/ttypes.ads 444 10015 7640 12600 5506244267 11175 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- T T Y P E S -- -- -- -- S p e c -- -- (32-bit Version) -- -- -- $Revision: 1.4 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This module contains values that describe the predefined (standard) -- target types that are provided. Note that it is essential that all -- references to Size values and other attributes of types use this -- package when talking about target types (rather than using the -- attributes directly which would give information about host types). package Ttypes is -- Note: GNAT always supplies all the following integer and float types, -- but depending on the machine, some of the types may be identical. For -- example, on some machines, Short_Float may be the same as Float, and -- Long_Long_Float may be the same as Long_Float. Standard_Short_Short_Integer_Size : constant := 8; -- Standard.Short_Short_Integer'Size Standard_Short_Short_Integer_Width : constant := 4; -- Standard.Short_Short_Integer'Width Standard_Short_Integer_Size : constant := 16; -- Standard.Short_Integer'Size Standard_Short_Integer_Width : constant := 6; -- Standard.Short_Integer'Width Standard_Integer_Size : constant := 32; -- Standard.Integer'Size Standard_Integer_Width : constant := 11; -- Standard.Integer'Width Standard_Long_Integer_Size : constant := 32; -- Standard.Long_Integer'Size Standard_Long_Integer_Width : constant := 11; -- Standard.Long_Integer'Width Standard_Long_Long_Integer_Size : constant := 64; -- Standard.Long_Long_Integer'Size Standard_Long_Long_Integer_Width : constant := 21; -- Standard.Long_Long_Integer'Width Standard_Short_Float_Size : constant := 32; -- Standard.Short_Float'Size Standard_Short_Float_Digits : constant := 6; -- Standard.Short_Float'Digits Standard_Float_Size : constant := 32; -- Standard.Float'Size Standard_Float_Digits : constant := 6; -- Standard.Float'Digits Standard_Long_Float_Size : constant := 64; -- Standard.Long_Float'Size Standard_Long_Float_Digits : constant := 15; -- Standard.Long_Float'Digits Standard_Long_Long_Float_Size : constant := 64; -- Standard.Long_Long_Float'Size Standard_Long_Long_Float_Digits : constant := 15; -- Standard.Long_Long_Float'Digits Standard_Character_Size : constant := 8; -- Standard.Character'Size System_Address_Size : constant := 32; -- System.Address'Size (also size of all thin pointers) System_Max_Binary_Modulus_Power : constant := 64; -- System.Max_Binary_Modulus := 2 ** System_Max_Binary_Modulus_Power System_Max_Nonbinary_Modulus_Power : constant := 32; -- System.Max_Nonbinary_Modulus := -- 2 ** System_Max_Nonbinary_Modulus_Power - 1 System_Storage_Unit : constant := 8; -- System.Storage_Unit System_Word_Size : constant := 32; -- System.Word_Size -- Note: there is no specific control over the representation of -- enumeration types. The convention used is that if an enumeration -- type has fewer than 2**(Character'Size) elements, then the size -- used is Character'Size, otherwise Integer'Size is used. Ones_Complement : constant Boolean := False; -- Set True if integers are represented in ones complement form. The -- current version of GCC does not support ones complement, so this -- constant will always be False, but we retain the control for -- possible future implementation end Ttypes; rr := new AFCB'(AFCB_In_Use => True, Desc => Stderr, Name => new String'("Standard_Error"), Form => new String'("gnat-1.67-src/rtl/unchecked_conversion.adb 444 10015 7640 4602 5506244267 14005 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- U N C H E C K E D _ C O N V E R S I O N -- -- -- -- B o d y -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Obviously the body below is incorrect, since it is simply a checked -- conversion. Indeed it is not possible to write a correct body for -- this generic function in Ada. The approach we take is to provide this -- bogus body, which is read in as a generic template using the normal -- mechanisms, then there is a special circuit (in Sem_Ch11) which checks -- for unchecked conversion and sets the Unchecked_Conversion flag in the -- N_Conversion node in the template. function Unchecked_Conversion (Source_Object : Source) return Target is begin return Target (Source_Object); end Unchecked_Conversion; -- -- GNAT is free software; you can redistribute it and/or modify it under gnat-1.67-src/rtl/unchecked_conversion.ads 444 10015 7640 3776 5506244267 14041 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- U N C H E C K E D _ C O N V E R S I O N -- -- -- -- S p e c -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; generic type Source (<>) is limited private; type Target (<>) is limited private; function Unchecked_Conversion (Source_Object : Source) return Target; pragma Convention (Intrinsic, Unchecked_Conversion); ergnat-1.67-src/rtl/unchecked_deallocation.adb 444 10015 7640 4041 5506244270 14245 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- U N C H E C K E D _ D E A L L O C A T I O N -- -- -- -- B o d y -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; with System; procedure Unchecked_Deallocation (X : in out Name) is procedure Free (A : System.Address); pragma Import (C, Free); begin if X /= null then Free (X.all'Address); X := null; end if; end Unchecked_Deallocation; package when talking about target types (rather than using the -- attributes directly which would give information about host types). package Ttypes is -- Note: GNAT always supplies all the following integer and float types, -- but depending on the machine, some of the types may be identical. For -- example, on some machines, Short_Float may be the same as Float, and -- Long_Long_Float may be the same as Long_Float. Standard_Short_Short_Integer_Size gnat-1.67-src/rtl/unchecked_deallocation.ads 444 10015 7640 3750 5506244270 14274 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- U N C H E C K E D _ D E A L L O C A T I O N -- -- -- -- S p e c -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; generic type Object (<>) is limited private; type Name is access Object; procedure Unchecked_Deallocation (X : in out Name); -- pragma Convention (Intrinsic, Unchecked_Deallocation); and/or modify it under gnat-1.67-src/README 444 10015 7640 650 5506244236 7171 This distribution contains the sources for gnat in the subdirectory src. In src, the directions for building gnat are contained in the files README.SPARC and README.OS2 Running gnat is documented in the file gnat-info. Debugging options are described in debug.doc. The examples directory contains simple examples. The files in the rtl directory are needed to link applications. Information about this is in gnat-intro. ils. You should have received a copy of the GNU -- -- General Public License along witgnat-1.67-src/gnat-intro 444 10015 7640 67723 5506244235 10373 ------------------------------------------------------------------------------ -- -- -- GNAT DOCUMENTS -- -- I N T R O -- -- U N I X V E R S I O N -- -- -- -- -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ Contents. --------- Running GNAT Using the binder. Using GNAT for syntax checking. RTL (Run-Time Library) Options. Gcc switches and GNAT switches. Constraint Checking and Pragma Suppress Using GNAT for semantics checking. Order of compilation Issues. File name rules. Getting Internal Debugging Information. When GNAT crashes. Using gdb. Features supported. Files. Copyright considerations. How to get in touch with us. Schedule A short gnat paper. The GNAT development team. ------------------------------------------------------------------------------ Running GNAT. ------------- Two steps are needed to create an executable file: it must first be compiled, and then bound with other object files it needs to execute. In some simple cases both steps can be performed with one command. Compilation typically takes place in a directory that contains all the sources files for your Ada library. A small example. ---------------- Files hello.adb, io.ads, io.adb, cio.c and bind_hello.c are the components of our modest version of "Hello World". All of these files can be found in the current distribution (in examples/simple_io). The command: gcc -o hello hello.adb io.adb cio.c bind_hello.c creates the executable called "hello" in your current directory. Typing hello will allow you to verify that the system is alive and willing to enter into a primitive dialogue. The same result can be obtained with separate commands: gcc -c hello.adb gcc -c io.adb gcc -c cio.c gcc -c bind_hello.c gcc -o hello bind_hello.o hello.o io.o cio.o Here, separate commands are used for each compilation step. The gcc switch -c indicates that we only want to compile, not link. The last step produces the executable by means of one final compilation and a subsequent linking with previouly created object files. As the example indicates, gcc recognizes the extension .adb and calls the components of GNAT accordingly. The first step in the sequence above produces the file hello.o. It also produces a file hello.ali, which contains dependency information, used by the binder to verify consistency and determine order of elaboration. The "ali" file is the basic building block for the implementation of library management in GNAT. The gcc system has a large number of switches to control compilation options. The switches that are specific to GNAT are entered in the format: -gnatX, where X is a sequence of option flags. Available options are described below. Using the Binder. ----------------- The file bind_hello.c, used in our small example, is actually the output of the binder. The binder is a separate program, invoked by the command 'gnatbind', whose task is to produce the driver program that causes all Ada elaboration procedures to be invoked, and the main program to be called. The input to the binder is the .ali file of the main program: gnatbind hello.ali which produces bind_hello.c. Our small example can therefore be compiled and executed thus: gcc -c hello.adb io.adb cio.c gnatbind hello.ali gcc -o hello bind_hello.c hello.o io.o cio.o Here we have combined the compilations of the sources into a single step. To see exactly what object files need to be linked together look at the bind_XXX.c (XXX is the program name) file produced by gnatbind. In the "main" procedure there are comments containing the names of ali files. These represent the object files that need to be linked together. Usually you will just link in the files that you actually compile but certain programs might need to link in GNAT Run-Time Library modules. This might be the case for programs that use for example 'Address, 'Tag, the image attribute, dynamic exponentiation, etc. This will be more automated in the future when there will be a real Run-Time Library. Constraint Checking and Pragma Suppress --------------------------------------- In the current version there are some checks performed that are mentioned in the LRM in section 11.7. These are: range checks on signed integer and enumeration types (assignment, in parameters and initial values in object declarations) index checks access checks Since this is relatively new there might still be some cases where exceptions are raised where they shouldn't. To disable constraint checks, compile the program with the "-gnatp" option. This is equivalent to having Pragma suppress applied to everything. Gdb can be used to find where the exception was raised. See the section on "Using gdb" for further information. Using GNAT for syntax checking ------------------------------ The current release of GNAT implements the full Ada 9X grammar as described in annotated Ada Reference Manual for Ada 9X (AARM, version 3.0) We think the parser gives excellent error messages (try it and see!) and is pleasantly fast (again, try and see!) To run GNAT in syntax checking only mode, use the switch "s", that is to say, enter the command: gcc -c -gnats file where file is the name of the file to be checked (wild cards can be used to check a set of files, as in *.adb). Note that the 'compile only' flag has to be given for gcc, as well as the 'syntax only' flag which is GNAT-specific. We will remove this redundancy in subsequent releases. The syntax checker is complete, and quite robust. If you manage to blow it up, or if it fails to diagnose an error, or lets a syntactically invalid program through, definitely let us know (see separate section below). If you find an error message you think could be improved, let us know as well. Of course no compiler can ever have perfect error messages (that would involve mind reading), but we are committed to doing as well as possible, so we are happy to get suggestions in this department. RTL (Run Time Library) files ---------------------------- You need to have some standard files around in your directory, such as for example the source of the spec of package System, and the object file for System. The distribution contains a directory called "rtl" containing the specs and bodies of necessary files. A makefile is included which builds the necessary object files. Run the makefile and then copy all the files (source, object and ali) from this directory except Makefile to the directory you will be working in. Later on we will implement search paths for these files, but for now everything must be in your current directory. Options. -------- Error reporting, as well as other aspects of the behavior of the system, are controlled by the following flags. All of these must be entered with the prefix '-gnat'. For example, '-gnatv83' specifies verbose mode for output, and Ada83 syntax checking. a Assertions enabled. Pragma Assert and Debug to be activated. b Generate brief messages to stderr even if verbose mode set. c Check syntax and semantics only (no code generation attempted) e Error messages generated immediately, not saved up till end f Full errors. Normally only the first error on each line is reported. g GNAT style checks enabled. (column alignment, spacing, capitalization. see any source file for examples). ix Identifier character set, x indicates which set: 1-4 = Latin 1-4, p = IBM PC, f/n = full/no upper (default = p) knnn Limit file names to k characters (k = krunch) l Output full source listing with embedded error messages mnnn Limit number of detected errors to nnn (1-999) n No inlining of subprograms (ignore pragma Inline) p Automatic suppression of all run-time checks mentioned in LRM 11.7 r Reference manual column layout required s Syntax check only t Do semantic processing even if there are syntax errors. u List units for this compilation v Verbose mode. Full error output with source lines to stdout. wx Warning mode. s = suppress, e = treat as error 83 Enforce Ada 83 restrictions sfile Source file names (wild cards allowed for multiple files) Some of these options are explained in more detail below. For full information. refer to file usage.adb, in this distribution. For first-time users, and for first-compilation attempts, the following mode of operation is recommended: gcc -c -gnatc let_try_this.adb Gcc swiches and GNAT switches. ------------------------------ The command line switches will be more fully integrated in later releases. For now, gcc recognizes a few GNAT-specific switches, so that these can be given without the prefix "gnat". These are "k8" (file name limit), "83" (Ada83 syntax) and "w" (warning mode). Thus, the following commands are identical: gcc -ws -k8 file.adb gcc -gnatws -k8 file.adb i.e. both of them suppress warning messages from GNAT, and expect file names to be 8 characters long at most (see below for usage). In addition, the following gcc switches are passed through and recognized by GNAT with the same effects as in cc1 (as for C files): "-g*"; "-O*"; "-p"; "-pg"; "-f*"; "-d*"; "-S". For example, gcc -c -g math.adb will generate debugging information that can be used with the debugger gdb. (see below). The other flags that control gcc itself (notably -B and -c) and the assembler, behave as usual. Please consult your GCC documentation for details. Using GNAT for semantics checking ---------------------------------- The command to perform semantic checking is: gcc -c -gnatc file To operate in this mode, since WITH'ed files must be accessed, the GNAT semantic restrictions on file structuring must be followed: o All files must be in the same directory (a temporary restriction, later on, we will implement a search path) o Each file must contain only one compilation unit (we may at least partially relax this restriction in subsequent releases). o The file name and unit name must match as described below, under File name rules (we will provide an alternative scheme in which a file is used to record the correspondence between unit names and file names, but this isn't done yet.) The coverage of semantic checks is still incomplete, and the system is not very robust in the presence of semantically illegal programs. Nevertheless, this release supports many more features of Ada9X than the previous one, and semantic checking is correspondingly more extensive. When you run in this mode, you may get "not implemented yet" messages, blowups, undetected semantic errors etc. Don't bother to tell us about any of these -- we know only too well what still needs to be worked on! Here again, use of the 'report errors immediately' switch will help pinpoint the source of the trouble if the system misbehaves. Note that in semantic checking mode, there is no trace of an Ada library, but of course the sources for all units on which the unit being compiled depends must be around (in the same directory, as noted above). Order of Compilation Issues. ---------------------------- You may have noticed that in our first example, we did not compile explicitly the package declaration in file io.ads. This is the result of the model we chose to implement library management. Details of the model can be found in file gnote1. Some of the unexpected consequences of the model (unexpected from the point of view of existing Ada compiler systems) are the following: o There is no point in compiling generics or specifications (except for package specifications with no bodies), since these are compiled as needed by clients. If you do attempt a useless compilation, you will get a warning message. It is also useless to compile subunits in this mode, since they are compiled as needed by the parent. o There are no order of compilation requirements, and performing a compilation never obsoletes anything. The only way you can obsolete something and require recompilations is if one of the relevant source files is modified. o There is no library as such, apart from the .ali files,whose format is also described in libfmt.ads. For now, we find it convenient to create separate .ali files,but eventually the information therein will be incorporated into the object file directly. o When you compile a unit, the source files for the specs of all units that it WITH's, all its subunits, and the bodies of any generics it instantiates must be around, or you will get a fatal error message. The above may seem surprising. Just to provide one immediate assurance, all of this does not mean that we are violating Ada's strict consistency rules; they are enforced instead by the binder. File Name Rules --------------- As mentioned above, the current version of GNAT requires that file names match compilation unit names. The matching rules are as follows: o The file name is obtained by replacing dots in the unit name with minus signs, and adding a suffix distinguishing bodies and specs. The suffix for specs is ".ads" and for bodies is ".adb". For example, the unchecked deallocation files would be called: unchecked_deallocation.ads unchecked_deallocation.adb in a modern system with no arbitrary file name length restrictions (most systems that support GCC are in this category, e.g. most Unixes, OS/2, NT, Nextstep). o When running under primitive systems like DOS which permit only short file names, the file name itself gets crunched to 8 characters. The exact details of the crunching algorithm are in the full documentation. You can always find out the name it expects by compiling it (since it warns you if it's wrong). Briefly: Only the first and last components of a subunit name are retained If there are no - or _ characters in the result, it is merely truncated to 8 characters. If there are - or _ characters, then each piece is truncated to the same length so that the total is 8 characters, favoring later components if there is a character left over. In DOS, the unchecked deallocation files names would be abbreviated: unc_deal.ads unc_deal.adb Of course the DOS limitations end up restricting the choice of unit names, since file names must be unique. As noted earlier, the final system will also have the option of providing a centralized file name directory (a kind of vestigial library) to avoid these restrictions, and allow complete freedom in choice of file names. Getting Internal Debugging Information. --------------------------------------- Most compilers have secret internal debugging switches and modes. GNAT is no exception, except that nothing about GNAT is secret. The list is contained in the file debug.doc. You will have to get the sources of the compiler for full documentation of the effect of these, but feel free to experiment with them. The switches that print the source of the program (reconstructed from the internal tree) are of general interest, as are the options to print the full internal tree, and the entity table (that is to say, the symbol table information). When GNAT crashes. ------------------ There are several things you can do when GNAT does the unexpected while compiling your Ada program, such as aborting with a segmentation fault, raising an internal exception, or otherwise terminating abnormally. The following lines of action are of course palliatives that will become unecessary as the system becomes more complete and robust. The following strategies are presented in increasing order of difficulty, corresponding to the sophistication of the user, and her curiosity about the functioning of the compiler. 1. run gcc with the -gnatf and -gnate switches. The 'f' switch causes all errors on a given line to be reported. In its absence, only the first error on a line is displayed. The 'e' switch causes errors to be displayed as soon as they are encountered, rather than after compilation is terminated. Often this will be enough to identify the construct that produced the crash. 2. run gcc with -v (verbose) switch. In this mode, gcc produces ongoing information about progress of the compilation and in particular the name of each procedure as it begins to generate code for it. This switch allows you to find which Ada procedure it was compiling when it ran into a code generation problem. 3. run gcc with the -gnatdc switch. This is a GNAT-specific switch that does for the front-end what -v does for the back-end. The system prints the name of each unit, either compilation unit or nested unit, as it is being analyzed. 4. run gdb directly on the gnat1 executable. Gnat1 is the front-end of GNAT, and can be run independently (normally it is just called from gcc). You can use gdb on gnat1 as you would on a C program (but see below for caveats). The "where" command is the first line of attack; the variable "lineno" (seen by "print lineno") used by the second phase of gnat1 and by the gcc back-end, indicates the source line at which the execution stopped, and "input_filename" the name of the source file. Using gdb --------- Gdb awaits modifications to handle Ada properly, and for now can only be used as it would be for a c program. (someone is working on the proper extensions, and these will appear in subsequent releases). In the meantime, the following naming conventions will allow you to find the Ada entities defined in your program: a) The names of all entities (variables, subprograms, etc) are converted to lower case. b) Entities that appear in library package declarations have the name package_name__subprogram_name (Note the two underscores separating package name from subprogram name). Exceptions can be caught by breaking in the "catch_except" routine and then doing a "bt" or "where" command. Features supported ------------------ The parser is a full Ada9X parser,and includes the latest decisions of the mapping team, including the keyowrd -abstract-. Semantic analysis and code generation are in constant evolution, and several important Ada9X features have been implemented in this release. In particular, tagged types, type extensions, and dynamic dispatching (but no private extensions yet) as well as the full hierarchical library mechanism. Chapter 2 pragma List, Page Chapter 3 Object declarations Number declarations Subtype declarations Type declarations Derived types and classes Enumeration types attributes (first, last, range, pos, val, image) Class-Wide types Character types attributes (first, last, range, pos, val, image) Boolean types Integer types attributes (first, last, range, pos, val, image) Modular types. subtypes Floating point (only operations on the predefined types) Array types attributes first, last, range, length Record types Discriminants and Discriminant constraints Variant Parts Tagged Types and extensions (without discriminant) Dispatching Access types Access to subprograms Incomplete types Chapter 4 Indexed Components Slices Selected Components Aggregates (record and array) Exponentiation Expressions (all forms) static concatenation type conversions (except array conversions) membership tests, conversion with class-wide types Chaper 5 statements (all forms) Chapter 6 subprogram declaration and bodies subprogram calls named and positional associations default parameters overloading of subprograms and operators functions returning unconstrained arrays Chapter 7 package declaration and bodies private types Chapter 8 use clauses object, subprogram and package (including library package) renaming exception renaming Chapter 10 library units with clauses stubs and subunits pragma elaborate child units Chapter 11 exceptions declarations handlers raise statement limited constraint checking on integer/enumeration types under the following catagories: Index Checks Access Checks Range Checks Initial values in object declarations. Assignment parameter passing of IN parameters type conversions Chapter 12 Generic units In and In-out generic parameters. Generic formal integer types. Generic formal array types. Generic formal access types. Generic formal subprograms Chapter 13 package System is more complete Address attribute pragma Import pragma Interface, Interface_Name Unchecked deallocation simple record representation clauses Unchecked conversion Chapter 14 package IO_Exceptions/Ada.IO_Exceptions package Text_IO/Ada.Text_IO sections 14.3.1, 14.3.2, 14.3.3, 14.3.4, 14.3.5, 14.3.6 section 14.3.7 (Integer_IO) for type Integer, but NOT Long_Integer and NOT Long_Long_Integer Features currently not supported -------------------------------- Chapter 3 Derived types from private types private type extensions Floating point declaration with constraint Floating point attributes Fixed point declaration Fixed point attributes tagged types with discriminants, Chapter 4 Attributes other than first, last, pos, val, address dynamic concatenation aggregates for tagged types. Chapter 6 full conformance rules Chapter 9 Tasks and protected types (some semantic processing, no runtime) package Calendar Chapter 11 No constraint checking on floating point types or modular types. Range checks which are not listed in the supported features section above. Chapter 12 Generic formal derived types. Generic formal packages. Chapter 14 Text_IO section 14.3.7 (Integer_IO) for Long_Integer and Long_Long_Integer section 14.3.8 (Float_IO) only Put and not Get supported Long_Integer and Long_Long_Integer not supported. section 14.3.8 (Fixed_IO) not supported yet section 14.3.9 (Enumeration_IO) not supported yet Ada 9X Modular_IO and Decimal_IO not supported. Sequential_IO Direct_IO Stream_IO Files. ------ If you want to examine the workings of the GNAT system, the following haiku-like description of its organization might be of minimal use: File with prefix "sc" contain the lexical scanner. All files prefixed with "par" are components of the parser. The numbers correspond to chapters of the Ada83 LRM (or the corresponding sections of the Ada9X LRM). For example, parsing of select statements can be found in par-ch9. All files prefixed with "sem" perform semantic analysis. Same numbering scheme. For example, all issues involving context clauses can be found in sem_ch10. All files prefixed with "exp" perform AST normalization and expansion. For example, the construction of record initialization procedures is done in exp_ch3. The files prefixed with "bind" implement the binder, which verifies the consistency of the compilation, determines an order of elaboration, and generates the bind file. The file atree details the low-level data structures used by the front-end. The file sinfo details the structure of the AST as produced by the parser. The file einfo details the attributes of all entities, computed during semantic analysis. Library management issues are dealt with in files with prefix "lib". Files with prefix a- are Ada-specific gcc files. They are the components of Gigi (gnat-to-gnu), the program that translates the Ada AST into gcc tree fragments. Gigi makes use of C versions of atree, einfo and sinfo, called a-atree[ch], a-einfo.[ch] and a-sinfo.h respectively. All the other .c files are modifications of common GCC files. Happy browsing! Copyright Considerations ------------------------ For now, everything is copyrighted by NYU, using the GNU public license. This means that you can copy everything freely, but you can't incorporate the code directly into a commercial program. For more information on the GNU license, see the file header. One important note is that it will be possible to use GNAT to generate software that is not itself covered by the GNU license. Eventually the copyright will be transferred to the Free Software Foundation, so that GNAT can be distributed directly by FSF under the same restrictions (or what we like to think of as lack of restrictions!) How to Get in Touch with Us --------------------------- To get on our external INTERNET mailing list, send a message to: gnat-request@cs.nyu.edu To send reports to us on the system, or ask questions, send messages to gnat-report@cs.nyu.edu To contact team members, send messages to: dewar@cs.nyu.edu schonberg@cs.nyu.edu To obtain electronically the latest version of the system, FTP from: cs.nyu.edu (directory pub/gnat) This FTP directory also includes full sources for the system, full documentation and technical notes, as well as executables of the system for several targets. We are sorry that our limited resources do not allow us to distribute the system through other media. We trust that this information will be mirrored at other FTP sites around the world (we encourage such mirroring to occur) which will make it easier for users in other continents to obtain the GNAT system without heavy communication uncertainties. Schedule. --------- We will make available new releases of GNAT at 2 week intervals, until the final delivery for this phase of the project, in December of this year. Please recall that releases of the system are still only snapshots of work in progress. We hope that it will be of some use in the work of others, even in its current embryonic form. A short gnat paper ------------------ A TeX file of a short paper describing something about the GNAT project is included under the name gnat-paper.tex. The GNAT development team. --------------------------- New York University Bernard Banner (*) Cyrille Comar (*) Robert Dewar (*) Sam Figueroa (*) Richard Kenner (*) Bruno LeClerc (*) Brett Porter (*) Gail Schenker (*) Edmond Schonberg (*) Florida State University (Tasking runtime work) Ted Baker Ted Giering (*) Frank Muller Ecole Nationale Superieure de Telecommunications Franco Gasperoni (*) Yvon Kermarrec Laurent Pautet Elsewhere Paul Hilfinger (*) (University of California, Berkeley) Jean Pierre Rosen (*) (Paris) Richard Stallman (Free Software Foundation) (*) partially supported by the NYU GNAT project (ARPA, USAF, AJPO, Ada 9X project office) rst, last, range, pos, val, image) Boolegnat-1.67-src/debug.doc 444 10015 7640 11705 5506244235 10130 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- D E B U G -- -- -- -- Documentation -- -- -- -- $Revision: 1.5 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ This documentation file contains a description of the current usage of the dynamic debug flags declared in package Debug and set in package Switch. Options for Tree and Source Print --------------------------------- This facility allows printing to Standard_Output of generated trees and also of source recreated from these generated trees. The basic options are: -dt Print generated tree of main unit (but not withed units) after the last phase (i.e. after parsing if there are parse errors or if in syntax check only mode, and otherwise after semantics/expansion), -ds Print recreated source from tree of main unit (but not withed units) after the last phase (i.e. after parsing if parse errors or if in syntax check only mode, and otherwise after semantics/expansion), Additional options are: -du Print generated tree of main unit after parsing and before semantics. If this is used together with -dt and semantics takes place, then both trees will be separately printed -dw Print recreated source from three of main unit after parsing and before semantics. If this is used together with -ds and semantics takes place, then both sources will be separately printed -dy Print generated tree for package Standard after last phase -dz Print recreated source for package Standard after last phase -df Modifies the effect of -ds -dt -du -dw switches so that in addition to output for the main unit, trees/sources will also be output for all subsidiary units, including those directly withed and those implicitly loaded. -dg Modifies the form of any recreated source printed to include only the generated (rewritten) tree without any {} characters -do Modifies the form of any recreated source printed to include only the original tree. Note that if expansion has taken place, the expander is allowed to clobber the tree, so even with -do you will see the clobbered tree. Note: in the absense of -dg and -do, source trees are printed with both the original tree before rewriting, and the rewritten generated tree, with sections from the latter enclosed in {} curly brackets. Other debugging switches ------------------------ -da Generate messages tracking semantic analyzer progress. A message will be output as each node is analyzed, resolved or expanded. -dc List names of units as they are compiled -dd Dynamic allocation of tables messages generated. Each time one of the dynamic tables (package Table) is expanded, a message is generated. -de List the entity table -dh Force unit loads even in syntax only mode. This is useful in debugging the basic unit loading mechanism, separate from semantic analysis. -di Generate messages for visibility linking/delinking -dk Force the compiler to crash as soon as Debug_Error, Compiler_Error or any standard exception are raised. That is the only way to get a traceback, now that these exceptions are handled in the procedure gnat. -dl Generate unit load trace messages. Each time a unit load is attempted a message is generated, showing the unit name, and whether the unit has already been loaded. -dn Generate messages for node/list allocation. A message is generated for each node or list allocated. -dp Generate messages for parser scope stack push/pops. Each time the parser stack is pushed or popped, a message is generated. -dr Generate parser resynchronization messages. When one of the parser resync routines in Par.Sync is called, two messages are generated at the start and end of the token scan. Debug Flag Usage for Binder --------------------------- -dc List units as they are chosen in the dependency analysis -dn List details of manipulation of Num_Pred values used in the dependency analysis One important note is that it will be possible to use GNAT gnat-1.67-src/examples/ 777 10015 7640 0 5506244247 10071 gnat-1.67-src/examples/README 755 10015 7640 1607 5506244237 11040 This is the Gnat Examples Directory. Our goal is to provide the gnat user some pieces of code that are easy to understand, easy to modify and to play with, and which demonstrate either : - some classic Ada features - some new Ada 9x features - some good pedagogical programming exercises If you are insterested in sharing your own programs with the Gnat community, please tune them with the latest Gnat version and send it with appropriate documentation (and bug reports) to comar@cs.nyu.edu 1- simple_io provides (extremely) basic Input-Output facilities with a text_io-like syntax. A "Hello World" program is used as main unit. 2- text_io_example trivial demonstration of a use of text_io. 3- instruments A very simple simulation of car dashboard instruments. Demonstrates simple type extension, dispatching and child unit. 2 main programs are provided, demo1 and demo2. syntax check only mode, and otherwise after semantics/expansion), Additional options are: -du Print generated tregnat-1.67-src/examples/ada-text_io.adb 444 10015 7640 36421 5506244237 13043 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- A D A . T E X T _ I O -- -- -- -- B o d y -- -- -- -- $Revision: 1.10 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO.Aux; package body Ada.Text_IO is procedure Unimplemented (Message : String) is begin Put (Message); Put_Line (" not implemented yet"); end Unimplemented; --------------------- -- File Management -- --------------------- procedure Create (File : in out File_Type; Mode : in File_Mode := Out_File; Name : in String := ""; Form : in String := "") renames Text_IO.Aux.Create; procedure Open (File : in out File_Type; Mode : in File_Mode; Name : in String; Form : in String := "") renames Text_IO.Aux.Open; procedure Close (File : in out File_Type) renames Text_IO.Aux.Close; procedure Delete (File : in out File_Type) renames Text_IO.Aux.Delete; procedure Reset (File : in out File_Type; Mode : in File_Mode) renames Text_IO.Aux.Reset; procedure Reset (File : in out File_Type) is begin Text_IO.Aux.Reset (File, Text_IO.Aux.Mode (File)); end Reset; function Mode (File : in File_Type) return File_Mode renames Text_IO.Aux.Mode; function Name (File : in File_Type) return String renames Text_IO.Aux.Name; function Form (File : in File_Type) return String renames Text_IO.Aux.Form; function Is_Open (File : in File_Type) return Boolean renames Text_IO.Aux.Is_Open; procedure Set_Input (File : in File_Type) renames Text_IO.Aux.Set_Input; procedure Set_Output (File : in File_Type) renames Text_IO.Aux.Set_Output; procedure Set_Error (File : in File_Type) renames Text_IO.Aux.Set_Error; function Standard_Input return File_Type renames Text_IO.Aux.Standard_Input; function Standard_Output return File_Type renames Text_IO.Aux.Standard_Output; function Standard_Error return File_Type renames Text_IO.Aux.Standard_Error; function Current_Input return File_Type renames Text_IO.Aux.Current_Input; function Current_Output return File_Type renames Text_IO.Aux.Current_Output; function Current_Error return File_Type renames Text_IO.Aux.Current_Error; -------------------------------------------- -- specification of line and page lengths -- -------------------------------------------- procedure Set_Line_Length (File : in File_Type; To : in Count) renames Text_IO.Aux.Set_Line_Length; procedure Set_Line_Length (To : in Count) is begin Text_IO.Aux.Set_Line_Length (Current_Output, To); end Set_Line_Length; function Line_Length (File : in File_Type) return Count renames Text_IO.Aux.Line_Length; function Line_Length return Count is begin return Text_IO.Aux.Line_Length (Current_Output); end Line_Length; procedure Set_Page_Length (File : in File_Type; To : in Count) renames Text_IO.Aux.Set_Page_Length; procedure Set_Page_Length (To : in Count) is begin Text_IO.Aux.Set_Page_Length (Current_Output, To); end Set_Page_Length; function Page_Length (File : in File_Type) return Count renames Text_IO.Aux.Page_Length; function Page_Length return Count is begin return Page_Length (Current_Output); end Page_Length; ------------------------------------ -- Column, Line, and Page Control -- ------------------------------------ procedure New_Line (File : in File_Type; Spacing : in Positive_Count := 1) renames Text_IO.Aux.New_Line; procedure New_Line (Spacing : in Positive_Count := 1) is begin New_Line (Current_Output, Spacing); end New_Line; procedure Skip_Line (File : in File_Type; Spacing : in Positive_Count := 1) renames Text_IO.Aux.Skip_Line; procedure Skip_Line (Spacing : in Positive_Count := 1) is begin Skip_Line (Current_Input, Spacing); end Skip_Line; function End_Of_Line (File : in File_Type) return Boolean renames Text_IO.Aux.End_Of_Line; function End_Of_Line return Boolean is begin return End_Of_Line (Current_Input); end End_Of_Line; procedure New_Page (File : in File_Type) renames Text_IO.Aux.New_Page; procedure New_Page is begin New_Page (Current_Output); end New_Page; procedure Skip_Page (File : in File_Type) renames Text_IO.Aux.Skip_Page; procedure Skip_Page is begin Skip_Page (Current_Input); end Skip_Page; function End_Of_Page (File : in File_Type) return Boolean renames Text_IO.Aux.End_Of_Page; function End_Of_Page return Boolean is begin return End_Of_Page (Current_Input); end End_Of_Page; function End_Of_File (File : in File_Type) return Boolean renames Text_IO.Aux.End_Of_File; function End_Of_File return Boolean is begin return End_Of_File (Current_Input); end End_Of_File; procedure Set_Col (File : in File_Type; To : in Positive_Count) renames Text_IO.Aux.Set_Col; procedure Set_Col (To : in Positive_Count) is begin Set_Col (Current_Output, To); end Set_Col; procedure Set_Line (File : in File_Type; To : in Positive_Count) renames Text_IO.Aux.Set_Line; procedure Set_Line (To : in Positive_Count) is begin Set_Line (Current_Output, To); end Set_Line; function Col (File : in File_Type) return Positive_Count renames Text_IO.Aux.Col; function Col return Positive_Count is begin return Col (Current_Output); end Col; function Line (File : in File_Type) return Positive_Count renames Text_IO.Aux.Line; function Line return Positive_Count is begin return Line (Current_Output); end Line; function Page (File : in File_Type) return Positive_Count renames Text_IO.Aux.Page; function Page return Positive_Count is begin return Page (Current_Output); end Page; ------------------------------- -- Characters Input-Output -- ------------------------------- procedure Get (File : in File_Type; Item : out Character) is begin Text_IO.Aux.The_File := File; Text_IO.Aux.Get (Item); end Get; procedure Get (Item : out Character) is begin Get (Current_Input, Item); end Get; procedure Put (File : in File_Type; Item : in Character) is begin Text_IO.Aux.The_File := File; Text_IO.Aux.Put (Item); end Put; procedure Put (Item : in Character) is begin Put (Current_Output, Item); end Put; ---------------------------- -- Strings Input-Output -- ---------------------------- procedure Get (File : in File_Type; Item : out String) is begin Text_IO.Aux.The_File := File; Text_IO.Aux.Get (Item); end Get; procedure Get (Item : out String) is begin Get (Current_Input, Item); end Get; procedure Put (File : in File_Type; Item : in String) is begin Text_IO.Aux.The_File := File; Text_IO.Aux.Put (Item); end Put; procedure Put (Item : in String) is begin Put (Current_Output, Item); end Put; procedure Get_Line (File : in File_Type; Item : out String; Last : out Natural) renames Text_IO.Aux.Get_Line; procedure Get_Line (Item : out String; Last : out Natural) is begin Get_Line (Current_Input, Item, Last); end Get_Line; procedure Put_Line (File : in File_Type; Item : in String) renames Text_IO.Aux.Put_Line; procedure Put_Line (Item : in String) is begin Put_Line (Current_Output, Item); end Put_Line; ------------------------------------- -- Input-Output of Integer Types -- ------------------------------------- package body Integer_Io is procedure Get (File : in File_Type; Item : out Num; Width : in Field := 0) is X : Integer; begin Text_IO.Aux.The_File := File; -- Some type of check against Integer'Last is necessary Text_IO.Aux.Get_Int (X, Width); if X < Integer (Num'First) or else X > Integer (Num'Last) then raise Data_Error; end if; Item := Num (X); end Get; procedure Get (Item : out Num; Width : in Field := 0) is begin Get (Current_Input, Item, Width); end Get; procedure Put (File : in File_Type; Item : in Num; Width : in Field := Default_Width; Base : in Number_Base := Default_Base) is begin Text_IO.Aux.The_File := File; Text_IO.Aux.Put_Int (Integer (Item), Width, Base); end Put; procedure Put (Item : in Num; Width : in Field := Default_Width; Base : in Number_Base := Default_Base) is begin Put (Current_Output, Item, Width, Base); end Put; procedure Get (From : in String; Item : out Num; Last : out positive) is X : Integer; begin -- Some type of check against Integer'Last is necessary Text_IO.Aux.Get_Int (From, X, Last); if X < Integer (Num'First) or else X > Integer (Num'Last) then raise Data_Error; end if; Item := Num (X); end Get; procedure Put (To : out String; Item : in Num; Base : in Number_Base := Default_Base) is begin Text_IO.Aux.Put_Int (To, Integer (Item), Base); end Put; end Integer_Io; ------------------------------------ -- Input-Output of Float Types -- ------------------------------------ package body Float_Io is procedure Get (File : in File_Type; Item : out Num; Width : in Field := 0) is begin Text_IO.Aux.The_File := File; -- Some type of check against Float'Last is necessary Text_IO.Aux.Get_Float (Float (Item), Width); end Get; procedure Get (Item : out Num; Width : in Field := 0) is begin Get (Current_Input, Item, Width); end Get; procedure Put (File : in File_Type; Item : in Num; Fore : in Field := Default_Fore; Aft : in Field := Default_Aft; Exp : in Field := Default_Exp) is begin Text_IO.Aux.The_File := File; Text_IO.Aux.Put_Float (Float (Item), Fore, Aft, Exp); end Put; procedure Put (Item : in Num; Fore : in Field := Default_Fore; Aft : in Field := Default_Aft; Exp : in Field := Default_Exp) is begin Put (Current_Output, Item, Fore, Aft, Exp); end Put; procedure Get (From : in String; Item : out Num; Last : out Positive) is begin Text_IO.Aux.Get_Float (From, Float (Item), Last); end Get; procedure Put (To : out String; Item : in Num; Aft : in Field := Default_Aft; Exp : in Field := Default_Exp) is begin Text_IO.Aux.Put_Float (To, Float (Item), Aft, Exp); end Put; end Float_Io; --------------------------------------- -- Input-Output of Enumeration Types -- --------------------------------------- package body Enumeration_Io is procedure Get (File : in File_Type; Item : out Enum) is use Text_IO.Aux; begin Unimplemented ("Enumeration_IO.Get"); end Get; procedure Get (Item : out Enum) is begin Unimplemented ("Enumeration_IO.Get"); end Get; procedure Put (File : in File_Type; Item : in Enum; Width : in Field := Default_Width; Set : in Type_Set := Default_Setting) is begin Unimplemented ("Enumeration_IO.Put"); end Put; procedure Put (Item : in Enum; Width : in Field := Default_Width; Set : in Type_Set := Default_Setting) is begin Unimplemented ("Enumeration_IO.Put"); end Put; procedure Get (From : in String; Item : out Enum; Last : out positive) is use Text_IO.Aux; begin Unimplemented ("Enumeration_IO.Get"); end Get; procedure Put (To : out String; Item : in Enum; Set : in Type_Set := Default_Setting) is begin Unimplemented ("Enumeration_IO.Put"); end Put; end Enumeration_Io; end Ada.Text_IO; ---------------------- -- REVISION HISTORY -- ---------------------- -- ---------------------------- -- revision 1.8 -- date: Wed Dec 15 16:56:17 1993; author: banner -- (Set_Output): mistakenly renamed Set_Input. -- ---------------------------- -- revision 1.9 -- date: Mon Dec 20 00:08:22 1993; author: banner -- (Current_Error): add renaming for new Ada 9X function. -- (Standard_Error): add renaming for new Ada 9X function. -- (Set_Error): add renaming for new Ada 9X function. -- ---------------------------- -- revision 1.10 -- date: Wed Dec 22 13:23:02 1993; author: banner -- (Integer_IO.Get): Make actual parmeter of call to Get_Int a variable of -- type Integer rather than a conversion to Integer. Correct test for -- detecting Data_Error upon return from Get_Int. -- ---------------------------- -- New changes after this line. Each line starts with: "-- " begin return Line (Current_Output); end Line; function Page (File : in File_Type) return Positive_Count renames Text_IO.Aux.Page; function Page return Positive_Count is begin return Page (Current_Output); gnat-1.67-src/examples/ada-text_io.ads 644 10015 7640 37574 5506244240 13072 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- A D A . T E X T _ I O -- -- -- -- S p e c -- -- -- -- $Revision: 1.8 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; with Ada.IO_Exceptions; package Ada.Text_IO is type File_Type is limited private; type File_Mode is (In_File, Out_File, Append_File); type Count is range 0 .. Integer'Last; -- implementation defined; subtype Positive_Count is Count range 1 .. Count'Last; Unbounded : constant Count := 0; -- line and page length subtype Field is Integer range 0 .. 100; -- implementation defined subtype Number_Base is Integer range 2 .. 16; type Type_Set is (Lower_Case, Upper_Case); --------------------- -- File Management -- --------------------- procedure Create (File : in out File_Type; Mode : in File_Mode := Out_File; Name : in String := ""; Form : in String := ""); procedure Open (File : in out File_Type; Mode : in File_Mode; Name : in String; Form : in String := ""); procedure Close (File : in out File_Type); procedure Delete (File : in out File_Type); procedure Reset (File : in out File_Type; Mode : in File_Mode); procedure Reset (File : in out File_Type); function Mode (File : in File_Type) return File_Mode; function Name (File : in File_Type) return String; function Form (File : in File_Type) return String; function Is_Open (File : in File_Type) return Boolean; ------------------------------------------------------ -- Control of default input, output and error files -- ------------------------------------------------------ procedure Set_Input (File : in File_Type); procedure Set_Output (File : in File_Type); procedure Set_Error (File : in File_Type); function Standard_Input return File_Type; function Standard_Output return File_Type; function Standard_Error return File_Type; function Current_Input return File_Type; function Current_Output return File_Type; function Current_Error return File_Type; -------------------------------------------- -- Specification of line and page lengths -- -------------------------------------------- procedure Set_Line_Length (File : in File_Type; To : in Count); procedure Set_Line_Length (To : in Count); procedure Set_Page_Length (File : in File_Type; To : in Count); procedure Set_Page_Length (To : in Count); function Line_Length (File : in File_Type) return Count; function Line_Length return Count; function Page_Length (File : in File_Type) return Count; function Page_Length return Count; ------------------------------------ -- Column, Line, and Page Control -- ------------------------------------ procedure New_Line (File : in File_Type; Spacing : in Positive_Count := 1); procedure New_Line (Spacing : in Positive_Count := 1); procedure Skip_Line (File : in File_Type; Spacing : in Positive_Count := 1); procedure Skip_Line (Spacing : in Positive_Count := 1); function End_Of_Line (File : in File_Type) return Boolean; function End_Of_Line return Boolean; procedure New_Page (File : in File_Type); procedure New_Page; procedure Skip_Page (File : in File_Type); procedure Skip_Page; function End_Of_Page (File : in File_Type) return Boolean; function End_Of_Page return Boolean; function End_Of_File (File : in File_Type) return Boolean; function End_Of_File return Boolean; procedure Set_Col (File : in File_Type; To : in Positive_Count); procedure Set_Col (To : in Positive_Count); procedure Set_Line (File : in File_Type; To : in Positive_Count); procedure Set_Line (To : in Positive_Count); function Col (File : in File_Type) return Positive_Count; function Col return Positive_Count; function Line (File : in File_Type) return Positive_Count; function Line return Positive_Count; function Page (File : in File_Type) return Positive_Count; function Page return Positive_Count; ------------------------------- -- Characters Input-Output -- ------------------------------- procedure Get (File : in File_Type; Item : out Character); procedure Get (Item : out Character); procedure Put (File : in File_Type; Item : in Character); procedure Put (Item : in Character); ---------------------------- -- Strings Input-Output -- ---------------------------- procedure Get (File : in File_Type; Item : out String); procedure Get (Item : out String); procedure Put (File : in File_Type; Item : in String); procedure Put (Item : in String); procedure Get_Line (File : in File_Type; Item : out String; Last : out Natural); procedure Get_Line (Item : out String; Last : out Natural); procedure Put_Line (File : in File_Type; Item : in String); procedure Put_Line (Item : in String); --------------------------------------------------------- -- Generic package for Input-Output of Integer Types -- --------------------------------------------------------- generic type Num is range <>; package Integer_Io is Default_Width : Field := 10; -- Num'Width Default_Base : Number_Base := 10; procedure Get (File : in File_Type; Item : out Num; Width : in Field := 0); procedure Get (Item : out Num; Width : in Field := 0); procedure Put (File : in File_Type; Item : in Num; Width : in Field := Default_Width; Base : in Number_Base := Default_Base); procedure Put (Item : in Num; Width : in Field := Default_Width; Base : in Number_Base := Default_Base); procedure Get (From : in String; Item : out Num; Last : out Positive); procedure Put (To : out String; Item : in Num; Base : in Number_Base := Default_Base); end Integer_Io; --------------------------------------------------------- -- Generic package for Input-Output of Modular Types -- --------------------------------------------------------- -- generic -- type Num is mod <>; -- package Modular_IO is -- Default_Width : Field := Num'Width; -- Default_Base : Number_Base := 10; -- procedure Get (File : in File_Type; -- Item : out Num; -- Width : in Field := 0); -- procedure Get (Item : out Num; -- Width : in Field := 0); -- procedure Put (File : in File_Type; -- Item : in Num; -- Width : in Field := Default_Width; -- Base : in Number_Base := Default_Base); -- procedure Put (Item : in Num; -- Width : in Field := Default_Width; -- Base : in Number_Base := Default_Base); -- procedure Get (From : in String; -- Item : out Num; -- Last : out Positive); -- procedure Put (To : out String; -- Item : in Num; -- Base : in Number_Base := Default_Base); -- -- end Modular_IO; -------------------------------------------------------- -- Generic packages for Input-Output of Real Types -- -------------------------------------------------------- generic type Num is digits <>; package Float_Io is Default_Fore : Field := 2; Default_Aft : Field := 5; -- Num'Digits - 1; Default_Exp : Field := 3; procedure Get (File : in File_Type; Item : out Num; Width : in Field := 0); procedure Get (Item : out Num; Width : in Field := 0); procedure Put (File : in File_Type; Item : in Num; Fore : in Field := Default_Fore; Aft : in Field := Default_Aft; Exp : in Field := Default_Exp); procedure Put (Item : in Num; Fore : in Field := Default_Fore; Aft : in Field := Default_Aft; Exp : in Field := Default_Exp); procedure Get (From : in String; Item : out Num; Last : out Positive); procedure Put (To : out String; Item : in Num; Aft : in Field := Default_Aft; Exp : in Field := Default_Exp); end Float_Io; -- generic -- type Num is delta <>; -- package Fixed_Io is -- Default_Fore : Field := Num'For; -- Default_Aft : Field := Num'Aft; -- Default_Exp : Field := 0; -- procedure Get (File : in File_Type; -- Item : out Num; -- Width : in Field := 0); -- procedure Get (Item : out Num; Width : in Field := 0); -- procedure Put (File : in File_Type; -- Item : in Num; -- Fore : in Field := Default_Fore; -- Aft : in Field := Default_Aft; -- Exp : in Field := Default_Exp); -- procedure Put (Item : in Num; -- Fore : in Field := Default_Fore; -- Aft : in Field := Default_Aft; -- Exp : in Field := Default_Expr); -- procedure Get (From : in String; Item : out Num; Last : out Positive); -- procedure Put (To : out String; -- Item : in Num; -- Aft : in Field := Default_Aft; -- Exp : in Field := Default_Exp); -- end Fixed_Io; -- generic -- type Num is delta <> digits <>; -- package Decimal_IO is -- -- Default_Fore : Field := Num'Fore; -- Default_Aft : Field := Num'Aft; -- Default_Exp : Field := 0; -- procedure Get (File : in File_Type; -- Item : out Num; -- Width : in Field := 0); -- procedure Get (Item : out Num; -- Width : in Field := 0); -- procedure Put (File : in File_Type; -- Item : in Num; -- Fore : in Field := Default_Fore; -- Aft : in Field := Default_Aft; -- Exp : in Field := Default_Exp); -- procedure Put (Item : in Num; -- Fore : in Field := Default_Fore; -- Aft : in Field := Default_Aft; -- Exp : in Field := Default_Exp); -- procedure Get (From : in String; -- Item : out Num; -- Last : out Positive); -- procedure Put (To : out String; -- Item : in Num; -- Aft : in Field := Default_Aft; -- Exp : in Field := Default_Exp); -- end Decimal_IO; --------------------------------------- -- Input-Output of Enumeration Types -- --------------------------------------- generic type Enum is ( <> ); package Enumeration_Io is Default_Width : Field := 0; Default_Setting : Type_Set := Upper_Case; procedure Get (File : in File_Type; Item : out Enum); procedure Get (Item : out Enum); procedure Put (File : in File_Type; Item : in Enum; Width : in Field := Default_Width; Set : in Type_Set := Default_Setting); procedure Put (Item : in Enum; Width : in Field := Default_Width; Set : in Type_Set := Default_Setting); procedure Get (From : in String; Item : out Enum; Last : out positive); procedure Put (To : out String; Item : in Enum; Set : in Type_Set := Default_Setting); end Enumeration_Io; -- Exceptions Status_Error : exception renames IO_Exceptions.Status_Error; Mode_Error : exception renames IO_Exceptions.Mode_Error; Name_Error : exception renames IO_Exceptions.Name_Error; Use_Error : exception renames IO_Exceptions.Use_Error; Device_Error : exception renames IO_Exceptions.Device_Error; End_Error : exception renames IO_Exceptions.End_Error; Data_Error : exception renames IO_Exceptions.Data_Error; Layout_Error : exception renames IO_Exceptions.Layout_Error; private type File_Ptr is mod 2#1#E32; type Pstring is access String; -- Ada File Control Block (Afcb) type AFCB is record AFCB_In_Use : Boolean; Desc : File_Ptr; Name : Pstring; Form : Pstring; Mode : File_Mode; Page : Count; Line : Count; Col : Positive_Count; Line_Length : Count; Page_Length : Count; Count : Integer; Look_Ahead : String (1 .. 3); end record; type File_Type is access AFCB; end Ada.Text_IO; ---------------------- -- REVISION HISTORY -- ---------------------- -- ---------------------------- -- revision 1.6 -- date: 1993/12/13 23:12:09; author: banner; state: Exp; lines: +55 -22 -- Make File_Type a limited private types as the LRM specifies it, now that -- the implementation of limited privates types seem to work. -- Uncomment remaining commented out specifications for Float_Io. -- Add in commented out specifications for Fixed_Io. -- ---------------------------- -- revision 1.7 -- date: 1993/12/15 21:56:10; author: banner; state: Exp; lines: +4 -4 -- Change value of Default_Aft to 5. -- ---------------------------- -- revision 1.8 -- date: 1993/12/20 05:08:12; author: banner; state: Exp; lines: +86 -8 -- (Current_Error): new Ada 9X function. -- (Standard_Error): new Ada 9X function. -- (Set_Error): new Ada 9X function. -- Add in commented out specifications for Modular_Io. -- Add in commented out specifications for Decimal_Io. -- ---------------------------- -- New changes after this line. Each line starts with: "-- " ackage for Input-Output of Modular Types -- --------------------------------------------------------- -- generic -- gnat-1.67-src/examples/Makefile 755 10015 7640 3755 5506244240 11620 #----------------------------------------------------------------------------- # EXAMPLES Makefile #----------------------------------------------------------------------------- # # Intructions to Add a new example # # 1. Update the variable LIST_EXEC with the new target (executable name) # # 2. Add a new entry in the dependencies with the following format : # name_exec_DEP= {list of .o files needed to build the executable} # name_exec : $(name_exec_DEP) #----------------------------------------------------------------------------- # the C compiler CC=gcc # the Ada Compiler ADAC=gcc # Gnat1 compilation flags GF= # Gnatbind binder flags BF= # Put here the final target of each test case. # it can be a '.o' file if the test is just a compilation one # otherwise it is the final executable LIST_COMPILE_ONLY= LIST_EXEC= hello text_io_example demo1 demo2 #----------------------------------------------------------------------------- # Main rule process : clean $(LIST_EXEC) #----------------------------------------------------------------------------- # Dependancies hello_DEP= hello.o io.o cio.o hello : $(hello_DEP) demo1_DEP= demo1.o ada-tags.o instr.o io.o cio.o demo1 : $(demo1_DEP) demo2_DEP= demo2.o ada-tags.o instr.o instr-child.o io.o cio.o demo2 : $(demo2_DEP) text_io_example_DEP = text_io_example.o ada.o ada-io_exceptions.o \ ada-text_io.o ada-text_io-aux.o system.o io-aux.o text_io.o text_io_example : $(text_io_example_DEP) ############################################################################### # General rules ############################################################################### .SUFFIXES: .adb .ads .ali .o .PHONY: clean process force .adb.o: $(ADAC) -c $(GF) $< .ads.o: $(ADAC) -c $(GF) $< .c.o: $(CC) -c $(CFLAGS) $< % : %.o $(BDIR)gnatbind $@.ali $(CC) -c $(CFLAGS) bind_$@.c $(CC) $(LDFLAGS) -o $@ bind_$@.o $($@_DEP) $@ clean : force @/bin/rm -f *.o *.ali bind_*.c *.s $(LIST_EXEC) force : le process : cleagnat-1.67-src/examples/cio.c 755 10015 7640 170 5506244240 11042 #include int get_int () { int x; scanf (" %d", &x); return x; } put_int (int x) { printf ("%d", x); } Šada.adsÜŠ ada-text_io-aux.adsôŠ ada-tags.adb, w Š ada-tags.adsftw Š demo1.adbss4Š demo2.adb13LŠ gen_list.adb dŠ gen_list.ads |Šinstr-child.adb”Šinstr-child.ads¨Š instr.adb--¼Š instr.ads--ÜŠ$ada-io_exceptions.adsIOŠ ada-text_io-aux.adbŠ!gnat-1.67-src/examples/hello.adb 755 10015 7640 1224 5506244241 11721 With IO; use IO; procedure Hello is C : Character; I : Integer; S : String (1 .. 100); begin Put_Line ("Hello. Welcome to the GNAT IO example" & "!"); Put ("Please enter a single character now followed by "); Get (C); Put ("Your character is: "); Put (C); Get (C); -- read the New_Line (2); Put ("Please enter a String now followed by :"); Get_Line (S, I); Put ("Your String is : "); Put_Line (S (1 .. I)); Put ("Its length is : "); Put (I); New_Line (2); Put ("Please enter an integer now followed by "); Get (I); Put ("Your number is: "); Put (I); New_Line (2); end; ###### .SUFFIXES: .adb .ads .ali .o .PHONY: clean process force .adb.o: $(ADAC) -c $(GF) $< .ads.o: $(ADAC) -c $(GF) $< .c.o: $(CC) -c $(CFLAGS) $< % : %.o $(BDIR)gnatbind $@.ali $(CC) -c $(CFLAGS) bind_$@.c $(CC) $(LDFLAGS) -o $@ bind_$@.o $($@_DEP) $@ clean : force @/bin/rm -f *.o *.ali bind_*.c *.s $(LIST_EXEC) force : le process : cleagnat-1.67-src/examples/io.adb 755 10015 7640 3046 5506244241 11231 package body IO is procedure Get (X : out Integer) is function Getint return Integer; pragma Interface (C, Getint); pragma Interface_Name (Getint, "get_int"); begin X := Getint; end Get; procedure Put (X : Integer) is procedure Putint (X : Integer); pragma Interface (C, Putint); pragma Interface_Name (Putint, "put_int"); begin Putint (X); end Put; procedure Get (C : out Character) is function Getchar return Character; pragma Interface (C, Getchar); begin C := Getchar; end Get; procedure Put (C : Character) is procedure Putchar (C : Character); pragma Interface (C, Putchar); begin Putchar (C); end Put; procedure Put (S : String) is begin for I in S'range loop Put (S (I)); end loop; end Put; procedure Put_Line (S : String) is begin Put (S); New_Line; end Put_Line; procedure New_Line (Spacing : Positive := 1) is begin for I in 1 .. Spacing loop Put (Ascii.LF); end loop; end New_Line; procedure Get_Line (Item : in out String; Last : out Natural) is I_Length : Integer := Item'Length; Nstore : Integer := 0; C : Character; begin loop Get (C); exit when Nstore = I_Length; if C = Ascii.Lf then exit; end if; Item (Item'First + Nstore) := C; Nstore := Nstore + 1; end loop; Last := Item'First + Nstore - 1; end Get_Line; end IO; -- Fore : in Field := Default_Fore; -- Aft : in Field := Default_Aft; -- Exp : in Field := Default_Expr); -- procedure Get (From : in String; Item : out Num; Last : out Positive); -- procedure Put (To : out String; -- Item : in Num; -- Aft : in Field := Default_Aft; -- Exp : in Field := Default_Exp); -- end Fixed_Io; -gnat-1.67-src/examples/io.ads 755 10015 7640 540 5506244241 11226 package Io is procedure Get (X : out Integer); procedure Put (X : Integer); procedure Get (C : out Character); procedure Put (C : Character); procedure Put (S : String); procedure Put_Line (S : String); procedure New_Line (Spacing : Positive := 1); procedure Get_Line (Item : in out String; Last : out Natural); end Io;  instr.ads¼ÜŠ$ada-io_exceptions.adsa-Š ada-text_io-aux.adbŠ!io-aux.c(Š" text_io.adsDŠ# text_io_example.gnat-1.67-src/examples/ada.ads 755 10015 7640 4160 5506244242 11367 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- A D A -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ package Ada is -- pragma Pure (Ada); end Ada; ---------------------- -- REVISION HISTORY -- ---------------------- -- ---------------------------- -- revision 1.1 -- date: Wed Oct 13 14:57:57 1993; author: banner -- Initial revision -- ---------------------------- -- New changes after this line. Each line starts with: "-- " Aft : in Field := Default_Aft; -- Exp : in Field := Default_Expr); -- procedure Get (From : in String; Item : out Num; Last : out Positive); -- procedure Put (To : out String; -- Item : in Num; -- Aft : in Field := Default_Aft; -- Exp : in Field := Default_Exp); -- end Fixed_Io; -gnat-1.67-src/examples/ada-text_io-aux.ads 444 10015 7640 17410 5506244242 13650 ------------------------------------------------------------------------------ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- -- A D A . T E X T _ I O . A U X -- -- -- -- S p e c -- -- -- -- $Revision: 1.9 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ private package Ada.Text_Io.Aux is Current_In : File_Type; Current_Out : File_Type; Current_Err : File_Type; The_File : File_Type; procedure Create (File : in out File_Type; Mode : in File_Mode := Out_File; Name : in String := ""; Form : in String := ""); procedure Open (File : in out File_Type; Mode : in File_Mode; Name : in String; Form : in String := ""); procedure Close (File : in out File_Type); procedure Delete (File : in out File_Type); procedure Reset (File : in out File_Type; Mode : in File_Mode); function Mode (File : in File_Type) return File_Mode; function Name (File : in File_Type) return String; function Form (File : in File_Type) return String; function Is_Open (File : in File_Type) return Boolean; ------------------------------------------------------ -- Control of default input, output and error files -- ------------------------------------------------------ procedure Set_Input (File : in File_Type); procedure Set_Output (File : in File_Type); procedure Set_Error (File : in File_Type); function Standard_Input return File_Type; function Standard_Output return File_Type; function Standard_Error return File_Type; function Current_Input return File_Type; function Current_Output return File_Type; function Current_Error return File_Type; -------------------------------------------- -- Specification of line and page lengths -- -------------------------------------------- procedure Set_Line_Length (File : in File_Type; To : in Count); procedure Set_Page_Length (File : in File_Type; To : in Count); function Line_Length (File : in File_Type) return Count; function Page_Length (File : in File_Type) return Count; ------------------------------------ -- Column, Line, and Page Control -- ------------------------------------ procedure New_Line (File : in File_Type; Spacing : in Positive_Count := 1); procedure Skip_Line (File : in File_Type; Spacing : in Positive_Count := 1); function End_Of_Line (File : in File_Type) return Boolean; procedure New_Page (File : in File_Type); procedure Skip_Page (File : in File_Type); function End_Of_Page (File : in File_Type) return boolean; function End_Of_File (File : in File_Type) return boolean; procedure Set_Col (File : in File_Type; To : in Positive_Count); procedure Set_Line (File : in File_Type; To : in Positive_Count); function Col (File : in File_Type) return Positive_Count; function Line (File : in File_Type) return Positive_Count; function Page (File : in File_Type) return Positive_Count; ----------------------------- -- Characters Input-Output -- ----------------------------- procedure Get (Item : out Character); procedure Put (Item : in Character); -------------------------- -- Strings Input-Output -- -------------------------- procedure Get (Item : out String); procedure Put (Item : in String); procedure Get_Line (File : in File_Type; Item : out String; Last : out Natural); procedure Put_Line (File : in File_Type; Item : in String); ----------------------------------- -- Input-Output of Integer Types -- ----------------------------------- Default_Width_Int : Field := 11; Default_Base_Int : Number_Base := 10; procedure Get_Int (Item : out Integer; Width : in Field := 0); procedure Put_Int (Item : in Integer; Width : in Field; Base : in Number_Base); procedure Get_Int (From : in String; Item : out Integer; Last : out Positive); procedure Put_Int (To : out String; Item : in Integer; Base : in Number_Base); ----------------------------------- -- Input-Output of Float Types -- ----------------------------------- procedure Get_Float (Item : out Float; Width : in Field); procedure Put_Float (Item : in Float; Fore : in Field; Aft : in Field; Exp : in Field); procedure Get_Float (From : in String; Item : out Float; Last : out Positive); procedure Put_Float (To : out String; Item : in Float; Aft : in Field; Exp : in Field); procedure Text_IO_Finalization; -- Finialization cleanup routine for Text_IO files ---------------------------------------------------------------- -- Variables used to share information with body of Text_IO -- ---------------------------------------------------------------- type Work_String_Type is array (0 .. 1023) of Character; Work_String : Work_String_Type; WS_Length : Natural := 0; WS_Index1 : Natural := 0; WS_Index2 : Natural := 0; WS_Index3 : Natural := 0; end Ada.Text_Io.Aux; ---------------------- -- REVISION HISTORY -- ---------------------- -- ---------------------------- -- revision 1.7 -- date: Mon Dec 13 18:12:23 1993; author: banner -- Eliminate Work_String2. -- (Get_Float, Put_Float): new procedures. -- (Put_Int): remove default value for Base parameter. -- ---------------------------- -- revision 1.8 -- date: Mon Dec 20 00:08:33 1993; author: banner -- (Current_Error): new Ada 9X function. -- (Standard_Error): new Ada 9X function. -- (Set_Error): new Ada 9X function. -- Add declaration for Current_Err. -- ---------------------------- -- revision 1.9 -- date: Wed Dec 22 13:23:10 1993; author: banner -- Change upper bound of Work_String to 1023 to allow for longer strings. -- ---------------------------- -- New changes after this line. Each line starts with: "-- " Form : in String := ""); procedure Close (File : in out File_Type); procedure Delete (File : in out File_Type); procedure Reset (File : in out File_Type; Mode : in File_Mode); function Mode (File : in Filgnat-1.67-src/examples/ada-tags.adb 755 10015 7640 5270 5506244242 12305 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- A D A . T A G S -- -- -- -- B o d y -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; package body Ada.Tags is ------------------- -- Expanded_Name -- ------------------- function Expanded_Name (T : Tag) return String is begin raise Program_Error; -- TBSL return ""; end; ------------------ -- External_Tag -- ------------------ function External_Tag (T : Tag) return String is begin raise Program_Error; -- TBSL return ""; end; ------------------ -- Internal_Tag -- ------------------ function Internal_Tag (External : String) return Tag is begin raise Program_Error; -- TBSL return null; end; end Ada.Tags; ---------------------- -- REVISION HISTORY -- ---------------------- -- ---------------------------- -- revision 1.1 -- date: Thu Oct 21 13:00:55 1993; author: dewar -- Initial revision -- ---------------------------- -- New changes after this line. Each line starts with: "-- " Boolean; ------------------------------------------------------ -- Control of default input, output and error files -- ------------------------------------------------------ procedure Set_Input (File : in File_Type); procedure Set_Output (File : in File_Type); procedure Set_Error (File : in File_Type); gnat-1.67-src/examples/ada-tags.ads 755 10015 7640 4555 5506244243 12334 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- A D A . T A G S -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; package Ada.Tags is type Tag is private; function Expanded_Name (T : Tag) return String; function External_Tag (T : Tag) return String; function Internal_Tag (External : String) return Tag; Tag_Error : exception; private type Tag is access Integer; end Ada.Tags; ---------------------- -- REVISION HISTORY -- ---------------------- -- ---------------------------- -- revision 1.1 -- date: Thu Oct 21 13:00:57 1993; author: dewar -- Initial revision -- ---------------------------- -- New changes after this line. Each line starts with: "-- " -- -- GNAT is free software; you can redistribute it and/or modify it under gnat-1.67-src/examples/demo1.adb 755 10015 7640 2324 5506244243 11627 with Instr; use Instr; with Gen_List; with Io; use Io; procedure Demo1 is type Acc is access all Instrument'Class; package Dash_Board is new Gen_List (Acc); use Dash_Board; procedure Print_Dash_Board (L : List) is L1 : List := L; A : Acc; begin while L1 /= Nil loop A := Element (L1); Display_Value (A.all); L1 := Tail (L1); end loop; New_Line; end Print_Dash_Board; Speed : aliased Speedometer; Fuel : aliased Gauge; Oil, Water : aliased Graphic_Gauge; Time : aliased Clock; Chrono : aliased Chronometer; DB : List := Nil; begin Set_Name (Speed, "Speed"); Set_Name (Fuel, "Fuel"); Set_Name (Water, "Water"); Set_Name (Oil, "Oil"); Set_Name (Time, "Time"); Set_Name (Chrono, "Chronometer"); Speed.Value := 45; -- mph Fuel.Value := 60; -- % Water.Value := 80; -- % Oil.Value := 30; -- % Init (Time, 12, 15, 00); Init (Chrono, 22, 12, 56); DB := Append (Speed'Access, Append (Fuel'Access, Append (Water'Access, Append (Oil'Access, Append (Time'Access, Chrono'Access))))); Print_Dash_board (DB); end Demo1; it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 witgnat-1.67-src/examples/demo2.adb 755 10015 7640 5666 5506244243 11644 with Instr; use Instr; with Instr.Child; use Instr.Child; with Io; use Io; with Gen_List; procedure Demo2 is type Acc is access Instrument'Class; package Dash_Board is new Gen_List (Acc); use Dash_Board; procedure Print_Dash_Board (L : List) is L1 : List := L; begin while L1 /= Nil loop Display_Value (Element (L1).all); L1 := Tail (L1); end loop; New_Line; end Print_Dash_Board; DB : List := Nil; Inc, Sec : Integer; begin DB := Append (new Speedometer, -- 1 Append (new Gauge, -- 2 Append (new Graphic_Gauge, -- 3 Append (new Graphic_Gauge, -- 4 Append (new Clock, -- 5 Append (new Chronometer, -- 6 Append (new Accurate_Clock))))))); -- 7 Set_Name (Element (DB, 1).all, "Speed"); Set_Name (Element (DB, 2).all, "Fuel"); Set_Name (Element (DB, 3).all, "Water"); Set_Name (Element (DB, 4).all, "Oil"); Set_Name (Element (DB, 5).all, "Time in NY"); Set_Name (Element (DB, 6).all, "Chrono"); Set_Name (Element (DB, 7).all, "Time in Paris"); Speedometer (Element (DB, 1).all).Value := 45; -- mph Gauge (Element (DB, 2).all).Value := 60; -- % Graphic_Gauge (Element (DB, 3).all).Value := 80; -- % Graphic_Gauge (Element (DB, 4).all).Value := 40; -- % Init (Clock (Element (DB, 5).all), 12, 15, 0); Init (Chronometer (Element (DB, 6).all), 0, 0, 0); Init (Accurate_Clock (Element (DB, 7).all), 6, 15, 0); loop Print_Dash_board (DB); if Graphic_Gauge (Element (DB, 3).all).Value < 60 then Put_Line ("There is a leak in the radiator."); end if; if Speedometer (Element (DB, 1).all).Value> 50 then Put_Line (" Speed limit is 50 ... "); end if; if Clock (Element (DB, 5).all).Seconds /= Accurate_Clock (Element (DB, 7).all).Seconds then Put_Line (" Your first clock is not very accurate "); end if; Put ("Give a time increment in milliseconds (0 to terminate) :"); Get (Inc); exit when Inc <= 0; Sec := Inc / 1000; Increment (Clock (Element (DB, 5).all), Sec); Increment (Chronometer (Element (DB, 6).all), Sec); Increment (Accurate_Clock (Element (DB, 7).all), Inc); Gauge (Element (DB, 2).all).Value := Integer (Float (Gauge (Element (DB, 2).all).Value) * (1.0 - Float (Sec) / 3600.0)); Graphic_Gauge (Element (DB, 3).all).Value := Integer (Float (Graphic_Gauge (Element (DB, 3).all).Value) * (1.0 - Float (Sec) / 600.0)); Speedometer (Element (DB, 1).all).Value := Speedometer (Element (DB, 1).all).Value + 2; end loop; exception when Others => Put_Line ("I think that's enough for today... Bye"); end Demo2; t (File : in File_Type); procedure Set_Error (File : in File_Type); gnat-1.67-src/examples/gen_list.adb 755 10015 7640 3465 5506244243 12435 package body Gen_List is function Append ( E1 : Elmt) return List is begin return new Internal'(E1, Nil); end Append; function Append ( E1, E2 : Elmt) return List is begin return new Internal'(E1, new Internal'(E2, Nil)); end Append; function Append ( E1 : Elmt; L1 : List) return List is begin return new Internal'(E1, L1); end Append; function Append ( L1 : List; E1 : Elmt) return List is L : List; begin if L1 = Nil then return new Internal'(E1, Nil); else L := L1; while L.Next /= Nil loop L := L.Next; end loop; L.Next := new Internal'(E1, Nil); return L1; end if; end Append; function Append ( L1, L2 : List) return List is L : List; begin if L1 = Nil then return L2; else L := L1; while L.Next /= Nil loop L := L.Next; end loop; L.Next := L2; return L1; end if; end Append; function Element (L : List; Number : Positive := 1) return Elmt is L1 : List := L; begin for I in 2 .. Number loop if L1 = Nil then raise Error_List; end if; L1 := L1.Next; end loop; return L1.E; end Element; function Tail (L : List; Skip : Positive := 1) return List is L1 : List := L; begin for I in 1 .. Skip loop if L1 = Nil then raise Error_List; end if; L1 := L1.Next; end loop; return L1; end Tail; function Length (L : List) return Natural is C : Natural := 0; L1 : List := L; begin while L1 /= Nil loop C := C + 1; L1 := L1.Next; end loop; return C; end Length; end Gen_List; if L1 = Nil then return L2; else L := L1; while L.Next /= Nil loop L := L.Next; end loop; L.Next := L2; return L1; engnat-1.67-src/examples/gen_list.ads 755 10015 7640 1313 5506244244 12445 generic type Elmt is private; package Gen_List is type Internal; type List is access Internal; type Internal is record E : Elmt; Next : List; end record; Nil : constant List := null; function Append ( E1 : Elmt) return List; function Append ( E1, E2 : Elmt) return List; function Append ( E1 : Elmt; L1 : List) return List; function Append ( L1 : List; E1 : Elmt) return List; function Append ( L1, L2 : List) return List; function Element (L : List; Number : Positive := 1) return Elmt; function Tail (L : List; Skip : Positive := 1) return List; function Length (L : List) return Natural; Error_List : exception; end Gen_List; C := C + 1; L1 := L1.Next; end loop; return C; end Length; end Gen_List; if L1 = Nil then return L2; else L := L1; while L.Next /= Nil loop L := L.Next; end loop; L.Next := L2; return L1; engnat-1.67-src/examples/instr-child.adb 755 10015 7640 1156 5506244244 13045 with Io; use Io; package body Instr.Child is procedure Display_Value (C : Accurate_Clock) is begin Display_Value (Clock (C)); Put (":"); Put (Character'Val (Character'Pos ('0') + (C.MilliSec / 100) mod 10)); Put (Character'Val (Character'Pos ('0') + (C.MilliSec / 10) mod 10)); Put (Character'Val (Character'Pos ('0') + C.MilliSec mod 10)); end Display_Value; procedure Increment (C : in out Accurate_Clock; Inc : Integer := 1) is begin Increment (Clock (C), (C.MilliSec + Inc) / 1000); C.MilliSec := (C.MilliSec + Inc) mod 1000; end Increment; end; function Length (L : List) return Natural; Error_List : exception; end Gen_List; C := C + 1; L1 := L1.Next; end loop; return C; end Length; end Gen_List; if L1 = Nil then return L2; else L := L1; while L.Next /= Nil loop L := L.Next; end loop; L.Next := L2; return L1; engnat-1.67-src/examples/instr-child.ads 755 10015 7640 473 5506244244 13047 package Instr.Child is subtype Thousand is Integer range 0 .. 1000; type Accurate_Clock is new Clock with record MilliSec : Thousand := 0; end record; procedure Display_Value (C : Accurate_Clock); procedure Increment (C : in out Accurate_Clock; inc : Integer := 1); end; Put (Character'Val (Character'Pos ('0') + C.MilliSec mod 10)); end Display_Value; procedure Increment (C : in out Accurate_Clock; Inc : Integer := 1) is begin Increment (Cgnat-1.67-src/examples/instr.adb 755 10015 7640 5202 5506244244 11760 with Io; use Io; package body Instr is procedure Set_Name (I : in out Instrument; S : String) is begin for J in S'range loop I.Name (J) := S (J); exit when J >= I.Name'Last; end loop; end Set_Name; procedure Display_Value (I : Instrument) is begin New_Line; Put (I.Name); Put (" : "); end Display_Value; procedure Display_Value (S : Speedometer) is begin Display_Value (Instrument (S)); Put (S.Value); Put (" Miles per Hour"); end Display_Value; procedure Display_Value (G : Gauge) is begin Display_Value (Instrument (G)); Put (G.Value); Put (" %"); end Display_Value; procedure Display_Value (G : Graphic_Gauge) is Lg : constant Integer := G.Size * G.Value / 100; S1 : constant String (1 .. Lg) := (others => G.Fill); S2 : constant String (Lg + 1 .. G.Size) := (others => G.Empty); begin Display_Value (Instrument (G)); Put ('<'); Put (S1); Put (S2); Put ('>'); end Display_Value; procedure Display_Value (C : Clock) is begin Display_Value (Instrument (C)); Put (Character'Val (Character'Pos ('0') + C.Hours / 10)); Put (Character'Val (Character'Pos ('0') + C.Hours mod 10)); Put (":"); Put (Character'Val (Character'Pos ('0') + C.Minutes / 10)); Put (Character'Val (Character'Pos ('0') + C.Minutes mod 10)); Put (":"); Put (Character'Val (Character'Pos ('0') + C.Seconds / 10)); Put (Character'Val (Character'Pos ('0') + C.Seconds mod 10)); end Display_Value; procedure Increment (C : in out Clock; Inc : Integer := 1) is nInc : Integer; begin C.Seconds := (C.Seconds + Inc) mod 60; nInc := (C.Seconds + Inc) / 60; C.Minutes := (C.Minutes + nInc) mod 60; nInc := (C.Minutes + nInc) / 60; C.Hours := (C.Hours + nInc) mod 24; end Increment; procedure Init (C : in out Clock; H : Twenty_Four := 0; M, S : Sixty := 0) is begin C.Seconds := S; C.Minutes := M; C.Hours := H; end Init; procedure Display_Value (C : Chronometer) is V : Integer; begin Display_Value (Instrument (C)); V := C.Seconds + C.Minutes * 60 + C.Hours * 3600; Put ("<<"); Put (Character'Val (Character'Pos ('0') + (V / 1000) mod 10)); Put (Character'Val (Character'Pos ('0') + (V / 100) mod 10)); Put (Character'Val (Character'Pos ('0') + (V / 10) mod 10)); Put (Character'Val (Character'Pos ('0') + V mod 10)); Put (">>"); end Display_Value; end Instr; ange loop I.Name (J) := S (J); exit when J >= I.Name'Last; end loop; end Set_Name; procedure Display_Value (I : Instrument) is begin New_Line; Put (I.Name); Put (" : "); end Display_Value; procedure Display_Value (S : Speedometer) is begin Display_Value (Instrument (S)); Put (S.Value); Put (" Milesgnat-1.67-src/examples/instr.ads 755 10015 7640 3522 5506244245 12005 package Instr is -- Instruments for a Dashboard -- -- Instrument ---- Speedometer -- | -- ---- Gauge ---- Graphic_Gauge -- | -- ---- Clock ---- Chronometer ----------------- -- Root Type -- ----------------- type Instrument is tagged record Name : String (1 .. 14) := " "; end record; procedure Set_Name (I : in out Instrument; S : String); procedure Display_Value (I : Instrument); ------------------- -- Speedometer -- ------------------- subtype Speed is Integer range 0 .. 85; -- mph type Speedometer is new Instrument with record Value : Speed; end record; procedure Display_Value (S : Speedometer); ----------------- -- Gauges -- ----------------- subtype Percent is Integer range 0 .. 100; type Gauge is new Instrument with record Value : Percent; end record; procedure Display_Value (G : Gauge); type Graphic_Gauge is new Gauge with record Size : Integer := 20; Fill : Character := '*'; Empty : Character := '.'; end record; procedure Display_Value (G : Graphic_Gauge); ----------------- -- Clocks -- ----------------- subtype Sixty is Integer range 0 .. 60; subtype Twenty_Four is Integer range 0 .. 24; type Clock is new Instrument with record Seconds : Sixty := 0; Minutes : Sixty := 0; Hours : Twenty_Four := 0; end record; procedure Display_Value (C : Clock); procedure Init (C : in out Clock; H : Twenty_Four := 0; M, S : Sixty := 0); procedure Increment (C : in out Clock; Inc : Integer :=1); type Chronometer is new Clock with null record; procedure Display_Value (C : Chronometer); end Instr; := (C.Minutes + nInc) / 60; C.Hours := (C.Hours + nInc) mod 24; end Increment; procedure Init (C : in out Clock; H : Twenty_Four := 0; gnat-1.67-src/examples/ada-io_exceptions.ads 444 10015 7640 5036 5506244245 14236 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- A D A . I O _ E X C E P T I O N S -- -- -- -- S p e c -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; package Ada.IO_Exceptions is Status_Error : exception; Mode_Error : exception; Name_Error : exception; Use_Error : exception; Device_Error : exception; End_Error : exception; Data_Error : exception; Layout_Error : exception; end Ada.IO_Exceptions; ---------------------- -- REVISION HISTORY -- ---------------------- -- ---------------------------- -- revision 1.1 -- date: Wed Oct 13 14:58:47 1993; author: banner -- Initial revision -- ---------------------------- -- revision 1.2 -- date: Thu Oct 14 15:19:20 1993; author: banner -- Add pragma Ada_9X in case user is compiling text_io while in Ada83 mode. -- ---------------------------- -- New changes after this line. Each line starts with: "-- " - Float (Sec) / 3600.0)); Graphic_Gauge (Element (DB, 3).all).Value := Integer (Float (Graphic_Gauge (Element (DB, 3).all).Value) * (1.0 - Float (Sec) / 600.0)); Speedometer (Element (DB, 1).all).Value := Speedometer (Element (DB, 1).all).Value + 2; end loop; exception when Others => Put_Line ("I think that's enough for today... Bye"); end Demo2; t (File : in File_Type); procedure Set_Error (File : in File_Type); gnat-1.67-src/examples/ada-text_io-aux.adb 444 10015 7640 205734 5506244246 13663 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- A D A . T E X T _ I O . A U X -- -- -- -- B o d y -- -- -- -- $Revision: 1.10 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with System; use System; package body Ada.Text_IO.Aux is Max_Num_Of_Files : constant := 60; Line_Feed : constant Character := Ascii.Lf; -- Character'Val (16#0A#); Nul : constant Character := Ascii.Nul; -- Character'Val (16#00#); Page_Mark : constant Character := Ascii.Ff; -- Character'Val (16#0C#); -- The term "file" here is used in the same way as in the Ada Reference -- Manual, that is it refers to an object of some "file_type". Otherwise -- "external file" is used. Open_Files : array (1 .. Max_Num_Of_Files) of File_Type; -- Used to make sure we don't open too many files and that we do not -- open the same file twice. Standard_In : File_Type; Standard_Out : File_Type; Standard_Err : File_Type; Scanning_From_File : Boolean; -- Determines if characters are read from a File (True) or String (False). type Temp_File_Rec; type Link is access Temp_File_Rec; type Temp_File_Rec is record File_Name : Pstring; Next : Link; end record; Temp_Files : Link; ------------------------ -- Local Subprograms -- ------------------------- procedure Allocate_AFCB; -- Determine which AFCB in the Open_Files table is available to be used -- for the current file. function Alpha (C : Character) return Boolean; -- Predicate to test if Character argument is an upper or lower case -- letter, returns True if the argument is a letter, False if not. function Alphanum (C : Character) return Boolean; -- Predicate to test if Character is an upper or lower case letter -- or a digit. Returns True if the arguement is a letter or a digit, -- False if not. procedure Check_Digit; -- Assert that the next Character is a digit otherwise raise Data_Error. procedure Check_Extended_Digit; -- Assert that the next Character is an extended digit otherwise raise -- Data_Error. procedure Check_File_Open; -- Check if the current file is open or not. If the file is not open, -- then Status_Error is raised. Otherwise control returns normally. procedure Check_Hash (C : Character); -- Determine if next Character is matching hash, raise Data_Error if not. -- Stores '#' in Work_String. procedure Check_Multiple_File_Opens; procedure Check_Opened_Ok; -- Check that an Fopen succeeded, raise Name_Error if not procedure Check_Status_And_Mode (C_Mode : File_Mode); -- If the current file is not open, then Status_Error is raised. If -- the file is open, then the mode is checked against the argument which -- is the desired mode for the operation. If it does not match, then -- Mode_Error is raised, otherwise control returns normally. procedure Check_Status_And_Mode (C_Mode1, C_Mode2 : File_Mode); -- If the current file is not open, then Status_Error is raised. If -- the file is open, then the mode is checked against the arguments which -- are the desired modes for the operation. If it does not match either -- one of them, Mode_Error is raised, otherwise control returns normally. procedure Close_File; -- Close file and deallocate the AFCB back to the pool. procedure Copy_Integer; -- This procedure copies a string with the syntax of "based_Integer" from -- the input to the Work_String. Underscores are allowed but not copied. procedure Copy_Based_Integer; -- This procedure copies a string with the syntax of "based_Integer" from -- the input to the Work_String. Underscores are allowed but not copied. procedure Copyc; -- Copy the next input Character to Work_String using WS_Index2 function Digit (C : Character) return Boolean; -- Predicate if C corresponds to the digits 0 thru 9. function Extended_Digit (C : Character) return Boolean; -- Predicate if C corresponds to the digits 0 thru 9 or letters A thru F. function Graphic (C : Character) return Boolean; -- Predicate to test if the Character is an Ascii graphic letter. -- True if the argument is an Ascii graphic character, False otherwise. function Getcp return Character; -- Gets the next Character from the string or file being scanned according -- to the setting of Scanning_From_File. In string mode, WS_Index1 is -- updated. If no more Characters remain to be scanned, End_Error is -- raised. function Get_Char return Character; -- Get the next character from the current text input file. If no -- character is available, End_Error is raised. procedure Image_Float (Item : Float; Aft, Exp : Field); -- Creates a string image of Item where Aft and Exp control the format -- according to the rules in 14.3.8. The result is placed in Work_String. procedure Image_Integer (Item : Integer; Base : Integer); -- Creates a string image of Item using the given Base and places it -- Work_String. If an out of range value or a bad character is -- encountered, Data_Error is raised. procedure Make_Temp_File_Name; -- Generate a unique file name and use it for the name of the current file. function Nextc return Character; -- Return the next Character to be read from the string file being -- scanned, according to the setting of Scanning_From_File. In string -- mode WS_Index1 is updated. If we are currently at the end of string -- then a line feed is returned. function Page_Is_Not_Terminated return Boolean; -- Indicates whether the current page of current file is not terminated. procedure Put_Blanks (N : Integer); -- Write N blanks to the output. There is no check for line overflow, it -- is assumed that the caller has already checked for this. procedure Put_Buffer (Width : Integer; Pad_Type : Character; Length : Integer); procedure Put_Line1; -- Outputs a line feed to the current text file procedure Put_Page; -- Write a page mark to current text file. procedure Load_Look_Ahead (End_Of_File_Flag : Boolean); -- This procedure loads the lookahead for a TEXT_IO input file, leaving -- CHARS set to 3 (unless the file is less than 3 bytes long), and CHAR1 -- CHAR2 and CHAR3 containing the initial characters of the file. A special -- exception occurs when the standard input file is the keyboard in which -- case we only read 1 character because of interactive I/O except when -- load_look_ahead is called in the case of END_OF_FILE where we want to -- read 2 characters to check for the EOT character. The parameter to this -- routine end_of_file_flag is TRUE when processing for and END_OF_FILE -- situation and is FALSE otherwise. procedure Range_Error; -- Procedure called if scanned number is out of range. function Scan_Based_Int (Base : Integer) return Integer; function Scan_Int return Integer; -- This routine scans an Integer value from the string pointed by the -- global Integer WS_Index2. On exit WS_Index2 is updated to point to -- the first -- non-digit. The result returned is always negative. This allows the -- largest negative Integer value to be properly stored and converted. -- A value of +1 returned indicated that overflow occured. procedure Scan_Integer (Width : Integer; Result : out Integer); -- Procedure to scan an Ada Integer value and return the Integer result -- The parameter Width specifies the width of the field (zero means an -- unlimited scan). The input is from the current TEXT_IO input file. procedure Scan_Integer_String (Last : out Integer; Result : out Integer); -- Procedure to scan an ada integer value and store it in Result. -- The input is from the string stored in Work_String. Last is set to -- the count of Characters scanned. procedure Scan_Integer_Val (Fixed_Field : Boolean; Result : out Integer); -- Procedure to scan an Ada Integer value and return the Integer result. procedure Scan_Blanks; -- Routine to scan past leading blanks to find first non-blank. -- Leaves WS_Index1 pointing to first non-blank character. procedure Setup_Fixed_Field (Width : Integer); -- This procedure is used for numeric conversions where the field to be -- scanned has a fixed width (i.e. width parameter is non-zero). -- It acquires the field from the input file and copies it to Work_String. -- It returns to the caller ready to scan the data from work_string. function Sign (C : Character) return Boolean; -- Predicate indicating whether character C is '+' or '-' procedure Skipc; -- This procedure skips the next input Character. procedure Test_Fixed_Field_End; -- this procedure is called after scanning an item from a fixed length -- field to ensure that only blanks remain in the field. An exception -- is raised if there are any unexpected non-blank Characters left in -- the field. function Upper_Case (C : Character) return Character; -- Converts character C to upper case if necessary procedure Unimplemented (Message : String) is begin Text_IO.Put (Message); Text_IO.Put_Line (" not implemented yet"); end Unimplemented; procedure Word_Mul (A : Integer; B : Integer; O : out Boolean; R : out Integer); -- Multiply with overflow check (use until trapping arithmetic works). procedure Word_Sub (A : Integer; B : Integer; O : out Boolean; R : out Integer); -- Subtraction with overflow check (use until trapping arithmetic works) -- -- Interface with system calls -- procedure C_Fgetc (F : Text_IO.File_Ptr; C : out Character; Is_Eof : out Boolean); procedure Fclose (P : Text_IO.File_Ptr); function Fopen (Name : String; Typ : File_Mode) return Text_IO.File_Ptr; procedure Fputc (F : Text_IO.File_Ptr; C : Character); function Isatty (F : Text_IO.File_Ptr) return Boolean; function Stdin return Text_IO.File_Ptr; function Stdout return Text_IO.File_Ptr; function Stderr return Text_IO.File_Ptr; procedure Unlink (Name : String); ----------- -- Chars -- ----------- function Chars return Integer is begin return The_File.Count; end Chars; --------------- -- Set_Chars -- --------------- procedure Set_Chars (Val : Integer) is begin The_File.Count := Val; end Set_Chars; ----------- -- Char1 -- ----------- function Char1 return Character is begin return The_File.Look_Ahead (1); end Char1; --------------- -- Set_Char1 -- --------------- procedure Set_Char1 (Val : Character) is begin The_File.Look_Ahead (1) := Val; end Set_Char1; ----------- -- Char2 -- ----------- function Char2 return Character is begin return The_File.Look_Ahead (2); end Char2; --------------- -- Set_Char2 -- --------------- procedure Set_Char2 (Val : Character) is begin The_File.Look_Ahead (2) := Val; end Set_Char2; ----------- -- Char3 -- ----------- function Char3 return Character is begin return The_File.Look_Ahead (3); end Char3; --------------- -- Set_Char3 -- --------------- procedure Set_Char3 (Val : Character) is begin The_File.Look_Ahead (3) := Val; end Set_Char3; ------------ -- Create -- ------------ procedure Create (File : in out File_Type; Mode : in File_Mode := Out_File; Name : in String := ""; Form : in String := "") is begin The_File := File; if The_File /= null then raise Status_Error; -- File already open elsif Mode = In_File then raise Use_Error; -- Unsupported file access end if; Allocate_AFCB; The_File.Name := new String'(Name); The_File.Form := new String'(Form); The_File.Mode := Mode; if Name'Length = 0 then Make_Temp_File_Name; end if; Check_Multiple_File_Opens; The_File.AFCB_In_Use := True; The_File.Desc := Fopen (The_File.Name.all, Out_File); Check_Opened_Ok; The_File.Page := 1; The_File.Line := 1; The_File.Col := 1; The_File.Line_Length := 0; The_File.Page_Length := 0; File := The_File; end Create; ---------- -- Open -- ---------- procedure Open (File : in out File_Type; Mode : in File_Mode; Name : in String; Form : in String := "") is begin The_File := File; if The_File /= null then raise Status_Error; -- File already open end if; Allocate_AFCB; The_File.Name := new String'(Name); The_File.Form := new String'(Form); The_File.Mode := Mode; if Name'Length = 0 then Make_Temp_File_Name; end if; Check_Multiple_File_Opens; The_File.AFCB_In_Use := True; if Mode = In_File then The_File.Desc := Fopen (Name, In_File); Check_Opened_Ok; Set_Chars (0); else The_File.Desc := Fopen (Name, Out_File); Check_Opened_Ok; end if; The_File.Page := 1; The_File.Line := 1; The_File.Col := 1; The_File.Line_Length := 0; The_File.Page_Length := 0; File := The_File; end Open; ----------- -- Close -- ----------- procedure Close (File : in out File_Type) is begin The_File := File; Check_File_Open; if The_File.Mode = Out_File or else The_File.Mode = Append_File then -- Simulate effect of NEW_PAGE unless current page is terminated if Page_Is_Not_Terminated then if The_File.Col > 1 or else (The_File.Col = 1 and then The_File.Line = 1) then Put_Line1; end if; Put_Page; end if; end if; -- If the file being closed is one of the default files, set the default -- file indicator to null to indicate that the file is closed. if The_File = Current_In then Current_In := null; elsif The_File = Current_Out then Current_Out := null; elsif The_File = Current_Err then Current_Err := null; end if; -- Sever the association between the given file and its associated -- external file. The given file is left closed. Do not perform system -- closes on the standard input, output and error files. if The_File /= Standard_In and then The_File /= Standard_Out and then The_File /= Standard_Err then Close_File; end if; The_File := null; File := The_File; end Close; ------------ -- Delete -- ------------ procedure Delete (File : in out File_Type) is File_Name_To_Delete : Pstring; begin The_File := File; Check_File_Open; File_Name_To_Delete := new String'(The_File.Name.all); Close (The_File); Unlink (File_Name_To_Delete.all); File := The_File; end Delete; ----------- -- Reset -- ----------- procedure Reset (File : in out File_Type; Mode : in File_Mode) is begin The_File := File; Check_File_Open; if (The_File = Current_In or else The_File = Current_Out) and then The_File.Mode /= Mode then raise Mode_Error; -- "Cannot change mode" end if; if The_File.Mode = Out_File or else The_File.Mode = Append_File then -- Simulate NEW_PAGE unless current page already terminated if Page_Is_Not_Terminated then if The_File.Col > 1 or else (The_File.Col = 1 and then The_File.Line = 1) then Put_Line1; end if; Put_Page; end if; end if; Fclose (The_File.Desc); if Mode = In_File then The_File.Desc := Fopen (The_File.Name.all, In_File); Check_Opened_Ok; else The_File.Desc := Fopen (The_File.Name.all, Out_File); Check_Opened_Ok; The_File.Line_Length := 0; The_File.Page_Length := 0; end if; The_File.Mode := Mode; Set_Chars (0); The_File.Col := 1; The_File.Line := 1; The_File.Page := 1; File := The_File; end Reset; ---------- -- Mode -- ---------- function Mode (File : in File_Type) return File_Mode is begin The_File := File; Check_File_Open; return The_File.Mode; end Mode; ---------- -- Name -- ---------- function Name (File : in File_Type) return String is begin The_File := File; Check_File_Open; return The_File.Name.all; end Name; ---------- -- Form -- ---------- function Form (File : in File_Type) return String is begin The_File := File; Check_File_Open; return The_File.Form.all; end Form; ------------- -- Is_Open -- ------------- function Is_Open (File : in File_Type) return Boolean is begin The_File := File; return The_File /= null; end Is_Open; --------------- -- Set_Input -- --------------- procedure Set_Input (File : in File_Type) is begin The_File := File; Check_Status_And_Mode (In_File); Current_In := The_File; end Set_Input; ---------------- -- Set_Output -- ---------------- procedure Set_Output (File : in File_Type) is begin The_File := File; Check_Status_And_Mode (Out_File, Append_File); Current_Out := The_File; end Set_Output; --------------- -- Set_Error -- --------------- procedure Set_Error (File : in File_Type) is begin The_File := File; Check_Status_And_Mode (Out_File, Append_File); Current_Err := The_File; end Set_Error; -------------------- -- Standard_Input -- -------------------- function Standard_Input return File_Type is begin return Standard_In; end Standard_Input; --------------------- -- Standard_Output -- --------------------- function Standard_Output return File_Type is begin return Standard_Out; end Standard_Output; -------------------- -- Standard_Error -- -------------------- function Standard_Error return File_Type is begin return Standard_Err; end Standard_Error; ------------------- -- Current_Input -- ------------------- function Current_Input return File_Type is begin return Current_In; end Current_Input; -------------------- -- Current_Output -- -------------------- function Current_Output return File_Type is begin return Current_Out; end Current_Output; ------------------- -- Current_Error -- ------------------- function Current_Error return File_Type is begin return Current_Err; end Current_Error; --------------------- -- Set_Line_Length -- --------------------- procedure Set_Line_Length (File : in File_Type; To : in Count) is begin The_File := File; Check_Status_And_Mode (Out_File, Append_File); The_File.Line_Length := To; end Set_Line_Length; ----------------- -- Line_Length -- ----------------- function Line_Length (File : in File_Type) return Count is begin The_File := File; Check_Status_And_Mode (Out_File, Append_File); return The_File.Line_Length; end Line_Length; --------------------- -- Set_Page_Length -- --------------------- procedure Set_Page_Length (File : in File_Type; To : in Count) is begin The_File := File; Check_Status_And_Mode (Out_File, Append_File); The_File.Page_Length := To; end Set_Page_Length; ----------------- -- Page_Length -- ----------------- function Page_Length (File : in File_Type) return Count is begin The_File := File; Check_Status_And_Mode (Out_File, Append_File); return The_File.Page_Length; end Page_Length; -------------- -- New_Line -- -------------- procedure New_Line (File : in File_Type; Spacing : in Positive_Count := 1) is begin The_File := File; Check_Status_And_Mode (Out_File, Append_File); for I in 1 .. Spacing loop Put_Line1; end loop; end New_Line; --------------- -- Skip_Line -- --------------- procedure Skip_Line (File : in File_Type; Spacing : in Positive_Count := 1) is C : Character; begin The_File := File; Check_Status_And_Mode (In_File); for I in 1 .. Spacing loop loop Load_Look_Ahead (False); exit when Get_Char = Line_Feed; end loop; -- ignore page marks for standard input. -- if The_File = Standard_In then return; end if; loop Load_Look_Ahead (False); exit when Char1 /= Page_Mark; C := Get_Char; end loop; end loop; end Skip_Line; ----------------- -- End_Of_Line -- ----------------- function End_Of_Line (File : in File_Type) return boolean is begin The_File := File; Check_Status_And_Mode (In_File); Load_Look_Ahead (False); return Chars = 0 or else Char1 = Line_Feed; end End_Of_Line; -------------- -- New_Page -- -------------- procedure New_Page (File : in File_Type) is begin The_File := File; Check_Status_And_Mode (Out_File, Append_File); if The_File.Col > 1 or else (The_File.Col = 1 and then The_File.Line = 1) then Put_Line1; end if; Put_Page; end New_Page; --------------- -- Skip_Page -- --------------- procedure Skip_Page (File : in File_Type) is begin The_File := File; Check_Status_And_Mode (In_File); while Get_Char /= Page_Mark loop null; end loop; end Skip_Page; ----------------- -- End_Of_Page -- ----------------- function End_Of_Page (File : in File_Type) return Boolean is begin The_File := File; Check_Status_And_Mode (In_File); if Isatty (The_File.Desc) then return False; end if; Load_Look_Ahead (False); if Chars > 1 then return Char1 = Line_Feed and then Char2 = Page_Mark; elsif Chars = 1 then return Char1 = Line_Feed; else return True; end if; end End_Of_Page; ----------------- -- End_Of_File -- ----------------- function End_Of_File (File : in File_Type) return Boolean is begin The_File := File; Check_Status_And_Mode (In_File); Load_Look_Ahead (True); if Isatty (The_File.Desc) then if Chars = 2 then return False; elsif Chars = 1 then return Char1 = Line_Feed; elsif Chars = 0 then return True; end if; else if Chars = 2 then return Char1 = Line_Feed and then Char2 = Page_Mark; elsif Chars = 1 then return Char1 = Line_Feed; elsif Chars = 0 then return True; else -- Chars = 3 return False; end if; end if; end End_Of_File; ------------- -- Set_Col -- ------------- procedure Set_Col (File : in File_Type; To : in Positive_Count) is C : Character; begin The_File := File; Check_File_Open; if The_File.Mode = In_File then -- SET_COL for file of mode In_File Load_Look_Ahead (False); while The_File.Col /= To or else Char1 = Line_Feed or else Char1 = Page_Mark loop C := Get_Char; end loop; else -- SET_COL for file of mode Out_File or Append_File if The_File.Line_Length > 0 and then To > The_File.Line_Length then raise Layout_Error; -- "SET_COL past end of line" end if; if To > The_File.Col then Put_Blanks (Integer (To - The_File.Col)); The_File.Col := To; elsif To < The_File.Col then Put_Line1; Put_Blanks (Integer (To - 1)); The_File.Col := To; end if; end if; end Set_Col; -------------- -- Set_Line -- -------------- procedure Set_Line (File : in File_Type; To : in Positive_Count) is C : Character; begin The_File := File; Check_File_Open; if The_File.Mode = In_File then -- SET_LINE for file of mode In_File Load_Look_Ahead (False); while The_File.Line /= To or else Char1 = Page_Mark loop C := Get_Char; end loop; else -- SET_LINE for file of mode Out_File or Append_File if The_File.Page_Length > 0 and then To > The_File.Page_Length then raise Layout_Error; -- "Set_Line > Page_Length" end if; if To > The_File.Line then for I in 1 .. To - The_File.Line loop Put_Line1; end loop; elsif To < The_File.Line then if The_File.Col > 1 or else (The_File.Col = 1 and then The_File.Line = 1) then Put_Line1; end if; Put_Page; for I in 1 .. To - 1 loop Put_Line1; end loop; end if; end if; end Set_Line; --------- -- Col -- --------- function Col (File : in File_Type) return Positive_Count is begin The_File := File; Check_File_Open; if (The_File.Col > Count'Last) then raise Layout_Error; -- "Col > Count'Last" end if; return The_File.Col; end Col; ---------- -- Line -- ---------- function Line (File : in File_Type) return Positive_Count is begin The_File := File; Check_File_Open; if (The_File.Line > Count'Last) then raise Layout_Error; -- "Line > Count'Last" end if; return The_File.Line; end Line; ---------- -- Page -- ---------- function Page (File : in File_Type) return Positive_Count is begin The_File := File; Check_File_Open; if (The_File.Page > Count'Last) then raise Layout_Error; -- "Page > Count'Last" end if; return The_File.Page; end Page; --------- -- Get -- --------- procedure Get (Item : out Character) is begin Check_Status_And_Mode (In_File); loop Item := Get_Char; exit when Item /= Page_Mark and then Item /= Line_Feed; end loop; end Get; --------- -- Put -- --------- procedure Put (Item : in Character) is begin Check_Status_And_Mode (Out_File, Append_File); if The_File.Line_Length /= 0 and then The_File.Col > The_File.Line_Length then Put_Line1; end if; Fputc (The_File.Desc, Item); The_File.Col := The_File.Col + 1; end Put; --------- -- Get -- --------- procedure Get (Item : out String) is I : Integer := 0; C : Character; begin Check_Status_And_Mode (In_File); while I < Item'Length loop C := Get_Char; if C /= Line_Feed and then C /= Page_Mark then Item (Item'First + I) := C; I := I + 1; end if; end loop; end Get; --------- -- Put -- --------- procedure Put (Item : in String) is begin for I in Item'range loop Put (Item (I)); end loop; end Put; -------------- -- Put_Line -- -------------- procedure Put_Line (File : in File_Type; Item : in String) is begin The_File := File; Put (Item); New_Line (File, 1); end Put_Line; -------------- -- Get_Line -- -------------- procedure Get_Line (File : in File_Type; Item : out String; Last : out Natural) is I_Length : Integer := Item'Length; Nstore : Integer := 0; begin The_File := File; Check_Status_And_Mode (In_File); loop Load_Look_Ahead (False); exit when Nstore = I_Length; if Char1 = Line_Feed then Skip_Line (File, 1); exit; end if; Item (Item'First + Nstore) := Get_Char; Nstore := Nstore + 1; end loop; Last := Item'First + Nstore - 1; end Get_Line; ------------- -- Get_Int -- ------------- procedure Get_Int (Item : out Integer; Width : in Field := 0) is begin Check_Status_And_Mode (In_File); Scan_Integer (Width, Item); end Get_Int; ------------- -- Put_Int -- ------------- procedure Put_Int (Item : in Integer; Width : in Field; Base : in Number_Base) is begin Check_Status_And_Mode (Out_File, Append_File); Image_Integer (Item, Base); Put_Buffer (Width, 'L', WS_Length); end Put_Int; ------------- -- Get_Int -- ------------- procedure Get_Int (From : in String; Item : out Integer; Last : out Positive) is begin WS_Length := From'Length; for I in 0 .. WS_Length - 1 loop Work_String (I) := From (From'First + I); end loop; Work_String (WS_Length) := ' '; WS_Index1 := 0; Scan_Integer_String (Last, Item); Last := From'First + Last - 1; end Get_Int; ------------- -- Put_Int -- ------------- procedure Put_Int (To : out String; Item : in Integer; Base : in Number_Base) is To_Length : Integer := To'Length; begin Image_Integer (Item, Base); if WS_Length > To_Length then raise Layout_Error; end if; for I in 0 .. To_Length - WS_Length - 1 loop To (To'First + I) := ' '; end loop; for I in To_Length - WS_Length .. To_Length - 1 loop To (To'First + I) := Work_String (I - To_Length + WS_Length); end loop; end Put_Int; --------------- -- Get_Float -- --------------- procedure Get_Float (Item : out Float; Width : in Field) is begin Check_Status_And_Mode (In_File); Unimplemented ("Float_IO.Get"); end Get_Float; --------------- -- Put_Float -- --------------- procedure Put_Float (Item : in Float; Fore : in Field; Aft : in Field; Exp : in Field) is begin Check_Status_And_Mode (Out_File, Append_File); Image_Float (Item, Aft, Exp); if Exp = 0 then Put_Buffer (Aft + Fore + 1, 'L', WS_Length + 1); else Put_Buffer (Aft + Fore + Exp + 2, 'L', WS_Length + 1); end if; end Put_Float; --------------- -- Get_Float -- --------------- procedure Get_Float (From : in String; Item : out Float; Last : out Positive) is begin Unimplemented ("Float_IO.Get with String parameter"); end Get_Float; --------------- -- Put_Float -- --------------- procedure Put_Float (To : out String; Item : in Float; Aft : in Field; Exp : in Field) is To_Length : Natural := To'Length; begin Image_Float (Item, Aft, Exp); if WS_Length > To_Length then raise Layout_Error; end if; for I in 0 .. To_Length - WS_Length - 1 loop To (To'First + I) := ' '; end loop; for I in To_Length - WS_Length .. To_Length - 1 loop To (To'First + I) := Work_String (I - To_Length + WS_Length); end loop; end Put_Float; -------------- -- Put_Page -- -------------- procedure Put_Page is begin Fputc (The_File.Desc, Page_Mark); The_File.Page := The_File.Page + 1; The_File.Line := 1; The_File.Col := 1; end Put_Page; --------------- -- Put_Line1 -- --------------- procedure Put_Line1 is begin Fputc (The_File.Desc, Line_Feed); The_File.Col := 1; if The_File.Page_Length > 0 and The_File.Line >= The_File.Page_Length then Put_Page; else The_File.Line := The_File.Line + 1; end if; end Put_Line1; --------------------- -- Check_Opened_Ok -- --------------------- procedure Check_Opened_Ok is begin if The_File.Desc = 0 then raise Name_Error; -- Error opening file due to invalid name end if; end Check_Opened_Ok; --------------------- -- Check_File_Open -- --------------------- procedure Check_File_Open is begin -- There are two ways a file can appear closed. Either it is null -- which indicates that it was not used as an argument of an Open_Create -- call or it is not null but its Is_Open field is False which indicates -- that the file was used in an Open/Create but subsequently was closed. if The_File = null then raise Status_Error; -- File not open end if; end Check_File_Open; --------------------------- -- Check_Status_And_Mode -- --------------------------- procedure Check_Status_And_Mode (C_Mode : File_Mode) is begin Check_File_Open; if The_File.Mode /= C_Mode then raise Mode_Error; end if; end Check_Status_And_Mode; --------------------------- -- Check_Status_And_Mode -- --------------------------- procedure Check_Status_And_Mode (C_Mode1, C_Mode2 : File_Mode) is begin Check_File_Open; if The_File.Mode /= C_Mode1 and then The_File.Mode /= C_Mode2 then raise Mode_Error; end if; end Check_Status_And_Mode; ------------------- -- Allocate_AFCB -- -------------------- procedure Allocate_AFCB is File_Num : Integer := Open_Files'First; begin -- Loop thorugh the array of AFCBs stopping at the first vacate spot -- that is not currently being used. while File_Num <= Max_Num_Of_Files and then Open_Files (File_Num) /= null and then Open_Files (File_Num).AFCB_In_Use loop File_Num := File_Num + 1; end loop; -- No vacate spots were available since too many file are open if File_Num > Max_Num_Of_Files then raise Use_Error; -- Too many files open end if; if Open_Files (File_Num) = null then Open_Files (File_Num) := new AFCB; end if; The_File := Open_Files (File_Num); end Allocate_AFCB; ------------------------- -- Make_Temp_File_Name -- ------------------------- procedure Make_Temp_File_Name is Temp_File_Name : String (1 .. 14); -- The template for temporary file name creation using Mktemp. procedure mktemp (S : Address); -- mktemp creates a unique temporary file name given the address of -- a null terminated template. pragma Import (C, mktemp); begin -- Create a template string which the call to mktemp will fill in to -- generate unique name file name. Temp_File_Name (1 .. 13) := "ADATEMPXXXXXX"; Temp_File_Name (14) := Ascii.Nul; mktemp (Temp_File_Name'Address); The_File.Name := new String'(Temp_File_Name (1 .. 13)); -- Append the name of the temporary file to the end of the Temp_File -- list which will be used for deleting all the temporary files after -- completion of the main program. if Temp_Files = null then Temp_Files := new Temp_File_Rec'(The_File.Name, null); else Temp_Files.Next := new Temp_File_Rec'(The_File.Name, null); end if; end Make_Temp_File_Name; ------------------------------- -- Check_Multiple_File_Opens -- ------------------------------- procedure Check_Multiple_File_Opens is begin -- Allow a several opens to read an external file, but not one open to -- read and another open to write a external file. for I in Open_Files'range loop if Open_Files (I) /= null and then Open_Files (I).AFCB_In_Use then if The_File.Name.all = Open_Files (I).Name.all and then (The_File.Mode /= In_File or else Open_Files (I).Mode /= In_File) then raise Use_Error; -- File already open end if; end if; end loop; end Check_Multiple_File_Opens; ----------------------------- -- Page_Is_Not_Terminated -- ----------------------------- function Page_Is_Not_Terminated return Boolean is begin return not (The_File.Col = 1 and then The_File.Line = 1 and then The_File.Page /= 1); end Page_Is_Not_Terminated; ---------------- -- Close_File -- ---------------- procedure Close_File is procedure Fclose (F : Text_IO.File_Ptr); pragma Import (C, fclose); File_Num : Integer := Open_Files'First; begin while File_Num <= Max_Num_Of_Files and then Open_Files (File_Num) /= The_File loop File_Num := File_Num + 1; end loop; if File_Num > Max_Num_Of_Files then raise Status_Error; end if; Fclose (The_File.Desc); The_File.AFCB_In_Use := False; end Close_File; --------------------- -- Load_Look_Ahead -- --------------------- procedure Load_Look_Ahead (End_Of_File_Flag : Boolean) is C : Character; Is_Eof : Boolean; begin -- Load first character of look ahead if Chars = 0 then Set_Char2 (Nul); Set_Char3 (Nul); C_Fgetc (The_File.Desc, C, Is_Eof); if Is_Eof then Set_Char1 (Nul); return; else Set_Char1 (C); Set_Chars (1); end if; end if; -- In the case where reading from the keyboard do not read more than -- 1 character unless you are processing an end_of_file test. if Isatty (The_File.Desc) and then not End_Of_File_Flag then return; end if; -- Load second character of look ahead if Chars = 1 then Set_Char3 (Nul); C_Fgetc (The_File.Desc, C, Is_Eof); if Is_Eof then Set_Char2 (Nul); return; else Set_Char2 (C); Set_Chars (2); end if; end if; -- Leave lookahead with at most two characters loaded if standard -- input is the keyboard. if not Isatty (The_File.Desc) then -- Load third character of look ahead if Chars = 2 then C_Fgetc (The_File.Desc, C, Is_Eof); if Is_Eof then Set_Char3 (Nul); return; else Set_Char3 (C); Set_Chars (3); end if; end if; end if; end Load_Look_Ahead; -------------- -- Get_Char -- -------------- function Get_Char return Character is C : Character; begin Load_Look_Ahead (False); if Chars = 0 then raise End_Error; -- End of file on TEXT_IO input end if; C := Char1; -- Update lookahead Set_Char1 (Char2); Set_Char2 (Char3); Set_Char3 (Nul); Set_Chars (Chars - 1); -- Update PAGE and LINE counters if page mark or line feed read if C = Page_Mark then The_File.Page := The_File.Page + 1; The_File.Line := 1; The_File.Col := 1; elsif C = Line_Feed then The_File.Line := The_File.Line + 1; The_File.Col := 1; else The_File.Col := The_File.Col + 1; end if; if Character'Pos (C) > 127 then raise Data_Error; -- Character > 127 for TEXT_IO input" end if; return C; end Get_Char; ---------------- -- Upper_Case -- ---------------- function Upper_Case (C : Character) return Character is V : constant Integer := 32; begin if C in 'a' .. 'z' then return Character'Val (Character'Pos (C) - V); else return C; end if; end Upper_Case; -------------- -- Word_Sub -- -------------- procedure Word_Sub (A : Integer; B : Integer; O : out Boolean; R : out Integer) is begin R := A - B; O := ((A < 0 and then B > 0) or else (A > 0 and then B < 0)) and then ((A < 0 and then R > 0) or else (A > 0 and then R < 0)); end Word_Sub; -------------- -- Word_Mul -- -------------- procedure Word_Mul (A : Integer; B : Integer; O : out Boolean; R : out Integer) is begin if A /= 0 then R := A * B; O := (B /= R / A) or else (A = -1 and then B < 0 and then R < 0); else R := 0; O := False; end if; end Word_Mul; ---------------- -- Put_Blanks -- ---------------- procedure Put_Blanks (N : Integer) is begin for I in 1 .. N loop Fputc (The_File.Desc, ' '); end loop; end Put_Blanks; ---------------- -- Put_Buffer -- ---------------- procedure Put_Buffer (Width : Integer; Pad_Type : Character; Length : Integer) is Pad : Character := Pad_Type; Target_Length : Integer; begin if Length >= Width then Target_Length := Length; Pad := ' '; else Target_Length := Width; end if; -- Ensure the buffer size does not exceed the line length if The_File.Line_Length > 0 then if Count (Target_Length) > The_File.Line_Length then raise Layout_Error; -- "Line too big" end if; end if; -- New line if does not fit on current line if The_File.Col + Count (Target_Length) - 1 > The_File.Line_Length then Put_Line1; end if; -- Output data with the required padding if Pad = 'L' then Put_Blanks (Width - Length); end if; for N in 0 .. Length - 1 loop Fputc (The_File.Desc, Work_String (N)); end loop; The_File.Col := The_File.Col + Count (Target_Length); if Pad = 'T' then Put_Blanks (Width - Length); end if; end Put_Buffer; ----------------- -- Image_Float -- ----------------- procedure Image_Float (Item : Float; Aft, Exp : Field) is procedure sprintf (Target : Address; Fmt : Address; Precision : Natural; Value : Long_Float; Length_Ptr : Address); pragma Import (C, sprintf); Fmt_E : constant String := "%.*E%n" & Ascii.NUL; Fmt_F : constant String := "%.*F%n" & Ascii.NUL; Fmt_Ptr : Address; E_Pos : Natural; Exp_Len : Natural; Length : aliased Natural; Precision : Natural; begin -- The value of Exp controls whether an exponent part is to appear. Use -- E or F format in the call to sprintf appropriately. if Exp = 0 then Fmt_Ptr := Fmt_F'Address; else Fmt_Ptr := Fmt_E'Address; end if; -- The number of digits of the fractional part is given by AFT, or is -- one if AFT equals zero. [RM 14.3.8] if Aft = 0 then Precision := 1; else Precision := Aft; end if; sprintf (Target => Work_String'Address, Fmt => Fmt_Ptr, Precision => Precision, Value => Long_Float (Item), Length_Ptr => Length'Address); WS_Length := Length - 1; -- A certain amount of correction to the exponent part of the image -- string is necessary since the semantics of sprintf do not allow the -- specification of the number of digits in the exponent as Ada allows. -- Find the index of the 'E' in the image string. E_Pos := WS_Length; while Work_String (E_Pos) /= 'E' loop E_Pos := E_Pos - 1; end loop; Exp_Len := WS_Length - E_Pos; -- Since sprintf always use a minimum of two digits for the exponent -- if there is a leading zero in the exponent and Exp is specified as -- one it is necessary to trim the extra zero off and slide the -- remaining digit over one. if Exp = 1 then if Work_String (E_Pos + 2) = '0' then Work_String (E_Pos + 2) := Work_String (E_Pos + 3); WS_Length := WS_Length - 1; end if; -- Extra leading zeroes may need to be added in front of the exponent -- if the value of Exp is greater than the number of digits necessary -- to portray the tru exponent value. elsif Exp > Exp_Len then for I in reverse E_Pos + 2 .. WS_Length loop Work_String (I + Exp_Len - Exp) := Work_String (I); end loop; for I in E_Pos + 2 .. E_Pos + 1 + Exp - Exp_Len loop Work_String (I) := '0'; end loop; WS_Length := WS_Length + Exp - Exp_Len; end if; end Image_Float; ------------------- -- Image_Integer -- ------------------- procedure Image_Integer (Item : Integer; Base : Integer) is P, Q : Integer; Digit : Integer; Buffer : Integer := Item; begin P := 0; if Base /= 10 then if Base > 10 then Work_String (P) := '1'; Work_String (P + 1) := Character'Val (Character'Pos ('0') + Base - 10); Work_String (P + 2) := '#'; P := P + 3; else Work_String (P) := Character'Val (Character'Pos ('0') + Base); Work_String (P + 1) := '#'; P := P + 2; end if; end if; -- Deal with the sign. Note we work with the negative of the absolute -- value of the number so that we do not have to make special checks -- for the largest negative number ion the twos complement case. if Buffer < 0 then Work_String (P) := '-'; P := P + 1; else Buffer := - Buffer; end if; -- Convert value to digit string in specified base if Buffer = 0 then Work_String (P) := '0'; P := P + 1; else Q := 15; while Buffer /= 0 loop Digit := - (Buffer rem Base); Buffer := Buffer / Base; if Digit > 9 then Work_String (Q) := Character'Val (Character'Pos ('A') + Digit - 10); else Work_String (Q) := Character'Val (Character'Pos ('0') + Digit); end if; Q := Q - 1; end loop; for I in 1 .. 15 - Q loop Work_String (P) := Work_String (Q + I); P := P + 1; end loop; end if; if Base /= 10 then Work_String (P) := '#'; P := P + 1; end if; WS_Length := P; end Image_Integer; ----------- -- Getcp -- ----------- function Getcp return Character is C : Character; begin if Scanning_From_File then return Get_Char; else if WS_Index1 > WS_Length then raise End_Error; end if; WS_Index1 := WS_Index1 + 1; return Work_String (WS_Index1); end if; end Getcp; ----------- -- Nextc -- ----------- function Nextc return Character is begin if Scanning_From_File then Load_Look_Ahead (False); return Char1; else if WS_Index1 < WS_Length then return Work_String (WS_Index1); else return Line_Feed; end if; end if; end Nextc; ----------- -- Skipc -- ----------- procedure Skipc is C : Character; begin if Scanning_From_File then C := Get_Char; else WS_Index1 := WS_Index1 + 1; end if; end Skipc; ----------- -- Copyc -- ----------- procedure Copyc is C : Character; begin if Scanning_From_File then C := Get_Char; else if WS_Index1 > WS_Length then raise Program_Error; else C := Work_String (WS_Index1); WS_Index1 := WS_Index1 + 1; end if; end if; Work_String (WS_Index2) := Upper_Case (C); WS_Index2 := WS_Index2 + 1; end Copyc; ------------------ -- Copy_Integer -- ------------------ procedure Copy_Integer is begin Check_Digit; while Digit (Nextc) loop Copyc; if Nextc = '_' then Skipc; Check_Digit; end if; end loop; end Copy_Integer; ------------------------ -- Copy_Based_Integer -- ------------------------ procedure Copy_Based_Integer is begin Check_Extended_Digit; while Extended_Digit (Nextc) loop Copyc; if Nextc = '_' then Skipc; Check_Extended_Digit; end if; end loop; end Copy_Based_Integer; ----------------- -- Scan_Blanks -- ----------------- procedure Scan_Blanks is C : Character; begin if Scanning_From_File then loop Load_Look_Ahead (False); if Chars = 0 then raise End_Error; end if; C := Nextc; if C = ' ' or else C = Ascii.HT or else C = Line_Feed or else C = Page_Mark then C := Getcp; else exit; end if; end loop; else while WS_Index1 <= WS_Length - 1 loop if Work_String (WS_Index1) = ' ' or else Work_String (WS_Index1) = Ascii.HT then WS_Index1 := WS_Index1 + 1; else exit; end if; end loop; end if; end Scan_Blanks; ------------------------ -- Setup_Fixed_Field -- ------------------------ procedure Setup_Fixed_Field (Width : Integer) is I : Integer := 0; begin loop Load_Look_Ahead (False); if Width /= I and then Chars /= 0 and then Char1 /= Page_Mark and then Char1 /= Line_Feed then Work_String (I) := Get_Char; I := I + 1; else exit; end if; end loop; WS_Length := I; Scanning_From_File := False; WS_Index1 := 0; end Setup_Fixed_Field; -------------------------- -- Test_Fixed_Field_End -- -------------------------- procedure Test_Fixed_Field_End is begin Scan_Blanks; if WS_Index1 < WS_Length then raise Data_Error; end if; end Test_Fixed_Field_End; ----------- -- Alpha -- ----------- function Alpha (C : Character) return Boolean is begin return C in 'A' .. 'Z' or else C in 'a' .. 'z'; end Alpha; -------------- -- Alphanum -- -------------- function Alphanum (C : Character) return Boolean is begin return Alpha (C) or else C in '0' .. '9'; end Alphanum; ------------- -- Graphic -- ------------- function Graphic (C : Character) return Boolean is Low : constant Integer := 32; High : constant Integer := 127; begin return Character'Pos (C) in Low .. High; end Graphic; ----------- -- Digit -- ----------- function Digit (C : Character) return Boolean is begin return C in '0' .. '9'; end Digit; -------------------- -- Extended_Digit -- -------------------- function Extended_Digit (C : Character) return Boolean is begin return C in '0' .. '9' or else C in 'a' .. 'f' or else C in 'A' .. 'F'; end Extended_Digit; ---------- -- Sign -- ---------- function Sign (C : Character) return Boolean is begin return C = '-' or C = '+'; end Sign; ----------------- -- Check_Digit -- ----------------- procedure Check_Digit is begin if not (Nextc in '0' .. '9') then raise Data_Error; end if; end Check_Digit; ---------------- -- Check_Hash -- ---------------- procedure Check_Hash (C : Character) is begin if Nextc /= C then raise Data_Error; end if; Skipc; Work_String (WS_Index2) := '#'; WS_Index2 := WS_Index2 + 1; end Check_Hash; -------------------------- -- Check_Extended_Digit -- -------------------------- procedure Check_Extended_Digit is begin if not Extended_Digit (Nextc) then raise Data_Error; end if; end Check_Extended_Digit; ----------------- -- Range_Error -- ----------------- procedure Range_Error is begin raise Data_Error; end Range_Error; -------------- -- Scan_Int -- -------------- function Scan_Int return Integer is Ival : Integer := 0; Digit_Value : Integer; Overflow1, Overflow2 : Boolean; begin while WS_Index2 < WS_Length and then Digit (Work_String (WS_Index2)) loop Digit_Value := Character'Pos (Work_String (WS_Index2)) - Character'Pos ('0'); WS_Index2 := WS_Index2 + 1; Word_Mul (Ival, 10, Overflow1, Ival); Word_Sub (Ival, Digit_Value, Overflow2, Ival); if Overflow1 or else Overflow2 then while WS_Index2 < WS_Length and then Digit (Work_String (WS_Index2)) loop WS_Index2 := WS_Index2 + 1; end loop; return 1; end if; end loop; return Ival; end Scan_Int; -------------------- -- Scan_Based_Int -- -------------------- function Scan_Based_Int (Base : Integer) return Integer is -- this routine scans a based Integer value fromt the string pointed by -- the global Integer WS_Index2. On exit WS_Index2 is updated to point -- to the -- first non-digit. The result returned is always negative. This allows -- the largest negative Integer value to be properly stored and converted. -- If overflow is detected, then the value +1 is returned to signal -- overflow. Ival : Integer := 0; Digit_Value : Integer; Overflow1, Overflow2 : Boolean; begin while WS_Index2 < WS_Length and then Extended_Digit (Work_String (WS_Index2)) loop Word_Mul (Ival, Base, Overflow1, Ival); Digit_Value := Character'Pos (Work_String (WS_Index2)) - Character'Pos ('0'); WS_Index2 := WS_Index2 + 1; if Digit_Value > 9 then Digit_Value := Digit_Value - 7; end if; if Digit_Value >= Base then raise Data_Error; end if; Word_Sub (Ival, Digit_Value, Overflow2, Ival); if Overflow1 or else Overflow2 then while WS_Index2 < WS_Length and then Extended_Digit (Work_String (WS_Index2)) loop WS_Index2 := WS_Index2 + 1; end loop; return 1; end if; end loop; return Ival; end Scan_Based_Int; ---------------------- -- Scan_Integer_Val -- ---------------------- procedure Scan_Integer_Val (Fixed_Field : Boolean; Result : out Integer) is Ival : Integer; Sign_Val : Character; C : Character; Base : Integer; Based : Boolean; Exponent : Integer; Overflow : Boolean; begin -- First scan out item with the proper syntax and put it in Work_String WS_Index2 := 0; if Sign (Nextc) then Copyc; end if; Copy_Integer; C := Nextc; if C = '#' or else C = ':' then Skipc; Work_String (WS_Index2) := '#'; WS_Index2 := WS_Index2 + 1; Copy_Based_Integer; Check_Hash (C); Based := True; else Based := False; end if; C := Nextc; if C = 'e' or else C = 'E' then Copyc; C := Nextc; if C = '+' or else C = '-' then Skipc; end if; Copy_Integer; if C = '-' then raise Data_Error; -- Negative exponent in integer value end if; end if; if Fixed_Field then Test_Fixed_Field_End; end if; WS_Length := WS_Index2; Work_String (WS_Index2) := ' '; -- Now we have the Integer literal stored in Work_String WS_Index2 := 0; if Sign (Work_String (WS_Index2)) then Sign_Val := Work_String (WS_Index2); WS_Index2 := WS_Index2 + 1; else Sign_Val := '+'; end if; if Based then Base := - Scan_Int; if not (Base in 2 .. 16) then raise Data_Error; end if; WS_Index2 := WS_Index2 + 1; Ival := Scan_Based_Int (Base); WS_Index2 := WS_Index2 + 1; else Ival := Scan_Int; Base := 10; end if; -- Number is in Ival (in negative form), deal with exponent. if Ival = 1 then Range_Error; end if; if Work_String (WS_Index2) = 'E' then WS_Index2 := WS_Index2 + 1; Exponent := Scan_Int; if Exponent < -64 or else Exponent = 1 then Range_Error; end if; while Exponent /= 0 loop Exponent := Exponent + 1; Word_Mul (Ival, Base, Overflow, Ival); if Overflow then Range_Error; end if; end loop; else WS_Index2 := WS_Index2 + 1; end if; if Sign_Val = '+' then Ival := -Ival; if Ival < 0 then Range_Error; end if; end if; Result := Ival; end Scan_Integer_Val; ------------------ -- Scan_Integer -- ------------------ procedure Scan_Integer (Width : Integer; Result : out Integer) is begin if Width /= 0 then Setup_Fixed_Field (Width); Scan_Blanks; if WS_Index1 = WS_Length then raise Data_Error; -- String is all blanks end if; Scan_Integer_Val (True, Result); else Scanning_From_File := True; Scan_Blanks; Scan_Integer_Val (False, Result); end if; end Scan_Integer; ------------------------- -- Scan_Integer_String -- ------------------------- procedure Scan_Integer_String (Last : out Integer; Result : out Integer) is begin Scanning_From_File := False; Scan_Blanks; if WS_Index1 = WS_Length then raise End_Error; end if; Scan_Integer_Val (False, Result); Last := WS_Index1; end Scan_Integer_String; --------------------------- -- Text_IO_Finialization -- --------------------------- procedure Text_IO_Finalization is begin -- Close all open files except stdin, stdout and stderr for I in 4 .. Open_Files'Last loop if Open_Files (I) /= null and then Open_Files (I).AFCB_In_Use and then Open_Files (I).Mode /= In_File then Close_File; end if; end loop; -- Delete temporary files upon completion of the main program while (Temp_Files /= null) loop Unlink (Temp_Files.File_Name.all); Temp_Files := Temp_Files.Next; end loop; end Text_IO_Finalization; ----------- -- Fopen -- ----------- function Fopen (Name : String; Typ : File_Mode) return Text_IO.File_Ptr is function C_Fopen (Name, Typ : Address) return Text_IO.File_Ptr; pragma Import (C, C_Fopen, "fopen"); Name1 : String (Name'First .. Name'Last + 1); Read_Only : String (1 .. 3) := "rt"; Write_Only : String (1 .. 3) := "wt"; begin Name1 (Name'range) := Name; Name1 (Name1'Last) := Nul; Read_Only (3) := Nul; Write_Only (3) := Nul; if Typ = In_File then return C_Fopen (Name1'Address, Read_Only'Address); else return C_Fopen (Name1'Address, Write_Only'Address); end if; end Fopen; ------------ -- Fclose -- ------------ procedure Fclose (P : Text_IO.File_Ptr) is procedure C_Fclose (P : Text_IO.File_Ptr); pragma Import (C, C_Fclose, "fclose"); begin C_Fclose (P); end Fclose; ------------ -- Unlink -- ------------ procedure Unlink (Name : String) is procedure C_Unlink (Name : Address); pragma Import (C, C_Unlink, "unlink"); Name1 : String (Name'First .. Name'Last + 1); begin Name1 (Name'range) := Name; Name1 (Name1'Last) := Nul; C_Unlink (Name1'Address); end Unlink; ------------ -- Isatty -- ------------ function Isatty (F : Text_IO.File_Ptr) return Boolean is function C_Isatty (I : Integer) return Boolean; pragma Import (C, C_Isatty, "isatty"); function C_Fileno (F : Text_IO.File_Ptr) return Integer; pragma Import (C, C_Fileno, "fileno"); begin return C_Isatty (C_Fileno (F)); end Isatty; ------------- -- C_Fgetc -- ------------- procedure C_Fgetc (F : Text_IO.File_Ptr; C : out Character; Is_Eof : out Boolean) is I : Integer; function Fgetc (F : Text_IO.File_Ptr) return Integer; pragma Import (C, Fgetc, "fgetc"); begin I := Fgetc (F); Is_Eof := I = -1; if not Is_Eof then C := Character'Val (I); end if; end C_Fgetc; ------------- -- C_Fputc -- ------------- procedure Fputc (F : Text_IO.File_Ptr; C : Character) is procedure C_Fputc (C : Character; F : Text_IO.File_Ptr); pragma Import (C, C_Fputc, "fputc"); begin C_Fputc (C, F); end Fputc; ----------- -- Stdin -- ------------ function Stdin return Text_IO.File_Ptr is function C_Stdin return Text_IO.File_Ptr; pragma Import (C, C_Stdin); begin return C_Stdin; end Stdin; ------------ -- Stdout -- ------------ function Stdout return Text_IO.File_Ptr is function C_Stdout return Text_IO.File_Ptr; pragma Import (C, C_Stdout); begin return C_Stdout; end Stdout; ------------ -- Stderr -- ------------ function Stderr return Text_IO.File_Ptr is function C_Stderr return Text_IO.File_Ptr; pragma Import (C, C_Stderr); begin return C_Stderr; end Stderr; begin -- Initialization of Standard Input Standard_In := new AFCB'(AFCB_In_Use => True, Desc => Stdin, Name => new String'("Standard_Input"), Form => new String'("rt"), Mode => In_File, Col => 1, Line => 1, Page => 1, Line_Length => 80, Page_Length => 24, Count => 0, Look_Ahead => " "); -- Initialization of Standard Output Standard_Out := new AFCB'(AFCB_In_Use => True, Desc => Stdout, Name => new String'("Standard_Output"), Form => new String'("wt"), Mode => Out_File, Col => 1, Line => 1, Page => 1, Line_Length => 80, Page_Length => 24, Count => 0, Look_Ahead => " "); -- Initialization of Standard Error Standard_Err := new AFCB'(AFCB_In_Use => True, Desc => Stderr, Name => new String'("Standard_Error"), Form => new String'("wt"), Mode => Out_File, Col => 1, Line => 1, Page => 1, Line_Length => 80, Page_Length => 24, Count => 0, Look_Ahead => " "); Current_In := Standard_In; Current_Out := Standard_Out; Current_Err := Standard_Err; Open_Files (Open_Files'First + 0) := Standard_In; Open_Files (Open_Files'First + 1) := Standard_Out; Open_Files (Open_Files'First + 2) := Standard_Err; end Ada.Text_IO.Aux; ---------------------- -- REVISION HISTORY -- ---------------------- -- ---------------------------- -- revision 1.8 -- date: Wed Dec 15 16:56:33 1993; author: banner -- (Get_Float): remove call to Check_Status_And_Mode for String version. -- (Put_Float): remove call to Check_Status_And_Mode for String version. -- (Put_Float): call Image_Float to do most of the work. -- (Put_Buffer): in the last loop replace calls to Put on Character with -- calls to Fputc instead so that Col does not get incremented too much. -- (Image_Float): change parameter type of Item to Float. -- (Image_Float): move code formerly in Put_Float here and generalize. -- (Image_Float): add code to correct exponent from the result of sprintf -- to comply with the semantics of the Exp parameter. -- ---------------------------- -- revision 1.9 -- date: Mon Dec 20 00:08:47 1993; author: banner -- Add declaration for Standard_Err and an entry for it in Open_Files. -- Add initializations for Standard_Err and Current_Err. -- (Current_Error): Add new Ada 9X function. -- (Standard_Error): Add new Ada 9X function. -- (Set_Error): Add new Ada 9X function. -- (Stderr): new function to retrieve value of stderr. -- (Text_IO_Finalization): Adjust iteration over Open_Files to allow for -- Standard_Err. -- ---------------------------- -- revision 1.10 -- date: Wed Dec 22 13:23:24 1993; author: banner -- (Close): Do not close the file associated with Standard_Error. -- (Text_IO_Finalization): Adjust comment to mention stderr. -- (Nextc): correct test against WS_Length. -- (Scan_Blanks): scan past Horizontal Tab as well as blanks in loop. -- (Scan_Integer, Scan_Integer_String): correct test against WS_Length. -- (Scan_Integer_Val): set WS_Length properly before rescan of Work_String. -- (Scan_Int, Scan_Based_Int): add condition in loops which check boundary -- of Work_String WS_Length during iteration to make sure do not go past -- end of string. -- ---------------------------- -- New changes after this line. Each line starts with: "-- " Range_Error; end if; gnat-1.67-src/examples/io-aux.c 444 10015 7640 3752 5506244246 11524 /****************************************************************************/ /* */ /* GNAT RUN-TIME COMPONENTS */ /* */ /* Text_IO Auxiliary C functions */ /* */ /* Body */ /* */ /* $Revision: 1.1 $ */ /* */ /* Copyright (c) 1992,1993, NYU, All Rights Reserved */ /* */ /* 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 */ /* Software Foundation; either version 2, or (at your option) any later */ /* version. GNAT is distributed in the hope that it will be useful, but */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- */ /* ABILITY 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 GNAT; see file COPYING. If not, write */ /* to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* */ /****************************************************************************/ #include FILE *c_stdin () { return stdin;} FILE *c_stdout () { return stdout;} FILE *c_stderr () { return stderr;} #if 0 ---------------------- -- REVISION HISTORY -- ---------------------- ---------------------------- revision 1.1 date: Mon Dec 20 01:05:22 1993; author: banner Initial revision ---------------------------- ** New changes after this line and before endif. ** #endif r; end if; gnat-1.67-src/examples/text_io.ads 444 10015 7640 4467 5506244247 12327 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- T E X T _ I O -- -- -- -- S p e c -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; with Ada.Text_IO; package Text_IO renames Ada.Text_IO; ---------------------- -- REVISION HISTORY -- ---------------------- -- ---------------------------- -- revision 1.1 -- date: Wed Oct 13 17:38:40 1993; author: banner -- Initial revision -- ---------------------------- -- revision 1.2 -- date: Thu Oct 14 15:19:06 1993; author: banner -- Add pragma Ada_9X in case user is compiling text_io while in Ada83 mode. -- ---------------------------- -- New changes after this line. Each line starts with: "-- " WS_Length then raise Data_Error; -- String is all blanks end if; Scan_Integer_Val (True, Result); else Scanning_From_File := True; Scan_Blanks; gnat-1.67-src/examples/text_io_example.adb 644 10015 7640 367 5506244247 13776 with Text_Io; use Text_Io; procedure Text_IO_Example is package Int_Io is new Integer_IO (Integer); use Int_Io; begin Put ("The following should be a five in base two:"); Put (5, Width => 7, Base => 2); New_Line; end Text_IO_Example; -- -- T E X T _ I O -- -- -- -- S pgnat-1.67-src/examples/system.ads 444 10015 7640 10214 5506244247 12203 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S Y S T E M -- -- -- -- S p e c -- -- -- -- $Revision: 1.11 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; package System is -- pragma Pure (System); type Name is (GNAT); System_Name : constant Name := GNAT; -- System-Dependent Named Numbers Min_Int : constant := - (2#1#E63); Max_Int : constant := (2#1#E63) - 1; Max_Binary_Modulus : constant := 2#1#E32; Max_Nonbinary_Modulus : constant := 2#1#E16 - 1; Max_Base_Digits : constant := 15; Max_Digits : constant := 15; Max_Mantissa : constant := 31; Fine_Delta : constant := 2#1.0#E-31; Tick : constant := 1.0; -- Storage related Declarations type Address is private; Null_Address : constant Address; Storage_Unit : constant := 8; Word_Size : constant := 32; Memory_Size : constant := 2#1#E32; -- Address comparison function "<" (Left, Right : Address) return Boolean; function "<=" (Left, Right : Address) return Boolean; function ">" (Left, Right : Address) return Boolean; function ">=" (Left, Right : Address) return Boolean; function "=" (Left, Right : Address) return Boolean; pragma Import (Intrinsic, "<"); pragma Import (Intrinsic, "<="); pragma Import (Intrinsic, ">"); pragma Import (Intrinsic, ">="); pragma Import (Intrinsic, "="); -- Declarations for real time Annexe (Annexe H) subtype Any_Priority is Integer range 0 .. 31; subtype Priority is Any_Priority range 0 .. 30; subtype Interrupt_Priority is Any_Priority range 31 .. 31; Default_Priority : constant Priority := (Priority'First + Priority'Last) / 2; private type Address is mod 2#1#E32; Null_Address : constant Address := 0; end System; ---------------------- -- REVISION HISTORY -- ---------------------- -- ---------------------------- -- revision 1.9 -- date: Thu Sep 9 11:14:37 1993; author: schenker -- add definition of Default_Priority -- ---------------------------- -- revision 1.10 -- date: Thu Oct 21 13:01:17 1993; author: dewar -- Remove type Tag (it's now in package Ada.Tags) -- ---------------------------- -- revision 1.11 -- date: Fri Nov 5 10:20:48 1993; author: schonber -- Fix typo. -- ---------------------------- -- New changes after this line. Each line starts with: "-- " l; if Typ = In_File then return C_Fopen (Name1'Address, Read_Only'Address); else return C_Fopen (Name1'Address, Write_Only'Address); end if; end Fopen; ------------ -- Fclose -- ------------ procedure Fclose (P : Text_IO.File_Ptr) is procedure C_Fclose (P : Text_IO.File_Ptr); pragma Import (C, C_Fclose, "fgnat-1.67-src/src/ 755 10015 7640 0 5506244522 7032 gnat-1.67-src/src/README.OS2 440 10015 7640 6164 5506244271 10403 HOW TO BUILD GNAT FOR OS/2 2.x Please follow these instructions carefully. 0) Install the latest executables of GNAT for OS/2 available via anonymous ftp from cs.nyu.edu, directory pub/gnat. Install the sources for gcc 2.5.4 (also available at the ftp site mentioned above) at the root level of the HPFS partition on which you installed the executables of GNAT for OS/2. You will also need the IBM Developer's Toolkit. 1) Make the root directory of the drive on which you installed the executables of GNAT for OS/2 the current directory. 2) Unzip the file GNAT-1.61-OS2-SRC.ZIP (available at the ftp site mentioned above) with the command UNZIP drive:path\GNAT-1.61-OS2-SRC.ZIP where "drive" and "path" is the drive and path in which the file GNAT-1.61-OS2-SRC.ZIP resides. This will create a directory called gnat-1.61, which will contain all the source code for GNAT. (If you are reading this file, you have presumable already done this step.) 3) Copy the sources for GNAT to the directory in which the sources for gcc 2.5.4 reside with the command COPY \GNAT-1.61\SRC \GCC-2.5.4 4) Make \GCC-2.5.4 your current directory. 5) Rename the file MAKEFILE.OS2 to MAKEFILE. Apply the patches listed in the file PATCHES-GCC254.OS2. 6) To bootstrap the compiler, type NMAKE BOOTSTRAPGNAT. You need plenty of virtual memory to do this: a total of at least 32 MB of combined physical memory and swap file space - more if you have any disk caches or other open windows or programs running. It takes about 2.5 hours to bootstrap on a 66 MHz 486DX2-based computer. The intermediate files and binaries created occupy about 19 MB of disk space. If you are running OS/2 2.1, the files GNAT1.EXE and GNATBIND.EXE in \GCC\BIN should be identical to the ones in \GCC-2.5.4. If you are running a different version of OS/2 2.x, you should still be able to bootstrap GNAT, but GNAT1.EXE and/or GNATBIND.EXE may be different from the ones in \GCC\BIN. In this case, you may want to copy the GNAT1.EXE and/or GNATBIND.EXE you just built to \GCC\BIN. 7) To build just the binder, type NMAKE GNATBIND.EXE. You may want to copy GNATBIND.EXE to \GCC\BIN. 8) If you want to get rid of all files which can be rebuilt from the sources, type NMAKE STAGE1 or NMAKE STAGE2, and delete both STAGE1 and STAGE2. 9) Other make targets of interest include BOOTSTRAP, which will attempt to build the compilers for the languages specified by the macro LANGUAGES. The only languages which are known to work are C and Ada. 10) To build the assembler, install the sources for gas 1.38.1 (available at the the ftp site mentioned above) at the root level of the HPFS partition on which you installed the executables of GNAT for OS/2. Make the directory \GAS-1.38 your current directory. Apply the patches listed in the file \GNAT-1.61\SRC\PATCHES-GAS138.OS2. Type NMAKE. This will create an executable called A386.EXE, which should then be renamed to AS.EXE, and copied to \GCC\BIN if you like. NOTE: GNAT is free software. See the file \GNAT-1.61\COPYING for copying permission. lib-sort.adb Œ¸² lib-writ.adb œ¸³lib.adb°¸´ libfmt.adsĸµ limits.adsaܸ¶ namet-ch.adbr r𸷠namet.ads¿¸¸opt.ads¸¹ namet.adb (¸º nmake.adt<¸» osint.adsP¸¼ osint.adbd¸½ output.adsx¸¾ output.adbˆ¸¿par.ads ¸À par-ch10.adb¢@¸¸Á par-ch11gnat-1.67-src/src/treeprs.ads 644 10015 7640 74662 5506244272 11335 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- T R E E P R S -- -- -- -- S p e c -- -- -- -- Generated by xtreeprs revision 1.16 using -- -- sinfo.ads revision 1.128 -- -- treeprs.adt revision 1.4 -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This package contains the declaration of the string used by the Tree_Print -- package. It must be updated whenever the arrangements of the field names -- in package Sinfo is changed. The utility program XTREEPRS is used to -- do this update correctly using the template treeprs.adt as input. with Sinfo; use Sinfo; with Types; use Types; package Treeprs is -------------------------------- -- String Data for Node Print -- -------------------------------- -- String data for print out. The Pchars array is a long string with the -- the entry for each node type consisting of a single blank, followed by -- a series of entries, one for each Op or Flag field used for the node. -- Each entry has a single character which identifies the field, followed -- by the synonym name. The starting location for a given node type is -- found from the corresponding entry in the Pchars_Pos_Array. -- The following characters identify the field. These are characters -- which could never occur in a field name, so they also mark the -- end of the previous name. subtype Fchar is Char range '#' .. '9'; F_Field1 : constant Fchar := '#'; -- Char'Val (16#23#) F_Field2 : constant Fchar := '$'; -- Char'Val (16#24#) F_Field3 : constant Fchar := '%'; -- Char'Val (16#25#) F_Field4 : constant Fchar := '&'; -- Char'Val (16#26#) F_Field5 : constant Fchar := '''; -- Char'Val (16#27#) F_Field6 : constant Fchar := '('; -- Char'Val (16#28#) F_Field7 : constant Fchar := ')'; -- Char'Val (16#29#) F_Flag1 : constant Fchar := '*'; -- Char'Val (16#2A#) F_Flag2 : constant Fchar := '+'; -- Char'Val (16#2B#) F_Flag3 : constant Fchar := ','; -- Char'Val (16#2C#) F_Flag4 : constant Fchar := '-'; -- Char'Val (16#2D#) F_Flag5 : constant Fchar := '.'; -- Char'Val (16#2E#) F_Flag6 : constant Fchar := '/'; -- Char'Val (16#2F#) F_Flag7 : constant Fchar := '0'; -- Char'Val (16#30#) F_Flag8 : constant Fchar := '1'; -- Char'Val (16#31#) F_Flag9 : constant Fchar := '2'; -- Char'Val (16#32#) F_Flag10 : constant Fchar := '3'; -- Char'Val (16#33#) F_Flag11 : constant Fchar := '4'; -- Char'Val (16#34#) F_Flag12 : constant Fchar := '5'; -- Char'Val (16#35#) F_Flag13 : constant Fchar := '6'; -- Char'Val (16#36#) F_Flag14 : constant Fchar := '7'; -- Char'Val (16#37#) F_Flag15 : constant Fchar := '8'; -- Char'Val (16#38#) F_Flag16 : constant Fchar := '9'; -- Char'Val (16#39#) Pchars : constant Str := -- Unused_At_Start "" & -- Empty "" & -- Error "" & -- Defining_Identifier "" & -- Defining_Character_Literal "" & -- Defining_Operator_Symbol "" & -- Expanded_Name "$Prefix%Selector_Name&Entity+Redundant_Use" & -- Identifier "&Entity+Redundant_Use" & -- Character_Literal "$Char_Literal_Value&Entity" & -- Operator_Symbol "%Strval&Entity" & -- Op_And "-Do_Length_Check" & -- Op_And_Then "" & -- Op_Or "-Do_Length_Check" & -- Op_Or_Else "" & -- Op_Xor "-Do_Length_Check" & -- Op_In "" & -- Op_Not_In "" & -- Op_Eq "" & -- Op_Ne "" & -- Op_Lt "" & -- Op_Le "" & -- Op_Gt "" & -- Op_Ge "" & -- Op_Add "" & -- Op_Subtract "" & -- Op_Concat "" & -- Op_Multiply "" & -- Op_Divide ",Do_Division_Check" & -- Op_Mod ",Do_Division_Check" & -- Op_Rem ",Do_Division_Check" & -- Op_Expon "" & -- Op_Plus "" & -- Op_Minus "" & -- Op_Abs "" & -- Op_Not "" & -- Integer_Literal "%Intval" & -- Real_Literal "%Numerator&Denominator+Decimal" & -- String_Literal "%Strval" & -- Explicit_Dereference "$Prefix+Do_Access_Check" & -- Indexed_Component "$Prefix%Expressions+Do_Access_Check" & -- Slice "$Prefix&Discrete_Range+Do_Access_Check" & -- Function_Call "$Name%Parameter_Associations&First_Named_Actual#Controlling_Argument+" & "Do_Elaboration_Check,Do_Tag_Check" & -- Selected_Component "$Prefix%Selector_Name+Do_Access_Check,Do_Discriminant_Check" & -- Attribute_Reference "$Prefix#Identifier%Expression&Entity+Do_Access_Check" & -- Aggregate "%Expressions&Component_Associations+Null_Record_Present" & -- Extension_Aggregate "%Expression&Component_Associations+Null_Record_Present" & -- Null "" & -- Parenthesized_Expression "%Expression" & -- Reference "%Expression" & -- Type_Conversion "&Subtype_Mark%Expression+Do_Overflow_Check,Do_Tag_Check-Do_Length_Che" & "ck4Unchecked_Conversion" & -- Qualified_Expression "&Subtype_Mark%Expression" & -- Allocator "%Expression+Do_Storage_Check" & -- Concat_Multiple "%Expressions" & -- Expression_Actions "#Actions%Expression" & -- Range "#Low_Bound$High_Bound" & -- Procedure_Call_Statement "$Name%Parameter_Associations&First_Named_Actual#Controlling_Argument+" & "Do_Elaboration_Check,Do_Tag_Check" & -- Subtype_Indication "&Subtype_Mark%Constraint" & -- Access_Function_Definition "*Protected_Present$Parameter_Specifications&Subtype_Mark" & -- Access_Procedure_Definition "*Protected_Present$Parameter_Specifications" & -- Unconstrained_Array_Definition "$Subtype_Marks*Aliased_Present&Subtype_Indication" & -- Constrained_Array_Definition "$Discrete_Subtype_Definitions*Aliased_Present&Subtype_Indication" & -- Subprogram_Body_Stub "#Specification&Library_Unit'Corresponding_Body" & -- Package_Body_Stub "#Defining_Identifier&Library_Unit'Corresponding_Body" & -- Task_Body_Stub "#Defining_Identifier&Library_Unit'Corresponding_Body" & -- Protected_Body_Stub "#Defining_Identifier&Library_Unit'Corresponding_Body" & -- Package_Instantiation "#Defining_Unit_Name$Name&Parent_Spec%Generic_Associations" & -- Procedure_Instantiation "#Defining_Unit_Name$Name&Parent_Spec%Generic_Associations" & -- Function_Instantiation "#Defining_Unit_Name$Name%Generic_Associations&Parent_Spec" & -- Subprogram_Body "#Specification%Declarations&Handled_Statement_Sequence*Bad_Is_Detecte" & "d'Corresponding_Spec-Acts_As_Spec+Do_Storage_Check.Is_Task_Master$" & "Activation_Chain_Entity/Has_Priority_Pragma" & -- Package_Body "#Defining_Unit_Name%Declarations&Handled_Statement_Sequence'Correspon" & "ding_Spec" & -- Task_Body "#Defining_Identifier%Declarations&Handled_Statement_Sequence.Is_Task_" & "Master$Activation_Chain_Entity'Corresponding_Spec" & -- Subprogram_Declaration "#Specification'Corresponding_Body&Parent_Spec" & -- Package_Declaration "#Specification'Corresponding_Body&Parent_Spec$Activation_Chain_Entity" & -- Task_Type_Declaration "#Defining_Identifier$Discriminant_Specifications%Task_Definition" & -- Single_Task_Declaration "#Defining_Identifier$Discriminant_Specifications%Task_Definition" & -- Implicit_Label_Declaration "#Defining_Identifier$Label" & -- Use_Package_Clause "$Names" & -- Pragma "#Identifier$Pragma_Argument_Associations%Debug_Statement" & -- Generic_Package_Declaration "#Specification'Corresponding_Body%Generic_Formal_Declarations&Parent_" & "Spec$Activation_Chain_Entity" & -- Generic_Subprogram_Declaration "#Specification'Corresponding_Body%Generic_Formal_Declarations&Parent_" & "Spec" & -- Formal_Object_Declaration "#Defining_Identifier*In_Present+Out_Present&Subtype_Mark%Expression.M" & "ore_Ids/Prev_Ids" & -- Formal_Type_Declaration "#Defining_Identifier%Formal_Type_Definition$Discriminant_Specificatio" & "ns,Has_Unknown_Discriminants" & -- Formal_Subprogram_Declaration "#Specification$Default_Name*Box_Present" & -- Formal_Package_Declaration "#Defining_Identifier$Name%Generic_Associations*Box_Present'Generic_Pa" & "rent" & -- Object_Renaming_Declaration "#Defining_Identifier&Subtype_Mark$Name" & -- Exception_Renaming_Declaration "#Defining_Identifier$Name" & -- Package_Renaming_Declaration "#Defining_Unit_Name$Name&Parent_Spec" & -- Subprogram_Renaming_Declaration "#Specification$Name&Parent_Spec'Corresponding_Spec" & -- Generic_Package_Renaming_Declaration "#Defining_Unit_Name$Name&Parent_Spec" & -- Generic_Procedure_Renaming_Declaration "#Defining_Unit_Name$Name&Parent_Spec" & -- Generic_Function_Renaming_Declaration "#Defining_Unit_Name$Name&Parent_Spec" & -- Attribute_Definition_Clause "$Name#Identifier%Expression" & -- Enumeration_Representation_Clause "#Identifier&Array_Aggregate" & -- Record_Representation_Clause "#Identifier$Mod_Clause%Component_Clauses" & -- Mod_Clause "%Expression" & -- Component_Clause "#Component_Name$Position%First_Bit&Last_Bit" & -- At_Clause "#Identifier%Expression" & -- Function_Specification "#Defining_Unit_Name$Parameter_Specifications&Subtype_Mark'Generic_Par" & "ent" & -- Procedure_Specification "#Defining_Unit_Name$Parameter_Specifications'Generic_Parent" & -- Abort_Statement "$Names" & -- Accept_Statement "#Accept_Name'Entry_Index%Declarations$Parameter_Specifications&Handle" & "d_Statement_Sequence" & -- Assignment_Statement "$Name%Expression,Do_Tag_Check-Do_Length_Check.Assignment_OK" & -- Block_Statement "#Identifier%Declarations&Handled_Statement_Sequence.Is_Task_Master$Ac" & "tivation_Chain_Entity*Has_Created_Identifier" & -- Case_Statement "%Expression&Alternatives" & -- Code_Statement "%Expression" & -- Delay_Relative_Statement "%Expression" & -- Delay_Until_Statement "%Expression" & -- Entry_Call_Statement "$Name%Parameter_Associations+Do_Elaboration_Check" & -- Exit_Statement "$Name'Condition" & -- Goto_Statement "$Name" & -- If_Statement "'Condition$Then_Statements%Elsif_Parts&Else_Statements" & -- Loop_Statement "#Identifier$Iteration_Scheme%Statements*Has_Created_Identifier" & -- Null_Statement "" & -- Raise_Statement "$Name" & -- Requeue_Statement "$Name*Abort_Present" & -- Return_Statement "%Expression,Do_Tag_Check" & -- Abortable_Part "%Statements" & -- Abstract_Subprogram_Declaration "#Specification" & -- Accept_Alternative "$Accept_Statement'Condition%Statements" & -- Access_Definition "&Subtype_Mark" & -- Access_To_Object_Definition "*All_Present&Subtype_Indication+Constant_Present" & -- Asynchronous_Select "#Triggering_Alternative$Abortable_Part" & -- Case_Statement_Alternative "&Discrete_Choices%Statements" & -- Compilation_Unit "&Library_Unit#Context_Items*Private_Present$Unit%Following_Pragmas+Pr" & "eelaborable,Body_Required-Acts_As_Spec0Elaborate_Body_Present" & -- Component_Association "#Choices%Expression" & -- Component_Declaration "#Defining_Identifier*Aliased_Present&Subtype_Indication%Expression.Mo" & "re_Ids/Prev_Ids" & -- Component_List "%Component_Declarations&Variant_Part,Null_Present" & -- Conditional_Entry_Call "#Entry_Call_Alternative&Else_Statements" & -- Derived_Type_Definition "-Abstract_Present&Subtype_Indication%Record_Extension_Part" & -- Decimal_Fixed_Point_Definition "%Delta_Expression$Digits_Expression&Real_Range_Specification" & -- Defining_Program_Unit_Name "$Name#Defining_Identifier" & -- Delay_Alternative "$Delay_Statement'Condition%Statements" & -- Delta_Constraint "%Delta_Expression&Range_Constraint" & -- Designator "$Name#Identifier" & -- Digits_Constraint "$Digits_Expression&Range_Constraint" & -- Discriminant_Association "#Selector_Names%Expression" & -- Discriminant_Specification "#Defining_Identifier$Discriminant_Type%Expression.More_Ids/Prev_Ids" & -- Elsif_Part "'Condition$Then_Statements" & -- Enumeration_Type_Definition "#Literals" & -- Entry_Body "#Defining_Identifier$Entry_Body_Formal_Part%Declarations&Handled_Stat" & "ement_Sequence'Condition" & -- Entry_Body_Formal_Part "#Entry_Index_Specification$Parameter_Specifications" & -- Entry_Call_Alternative "#Entry_Call_Statement%Statements" & -- Entry_Declaration "#Defining_Identifier&Discrete_Subtype_Definition$Parameter_Specificat" & "ions" & -- Entry_Index_Specification "#Defining_Identifier&Discrete_Subtype_Definition" & -- Exception_Declaration "#Defining_Identifier.More_Ids/Prev_Ids" & -- Exception_Handler "$Choice_Parameter&Exception_Choices%Statements" & -- Floating_Point_Definition "$Digits_Expression&Real_Range_Specification" & -- Formal_Decimal_Fixed_Point_Definition "" & -- Formal_Derived_Type_Definition "&Subtype_Mark*Private_Present" & -- Formal_Discrete_Type_Definition "" & -- Formal_Floating_Point_Definition "" & -- Formal_Modular_Type_Definition "" & -- Formal_Ordinary_Fixed_Point_Definition "" & -- Formal_Private_Type_Definition "-Abstract_Present*Tagged_Present+Limited_Present" & -- Formal_Signed_Integer_Type_Definition "" & -- Freeze_Entity "&Entity" & -- Full_Type_Declaration "#Defining_Identifier$Discriminant_Specifications%Type_Definition" & -- Generic_Association "%Selector_Name$Explicit_Generic_Actual_Parameter" & -- Handled_Sequence_Of_Statements "%Statements&Exception_Handlers#Identifier" & -- Implicit_Type "#Defining_Identifier" & -- Incomplete_Type_Declaration "#Defining_Identifier$Discriminant_Specifications,Has_Unknown_Discrimi" & "nants" & -- Index_Or_Discriminant_Constraint "#Constraints" & -- Iteration_Scheme "'Condition$Loop_Parameter_Specification" & -- Label "#Identifier" & -- Loop_Parameter_Specification "#Defining_Identifier*Reverse_Present&Discrete_Subtype_Definition" & -- Modular_Type_Definition "%Expression" & -- Number_Declaration "#Defining_Identifier%Expression.More_Ids/Prev_Ids" & -- Object_Declaration "#Defining_Identifier*Aliased_Present+Constant_Present$Object_Definiti" & "on%Expression.More_Ids/Prev_Ids" & -- Ordinary_Fixed_Point_Definition "%Delta_Expression&Real_Range_Specification" & -- Others_Choice "#Others_Discrete_Choices" & -- Package_Specification "#Defining_Unit_Name$Visible_Declarations&Private_Declarations'Generic" & "_Parent" & -- Parameter_Association "%Selector_Name$Actual_Parameter&Next_Named_Actual" & -- Parameter_Specification "#Defining_Identifier*In_Present+Out_Present$Parameter_Type%Expression" & ",Do_Accessibility_Check.More_Ids/Prev_Ids" & -- Pragma_Argument_Association "#Identifier%Expression" & -- Private_Extension_Declaration "#Defining_Identifier$Discriminant_Specifications,Has_Unknown_Discrimi" & "nants-Abstract_Present&Subtype_Indication" & -- Private_Type_Declaration "#Defining_Identifier$Discriminant_Specifications,Has_Unknown_Discrimi" & "nants-Abstract_Present*Tagged_Present+Limited_Present" & -- Protected_Body "#Defining_Identifier%Declarations" & -- Protected_Definition "$Visible_Declarations&Private_Declarations/Has_Priority_Pragma" & -- Protected_Type_Declaration "#Defining_Identifier$Discriminant_Specifications%Protected_Definition" & -- Range_Constraint "&Range_Expression" & -- Real_Range_Specification "#Low_Bound$High_Bound" & -- Record_Definition "-Abstract_Present*Tagged_Present+Limited_Present#Component_List$Impli" & "cit_Types,Null_Present" & -- Selective_Accept "#Selective_Accept_Alternatives&Else_Statements" & -- Signed_Integer_Type_Definition "#Low_Bound$High_Bound" & -- Single_Protected_Declaration "#Defining_Identifier$Discriminant_Specifications%Protected_Definition" & -- Subtype_Declaration "#Defining_Identifier&Subtype_Indication" & -- Subunit "$Name#Proper_Body" & -- Task_Definition "$Visible_Declarations&Private_Declarations/Has_Priority_Pragma.Has_Ta" & "sk_Stack_Size_Pragma" & -- Terminate_Alternative "'Condition" & -- Timed_Entry_Call "#Entry_Call_Alternative&Delay_Alternative" & -- Triggering_Alternative "#Triggering_Statement%Statements" & -- Use_Type_Clause "$Subtype_Marks" & -- Variant "&Discrete_Choices#Component_List$Enclosing_Variant" & -- Variant_Part "$Name#Variants" & -- With_Clause "$Name&Library_Unit'Corresponding_Spec.First_Name/Last_Name,Context_In" & "stalled-Elaborate_Present*Elaborate_All_Present+Implicit_With" & -- Unused_At_End ""; type Pchar_Pos_Array is array (Node_Kind) of Int; Pchar_Pos : constant Pchar_Pos_Array := Pchar_Pos_Array'( N_Unused_At_Start => 0, N_Empty => 0, N_Error => 0, N_Defining_Identifier => 0, N_Defining_Character_Literal => 0, N_Defining_Operator_Symbol => 0, N_Expanded_Name => 0, N_Identifier => 42, N_Character_Literal => 63, N_Operator_Symbol => 89, N_Op_And => 103, N_Op_And_Then => 119, N_Op_Or => 119, N_Op_Or_Else => 135, N_Op_Xor => 135, N_Op_In => 151, N_Op_Not_In => 151, N_Op_Eq => 151, N_Op_Ne => 151, N_Op_Lt => 151, N_Op_Le => 151, N_Op_Gt => 151, N_Op_Ge => 151, N_Op_Add => 151, N_Op_Subtract => 151, N_Op_Concat => 151, N_Op_Multiply => 151, N_Op_Divide => 151, N_Op_Mod => 169, N_Op_Rem => 187, N_Op_Expon => 205, N_Op_Plus => 205, N_Op_Minus => 205, N_Op_Abs => 205, N_Op_Not => 205, N_Integer_Literal => 205, N_Real_Literal => 212, N_String_Literal => 242, N_Explicit_Dereference => 249, N_Indexed_Component => 272, N_Slice => 307, N_Function_Call => 345, N_Selected_Component => 447, N_Attribute_Reference => 506, N_Aggregate => 558, N_Extension_Aggregate => 613, N_Null => 667, N_Parenthesized_Expression => 667, N_Reference => 678, N_Type_Conversion => 689, N_Qualified_Expression => 781, N_Allocator => 805, N_Concat_Multiple => 833, N_Expression_Actions => 845, N_Range => 864, N_Procedure_Call_Statement => 885, N_Subtype_Indication => 987, N_Access_Function_Definition => 1011, N_Access_Procedure_Definition => 1067, N_Unconstrained_Array_Definition => 1110, N_Constrained_Array_Definition => 1159, N_Subprogram_Body_Stub => 1223, N_Package_Body_Stub => 1269, N_Task_Body_Stub => 1321, N_Protected_Body_Stub => 1373, N_Package_Instantiation => 1425, N_Procedure_Instantiation => 1482, N_Function_Instantiation => 1539, N_Subprogram_Body => 1596, N_Package_Body => 1774, N_Task_Body => 1852, N_Subprogram_Declaration => 1970, N_Package_Declaration => 2015, N_Task_Type_Declaration => 2084, N_Single_Task_Declaration => 2148, N_Implicit_Label_Declaration => 2212, N_Use_Package_Clause => 2238, N_Pragma => 2244, N_Generic_Package_Declaration => 2300, N_Generic_Subprogram_Declaration => 2397, N_Formal_Object_Declaration => 2470, N_Formal_Type_Declaration => 2555, N_Formal_Subprogram_Declaration => 2652, N_Formal_Package_Declaration => 2691, N_Object_Renaming_Declaration => 2764, N_Exception_Renaming_Declaration => 2802, N_Package_Renaming_Declaration => 2827, N_Subprogram_Renaming_Declaration => 2863, N_Generic_Package_Renaming_Declaration => 2913, N_Generic_Procedure_Renaming_Declaration => 2949, N_Generic_Function_Renaming_Declaration => 2985, N_Attribute_Definition_Clause => 3021, N_Enumeration_Representation_Clause => 3048, N_Record_Representation_Clause => 3075, N_Mod_Clause => 3115, N_Component_Clause => 3126, N_At_Clause => 3169, N_Function_Specification => 3191, N_Procedure_Specification => 3263, N_Abort_Statement => 3322, N_Accept_Statement => 3328, N_Assignment_Statement => 3417, N_Block_Statement => 3476, N_Case_Statement => 3589, N_Code_Statement => 3613, N_Delay_Relative_Statement => 3624, N_Delay_Until_Statement => 3635, N_Entry_Call_Statement => 3646, N_Exit_Statement => 3695, N_Goto_Statement => 3710, N_If_Statement => 3715, N_Loop_Statement => 3769, N_Null_Statement => 3831, N_Raise_Statement => 3831, N_Requeue_Statement => 3836, N_Return_Statement => 3855, N_Abortable_Part => 3879, N_Abstract_Subprogram_Declaration => 3890, N_Accept_Alternative => 3904, N_Access_Definition => 3942, N_Access_To_Object_Definition => 3955, N_Asynchronous_Select => 4003, N_Case_Statement_Alternative => 4041, N_Compilation_Unit => 4069, N_Component_Association => 4199, N_Component_Declaration => 4218, N_Component_List => 4302, N_Conditional_Entry_Call => 4351, N_Derived_Type_Definition => 4390, N_Decimal_Fixed_Point_Definition => 4448, N_Defining_Program_Unit_Name => 4508, N_Delay_Alternative => 4533, N_Delta_Constraint => 4570, N_Designator => 4604, N_Digits_Constraint => 4620, N_Discriminant_Association => 4655, N_Discriminant_Specification => 4681, N_Elsif_Part => 4748, N_Enumeration_Type_Definition => 4774, N_Entry_Body => 4783, N_Entry_Body_Formal_Part => 4876, N_Entry_Call_Alternative => 4927, N_Entry_Declaration => 4959, N_Entry_Index_Specification => 5032, N_Exception_Declaration => 5080, N_Exception_Handler => 5118, N_Floating_Point_Definition => 5164, N_Formal_Decimal_Fixed_Point_Definition => 5207, N_Formal_Derived_Type_Definition => 5207, N_Formal_Discrete_Type_Definition => 5236, N_Formal_Floating_Point_Definition => 5236, N_Formal_Modular_Type_Definition => 5236, N_Formal_Ordinary_Fixed_Point_Definition => 5236, N_Formal_Private_Type_Definition => 5236, N_Formal_Signed_Integer_Type_Definition => 5284, N_Freeze_Entity => 5284, N_Full_Type_Declaration => 5291, N_Generic_Association => 5355, N_Handled_Sequence_Of_Statements => 5403, N_Implicit_Type => 5444, N_Incomplete_Type_Declaration => 5464, N_Index_Or_Discriminant_Constraint => 5538, N_Iteration_Scheme => 5550, N_Label => 5589, N_Loop_Parameter_Specification => 5600, N_Modular_Type_Definition => 5664, N_Number_Declaration => 5675, N_Object_Declaration => 5724, N_Ordinary_Fixed_Point_Definition => 5824, N_Others_Choice => 5866, N_Package_Specification => 5890, N_Parameter_Association => 5966, N_Parameter_Specification => 6015, N_Pragma_Argument_Association => 6125, N_Private_Extension_Declaration => 6147, N_Private_Type_Declaration => 6257, N_Protected_Body => 6379, N_Protected_Definition => 6412, N_Protected_Type_Declaration => 6474, N_Range_Constraint => 6543, N_Real_Range_Specification => 6560, N_Record_Definition => 6581, N_Selective_Accept => 6672, N_Signed_Integer_Type_Definition => 6718, N_Single_Protected_Declaration => 6739, N_Subtype_Declaration => 6808, N_Subunit => 6847, N_Task_Definition => 6864, N_Terminate_Alternative => 6953, N_Timed_Entry_Call => 6963, N_Triggering_Alternative => 7004, N_Use_Type_Clause => 7036, N_Variant => 7050, N_Variant_Part => 7100, N_With_Clause => 7114, N_Unused_At_End => 7244); end Treeprs; => 689, N_Qualified_Expression => 781, N_Allocatgnat-1.67-src/src/alloc.ads 444 10015 7640 10452 5506244272 10724 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- A L L O C -- -- -- -- S p e c -- -- -- -- $Revision: 1.7 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ package Alloc is -- This package contains definitions for initial sizes and growth increments -- for the various dynamic arrays used for principle compiler data strcutures. -- The indicated initial size is allocated for the start of each file, and -- the increment value is a percentage used to increase the size of the table -- when it needs expanding (e.g. a value of 100 = 100% increase = double) Alloc_Name_Chars_Initial : constant := 64_000; -- Initial allocation for name characters table (Namet) Alloc_Name_Chars_Increment : constant := 100; -- Incremental allocation for name characters table (Namet) Alloc_Names_Initial : constant := 4_000; -- Initial allocation of entries in names table (Namet) Alloc_Names_Increment : constant := 100; -- Incremental allocation of entries in names table (Namet) Alloc_String_Chars_Initial : constant := 64_000; -- Initial allocation for name characters table (Stringt) Alloc_String_Chars_Increment : constant := 150; -- Incremental allocation for name characters table (Stringt) Alloc_Strings_Initial : constant := 500; -- Initial allocation of entries in names table (Stringt) Alloc_Strings_Increment : constant := 150; -- Incremental allocation of entries in names table (Stringt) Alloc_Lines_Initial : constant := 4_000; -- Initial allocation for lines table (Scn) Alloc_Lines_Increment : constant := 150; -- Incremental allocation for lines table (Sinput) Alloc_Nodes_Initial : constant := 8_000; -- Initial allocation in nodes for tree (Tree) Alloc_Nodes_Increment : constant := 150; -- Incremental allocation for nodes table (Tree) Alloc_Lists_Initial : constant := 4_000; -- Initial allocation in list headers for tree (Tree) Alloc_Lists_Increment : constant := 150; -- Incremental allocation for list table (Tree) Alloc_Hash_Sub_Initial : constant := 2048; -- Initial allocation in tree substitution hash table (Tree.Sub) Alloc_Hash_Sub_Increment : constant := 300; -- Incremental allocation in tree substitution hash table (Tree.Sub) Alloc_Uints_Initial : constant := 500; -- Initial allocation for universal integer table in entries (Uintp) Alloc_Uints_Increment : constant := 100; -- Incremental allocation for universal integer table in digits (Uintp) Alloc_Udigits_Initial : constant := 5000; -- Initial allocation for Uint digits table (Uintp) Alloc_Udigits_Increment : constant := 100; -- Incremental allocation Uint digits table (Uintp) end Alloc; treepr.adbÔ¹+ treeprs.adtè¹, ttypes.ads$ü¹- ttypes.adtG¹. types.adsDV$¹/ types.adb8¹0 uintp.adsL¹1 uintp.adb`¹2 uname.adst¹3gnat-1.67-src/src/atree-ts.adb 444 10015 7640 17263 5506244272 11344 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- A T R E E . T S -- -- -- -- B o d y -- -- -- -- $Revision: 1.8 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This package implements the tree substitution rewrite package separate (Atree) package body TS is --------------------------------------- -- Data structures for mapping table -- --------------------------------------- -- A hash table is used to keep track of the mapping between substituted -- nodes and their corresponding original tree nodes. type Hash_Entry_Id is new Nat; -- Id of hash table entry is its subscript in the hash table No_Entry : constant Hash_Entry_Id := 0; -- Value used to mark no chain, or end of chain type Hash_Entry is record Next : Hash_Entry_Id; Old_Node : Node_Id; New_Node : Node_Id; end record; Num_Hash_Headers : constant := 512; -- Number of headers in Hash_Headers array Hash_Headers : array (Nat range 0 .. Num_Hash_Headers - 1) of Hash_Entry_Id; -- Table of hash headers, each entry points to chain of entries in the -- hash table whose hash value matches the subscript in the header table. -- The hash code is simply the Node_Id value mod Num_Hash_Headers. package Hash_Sub is new Table ( Component_Type => Hash_Entry, Index_Type => Hash_Entry_Id, Low_Bound => 1, Initial => Alloc_Hash_Sub_Initial, Increment => Alloc_Hash_Sub_Increment, Table_Name => "Hash_Sub"); ----------------------- -- Local Subprograms -- ----------------------- procedure Fix_Parent (Field : Int; Old_Node, New_Node : Node_Id); -- This subprogram is used to fixup parent pointers that are rendered -- incorrect because of the node exchange. Field is checked to see if -- it points to a node, list, or element list that has a parent that -- points to Old_Node. If so, the parent is reset to point to New_Node. -------------------- -- Initialize_Sub -- -------------------- procedure Initialize_Sub is begin for I in Hash_Headers'range loop Hash_Headers (I) := No_Entry; end loop; Hash_Sub.Init; end Initialize_Sub; ------------------------- -- Set_Substitute_Tree -- ------------------------- procedure Set_Substitute_Tree (Old_Node, New_Node : Node_Id) is begin pragma Debug (Dcheck_Is_Node (Old_Node)); pragma Debug (Dcheck_Is_Node (New_Node)); pragma Assert (not Has_Extension (Old_Node) and not Has_Extension (New_Node), Compiler_Abort); -- Do the exchange Exchange_Nodes (Old_Node, New_Node); Nodes.Table (Old_Node).Rewrite_Sub := True; -- Only remaining step is to fix up the parent pointers Fix_Parent (Field1 (Old_Node), New_Node, Old_Node); Fix_Parent (Field2 (Old_Node), New_Node, Old_Node); Fix_Parent (Field3 (Old_Node), New_Node, Old_Node); Fix_Parent (Field4 (Old_Node), New_Node, Old_Node); Fix_Parent (Field5 (Old_Node), New_Node, Old_Node); Fix_Parent (Field1 (New_Node), Old_Node, New_Node); Fix_Parent (Field2 (New_Node), Old_Node, New_Node); Fix_Parent (Field3 (New_Node), Old_Node, New_Node); Fix_Parent (Field4 (New_Node), Old_Node, New_Node); Fix_Parent (Field5 (New_Node), Old_Node, New_Node); -- Now, make an entry in the hash table. Note that we overwrite any -- existing entry that references Old_Node. This allows multiple steps -- of substitutions, and we will always get the real original. declare Hash_Code : Nat := Int (Old_Node) mod Num_Hash_Headers; Index : Hash_Entry_Id := Hash_Headers (Hash_Code); begin if Index = No_Entry then Hash_Sub.Increment_Last; Hash_Headers (Hash_Code) := Hash_Sub.Last; Hash_Sub.Table (Hash_Sub.Last).Next := No_Entry; Hash_Sub.Table (Hash_Sub.Last).New_Node := Old_Node; Hash_Sub.Table (Hash_Sub.Last).Old_Node := New_Node; else loop if Hash_Sub.Table (Index).New_Node = Old_Node then Hash_Sub.Table (Index).Old_Node := New_Node; exit; elsif Hash_Sub.Table (Index).Next = No_Entry then Hash_Sub.Increment_Last; Hash_Sub.Table (Index).Next := Hash_Sub.Last; Hash_Sub.Table (Hash_Sub.Last).Next := No_Entry; Hash_Sub.Table (Hash_Sub.Last).New_Node := Old_Node; Hash_Sub.Table (Hash_Sub.Last).Old_Node := New_Node; exit; else Index := Hash_Sub.Table (Index).Next; end if; end loop; end if; end; end Set_Substitute_Tree; ------------------------- -- Get_Substitute_Tree -- ------------------------- function Get_Substitute_Tree (New_Node : Node_Id) return Node_Id is Hash_Code : Nat := Int (New_Node) mod Num_Hash_Headers; Index : Hash_Entry_Id := Hash_Headers (Hash_Code); begin loop pragma Assert (Index /= No_Entry, Compiler_Abort); if New_Node = Hash_Sub.Table (Index).New_Node then return Hash_Sub.Table (Index).Old_Node; else Index := Hash_Sub.Table (Index).Next; end if; end loop; end Get_Substitute_Tree; ---------------- -- Fix_Parent -- ---------------- procedure Fix_Parent (Field : Int; Old_Node, New_Node : Node_Id) is begin if Field in Node_Range and then Node_Id (Field) /= Empty and then Parent (Node_Id (Field)) = Old_Node then Set_Parent (Node_Id (Field), New_Node); elsif Field in List_Range and then List_Id (Field) /= No_List and then List_Parent (List_Id (Field)) = Old_Node then Set_Parent (List_Id (Field), New_Node); elsif Field in Elist_Range and then Elist_Id (Field) /= No_Elist and then Elist_Parent (Elist_Id (Field)) = Old_Node then Set_Parent (Elist_Id (Field), New_Node); end if; end Fix_Parent; end TS; ke.adsge¹v nmake.ads› => 5164, N_Formal_Decimal_Fixed_Point_Definition => 5207, N_Formal_Derived_Type_Definition => 5207, N_Formal_Discrete_Type_Definition => 5236, N_Formal_Floating_Point_Definition => 5236, N_Formal_Modular_Type_Definition => 523gnat-1.67-src/src/atree.ads 444 10015 7640 202154 5506244274 10756 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- A T R E E -- -- -- -- S p e c -- -- -- -- $Revision: 1.43 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Alloc; use Alloc; with Sinfo; use Sinfo; with Einfo; use Einfo; with Types; use Types; with Table; package Atree is -- This package defines the format of the tree used to represent the Ada -- program internally. Syntactic and semantic information is combined in -- this tree. There is no separate symbol table structure. -- WARNING: There is a C version of this package. Any changes to this -- source file must be properly reflected in the C header file tree.h -- Package Atree defines the basic structure of the tree and its nodes and -- provides the basic abstract interface for manipulating the tree. Two -- other packages use this interface to define the representation of Ada -- programs using this tree format. The package Sinfo defines the basic -- representation of the syntactic structure of the program, as output -- by the parser. The package Entity_Info defines the semantic information -- which is added to the tree nodes that represent declared entities (i.e. -- the information which might typically be described in a separate symbol -- table structure. -- The front end of the compiler first parses the program and generates a -- tree that is simply a syntactic representation of the program in abstract -- syntax tree format. Subsequent processing in the front end traverses the -- tree, transforming it in various ways and adding semantic information. ---------------------------------------- -- Definitions of Fields in Tree Node -- ---------------------------------------- -- The representation of the tree is completely hidden, using a functional -- interface for accessing and modifying the contents of nodes. Logically -- a node contains a number of fields, much as though the nodes were -- defined as a record type. The fields in a node are as follows: -- Nkind Indicates the kind of the node. This field is present -- in all nodes. The type is Node_Kind, which is declared -- in the package Sinfo. -- Sloc Location (Source_Ptr) of the corresponding token -- in the Source buffer. The individual node definitions -- show which token is referenced by this pointer. -- Field1 An Int value stored in the tree -- Node1 Synonym for Field1 typed as Node_Id -- List1 Synonym for Field1 typed as List_Id -- Elist1 Synonym for Field1 typed as Elist_Id -- Name1 Synonym for Field1 typed as Name_Id -- Char_Code1 Synonym for Field1 typed as Char_Code -- Uint1 Synonym for Field1 typed as Uint -- Note: the actual usage of Field1 (i.e. whether it contains a Node_Id, -- List_Id, Elist_Id, Name_Id, Char_Code or Uint), depends on the value -- in Nkind (and, for entities, the value in Ekind). Generally the access -- to this field is always via the functional interface, so the field -- names Field1, Node1, List1, Elist1, Name1, Char_Code1 and Uint1 are -- used only in the bodies of the access functions (i.e. in the bodies -- of Sinfo and Einfo). These access functions contain debugging code -- that checks that the usage is consistent with Nkind and Ekind. -- However, in specialized circumstances (examples are the circuit in -- generic instantiation to copy trees, and in the tree dump routine), -- it is useful to be able to do untyped traversals, and an internal -- package in Atree allows for direct untyped accesses in such cases. -- Similar definitions for Field2, Field3, Field4, Field5 (and also -- Node2-5, List2-5, Elist2-5, Name2-5, Char_Code2-5, Uint2-5) -- Flag1 Twenty Boolean flags (use depends on Nkind and -- Flag2 Ekind, as described for Fieldn). Again the access -- Flag3 is usually via subprograms in Sinfo and Einfo which -- Flag4 provide high-level synonyms for these flags, and -- Flag5 contain debugging code that checks that the values -- Flag6 in Nkind and Ekind are appropriate for the access. -- Flag7 -- Flag8 -- Flag9 -- Flag10 -- Flag11 -- Flag12 -- Flag13 -- Flag14 -- Flag15 -- Flag16 -- Flag17 -- Flag18 -- Flag19 -- Flag20 -- Parent Pointer to parent node, i.e. node which points to -- the node which references this field. The parent -- field can only be set in a node which is not in -- a list, or in a list header. The parent field of -- nodes that are in a list is automatically set to -- the parent of the list header, and cannot be -- explicitly set. This field is considered private -- to Atree. -- The following additional fields are present in extended nodes -- (i.e. nodes extended by a call to the Extend_Node function) -- Ekind Entity type. This field is present only in entity -- nodes (i.e. Nkind in N_Entity). It is of type -- Entity_Kind, which is defined in package Einfo. -- All entity nodes are extended nodes. -- Flag21 Twenty-three additional flags -- Flag22 -- Flag23 -- Flag24 -- Flag25 -- Flag26 -- Flag27 -- Flag28 -- Flag29 -- Flag30 -- Flag31 -- Flag32 -- Flag33 -- Flag34 -- Flag35 -- Flag36 -- Flag37 -- Flag38 -- Flag39 -- Flag40 -- Flag41 -- Flag42 -- Flag43 -- Field6 Additional Int value stored in tree -- Node6 Synonym for Field6 typed as Node_Id -- List6 Synonym for Field6 typed as List_Id -- Elist6 Synonym for Field6 typed as Elist_Id -- Uint6 Synonym for Field6 typed as Uint -- Similar definitions for Field7 to Field12 (and Node7-Node12, -- List7-List12, Elist7-Elist12, Uint7-Uint12). function Last_Node_Id return Node_Id; pragma Inline (Last_Node_Id); -- Returns Id of last allocated node Id function Last_List_Id return List_Id; pragma Inline (Last_List_Id); -- Returns Id of last allocated list Id ----------------------- -- Use of Empty Node -- ----------------------- -- The special Node_Id Empty is used to mark missing fields. Whenever the -- syntax has an optional component, then the corresponding field will be -- set to Empty if the component is missing. -- Note: Empty is not used to describe an empty list. Instead in this -- case the node field contains a list which is empty, and these cases -- should be distinguished (essentially from a type point of view, Empty -- is a Node, and is thus not a list). -- Note: Empty does in fact correspond to an allocated node. Only the -- Nkind field of this node may be referenced. It contains N_Empty, which -- uniquely identifies the empty case. This allows the Nkind field to be -- dereferenced before the check for Empty which is sometimes useful. ------------------------------- -- Default Setting of Fields -- ------------------------------- -- Nkind is always set, there is no default value -- Ekind is always set, there is no default value -- Sloc is always set, there is no default value -- Field1-5 fields are set to Empty -- Field6-12 fields in extended nodes are set to Empty -- Parent is set to Empty -- All Boolean flag fields are set to False -- Note: the value Empty is used in Field1-Field12 to indicate a null node. -- The usage varies. The common uses are to indicate absence of an -- optional clause or a completely unused Field1-12 field. ------------------------------------- -- Use of Synonyms for Node Fields -- ------------------------------------- -- A subpackage Atree.Unchecked_Access provides routines for reading and -- writing the fields defined above (Field1-12, Node1-12, Flag1-29 etc). -- These unchecked access routines can be used for untyped traversals. In -- In addition they are used in the implementations of the Sinfo and -- Einfo packages. These packages both provide logical synonyms for -- the generic fields, together with an appropriate set of access routines. -- Normally access to information within tree nodes uses these synonyms, -- providing a high level typed interface to the tree information. ---------------- -- Node Lists -- ---------------- -- A node list is a list that is threaded through nodes (using the Link -- field). This means that it takes minimum space, but a node can be on -- at most one such node list. For each node list, a list header is -- allocated in the lists table, and a List_Id value references this -- header which may be used to access the nodes in the list using the -- following set of routines that define the interface: function New_List return List_Id; -- Creates a new empty node list. Typically this is used to initialize -- a field in some other node which points to a node list where the list -- is then subsequently filled in using Append calls. function Empty_List return List_Id renames New_List; -- Used in contexts where an empty list (as opposed to an initially empty -- list to be filled in) is required. function New_List_1 (A : Node_Id) return List_Id; function New_List_2 (A, B : Node_Id) return List_Id; function New_List_3 (A, B, C : Node_Id) return List_Id; function New_List_4 (A, B, C, D : Node_Id) return List_Id; function New_List_5 (A, B, C, D, E : Node_Id) return List_Id; function New_List_6 (A, B, C, D, E, F : Node_Id) return List_Id; function New_List_7 (A, B, C, D, E, F, G : Node_Id) return List_Id; function New_List_8 (A, B, C, D, E, F, G, H : Node_Id) return List_Id; function New_List_9 (A, B, C, D, E, F, G, H, I : Node_Id) return List_Id; -- Build lists with indicated number of initial node values. Exactly -- Equivalent to calling New_List and then calling Append to insert -- the nodes A-I in sequence, in particular, if any of the nodes contain -- Error, then they are not inserted. function New_List_Copy (List : List_Id) return List_Id; -- Creates a new list containing copies (made with New_Copy) of every -- node in the original list. If the argument is No_List, then the -- returned result is No_List. If the argument is an empty list, then -- the returned result is a new empty list. function First (List : List_Id) return Node_Id; pragma Inline (First); -- Obtains the first element of the given node list or, if the node list -- has no items, then Empty is returned. It is an error to call First with -- a pointer to a node or Empty (Empty is not considered to be the -- same as an empty node list). function Last (List : List_Id) return Node_Id; pragma Inline (Last); -- Obtains the last element of the given node list or, if the node list -- has no items, then Empty is returned. It is an error to call Last with -- a pointer to a node or Empty (Empty is not considered to be the -- same as an empty node list). function Nth (List : List_Id; Index : Pos) return Node_Id; -- Returns the Index'th item in List (first node = 1). If Index is -- greater than the number of items in the list, Empty is returned. function Next (Node : Node_Id) return Node_Id; pragma Inline (Next); -- This function returns the next node on a node list, or Empty if Node is -- the last element of the node list. The argument must be a member of a function Prev (Node : Node_Id) return Node_Id; -- This function returns the previous node on a node list list, or Empty if -- Node is the first element of the node list. The argument must be a -- member of a node list. function Is_Empty_List (L : List_Id) return Boolean; pragma Inline (Is_Empty_List); -- This function determines if a given list id references a node list that -- contains no items. No_List is a not a legitimate argument. function Is_Non_Empty_List (L : List_Id) return Boolean; -- This function determines if a given list id references a node list that -- contains at least one item. No_List is not a legitimate argument. function Is_List_Member (Node : Node_Id) return Boolean; pragma Inline (Is_List_Member); -- This function determines if a given node is a member of a node list. -- It is an error for Node to be Empty, or to be a node list. function List_Containing (Node : Node_Id) return List_Id; -- This function provides a pointer to the node list containing Node. -- Node must be a member of a node list. procedure Append (Node : Node_Id; To : List_Id); -- Appends Node at the end of node list To. Node must be a non-empty node -- that is not already a member of a node list, and To must be a -- node list. An attempt to append an error node is ignored without -- complaint and the list is unchanged. procedure Append_To (To : List_Id; Node : Node_Id); pragma Inline (Append_To); -- Like Append, but arguments are the other way round procedure Append_List (List : List_Id; To : List_Id); -- Appends node list List to the end of node list To. On return, -- List is reset to be empty. procedure Append_List_To (To : List_Id; List : List_Id); pragma Inline (Append_List_To); -- Like Append_List, but arguments are the other way round procedure Insert_After (After : Node_Id; Node : Node_Id); -- Insert Node, which must be a non-empty node that is not already a -- member of a node list, immediately past node After, which must be a -- node that is currently a member of a node list. An attempt to insert -- an error node is ignored without complaint (and the list is unchanged). procedure Insert_List_After (After : Node_Id; List : List_Id); -- Inserts the entire contents of node list List immediately after node -- After, which must be a member of a node list. On return, the node list -- List is reset to be the empty node list. procedure Insert_Before (Before : Node_Id; Node : Node_Id); -- Insert Node, which must be a non-empty node that is not already a -- member of a node list, immediately before Before, which must be a node -- that is currently a member of a node list. An attempt to insert an -- error node is ignored without complaint (and the list is unchanged). procedure Insert_List_Before (Before : Node_Id; List : List_Id); -- Inserts the entire contents of node list List immediately before node -- Before, which must be a member of a node list. On return, the node list -- List is reset to be the empty node list. procedure Prepend (Node : Node_Id; To : List_Id); -- Prepends Node at the start of node list To. Node must be a non-empty -- node that is not already a member of a node list, and To must be a -- node list. An attempt to prepend an error node is ignored without -- complaint and the list is unchanged. procedure Prepend_To (To : List_Id; Node : Node_Id); pragma Inline (Prepend_To); -- Like Prepend, but arguments are the other way round procedure Remove (Node : Node_Id); -- Removes Node, which must be a node that is a member of a node list, -- from this node list. The contents of Node are not otherwise affected. function Remove_Head (List : List_Id) return Node_Id; -- Removes the head element of a node list, and returns the node (whose -- contents are not otherwise affected) as the result. If the node list is -- empty, then Empty is returned. function Remove_Next (Node : Node_Id) return Node_Id; -- Removes the item immediately following the given node, and returns it -- as the result. If Node is the last element of the list, then Empty is -- returned. ------------------- -- Element Lists -- ------------------- -- As described above, node lists are threaded through nodes. This is -- space efficient, since the only space overhead is for the list header, -- but limited in two. First a node can be only on one such list. -- Second, since there is only room for one pointer in a list, the list -- is singly linked, and consequently the Prev operation is slow. -- Element lists are more general and resolve all these limitations. They -- use separate list elements to represent the list. This takes extra -- space, but it allows a node to be on multiple lists. In addition, there -- is room in a list element for both a forward and backward pointer, so -- operations like Prev are efficient. -- Note that element lists do NOT have a parent pointer. This is because -- element lists are never used for structural representation of the -- tree (e.g. the parser never generates element lists). -- The following set of routines define the interface for element lists function Id_Of (Elmt : Elmt_Id) return Node_Id; pragma Inline (Id_Of); -- Returns the value of a given list element function New_Elmt_List return Elist_Id; -- Creates a new empty element list. Typically this is used to initialize -- a field in some other node which points to an element list where the -- list is then subsequently filled in using Append calls. function Empty_Elmt_List return Elist_Id renames New_Elmt_List; -- Used in contexts where an empty element list (as opposed to an -- initially empty element list to be filled in) is required. function New_Elmt_List_Copy (List : Elist_Id) return Elist_Id; -- Creates a new list containing copies (made with New_Copy) of every -- node in the original list. If the argument is No_Elist, then the -- result is No_Elist. If the argument is an empty element list, then -- the result is a new empty element list. function First_Elmt (List : Elist_Id) return Elmt_Id; pragma Inline (First_Elmt); -- Obtains the first element of the given element list or, if the element -- list has no items, then No_Elmt is returned. It is an error to call -- First_Elmt with anything other than an element list. function Last_Elmt (List : Elist_Id) return Elmt_Id; pragma Inline (Last_Elmt); -- Obtains the last element of the given element list or, if the element -- list has no items, then No_Elmt is returned. It is an error to call -- Last_Elmt with anything other than an element list. function Nth_Elmt (List : Elist_Id; Index : Pos) return Elmt_Id; -- Returns the Index'th element in the element list List (first node = 1). -- If Index exceeds the number of items in the list, No_Elmt is returned. function Next_Elmt (Elmt : Elmt_Id) return Elmt_Id; pragma Inline (Next_Elmt); -- This function returns the next element on an element list. The argument -- must be a list element other than No_Elmt. Returns No_Elmt if the given -- element is the last element of the list. function Prev_Elmt (Elmt : Elmt_Id) return Elmt_Id; pragma Inline (Prev_Elmt); -- This function returns the previous element on an element list. The -- argument must be a list element other than No_Elmt. Returns No_Elmt -- if the given element is the last element of the list. function Is_Empty_Elmt_List (L : Elist_Id) return Boolean; -- This function determines if a given tree id references an element list -- that contains no items. function Is_Non_Empty_Elmt_List (L : Elist_Id) return Boolean; -- This function determines if a given tree id references an element -- list that contains at least one item. procedure Append_Elmt (Node : Node_Id; To : Elist_Id); -- Appends Node at the end of To, allocating a new element. procedure Append_Elmt_List (List : Elist_Id; To : Elist_Id); -- Appends element list List to the end of element list To. On return, -- List is reset to be empty. procedure Insert_Elmt_After (After : Elmt_Id; Node : Node_Id); -- Insert Node immediately after After, allocating a new element procedure Insert_Elmt_List_After (After : Elmt_Id; List : Elist_Id); -- Inserts the entire contents of element list List immediately after -- element After. On return, List is reset to be the empty element list. procedure Insert_Elmt_Before (Before : Elmt_Id; Node : Node_Id); -- Insert Node immediately before Before, allocating a new element procedure Insert_Elmt_List_Before (Before : Elmt_Id; List : Elist_Id); -- Inserts the entire contents of element list List immediately before -- element Before. On return, List is reset to be the empty element list. procedure Remove_Elmt (Elmt : Elmt_Id); -- Removes the given element from the list. The contents of the item -- referenced by the list element are not affected. The space used by -- the list element itself is freed for reuse. function Remove_Head_Elmt (List : Elist_Id) return Node_Id; -- Removes the head element of an element list, and returns the item -- referenced by this head element. The space used by the list element -- itself is freed for reuse. If the element list is empty, then Empty -- is returned. function Remove_Next_Elmt (Elmt : Elmt_Id) return Node_Id; -- Removes the element immediately following the given element and returns -- the node referenced by this element. If the element is the last element -- of the list, then Empty is returned. The space used by the removed list -- element itself is freed for reuse. -------------------------------------------------- -- Node Allocation and Modification Subprograms -- -------------------------------------------------- -- Generally the parser builds the tree amd then it is further decorated -- (e.g. by setting the entity fields), but not fundamentally modified. -- However, there are cases in which the tree must be restructured by -- adding and rearranging nodes, as a result of disambiguating cases -- which the parser could not parse correctly, and adding additional -- semantic information (e.g. making constraint checks explicit). The -- following subprograms are used for constructing the tree in the first -- place, and then for subsequent modifications as required procedure Initialize_Atree; -- Called at the start of compilation to initialize the allocation of -- the node and list tables and make the standard entries for Empty, -- Error and Error_List. function New_Node (New_Node_Kind : Node_Kind; New_Sloc : Source_Ptr) return Node_Id; -- Allocates a completely new node with the given node type and source -- location values. All other fields are set to their standard defaults: -- Empty for all Fieldn fields -- False for all Flagn fields -- The usual approach is to build a new node using this function and -- then, using the value returned, use the Set_xxx functions to set -- fields of the node as required. Note that nodes allocated using this -- function never have an extension. If an extension is required, then -- a subsequent call to Extend_Node must be made. function Extend_Node (Node : Node_Id) return Node_Id; -- This function returns a copy of its input node with an extension added. -- The fields of the extension are set to Empty. Due to the way extensions -- are handled (as two consecutive array elements), it may be necessary to -- reallocate the node, so that the returned value is not the same as the -- input value, but where possible the returned value will be the same as -- the input value (i.e. the extension will occur in place). It is the -- caller's responsibility to ensure that any pointers to the original -- node are appropriately updated. function Has_Extension (N : Node_Id) return Boolean; pragma Inline (Has_Extension); -- Returns True if the given node has an extension (i.e. was the result of -- a Extend_Node call). Returns False for a non-extended node. procedure Change_Node (N : Node_Id; New_Node_Kind : Node_Kind); -- This procedure replaces the given node by setting its Nkind field to -- the indicated value and resetting all other fields to their default -- values except for Sloc, which is unchanged, and the Parent pointer -- and list links, which are also unchanged. All other information in -- the original node is lost. The new node has an extension if the -- original node had an extension. procedure Copy_Node (Source : Node_Id; Destination : Node_Id); -- Copy the entire contents of the source node to the destination node. -- The contents of the source node is not affected. If the source node -- has an extension, then the destination must have an extension also. -- The parent pointer of the destination and its list link, if any, are -- not affected by the copy. function New_Copy (Source : Node_Id) return Node_Id; -- This function allocates a completely new node, and then initializes -- it by copying the contents of the source node into it. The contents -- of the source node is not affected. The target node is always marked -- as not being in a list (even if the source is a list member). The -- new node will have an extension if the source has an extension. -- New_Copy (Empty) returns Empty and New_Copy (Error) returns Error. procedure Exchange_Nodes (Node1 : Node_Id; Node2 : Node_Id); -- Exchange the contents of the two nodes, except that the Parent pointers, -- and list pointers are not modified. If either node has an extension then -- the other node must also have an extension. procedure Delete_Node (Node : Node_Id); -- The node is first removed from its containing list if it is a list -- member. Then it is deleted from the tree and its type is set to N_Void. -- It is an error (not necessarily detected) to reference this node after -- it has been deleted. The implementation of the body of Atree is free to -- reuse the node to satisfy future node allocation requests. --------------------------- -- Node Access Functions -- --------------------------- -- The following functions return the contents of the indicated field of -- the node referenced by the argument, which is a Node_Id. function Nkind (N : Node_Id) return Node_Kind; pragma Inline (Nkind); function Ekind (N : Node_Id) return Entity_Kind; pragma Inline (Ekind); function Sloc (N : Node_Id) return Source_Ptr; pragma Inline (Sloc); function Parent (N : Node_Id) return Node_Id; pragma Inline (Parent); function List_Parent (L : List_Id) return Node_Id; pragma Inline (List_Parent); function Elist_Parent (E : Elist_Id) return Node_Id; pragma Inline (Elist_Parent); function No (N : Node_Id) return Boolean; pragma Inline (No); -- Tests given Id for equality with the Empty node. This allows notations -- like "if No (Variant_Part) then" as opposed to "if Variant_Part = Empty -- then". Note that this function may not be used with Elist values (use -- explicit compare with No_Elist for this case). function Present (N : Node_Id) return Boolean; pragma Inline (Present); -- Tests given Id for inequality with the Empty node. This allows notations -- like "if Present (Variant_Part) then" as opposed to "if Variant_Part /= -- Empty then". Note that this function may not be used with Elist values -- (used explicit compare with No_Elist for this case). function List_Present (L : List_Id) return Boolean; pragma Inline (List_Present); ---------------------------- -- Node Update Procedures -- ---------------------------- -- The following functions set a specified field in the node whose Id is -- passed as the first argument. The second parameter is the new value -- to be set in the specified field. Note that Set_Nkind is in the next -- section, since its use is restricted. procedure Set_Ekind (N : Node_Id; Val : Entity_Kind); pragma Inline (Set_Ekind); procedure Set_Sloc (N : Node_Id; Val : Source_Ptr); pragma Inline (Set_Sloc); procedure Set_Parent (N : Node_Id; Val : Node_Id); procedure Set_Parent (L : List_Id; Val : Node_Id); procedure Set_Parent (E : Elist_Id; Val : Node_Id); pragma Inline (Set_Parent); --------------------------- -- Tree Rewrite Routines -- --------------------------- -- During the compilation process it is necessary in a number of situations -- to rewrite the tree. In some cases, such rewrites do not affect the -- structure of the tree, for example, when an indexed component node is -- replaced by the corresponding call node (the parser cannot distinguish -- between these two cases). -- In other situations, the rewrite does affect the structure of the -- tree. Examples are the replacement of a generic instantiation by the -- instantiated spec and body, and the static evaluation of expressions. -- If such structural modifications are done by the expander, there are -- no difficulties, since the form of the tree after the expander has no -- special significance, except as input to the backend of the compiler. -- However, if these modifications are done by the semantic phase, then -- it is important that they be done in a manner which allows the original -- tree to be preserved. This is because tools like pretty printers need -- to have this original tree structure available. -- The subprograms in this section allow rewriting of the tree by either -- insertion of new nodes in an existing list, or complete replacement of -- a subtree. The resulting tree for most purposes looks as though it has -- been really changed, and there is no trace of the original. However, -- special subprograms, also defined in this section, allow the original -- tree to be reconstructed if necessary. -- For tree modifications done in the expander, it is permissible to -- destroy the original tree, although it is also allowable to use the -- tree rewrite routines where it is convenient to do so. procedure Mark_Rewrite_Insertion (New_Node : Node_Id); pragma Inline (Mark_Rewrite_Insertion); -- This procedure marks the given node as an insertion made during a tree -- rewriting operation. Only the root needs to be marked. The call does -- not do the actual insertion, which must be done using one of the normal -- list insertion routines. The node is treated normally in all respects -- except for its response to Is_Rewrite_Insertion. function Is_Rewrite_Insertion (Node : Node_Id) return Boolean; pragma Inline (Is_Rewrite_Insertion); -- Tests whether the given node was marked using Set_Rewrite_Insert. This -- is used in reconstructing the original tree (where such nodes are to -- be eliminated from the reconstructed tree). procedure Rewrite_Substitute_Tree (Old_Node, New_Node : Node_Id); -- This is used when a complete subtree is to be replaced. Old_Node is the -- root of the old subtree to be replaced, and New_Node is the root of the -- newly constructed replacement subtree. The actual mechanism is to swap -- the contents of these two nodes fixing up parent pointers appropriately. -- At the current time, there is a limitation that requires that neither -- Old_Node, nor New_Node can be extended nodes. New_Node should *not* -- be marked using Mark_Rewrite_Insertion. function Is_Rewrite_Substitution (Node : Node_Id) return Boolean; pragma Inline (Is_Rewrite_Substitution); -- Return True iff Node has been rewritten (i.e. if Node is the root -- or a subtree which was installed using Rewrite_Substitute_Tree) function Original_Node (Node : Node_Id) return Node_Id; -- If Node has not been rewritten, then returns its input argument -- unchanged, else returns the Node for the original subtree. If -- applied to a node marked by Set_Rewrite_Insert, returns Empty. -- Note: there is no direct mechanism for deleting an original subtree. -- Instead it must be rewritten using Rewrite_Substitute_Tree (one -- possibility is to substitute a null statement). ----------------------------------- -- Generic Field Access Routines -- ----------------------------------- -- This subpackage provides the functions for accessing and procedures -- for setting fields that are normally referenced by their logical -- synonyms defined in packages Sinfo and Einfo. As previously -- described the implementations of these packages use the package -- Atree.Unchecked_Access. package Unchecked_Access is -- Functions to fetch contents of indicated field. It is an error -- to attempt to read the value of a field which is not present. function Field1 (N : Node_Id) return Int; pragma Inline (Field1); function Field2 (N : Node_Id) return Int; pragma Inline (Field2); function Field3 (N : Node_Id) return Int; pragma Inline (Field3); function Field4 (N : Node_Id) return Int; pragma Inline (Field4); function Field5 (N : Node_Id) return Int; pragma Inline (Field5); function Field6 (N : Node_Id) return Int; pragma Inline (Field6); function Field7 (N : Node_Id) return Int; pragma Inline (Field7); function Field8 (N : Node_Id) return Int; pragma Inline (Field8); function Field9 (N : Node_Id) return Int; pragma Inline (Field9); function Field10 (N : Node_Id) return Int; pragma Inline (Field10); function Field11 (N : Node_Id) return Int; pragma Inline (Field11); function Field12 (N : Node_Id) return Int; pragma Inline (Field12); function Node1 (N : Node_Id) return Node_Id; pragma Inline (Node1); function Node2 (N : Node_Id) return Node_Id; pragma Inline (Node2); function Node3 (N : Node_Id) return Node_Id; pragma Inline (Node3); function Node4 (N : Node_Id) return Node_Id; pragma Inline (Node4); function Node5 (N : Node_Id) return Node_Id; pragma Inline (Node5); function Node6 (N : Node_Id) return Node_Id; pragma Inline (Node6); function Node7 (N : Node_Id) return Node_Id; pragma Inline (Node7); function Node8 (N : Node_Id) return Node_Id; pragma Inline (Node8); function Node9 (N : Node_Id) return Node_Id; pragma Inline (Node9); function Node10 (N : Node_Id) return Node_Id; pragma Inline (Node10); function Node11 (N : Node_Id) return Node_Id; pragma Inline (Node11); function Node12 (N : Node_Id) return Node_Id; pragma Inline (Node12); function List1 (N : Node_Id) return List_Id; pragma Inline (List1); function List2 (N : Node_Id) return List_Id; pragma Inline (List2); function List3 (N : Node_Id) return List_Id; pragma Inline (List3); function List4 (N : Node_Id) return List_Id; pragma Inline (List4); function List5 (N : Node_Id) return List_Id; pragma Inline (List5); function List6 (N : Node_Id) return List_Id; pragma Inline (List6); function List7 (N : Node_Id) return List_Id; pragma Inline (List7); function List8 (N : Node_Id) return List_Id; pragma Inline (List8); function List9 (N : Node_Id) return List_Id; pragma Inline (List9); function List10 (N : Node_Id) return List_Id; pragma Inline (List10); function List11 (N : Node_Id) return List_Id; pragma Inline (List11); function List12 (N : Node_Id) return List_Id; pragma Inline (List12); function Elist1 (N : Node_Id) return Elist_Id; pragma Inline (Elist1); function Elist2 (N : Node_Id) return Elist_Id; pragma Inline (Elist2); function Elist3 (N : Node_Id) return Elist_Id; pragma Inline (Elist3); function Elist4 (N : Node_Id) return Elist_Id; pragma Inline (Elist4); function Elist5 (N : Node_Id) return Elist_Id; pragma Inline (Elist5); function Elist6 (N : Node_Id) return Elist_Id; pragma Inline (Elist6); function Elist7 (N : Node_Id) return Elist_Id; pragma Inline (Elist7); function Elist8 (N : Node_Id) return Elist_Id; pragma Inline (Elist8); function Elist9 (N : Node_Id) return Elist_Id; pragma Inline (Elist9); function Elist10 (N : Node_Id) return Elist_Id; pragma Inline (Elist10); function Elist11 (N : Node_Id) return Elist_Id; pragma Inline (Elist11); function Elist12 (N : Node_Id) return Elist_Id; pragma Inline (Elist12); function Name1 (N : Node_Id) return Name_Id; pragma Inline (Name1); function Name2 (N : Node_Id) return Name_Id; pragma Inline (Name2); function Name3 (N : Node_Id) return Name_Id; pragma Inline (Name3); function Name4 (N : Node_Id) return Name_Id; pragma Inline (Name4); function Name5 (N : Node_Id) return Name_Id; pragma Inline (Name5); function Char_Code1 (N : Node_Id) return Char_Code; pragma Inline (Char_Code1); function Char_Code2 (N : Node_Id) return Char_Code; pragma Inline (Char_Code2); function Char_Code3 (N : Node_Id) return Char_Code; pragma Inline (Char_Code3); function Char_Code4 (N : Node_Id) return Char_Code; pragma Inline (Char_Code4); function Char_Code5 (N : Node_Id) return Char_Code; pragma Inline (Char_Code5); function Str1 (N : Node_Id) return String_Id; pragma Inline (Str1); function Str2 (N : Node_Id) return String_Id; pragma Inline (Str2); function Str3 (N : Node_Id) return String_Id; pragma Inline (Str3); function Str4 (N : Node_Id) return String_Id; pragma Inline (Str4); function Str5 (N : Node_Id) return String_Id; pragma Inline (Str5); function Uint1 (N : Node_Id) return Uint; pragma Inline (Uint1); function Uint2 (N : Node_Id) return Uint; pragma Inline (Uint2); function Uint3 (N : Node_Id) return Uint; pragma Inline (Uint3); function Uint4 (N : Node_Id) return Uint; pragma Inline (Uint4); function Uint5 (N : Node_Id) return Uint; pragma Inline (Uint5); function Uint6 (N : Node_Id) return Uint; pragma Inline (Uint6); function Uint7 (N : Node_Id) return Uint; pragma Inline (Uint7); function Uint8 (N : Node_Id) return Uint; pragma Inline (Uint8); function Uint9 (N : Node_Id) return Uint; pragma Inline (Uint9); function Uint10 (N : Node_Id) return Uint; pragma Inline (Uint10); function Uint11 (N : Node_Id) return Uint; pragma Inline (Uint11); function Uint12 (N : Node_Id) return Uint; pragma Inline (Uint12); function Flag1 (N : Node_Id) return Boolean; pragma Inline (Flag1); function Flag2 (N : Node_Id) return Boolean; pragma Inline (Flag2); function Flag3 (N : Node_Id) return Boolean; pragma Inline (Flag3); function Flag4 (N : Node_Id) return Boolean; pragma Inline (Flag4); function Flag5 (N : Node_Id) return Boolean; pragma Inline (Flag5); function Flag6 (N : Node_Id) return Boolean; pragma Inline (Flag6); function Flag7 (N : Node_Id) return Boolean; pragma Inline (Flag7); function Flag8 (N : Node_Id) return Boolean; pragma Inline (Flag8); function Flag9 (N : Node_Id) return Boolean; pragma Inline (Flag9); function Flag10 (N : Node_Id) return Boolean; pragma Inline (Flag10); function Flag11 (N : Node_Id) return Boolean; pragma Inline (Flag11); function Flag12 (N : Node_Id) return Boolean; pragma Inline (Flag12); function Flag13 (N : Node_Id) return Boolean; pragma Inline (Flag13); function Flag14 (N : Node_Id) return Boolean; pragma Inline (Flag14); function Flag15 (N : Node_Id) return Boolean; pragma Inline (Flag15); function Flag16 (N : Node_Id) return Boolean; pragma Inline (Flag16); function Flag17 (N : Node_Id) return Boolean; pragma Inline (Flag17); function Flag18 (N : Node_Id) return Boolean; pragma Inline (Flag18); function Flag19 (N : Node_Id) return Boolean; pragma Inline (Flag19); function Flag20 (N : Node_Id) return Boolean; pragma Inline (Flag20); function Flag21 (N : Node_Id) return Boolean; pragma Inline (Flag21); function Flag22 (N : Node_Id) return Boolean; pragma Inline (Flag22); function Flag23 (N : Node_Id) return Boolean; pragma Inline (Flag23); function Flag24 (N : Node_Id) return Boolean; pragma Inline (Flag24); function Flag25 (N : Node_Id) return Boolean; pragma Inline (Flag25); function Flag26 (N : Node_Id) return Boolean; pragma Inline (Flag26); function Flag27 (N : Node_Id) return Boolean; pragma Inline (Flag27); function Flag28 (N : Node_Id) return Boolean; pragma Inline (Flag28); function Flag29 (N : Node_Id) return Boolean; pragma Inline (Flag29); function Flag30 (N : Node_Id) return Boolean; pragma Inline (Flag30); function Flag31 (N : Node_Id) return Boolean; pragma Inline (Flag31); function Flag32 (N : Node_Id) return Boolean; pragma Inline (Flag32); function Flag33 (N : Node_Id) return Boolean; pragma Inline (Flag33); function Flag34 (N : Node_Id) return Boolean; pragma Inline (Flag34); function Flag35 (N : Node_Id) return Boolean; pragma Inline (Flag35); function Flag36 (N : Node_Id) return Boolean; pragma Inline (Flag36); function Flag37 (N : Node_Id) return Boolean; pragma Inline (Flag37); function Flag38 (N : Node_Id) return Boolean; pragma Inline (Flag38); function Flag39 (N : Node_Id) return Boolean; pragma Inline (Flag39); function Flag40 (N : Node_Id) return Boolean; pragma Inline (Flag40); function Flag41 (N : Node_Id) return Boolean; pragma Inline (Flag41); function Flag42 (N : Node_Id) return Boolean; pragma Inline (Flag42); function Flag43 (N : Node_Id) return Boolean; pragma Inline (Flag43); -- Procedures to set value of indicated field procedure Set_Nkind (N : Node_Id; Val : Node_Kind); pragma Inline (Set_Nkind); procedure Set_Field1 (N : Node_Id; Val : Int); pragma Inline (Set_Field1); procedure Set_Field2 (N : Node_Id; Val : Int); pragma Inline (Set_Field2); procedure Set_Field3 (N : Node_Id; Val : Int); pragma Inline (Set_Field3); procedure Set_Field4 (N : Node_Id; Val : Int); pragma Inline (Set_Field4); procedure Set_Field5 (N : Node_Id; Val : Int); pragma Inline (Set_Field5); procedure Set_Field6 (N : Node_Id; Val : Int); pragma Inline (Set_Field6); procedure Set_Field7 (N : Node_Id; Val : Int); pragma Inline (Set_Field7); procedure Set_Field8 (N : Node_Id; Val : Int); pragma Inline (Set_Field8); procedure Set_Field9 (N : Node_Id; Val : Int); pragma Inline (Set_Field9); procedure Set_Field10 (N : Node_Id; Val : Int); pragma Inline (Set_Field10); procedure Set_Field11 (N : Node_Id; Val : Int); pragma Inline (Set_Field11); procedure Set_Field12 (N : Node_Id; Val : Int); pragma Inline (Set_Field12); procedure Set_Node1 (N : Node_Id; Val : Node_Id); pragma Inline (Set_Node1); procedure Set_Node2 (N : Node_Id; Val : Node_Id); pragma Inline (Set_Node2); procedure Set_Node3 (N : Node_Id; Val : Node_Id); pragma Inline (Set_Node3); procedure Set_Node4 (N : Node_Id; Val : Node_Id); pragma Inline (Set_Node4); procedure Set_Node5 (N : Node_Id; Val : Node_Id); pragma Inline (Set_Node5); procedure Set_Node6 (N : Node_Id; Val : Node_Id); pragma Inline (Set_Node6); procedure Set_Node7 (N : Node_Id; Val : Node_Id); pragma Inline (Set_Node7); procedure Set_Node8 (N : Node_Id; Val : Node_Id); pragma Inline (Set_Node8); procedure Set_Node9 (N : Node_Id; Val : Node_Id); pragma Inline (Set_Node9); procedure Set_Node10 (N : Node_Id; Val : Node_Id); pragma Inline (Set_Node10); procedure Set_Node11 (N : Node_Id; Val : Node_Id); pragma Inline (Set_Node11); procedure Set_Node12 (N : Node_Id; Val : Node_Id); pragma Inline (Set_Node12); procedure Set_List1 (N : Node_Id; Val : List_Id); pragma Inline (Set_List1); procedure Set_List2 (N : Node_Id; Val : List_Id); pragma Inline (Set_List2); procedure Set_List3 (N : Node_Id; Val : List_Id); pragma Inline (Set_List3); procedure Set_List4 (N : Node_Id; Val : List_Id); pragma Inline (Set_List4); procedure Set_List5 (N : Node_Id; Val : List_Id); pragma Inline (Set_List5); procedure Set_List6 (N : Node_Id; Val : List_Id); pragma Inline (Set_List6); procedure Set_List7 (N : Node_Id; Val : List_Id); pragma Inline (Set_List7); procedure Set_List8 (N : Node_Id; Val : List_Id); pragma Inline (Set_List8); procedure Set_List9 (N : Node_Id; Val : List_Id); pragma Inline (Set_List9); procedure Set_List10 (N : Node_Id; Val : List_Id); pragma Inline (Set_List10); procedure Set_List11 (N : Node_Id; Val : List_Id); pragma Inline (Set_List11); procedure Set_List12 (N : Node_Id; Val : List_Id); pragma Inline (Set_List12); procedure Set_Elist1 (N : Node_Id; Val : Elist_Id); pragma Inline (Set_Elist1); procedure Set_Elist2 (N : Node_Id; Val : Elist_Id); pragma Inline (Set_Elist2); procedure Set_Elist3 (N : Node_Id; Val : Elist_Id); pragma Inline (Set_Elist3); procedure Set_Elist4 (N : Node_Id; Val : Elist_Id); pragma Inline (Set_Elist4); procedure Set_Elist5 (N : Node_Id; Val : Elist_Id); pragma Inline (Set_Elist5); procedure Set_Elist6 (N : Node_Id; Val : Elist_Id); pragma Inline (Set_Elist6); procedure Set_Elist7 (N : Node_Id; Val : Elist_Id); pragma Inline (Set_Elist7); procedure Set_Elist8 (N : Node_Id; Val : Elist_Id); pragma Inline (Set_Elist8); procedure Set_Elist9 (N : Node_Id; Val : Elist_Id); pragma Inline (Set_Elist9); procedure Set_Elist10 (N : Node_Id; Val : Elist_Id); pragma Inline (Set_Elist10); procedure Set_Elist11 (N : Node_Id; Val : Elist_Id); pragma Inline (Set_Elist11); procedure Set_Elist12 (N : Node_Id; Val : Elist_Id); pragma Inline (Set_Elist12); procedure Set_Name1 (N : Node_Id; Val : Name_Id); pragma Inline (Set_Name1); procedure Set_Name2 (N : Node_Id; Val : Name_Id); pragma Inline (Set_Name2); procedure Set_Name3 (N : Node_Id; Val : Name_Id); pragma Inline (Set_Name3); procedure Set_Name4 (N : Node_Id; Val : Name_Id); pragma Inline (Set_Name4); procedure Set_Name5 (N : Node_Id; Val : Name_Id); pragma Inline (Set_Name5); procedure Set_Char_Code1 (N : Node_Id; Val : Char_Code); pragma Inline (Set_Char_Code1); procedure Set_Char_Code2 (N : Node_Id; Val : Char_Code); pragma Inline (Set_Char_Code2); procedure Set_Char_Code3 (N : Node_Id; Val : Char_Code); pragma Inline (Set_Char_Code3); procedure Set_Char_Code4 (N : Node_Id; Val : Char_Code); pragma Inline (Set_Char_Code4); procedure Set_Char_Code5 (N : Node_Id; Val : Char_Code); pragma Inline (Set_Char_Code5); procedure Set_Str1 (N : Node_Id; Val : String_Id); pragma Inline (Set_Str1); procedure Set_Str2 (N : Node_Id; Val : String_Id); pragma Inline (Set_Str2); procedure Set_Str3 (N : Node_Id; Val : String_Id); pragma Inline (Set_Str3); procedure Set_Str4 (N : Node_Id; Val : String_Id); pragma Inline (Set_Str4); procedure Set_Str5 (N : Node_Id; Val : String_Id); pragma Inline (Set_Str5); procedure Set_Uint1 (N : Node_Id; Val : Uint); pragma Inline (Set_Uint1); procedure Set_Uint2 (N : Node_Id; Val : Uint); pragma Inline (Set_Uint2); procedure Set_Uint3 (N : Node_Id; Val : Uint); pragma Inline (Set_Uint3); procedure Set_Uint4 (N : Node_Id; Val : Uint); pragma Inline (Set_Uint4); procedure Set_Uint5 (N : Node_Id; Val : Uint); pragma Inline (Set_Uint5); procedure Set_Uint6 (N : Node_Id; Val : Uint); pragma Inline (Set_Uint5); procedure Set_Uint7 (N : Node_Id; Val : Uint); pragma Inline (Set_Uint7); procedure Set_Uint8 (N : Node_Id; Val : Uint); pragma Inline (Set_Uint8); procedure Set_Uint9 (N : Node_Id; Val : Uint); pragma Inline (Set_Uint9); procedure Set_Uint10 (N : Node_Id; Val : Uint); pragma Inline (Set_Uint10); procedure Set_Uint11 (N : Node_Id; Val : Uint); pragma Inline (Set_Uint11); procedure Set_Uint12 (N : Node_Id; Val : Uint); pragma Inline (Set_Uint12); procedure Set_Flag1 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag1); procedure Set_Flag2 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag2); procedure Set_Flag3 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag3); procedure Set_Flag4 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag4); procedure Set_Flag5 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag5); procedure Set_Flag6 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag6); procedure Set_Flag7 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag7); procedure Set_Flag8 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag8); procedure Set_Flag9 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag9); procedure Set_Flag10 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag10); procedure Set_Flag11 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag11); procedure Set_Flag12 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag12); procedure Set_Flag13 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag13); procedure Set_Flag14 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag14); procedure Set_Flag15 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag15); procedure Set_Flag16 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag16); procedure Set_Flag17 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag17); procedure Set_Flag18 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag18); procedure Set_Flag19 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag19); procedure Set_Flag20 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag20); procedure Set_Flag21 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag21); procedure Set_Flag22 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag22); procedure Set_Flag23 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag23); procedure Set_Flag24 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag24); procedure Set_Flag25 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag25); procedure Set_Flag26 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag26); procedure Set_Flag27 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag27); procedure Set_Flag28 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag28); procedure Set_Flag29 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag29); procedure Set_Flag30 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag30); procedure Set_Flag31 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag31); procedure Set_Flag32 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag32); procedure Set_Flag33 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag33); procedure Set_Flag34 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag34); procedure Set_Flag35 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag35); procedure Set_Flag36 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag36); procedure Set_Flag37 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag37); procedure Set_Flag38 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag38); procedure Set_Flag39 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag39); procedure Set_Flag40 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag40); procedure Set_Flag41 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag41); procedure Set_Flag42 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag42); procedure Set_Flag43 (N : Node_Id; Val : Boolean); pragma Inline (Set_Flag43); -- The following versions of Set_Noden also set the parent -- pointer of the referenced node if it is non_Empty procedure Set_Node1_With_Parent (N : Node_Id; Val : Node_Id); pragma Inline (Set_Node1); procedure Set_Node2_With_Parent (N : Node_Id; Val : Node_Id); pragma Inline (Set_Node2); procedure Set_Node3_With_Parent (N : Node_Id; Val : Node_Id); pragma Inline (Set_Node3); procedure Set_Node4_With_Parent (N : Node_Id; Val : Node_Id); pragma Inline (Set_Node4); procedure Set_Node5_With_Parent (N : Node_Id; Val : Node_Id); pragma Inline (Set_Node5); procedure Set_Node6_With_Parent (N : Node_Id; Val : Node_Id); pragma Inline (Set_Node6); procedure Set_Node7_With_Parent (N : Node_Id; Val : Node_Id); pragma Inline (Set_Node7); procedure Set_Node8_With_Parent (N : Node_Id; Val : Node_Id); pragma Inline (Set_Node8); procedure Set_Node9_With_Parent (N : Node_Id; Val : Node_Id); pragma Inline (Set_Node9); procedure Set_Node10_With_Parent (N : Node_Id; Val : Node_Id); pragma Inline (Set_Node10); procedure Set_Node11_With_Parent (N : Node_Id; Val : Node_Id); pragma Inline (Set_Node11); procedure Set_Node12_With_Parent (N : Node_Id; Val : Node_Id); pragma Inline (Set_Node12); -- The following versions of Set_Listn also set the parent pointer of -- the referenced node if it is non_Empty. The procedures for List6 -- to List12 can only be applied to nodes which have an extension. procedure Set_List1_With_Parent (N : Node_Id; Val : List_Id); pragma Inline (Set_List1_With_Parent); procedure Set_List2_With_Parent (N : Node_Id; Val : List_Id); pragma Inline (Set_List2_With_Parent); procedure Set_List3_With_Parent (N : Node_Id; Val : List_Id); pragma Inline (Set_List3_With_Parent); procedure Set_List4_With_Parent (N : Node_Id; Val : List_Id); pragma Inline (Set_List4_With_Parent); procedure Set_List5_With_Parent (N : Node_Id; Val : List_Id); pragma Inline (Set_List5_With_Parent); procedure Set_List6_With_Parent (N : Node_Id; Val : List_Id); pragma Inline (Set_List6_With_Parent); procedure Set_List7_With_Parent (N : Node_Id; Val : List_Id); pragma Inline (Set_List7_With_Parent); procedure Set_List8_With_Parent (N : Node_Id; Val : List_Id); pragma Inline (Set_List8_With_Parent); procedure Set_List9_With_Parent (N : Node_Id; Val : List_Id); pragma Inline (Set_List9_With_Parent); procedure Set_List10_With_Parent (N : Node_Id; Val : List_Id); pragma Inline (Set_List10_With_Parent); procedure Set_List11_With_Parent (N : Node_Id; Val : List_Id); pragma Inline (Set_List11_With_Parent); procedure Set_List12_With_Parent (N : Node_Id; Val : List_Id); pragma Inline (Set_List12_With_Parent); end Unchecked_Access; ----------------------------- -- Private Part Subpackage -- ----------------------------- -- The following package contains the definition of the data structure -- used by the implementation of the Atree package. Logically it really -- corresponds to the private part, hence the name. The reason that it -- is defined as a sub-package is to allow special access from clients -- that need to see the internals of the data structures. package Atree_Private_Part is ------------------------- -- Tree Representation -- ------------------------- -- The nodes of the tree are stored in a table (i.e. an array). In the -- case of extended nodes, two consecutive components in the array are -- used. There are thus two formats for array components. One is used -- for non-extended nodes, and for the first component of extended -- nodes. The other is used for the extension (second component) of -- an extended node. A variant record structure is used to distinguish -- the two formats. type Node_Record (Is_Extension : Boolean := False) is record -- Logically, the only field in the common part is the above -- Is_Extension discriminant (a single bit). However, Gigi cannot -- yet handle such a structure, so we fill out the common part of -- the record with fields that are used in different ways for -- normal nodes and node extensions. In_List : Boolean; -- Flag used to indicate if node is a member of a list. -- This field is considered private to the Atree package. Rewrite_Sub : Boolean; -- Flag set if this node was result of Rewrite_Substitute_Tree. -- This field is considered private to the Atree package. Rewrite_Ins : Boolean; -- Flag set by Mark_Rewrite_Insertion procedure. -- This field is considered private to the Atree package. Flag1 : Boolean; Flag2 : Boolean; Flag3 : Boolean; Flag4 : Boolean; Flag5 : Boolean; Flag6 : Boolean; Flag7 : Boolean; Flag8 : Boolean; Flag9 : Boolean; Flag10 : Boolean; Flag11 : Boolean; Flag12 : Boolean; Flag13 : Boolean; Flag14 : Boolean; Flag15 : Boolean; Flag16 : Boolean; Flag17 : Boolean; Flag18 : Boolean; Flag19 : Boolean; Flag20 : Boolean; -- The twenty flags for a normal node -- The above fields are used as follows in a node extension -- In_List used as Flag21 in extension -- Rewrite_Sub used as Flag22 in extension -- Rewrite_Ins used as Flag23 in extension -- Flag1 used as Flag24 in extension -- Flag2 used as Flag25 in extension -- Flag3 used as Flag26 in extension -- Flag4 used as Flag27 in extension -- Flag5 used as Flag28 in extension -- Flag6 used as Flag29 in extension -- Flag7 used as Flag30 in extension -- Flag8 used as Flag31 in extension -- Flag9 used as Flag32 in extension -- Flag10 used as Flag33 in extension -- Flag11 used as Flag34 in extension -- Flag12 used as Flag35 in extension -- Flag13 used as Flag36 in extension -- Flag14 used as Flag37 in extension -- Flag15 used as Flag38 in extension -- Flag16 used as Flag39 in extension -- Flag17 used as Flag40 in extension -- Flag18 used as Flag41 in extension -- Flag19 used as Flag42 in extension -- Flag20 used as Flag43 in extension Nkind : Node_Kind; -- For a non-extended node, or the initial section of an extended -- node, this field holds the Node_Kind value. For an extended node, -- this field is used (by means of unchecked conversion) to hold -- the Ekind field of the entity. -- Now finally (on an 32-bit boundary!) comes the variant part case Is_Extension is -- Non-extended node, or first component of extended node when False => Sloc : Source_Ptr; -- Source location for this node Link : Int; -- This field is used either as the Parent pointer (if In_List -- is False), or as the list link pointer (if In_List is True) -- This field is considered private to the Atree package. Field1 : Int; Field2 : Int; Field3 : Int; Field4 : Int; Field5 : Int; -- Five general use fields, which can contain Node_Id, List_Id, -- Elist_Id, String_Id, Name_Id, or Char_Code values depending -- on the values in Nkind and (for extended nodes), in Ekind. -- See packages Sinfo and Einfo for details of their use. -- Extension (second component) of extended node when True => Field6 : Int; Field7 : Int; Field8 : Int; Field9 : Int; Field10 : Int; Field11 : Int; Field12 : Int; -- Seven additional general fields available only for entities -- See package Einfo for details of their use (which depends -- on the value in the Ekind field). end case; end record; pragma Pack (Node_Record); -- The following defines the extendible array used for the nodes table -- Nodes with extensions use two consecutive entries in the array package Nodes is new Table ( Component_Type => Node_Record, Index_Type => Node_Id, Low_Bound => First_Node_Id, Initial => Alloc_Nodes_Initial, Increment => Alloc_Nodes_Increment, Table_Name => "Nodes"); -- The following is the structure used for the lists table. Nodes in -- this table are used in three different ways: -- For node list headers -- Lfield1 points to the first node in the list (Empty if none) -- Lfield2 points to the last node in the list (Empty if none) -- Lnode points to the parent (Empty if none) -- For element list headers -- Lfield1 points to the first element in the list (No_Elmt if none) -- Lfield2 points to the last element in the list (No_Elmt if none) -- Lnode points to the parent (Empty if none) -- For elements in an element list -- Lfield1 points to the prev element or to header if at list start -- Lfield2 points to the next element or to header if at list end -- Lnode contains pointer to referenced Val of element type List_Header is record Lfield1 : Int; Lfield2 : Int; Lnode : Node_Id; end record; for List_Header'Size use 8 * 12; List_Header_Bytes : constant := 12; -- Size of list header in bytes package Lists is new Table ( Component_Type => List_Header, Index_Type => List_Id, Low_Bound => First_List_Id, Initial => Alloc_Lists_Initial, Increment => Alloc_Lists_Increment, Table_Name => "Lists"); end Atree_Private_Part; end Atree; t_Id); pragma Inline (Set_List10_With_Parent); procedure Set_List11_With_Parent (N : Node_Id; Val : List_Id); pragma Inline (Set_List11_With_Parent); procedure Set_List12_With_Parent (N : Node_Id; Val : List_Id); pragma Inline (Set_List12_With_Parent); end Unchecked_Access; ----------------------------- -- Private Part Subpackage -- -----------------------gnat-1.67-src/src/atree.adb 444 10015 7640 321725 5506244276 10745 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- A T R E E -- -- -- -- B o d y -- -- -- -- $Revision: 1.55 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Comperr; use Comperr; with Debug; use Debug; with Output; use Output; with Unchecked_Conversion; package body Atree is -- WARNING: There is a C version of this package. Any changes to this source -- file must be properly reflected in the C header a-atree.h (for inlined -- bodies) and the C file a-atree.c (for remaining non-inlined bodies). use Unchecked_Access; -- We are allowed to see these from within our own body! use Atree_Private_Part; -- We are also allowed to see our private data structures! function E_To_N is new Unchecked_Conversion (Entity_Kind, Node_Kind); function N_To_E is new Unchecked_Conversion (Node_Kind, Entity_Kind); -- Functions used to store Entity_Kind value in Nkind field -- Default value used to initialize default nodes. Note that some of the -- fields get overwritten, and in particular, Nkind always gets reset. Default_Node : constant Node_Record := ( Is_Extension => False, In_List => False, Rewrite_Sub => False, Rewrite_Ins => False, Flag1 => False, Flag2 => False, Flag3 => False, Flag4 => False, Flag5 => False, Flag6 => False, Flag7 => False, Flag8 => False, Flag9 => False, Flag10 => False, Flag11 => False, Flag12 => False, Flag13 => False, Flag14 => False, Flag15 => False, Flag16 => False, Flag17 => False, Flag18 => False, Flag19 => False, Flag20 => False, Nkind => N_Unused_At_Start, Sloc => No_Location, Link => Int (Empty), Field1 => Int (Empty), Field2 => Int (Empty), Field3 => Int (Empty), Field4 => Int (Empty), Field5 => Int (Empty)); -- Default value used to initialize node extensions (i.e. the second -- component of an extended node) Default_Node_Extension : constant Node_Record := ( Is_Extension => True, In_List => False, Rewrite_Sub => False, Rewrite_Ins => False, Flag1 => False, Flag2 => False, Flag3 => False, Flag4 => False, Flag5 => False, Flag6 => False, Flag7 => False, Flag8 => False, Flag9 => False, Flag10 => False, Flag11 => False, Flag12 => False, Flag13 => False, Flag14 => False, Flag15 => False, Flag16 => False, Flag17 => False, Flag18 => False, Flag19 => False, Flag20 => False, Nkind => E_To_N (E_Void), Field6 => Int (Empty), Field7 => Int (Empty), Field8 => Int (Empty), Field9 => Int (Empty), Field10 => Int (Empty), Field11 => Int (Empty), Field12 => Int (Empty)); ---------------------------------- -- Implementation of Node Lists -- ---------------------------------- -- To allow efficient access to the list, both for traversal, and for -- insertion of new entries at the end of the list, a list is stored -- using a circular format, as indicated by the following diagram: -- +--------+ +-------+ +-------+ +-------+ -- | List | | 1st | | 2nd | | Last | -- | ------->| -------->| ------>....-->| -------+ -- | Header | | Entry | | Entry | | Entry | | -- +-----|--+ +-------+ +-------+ +-------+ | -- ^ | ^ | -- | | | | -- | + -----------------------------------------+ | -- +--- ------------------------------------------------+ -- The list header is an entry in the Lists table. List_Id values -- are used to reference list headers. -- The First field of the list header contains Empty for a null list, -- or a standard Node_Id value pointing to the first item on the list. -- The Last field of the list header contains Empty for a null list or a -- standard Node_Id value pointing to the last item on the list. -- The nodes within the list use the Link field to hold a normal -- Node_Id value, which points to the next item in the list except for -- the last item in the list, which points to the list head, and is -- negative (i.e. it is a standard List_Id value referencing the containing -- list. This allows a quick check for the end of the list in a list -- traversal (test for negative), and also makes it possible to find the -- list containing any given node (find the end of the list by chasing -- link fields, and then the link field of this node references the list). -- All nodes that are elements of a list have the In_List flag set True. -- All nodes that are not list elements have the In_List flag set False. -- Note that since the Link field of a node is used both for a Parent -- pointer and for a forward link field in a list, that list elements -- cannot have direct parent pointers (and hence cannot be referenced -- directly from a field in another node). However, the list header -- itself does have a parent field. ------------------------------------------------------- -- Internal subprograms for node list implementation -- ------------------------------------------------------- procedure Set_First (List : List_Id; Node : Node_Id); pragma Inline (Set_First); -- Used internally in the implementation of the list routines to set the -- first element of a list to point to a given node. procedure Set_Last (List : List_Id; Node : Node_Id); pragma Inline (Set_Last); -- Used internally in the implementation of the list routines to set the -- last element of a list to point to a given node. function Node_Link (Node : Node_Id) return Node_Id; pragma Inline (Node_Link); -- Used internally in the implementation of the list routines to return -- the contents of the Link field of a specified node as a node. function List_Link (Node : Node_Id) return List_Id; pragma Inline (List_Link); -- Used internally in the implementation of the list routines to return -- the contents of the Link field of a specified node as a list. procedure Set_Node_Link (Node : Node_Id; To : Node_Id); pragma Inline (Set_Node_Link); -- Used internally in the implementation of the list routines to set -- the Link field of a node to point to a given node. procedure Set_List_Link (Node : Node_Id; To : List_Id); pragma Inline (Set_List_Link); -- Used internally in the implementation of the list routines to set -- the Link field of a node to point to a given list. function Is_At_End_Of_List (Node : Node_Id) return Boolean; pragma Inline (Is_At_End_Of_List); -- Used internally in the implementation of the list routines to determine -- if a given node is the last element of a list. False for nodes that are -- not elements of lists. ------------------------------------- -- Implementation of Element Lists -- ------------------------------------- -- Element lists are composed of three types of entities. The element -- list header, which references the first and last elements of the -- list, the elements themselves which are doubly linked and also -- reference the nodes on the list, and finally the nodes themselves. -- The following diagram shows how an element list is represented: -- +----------------------------------------------------+ -- | +------------------------------------------+ | -- | | | | -- V | V | -- +-----|--+ +-------+ +-------+ +-------+ | -- | Elmt | | 1st | | 2nd | | Last | | -- | List |<-->| Elmt |<-->| Elmt <--...-->| Elmt ---+ -- | Header | | | | | | | | | | -- +--------+ +---|---+ +---|---+ +---|---+ -- | | | -- V V V -- +-------+ +-------+ +-------+ -- | | | | | | -- | Node1 | | Node2 | | Node3 | -- | | | | | | -- +-------+ +-------+ +-------+ -- The list header is an entry in the Lists table. The values used for -- the type Elist_Id are subscripts into this table, biased so that -- they have values that are separated from normal List_Id values. The -- First_Elmt field (Lfield1) points to the first element on the list, -- or to No_Elmt in the case of an empty list. Similarly the Last_Elmt -- field (Lfield2) points to the last element on the list, or to No_Elmt -- in the case of an empty list. -- The elements themselves are also entries in the Lists table. Again -- the values for the type Elmt_Id are subscripts into this table, biased -- with a different bias value to separate them from List_Id and Elist_Id -- values. The Prev_Elmt field (Lfield1) points to the previous element, -- or to the list header for the first element of the list. Similarly -- The Next_Elmt field (Lfield2) points to the next element, or to the -- list header for the last element of the list. -- The nodes themselves are simply referenced by the Lnode field of the -- associated element (no values are stored or modified in the node -- itself as a result of putting the node in one or more element lists). ----------------------------------------------------------- -- Internal subprograms for element list implementation -- ----------------------------------------------------------- function L_Id (Id : Elist_Id) return List_Id; function L_Id (Id : Elmt_Id) return List_Id; pragma Inline (L_Id); -- Functions used to convert Elist_Id and Elmt_Id values to a subscript -- in the Lists table (by subtracting the appropriate bias value) procedure Set_First_Elmt (List : Elist_Id; Val : Elmt_Id); pragma Inline (Set_First_Elmt); -- Procedure used to set First_Elmt field of a list element header procedure Set_Last_Elmt (List : Elist_Id; Val : Elmt_Id); pragma Inline (Set_Last_Elmt); -- Procedure used to set Last_Elmt field of a list element header function Is_First_Elmt (Elmt : Elmt_Id) return Boolean; pragma Inline (Is_First_Elmt); -- Function to determine if list element is first element of a list function Is_Last_Elmt (Elmt : Elmt_Id) return Boolean; pragma Inline (Is_Last_Elmt); -- Function to determine if list element is last element of a list function Get_Header_From_First_Elmt (Elmt : Elmt_Id) return Elist_Id; pragma Inline (Get_Header_From_First_Elmt); -- Function to get element list header from first element on list function Get_Header_From_Last_Elmt (Elmt : Elmt_Id) return Elist_Id; pragma Inline (Get_Header_From_Last_Elmt); -- Function to get element list header from last element on list procedure Set_Next_Elmt (Elmt : Elmt_Id; Val : Elmt_Id); procedure Set_Next_Elmt (Elmt : Elmt_Id; Val : Elist_Id); pragma Inline (Set_Next_Elmt); -- Procedures to set contents of Next_Elmt field of list element. -- Two forms needed to deal with normal case and end of list case. procedure Set_Prev_Elmt (Elmt : Elmt_Id; Val : Elmt_Id); procedure Set_Prev_Elmt (Elmt : Elmt_Id; Val : Elist_Id); pragma Inline (Set_Prev_Elmt); -- Procedures to set contents of Prev_Elmt field of list element. -- Two forms needed to deal with normal case and start of list case. procedure Set_Elmt_Links (List : Elist_Id; First_Elmt : Elmt_Id); procedure Set_Elmt_Links (Elmt1 : Elmt_Id; Elmt2 : Elmt_Id); procedure Set_Elmt_Links (Last_Elmt : Elmt_Id; List : Elist_Id); pragma Inline (Set_Elmt_Links); -- These procedures set bidirectional links. There are three versions, -- one for linking the header to the first element on the list, one -- for linking two elements, and the third for linking the last element -- on the list to the header. function New_Elmt (Node : Node_Id) return Elmt_Id; -- Function to create new list element pointing to indicated node. -- The Next_Elmt and Prev_Elmt fields are not initialized. -------------------------- -- Debugging Procedures -- -------------------------- -- These debugging procedures are called only if assertions are enabled procedure Dcheck_Is_Node (N : Node_Id); -- Debug procedure used to check that the given value is the Id of a -- currently allocated node. A compiler abort is signalled if not. procedure Dcheck_Is_Extended_Node (N : Node_Id); -- Debug procedure used to check that the given value is the Id of a -- currently allocated extended node and that the node is an entity -- (since only entities can be extended nodes). A compiler abort is -- signalled if not. procedure Dcheck_Is_List (L : List_Id); -- Debug procedure used to check that the given value is the Id of a -- currently allocated node list header. A compiler abort is signalled -- if not, or if the argument is No_List. procedure Dcheck_Is_Elist (E : Elist_Id); -- Debug procedure used to check that the given value is the Id of a -- currently allocated element list header. A compiler abort is signalled -- if not, or if the argument is No_Elist. procedure Dcheck_List_Member (N : Node_Id); -- Debug procedure used to check that the given node is in a list. -- A compiler abort is signalled if not. procedure Dcheck_Not_List_Member (N : Node_Id); -- Debug procedure used to check that the given node is not in a list. -- A compiler abort is signalled if not. --------------------------------------------- -- Implementation of Tree Rewrite Routines -- --------------------------------------------- -- The tree rewrite insert routines are essentially trivial, so they are -- included in this unit. The replacement routines are more complex and -- are split out into a package subunit. package TS is procedure Initialize_Sub; -- Initialize data structures for tree rewrite substitution processing. -- This procedure is called from Initialize_Tree. procedure Set_Substitute_Tree (Old_Node, New_Node : Node_Id); -- This is the implementation of Rewrite_Substitute_Tree function Get_Substitute_Tree (New_Node : Node_Id) return Node_Id; -- This function implements Original_Node for the case of a node -- that was inserted into the tree using Rewrite_Substitute_Tree. -- It is a fatal error to use it on any other node. end TS; package body TS is separate; -------------------- -- Dcheck_Is_Node -- -------------------- procedure Dcheck_Is_Node (N : Node_Id) is begin if N < Empty or else N > Nodes.Last or else Nodes.Table (N).Is_Extension then Compiler_Error; Write_Eol; Write_String ("Out of range N = "); Write_Int (Int (N)); Write_String (" Nodes.Last = "); Write_Int (Int (Nodes.Last)); Write_Eol; Compiler_Abort; end if; end Dcheck_Is_Node; ----------------------------- -- Dcheck_Is_Extended_Node -- ----------------------------- procedure Dcheck_Is_Extended_Node (N : Node_Id) is begin Dcheck_Is_Node (N); if not Nodes.Table (N + 1).Is_Extension then Compiler_Error; Write_Eol; Write_String ("Node N (Id = "); Write_Int (Int (N)); Write_String (" ) is not extended node"); Write_Eol; Compiler_Abort; elsif Nodes.Table (N).Nkind not in N_Entity then Compiler_Error; Write_Eol; Write_String ("Node N (Id = "); Write_Int (Int (N)); Write_String (" ) is not an entity"); Write_Eol; Compiler_Abort; end if; end Dcheck_Is_Extended_Node; -------------------- -- Dcheck_Is_List -- -------------------- procedure Dcheck_Is_List (L : List_Id) is begin if L > Lists.Last then Compiler_Error; Write_Eol; Write_String ("Out of range L = "); Write_Int (Int (L)); Write_String (" Lists.Last = "); Write_Int (Int (Lists.Last)); Write_Eol; Compiler_Abort; end if; end Dcheck_Is_List; --------------------- -- Dcheck_Is_Elist -- --------------------- procedure Dcheck_Is_Elist (E : Elist_Id) is begin if L_Id (E) > Lists.Last then Compiler_Error; Write_Eol; Write_String ("Out of range E = "); Write_Int (Int (E)); Write_String (" Lists.Last = "); Write_Int (Int (Lists.Last)); Write_Eol; Compiler_Abort; end if; end Dcheck_Is_Elist; ------------------------ -- Dcheck_List_Member -- ------------------------ procedure Dcheck_List_Member (N : Node_Id) is begin Dcheck_Is_Node (N); if not Nodes.Table (N).In_List then Compiler_Error; Write_String ("Node Id = "); Write_Int (Int (N)); Write_String (" is not a list member"); Write_Eol; Compiler_Abort; end if; end Dcheck_List_Member; ---------------------------- -- Dcheck_Not_List_Member -- ---------------------------- procedure Dcheck_Not_List_Member (N : Node_Id) is begin Dcheck_Is_Node (N); if Nodes.Table (N).In_List then Compiler_Error; Write_String ("Node Id = "); Write_Int (Int (N)); Write_String (" is a list member"); Write_Eol; Compiler_Abort; end if; end Dcheck_Not_List_Member; ------------------ -- Last_Node_Id -- ------------------ function Last_Node_Id return Node_Id is begin return Nodes.Last; end Last_Node_Id; ------------------ -- Last_List_Id -- ------------------ function Last_List_Id return List_Id is begin return Lists.Last; end Last_List_Id; ---------------------- -- Initialize_Atree -- ---------------------- procedure Initialize_Atree is Dummy : Node_Id; begin Nodes.Init; Lists.Init; TS.Initialize_Sub; -- Allocate Empty and Error nodes Dummy := New_Node (N_Empty, No_Location); Set_Name1 (Empty, No_Name); Dummy := New_Node (N_Error, No_Location); Set_Name1 (Error, Error_Name); -- Allocate Error_List list header Lists.Increment_Last; Set_Parent (Error_List, Empty); Set_First (Error_List, Empty); Set_Last (Error_List, Empty); end Initialize_Atree; -------------- -- New_Node -- -------------- function New_Node (New_Node_Kind : Node_Kind; New_Sloc : Source_Ptr) return Node_Id is begin Nodes.Increment_Last; Nodes.Table (Nodes.Last) := Default_Node; Nodes.Table (Nodes.Last).Nkind := New_Node_Kind; Nodes.Table (Nodes.Last).Sloc := New_Sloc; if Debug_Flag_N then Write_String ("Allocate new node, Id = "); Write_Int (Int (Nodes.Last)); Write_String (" Nkind = "); Write_String (Node_Kind'Image (New_Node_Kind)); Write_Eol; end if; return Nodes.Last; end New_Node; ----------------- -- Extend_Node -- ----------------- function Extend_Node (Node : Node_Id) return Node_Id is Result : Node_Id; begin if Node /= Nodes.Last then Result := New_Copy (Node); else Result := Node; end if; Nodes.Increment_Last; Nodes.Table (Nodes.Last) := Default_Node_Extension; if Debug_Flag_N then Write_String ("Allocate extension Id = "); Write_Int (Int (Nodes.Last)); Write_Eol; end if; return Result; end Extend_Node; ------------------- -- Has_Extension -- ------------------- function Has_Extension (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Node (N)); return N < Nodes.Last and then Nodes.Table (N + 1).Is_Extension; end Has_Extension; ----------------- -- Change_Node -- ----------------- procedure Change_Node (N : Node_Id; New_Node_Kind : Node_Kind) is Save_Sloc : Source_Ptr := Sloc (N); Save_In_List : Boolean := Nodes.Table (N).In_List; Save_Link : Int := Nodes.Table (N).Link; begin Nodes.Table (N) := Default_Node; Nodes.Table (N).Sloc := Save_Sloc; Nodes.Table (N).In_List := Save_In_List; Nodes.Table (N).Link := Save_Link; Nodes.Table (N).Nkind := New_Node_Kind; end Change_Node; --------------- -- Copy_Node -- --------------- procedure Copy_Node (Source : Node_Id; Destination : Node_Id) is Save_In_List : Boolean; Save_Link : Int; begin pragma Debug (Dcheck_Is_Node (Source)); pragma Debug (Dcheck_Is_Node (Destination)); pragma Assert (Has_Extension (Source) = Has_Extension (Destination), Compiler_Abort); Save_In_List := Nodes.Table (Destination).In_List; Save_Link := Nodes.Table (Destination).Link; Nodes.Table (Destination) := Nodes.Table (Source); Nodes.Table (Destination).In_List := Save_In_List; Nodes.Table (Destination).Link := Save_Link; if Has_Extension (Source) then Nodes.Table (Destination + 1) := Nodes.Table (Source + 1); end if; end Copy_Node; -------------- -- New_Copy -- -------------- function New_Copy (Source : Node_Id) return Node_Id is New_Id : Node_Id; begin pragma Debug (Dcheck_Is_Node (Source)); if Source <= Empty_Or_Error then return Source; else Nodes.Increment_Last; New_Id := Nodes.Last; Nodes.Table (New_Id) := Nodes.Table (Source); Set_Node_Link (New_Id, Empty); Nodes.Table (New_Id).In_List := False; if Has_Extension (Source) then New_Id := Extend_Node (New_Id); Nodes.Table (New_Id + 1) := Nodes.Table (Source + 1); end if; if Is_Rewrite_Substitution (Source) then Nodes.Table (New_Id).Rewrite_Sub := False; end if; return New_Id; end if; end New_Copy; -------------------- -- Exchange_Nodes -- -------------------- procedure Exchange_Nodes (Node1 : Node_Id; Node2 : Node_Id) is N1, N2 : Node_Record; begin pragma Debug (Dcheck_Is_Node (Node1)); pragma Debug (Dcheck_Is_Node (Node2)); pragma Assert (Has_Extension (Node1) = Has_Extension (Node2), Compiler_Abort); N1 := Nodes.Table (Node1); N2 := Nodes.Table (Node2); Nodes.Table (Node1) := N2; Nodes.Table (Node2) := N1; Nodes.Table (Node1).In_List := N1.In_List; Nodes.Table (Node2).In_List := N2.In_List; Nodes.Table (Node1).Link := N1.Link; Nodes.Table (Node2).Link := N2.Link; if Has_Extension (Node1) then N1 := Nodes.Table (Node1 + 1); Nodes.Table (Node1 + 1) := Nodes.Table (Node2 + 1); Nodes.Table (Node2 + 1) := N1; end if; end Exchange_Nodes; -------------- -- New_List -- -------------- function New_List return List_Id is begin Lists.Increment_Last; Set_Parent (Lists.Last, Empty); Set_First (Lists.Last, Empty); Set_Last (Lists.Last, Empty); if Debug_Flag_N then Write_String ("Allocate new list, returned ID = "); Write_Int (Int (Lists.Last)); Write_Eol; end if; return (Lists.Last); end New_List; ---------------- -- New_List_1 -- ---------------- -- Since this is a common case, we optimize to build the right list -- directly, rather than first building an empty list and then doing -- the insertion, which results in some unnecessary work. function New_List_1 (A : Node_Id) return List_Id is begin if A = Error then return New_List; else Lists.Increment_Last; Set_Parent (Lists.Last, Empty); Set_First (Lists.Last, A); Set_Last (Lists.Last, A); Set_List_Link (A, Lists.Last); Nodes.Table (A).In_List := True; end if; if Debug_Flag_N then Write_String ("Allocate new list, returned ID = "); Write_Int (Int (Lists.Last)); Write_Eol; end if; return (Lists.Last); end New_List_1; ---------------- -- New_List_2 -- ---------------- function New_List_2 (A, B : Node_Id) return List_Id is L : constant List_Id := New_List_1 (A); begin Append (B, L); return L; end New_List_2; ---------------- -- New_List_3 -- ---------------- function New_List_3 (A, B, C : Node_Id) return List_Id is L : constant List_Id := New_List_1 (A); begin Append (B, L); Append (C, L); return L; end New_List_3; ---------------- -- New_List_4 -- ---------------- function New_List_4 (A, B, C, D : Node_Id) return List_Id is L : constant List_Id := New_List_1 (A); begin Append (B, L); Append (C, L); Append (D, L); return L; end New_List_4; ---------------- -- New_List_5 -- ---------------- function New_List_5 (A, B, C, D, E : Node_Id) return List_Id is L : constant List_Id := New_List_1 (A); begin Append (B, L); Append (C, L); Append (D, L); Append (E, L); return L; end New_List_5; ---------------- -- New_List_6 -- ---------------- function New_List_6 (A, B, C, D, E, F : Node_Id) return List_Id is L : constant List_Id := New_List_1 (A); begin Append (B, L); Append (C, L); Append (D, L); Append (E, L); Append (F, L); return L; end New_List_6; ---------------- -- New_List_7 -- ---------------- function New_List_7 (A, B, C, D, E, F, G : Node_Id) return List_Id is L : constant List_Id := New_List_1 (A); begin Append (B, L); Append (C, L); Append (D, L); Append (E, L); Append (F, L); Append (G, L); return L; end New_List_7; ---------------- -- New_List_8 -- ---------------- function New_List_8 (A, B, C, D, E, F, G, H : Node_Id) return List_Id is L : constant List_Id := New_List_1 (A); begin Append (B, L); Append (C, L); Append (D, L); Append (E, L); Append (F, L); Append (G, L); Append (H, L); return L; end New_List_8; ---------------- -- New_List_9 -- ---------------- function New_List_9 (A, B, C, D, E, F, G, H, I : Node_Id) return List_Id is L : constant List_Id := New_List_1 (A); begin Append (B, L); Append (C, L); Append (D, L); Append (E, L); Append (F, L); Append (G, L); Append (H, L); Append (I, L); return L; end New_List_9; ------------------- -- New_List_Copy -- ------------------- function New_List_Copy (List : List_Id) return List_Id is NL : List_Id; E : Node_Id; begin if List = No_List then return No_List; else NL := New_List; E := First (List); while Present (E) loop Append (New_Copy (E), NL); E := Next (E); end loop; return NL; end if; end New_List_Copy; ----------- -- First -- ----------- function First (List : List_Id) return Node_Id is begin pragma Debug (Dcheck_Is_List (List)); return Node_Id (Lists.Table (List).Lfield1); end First; --------------- -- Set_First -- --------------- -- Note: for internal use only procedure Set_First (List : List_Id; Node : Node_Id) is begin pragma Debug (Dcheck_Is_List (List)); Lists.Table (List).Lfield1 := Int (Node); end Set_First; ---------- -- Last -- ---------- function Last (List : List_Id) return Node_Id is begin pragma Debug (Dcheck_Is_List (List)); return Node_Id (Lists.Table (List).Lfield2); end Last; -------------- -- Set_Last -- -------------- -- Note: for internal use only procedure Set_Last (List : List_Id; Node : Node_Id) is begin pragma Debug (Dcheck_Is_List (List)); Lists.Table (List).Lfield2 := Int (Node); end Set_Last; --------- -- Nth -- --------- function Nth (List : List_Id; Index : Pos) return Node_Id is Result : Node_Id; Count : Int := 1; begin Result := First (List); while Count < Index and then Result /= Empty loop Result := Next (Result); end loop; return Result; end Nth; ---------- -- Next -- ---------- function Next (Node : Node_Id) return Node_Id is begin pragma Debug (Dcheck_List_Member (Node)); if Is_At_End_Of_List (Node) then return Empty; else return Node_Link (Node); end if; end Next; --------------- -- Node_Link -- --------------- -- Note: for internal use only function Node_Link (Node : Node_Id) return Node_Id is begin pragma Debug (Dcheck_Is_Node (Node)); return Node_Id (Nodes.Table (Node).Link); end Node_Link; --------------- -- List_Link -- --------------- -- Note: for internal use only function List_Link (Node : Node_Id) return List_Id is begin pragma Debug (Dcheck_Is_Node (Node)); return List_Id (Nodes.Table (Node).Link); end List_Link; ------------------- -- Set_Node_Link -- ------------------- -- Note: for internal use only procedure Set_Node_Link (Node : Node_Id; To : Node_Id) is begin pragma Debug (Dcheck_Is_Node (Node)); Nodes.Table (Node).Link := Int (To); end Set_Node_Link; ------------------- -- Set_List_Link -- ------------------- -- Note: for internal use only procedure Set_List_Link (Node : Node_Id; To : List_Id) is begin pragma Debug (Dcheck_Is_Node (Node)); Nodes.Table (Node).Link := Int (To); end Set_List_Link; ----------------------- -- Is_At_End_Of_List -- ----------------------- -- Note: for internal use only function Is_At_End_Of_List (Node : Node_Id) return Boolean is begin return (Nodes.Table (Node).Link in List_Range); end Is_At_End_Of_List; ---------- -- Prev -- ---------- function Prev (Node : Node_Id) return Node_Id is P : Node_Id; begin P := First (List_Containing (Node)); if P = Node then return Empty; else while Node_Link (P) /= Node loop P := Node_Link (P); end loop; return P; end if; end Prev; ------------------- -- Is_Empty_List -- ------------------- function Is_Empty_List (L : List_Id) return Boolean is begin return First (L) = Empty; end Is_Empty_List; ----------------------- -- Is_Non_Empty_List -- ----------------------- function Is_Non_Empty_List (L : List_Id) return Boolean is begin return First (L) /= Empty; end Is_Non_Empty_List; -------------------- -- Is_List_Member -- -------------------- function Is_List_Member (Node : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Node (Node)); return Nodes.Table (Node).In_List; end Is_List_Member; --------------------- -- List_Containing -- --------------------- function List_Containing (Node : Node_Id) return List_Id is N : Node_Id; begin pragma Debug (Dcheck_List_Member (Node)); N := Node; while not Is_At_End_Of_List (N) loop N := Node_Link (N); end loop; return List_Link (N); end List_Containing; ------------ -- Append -- ------------ procedure Append (Node : Node_Id; To : List_Id) is begin pragma Debug (Dcheck_Not_List_Member (Node)); pragma Debug (Dcheck_Is_List (To)); if Node = Error then return; end if; if Debug_Flag_N then Write_String ("Append node "); Write_Int (Int (Node)); Write_String (" to list "); Write_Int (Int (To)); Write_Eol; end if; if Last (To) = Empty then Set_First (To, Node); else Set_Node_Link (Last (To), Node); end if; Set_Last (To, Node); Set_List_Link (Node, To); Nodes.Table (Node).In_List := True; end Append; --------------- -- Append_To -- --------------- procedure Append_To (To : List_Id; Node : Node_Id) is begin Append (Node, To); end Append_To; ----------------- -- Append_List -- ----------------- procedure Append_List (List : List_Id; To : List_Id) is begin pragma Debug (Dcheck_Is_List (List)); pragma Debug (Dcheck_Is_List (To)); if Debug_Flag_N then Write_String ("Append list "); Write_Int (Int (List)); Write_String (" to list "); Write_Int (Int (To)); Write_Eol; end if; if Is_Empty_List (List) then return; else if Is_Empty_List (To) then Set_First (To, First (List)); else Set_Node_Link (Last (To), First (List)); end if; Set_Last (To, Last (List)); Set_List_Link (Last (List), To); Set_Last (List, Empty); Set_First (List, Empty); end if; end Append_List; -------------------- -- Append_List_To -- -------------------- procedure Append_List_To (To : List_Id; List : List_Id) is begin Append_List (List, To); end Append_List_To; ------------------ -- Insert_After -- ------------------ procedure Insert_After (After : Node_Id; Node : Node_Id) is begin pragma Debug (Dcheck_Not_List_Member (Node)); pragma Debug (Dcheck_List_Member (After)); if Node = Error then return; end if; if Debug_Flag_N then Write_String ("Insert node"); Write_Int (Int (Node)); Write_String (" after node "); Write_Int (Int (After)); Write_Eol; end if; if Is_At_End_Of_List (After) then Set_Last (List_Containing (After), Node); Set_List_Link (Node, List_Link (After)); else Set_Node_Link (Node, Node_Link (After)); end if; Set_Node_Link (After, Node); Nodes.Table (Node).In_List := True; end Insert_After; ----------------------- -- Insert_List_After -- ----------------------- procedure Insert_List_After (After : Node_Id; List : List_Id) is begin pragma Debug (Dcheck_Is_List (List)); pragma Debug (Dcheck_List_Member (After)); if Debug_Flag_N then Write_String ("Insert list "); Write_Int (Int (List)); Write_String (" after node "); Write_Int (Int (After)); Write_Eol; end if; if Is_Empty_List (List) then return; else if Is_At_End_Of_List (After) then Set_Last (List_Containing (After), Last (List)); Set_List_Link (Last (List), List_Link (After)); else Set_Node_Link (Last (List), Node_Link (After)); end if; Set_Node_Link (After, First (List)); Set_First (List, Empty); Set_Last (List, Empty); end if; end Insert_List_After; ------------------- -- Insert_Before -- ------------------- procedure Insert_Before (Before : Node_Id; Node : Node_Id) is L : List_Id; N : Node_Id; begin pragma Debug (Dcheck_Not_List_Member (Node)); pragma Debug (Dcheck_List_Member (Before)); if Node = Error then return; end if; if Debug_Flag_N then Write_String ("Insert node"); Write_Int (Int (Node)); Write_String (" before node "); Write_Int (Int (Before)); Write_Eol; end if; L := List_Containing (Before); if First (L) = Before then Set_First (L, Node); else N := First (L); while Node_Link (N) /= Before loop N := Node_Link (N); end loop; Set_Node_Link (N, Node); end if; Set_Node_Link (Node, Before); Nodes.Table (Node).In_List := True; end Insert_Before; ------------------------ -- Insert_List_Before -- ------------------------ procedure Insert_List_Before (Before : Node_Id; List : List_Id) is L : List_Id; N : Node_Id; begin pragma Debug (Dcheck_Is_List (List)); pragma Debug (Dcheck_List_Member (Before)); if Debug_Flag_N then Write_String ("Insert list "); Write_Int (Int (List)); Write_String (" before node "); Write_Int (Int (Before)); Write_Eol; end if; if Is_Empty_List (List) then return; else L := List_Containing (Before); if First (L) = Before then Set_First (L, First (List)); else N := First (L); while Node_Link (N) /= Before loop N := Node_Link (N); end loop; Set_Node_Link (N, First (List)); end if; Set_Node_Link (Last (List), Before); end if; end Insert_List_Before; ------------- -- Prepend -- ------------- procedure Prepend (Node : Node_Id; To : List_Id) is begin if Is_Empty_List (To) then Append (Node, To); else Insert_Before (First (To), Node); end if; end Prepend; ---------------- -- Prepend_To -- ---------------- procedure Prepend_To (To : List_Id; Node : Node_Id) is begin Prepend (Node, To); end Prepend_To; ------------ -- Remove -- ------------ procedure Remove (Node : Node_Id) is L : List_Id; N : Node_Id; begin L := List_Containing (Node); if Debug_Flag_N then Write_String ("Remove node "); Write_Int (Int (Node)); Write_Eol; end if; if First (L) = Node then if Is_At_End_Of_List (Node) then Set_Last (L, Empty); Set_First (L, Empty); else Set_First (L, Node_Link (Node)); end if; else N := First (L); while Node_Link (N) /= Node loop N := Node_Link (N); end loop; if Is_At_End_Of_List (Node) then Set_Last (L, N); Set_List_Link (N, List_Link (Node)); else Set_Node_Link (N, Node_Link (Node)); end if; end if; Set_Node_Link (Node, Empty); Nodes.Table (Node).In_List := False; end Remove; ----------------- -- Remove_Head -- ----------------- function Remove_Head (List : List_Id) return Node_Id is N : Node_Id; begin pragma Debug (Dcheck_Is_List (List)); if Debug_Flag_N then Write_String ("Remove head of list "); Write_Int (Int (List)); Write_Eol; end if; N := First (List); if N = Empty then return Empty; else if Is_At_End_Of_List (N) then Set_Last (List, Empty); Set_First (List, Empty); else Set_First (List, Node_Link (N)); end if; Set_Node_Link (N, Empty); Nodes.Table (N).In_List := False; return N; end if; end Remove_Head; ----------------- -- Remove_Next -- ----------------- function Remove_Next (Node : Node_Id) return Node_Id is Nxt : Node_Id; begin Nxt := Next (Node); if Nxt /= Empty then Nodes.Table (Node).Link := Nodes.Table (Nxt).Link; Set_Node_Link (Nxt, Empty); Nodes.Table (Nxt).In_List := False; end if; return Nxt; end Remove_Next; ----------------- -- Delete_Node -- ----------------- procedure Delete_Node (Node : Node_Id) is begin if Is_List_Member (Node) then Remove (Node); end if; if Debug_Flag_N then Write_String ("Delete node "); Write_Int (Int (Node)); Write_Eol; end if; Nodes.Table (Node) := Default_Node; Nodes.Table (Node).Nkind := N_Unused_At_Start; -- Note: for now, we are not bothering to reuse deleted nodes end Delete_Node; ---------- -- L_Id -- ---------- function L_Id (Id : Elist_Id) return List_Id is begin return List_Id (Int (Id) - Elist_Bias); end L_Id; function L_Id (Id : Elmt_Id) return List_Id is begin return List_Id (Int (Id) - Elmt_Bias); end L_Id; ----------- -- Id_Of -- ----------- function Id_Of (Elmt : Elmt_Id) return Node_Id is begin return Lists.Table (L_Id (Elmt)).Lnode; end Id_Of; ------------------- -- New_Elmt_List -- ------------------- function New_Elmt_List return Elist_Id is E : Elist_Id; begin Lists.Increment_Last; E := Elist_Id (Lists.Last + Elist_Bias); Set_Parent (E, Empty); Set_First_Elmt (E, No_Elmt); Set_Last_Elmt (E, No_Elmt); if Debug_Flag_N then Write_String ("Allocate new element list, returned ID = "); Write_Int (Int (E)); Write_Eol; end if; return E; end New_Elmt_List; ------------------------ -- New_Elmt_List_Copy -- ------------------------ function New_Elmt_List_Copy (List : Elist_Id) return Elist_Id is NL : Elist_Id := New_Elmt_List; E : Elmt_Id := First_Elmt (List); begin if List = No_Elist then return No_Elist; else NL := New_Elmt_List; E := First_Elmt (List); while E /= No_Elmt loop Append_Elmt (New_Copy (Id_Of (E)), NL); E := Next_Elmt (E); end loop; return NL; end if; end New_Elmt_List_Copy; ---------------- -- First_Elmt -- ---------------- function First_Elmt (List : Elist_Id) return Elmt_Id is begin return Elmt_Id (Lists.Table (L_Id (List)).Lfield1); end First_Elmt; -------------------- -- Set_First_Elmt -- -------------------- procedure Set_First_Elmt (List : Elist_Id; Val : Elmt_Id) is begin Lists.Table (L_Id (List)).Lfield1 := Int (Val); end Set_First_Elmt; ------------------- -- Is_First_Elmt -- ------------------- function Is_First_Elmt (Elmt : Elmt_Id) return Boolean is begin return Lists.Table (L_Id (Elmt)).Lfield1 in Elist_Range; end Is_First_Elmt; -------------------------------- -- Get_Header_From_First_Elmt -- -------------------------------- function Get_Header_From_First_Elmt (Elmt : Elmt_Id) return Elist_Id is begin return Elist_Id (Lists.Table (L_Id (Elmt)).Lfield1); end Get_Header_From_First_Elmt; --------------- -- Last_Elmt -- --------------- function Last_Elmt (List : Elist_Id) return Elmt_Id is begin return Elmt_Id (Lists.Table (L_Id (List)).Lfield2); end Last_Elmt; ------------------- -- Set_Last_Elmt -- ------------------- procedure Set_Last_Elmt (List : Elist_Id; Val : Elmt_Id) is begin Lists.Table (L_Id (List)).Lfield2 := Int (Val); end Set_Last_Elmt; ------------------- -- Is_Last_Elmt -- ------------------- function Is_Last_Elmt (Elmt : Elmt_Id) return Boolean is begin return Lists.Table (L_Id (Elmt)).Lfield2 in Elist_Range; end Is_Last_Elmt; ------------------------------- -- Get_Header_From_Last_Elmt -- ------------------------------- function Get_Header_From_Last_Elmt (Elmt : Elmt_Id) return Elist_Id is begin return Elist_Id (Lists.Table (L_Id (Elmt)).Lfield2); end Get_Header_From_Last_Elmt; -------------- -- Nth_Elmt -- -------------- function Nth_Elmt (List : Elist_Id; Index : Pos) return Elmt_Id is Result : Elmt_Id; Count : Int := 1; begin Result := First_Elmt (List); while Count < Index and then Result /= No_Elmt loop Result := Next_Elmt (Result); end loop; return Result; end Nth_Elmt; --------------- -- Next_Elmt -- --------------- function Next_Elmt (Elmt : Elmt_Id) return Elmt_Id is begin if Is_Last_Elmt (Elmt) then return No_Elmt; else return Elmt_Id (Lists.Table (L_Id (Elmt)).Lfield2); end if; end Next_Elmt; ------------------- -- Set_Next_Elmt -- ------------------- procedure Set_Next_Elmt (Elmt : Elmt_Id; Val : Elmt_Id) is begin Lists.Table (L_Id (Elmt)).Lfield2 := Int (Val); end Set_Next_Elmt; procedure Set_Next_Elmt (Elmt : Elmt_Id; Val : Elist_Id) is begin Lists.Table (L_Id (Elmt)).Lfield2 := Int (Val); end Set_Next_Elmt; --------------- -- Prev_Elmt -- --------------- function Prev_Elmt (Elmt : Elmt_Id) return Elmt_Id is begin if Is_First_Elmt (Elmt) then return No_Elmt; else return Elmt_Id (Lists.Table (L_Id (Elmt)).Lfield1); end if; end Prev_Elmt; ------------------- -- Set_Prev_Elmt -- ------------------- procedure Set_Prev_Elmt (Elmt : Elmt_Id; Val : Elmt_Id) is begin Lists.Table (L_Id (Elmt)).Lfield1 := Int (Val); end Set_Prev_Elmt; procedure Set_Prev_Elmt (Elmt : Elmt_Id; Val : Elist_Id) is begin Lists.Table (L_Id (Elmt)).Lfield1 := Int (Val); end Set_Prev_Elmt; -------------------- -- Set_Elmt_Links -- -------------------- procedure Set_Elmt_Links (List : Elist_Id; First_Elmt : Elmt_Id) is begin Set_First_Elmt (List, First_Elmt); Set_Prev_Elmt (First_Elmt, List); end Set_Elmt_Links; procedure Set_Elmt_Links (Elmt1 : Elmt_Id; Elmt2 : Elmt_Id) is begin Set_Next_Elmt (Elmt1, Elmt2); Set_Prev_Elmt (Elmt2, Elmt1); end Set_Elmt_Links; procedure Set_Elmt_Links (Last_Elmt : Elmt_Id; List : Elist_Id) is begin Set_Next_Elmt (Last_Elmt, List); Set_Last_Elmt (List, Last_Elmt); end Set_Elmt_Links; ------------------------ -- Is_Empty_Elmt_List -- ------------------------ function Is_Empty_Elmt_List (L : Elist_Id) return Boolean is begin return First_Elmt (L) = No_Elmt; end Is_Empty_Elmt_List; ---------------------------- -- Is_Non_Empty_Elmt_List -- ---------------------------- function Is_Non_Empty_Elmt_List (L : Elist_Id) return Boolean is begin return First_Elmt (L) /= No_Elmt; end Is_Non_Empty_Elmt_List; -------------- -- New_Elmt -- -------------- function New_Elmt (Node : Node_Id) return Elmt_Id is begin Lists.Increment_Last; Lists.Table (Lists.Last).Lnode := Node; return Elmt_Id (Lists.Last + Elmt_Bias); end New_Elmt; ----------------- -- Append_Elmt -- ----------------- procedure Append_Elmt (Node : Node_Id; To : Elist_Id) is E : Elmt_Id; begin E := New_Elmt (Node); if Is_Empty_Elmt_List (To) then Set_Elmt_Links (To, E); else Set_Elmt_Links (Last_Elmt (To), E); end if; Set_Elmt_Links (E, To); end Append_Elmt; ---------------------- -- Append_Elmt_List -- ---------------------- procedure Append_Elmt_List (List : Elist_Id; To : Elist_Id) is begin if Is_Empty_Elmt_List (List) then return; else if Is_Empty_Elmt_List (To) then Set_Elmt_Links (To, First_Elmt (List)); Set_Elmt_Links (Last_Elmt (List), To); else Set_Elmt_Links (Last_Elmt (To), First_Elmt (List)); Set_Elmt_Links (Last_Elmt (List), To); end if; Set_First_Elmt (List, No_Elmt); Set_Last_Elmt (List, No_Elmt); end if; end Append_Elmt_List; ----------------------- -- Insert_Elmt_After -- ----------------------- procedure Insert_Elmt_After (After : Elmt_Id; Node : Node_Id) is E : Elmt_Id; begin E := New_Elmt (Node); if Is_Last_Elmt (After) then Set_Elmt_Links (E, Get_Header_From_Last_Elmt (After)); else Set_Elmt_Links (E, Next_Elmt (After)); end if; Set_Elmt_Links (After, E); end Insert_Elmt_After; ---------------------------- -- Insert_Elmt_List_After -- ---------------------------- procedure Insert_Elmt_List_After (After : Elmt_Id; List : Elist_Id) is begin if Is_Empty_Elmt_List (List) then return; else if Is_Last_Elmt (After) then Set_Elmt_Links (Last_Elmt (List), Get_Header_From_Last_Elmt (After)); else Set_Elmt_Links (Last_Elmt (List), Next_Elmt (After)); end if; Set_Elmt_Links (After, First_Elmt (List)); Set_First_Elmt (List, No_Elmt); Set_Last_Elmt (List, No_Elmt); end if; end Insert_Elmt_List_After; ------------------------ -- Insert_Elmt_Before -- ------------------------ procedure Insert_Elmt_Before (Before : Elmt_Id; Node : Node_Id) is E : Elmt_Id; begin E := New_Elmt (Node); if Is_First_Elmt (Before) then Set_Elmt_Links (Get_Header_From_First_Elmt (Before), E); else Set_Elmt_Links (Prev_Elmt (Before), E); end if; Set_Elmt_Links (E, Before); end Insert_Elmt_Before; ----------------------------- -- Insert_Elmt_List_Before -- ----------------------------- procedure Insert_Elmt_List_Before (Before : Elmt_Id; List : Elist_Id) is begin if Is_Empty_Elmt_List (List) then return; else if Is_First_Elmt (Before) then Set_Elmt_Links (Get_Header_From_First_Elmt (Before), First_Elmt (List)); else Set_Elmt_Links (Prev_Elmt (Before), First_Elmt (List)); end if; Set_Elmt_Links (Last_Elmt (List), Before); Set_First_Elmt (List, No_Elmt); Set_Last_Elmt (List, No_Elmt); end if; end Insert_Elmt_List_Before; ----------------- -- Remove_Elmt -- ----------------- procedure Remove_Elmt (Elmt : Elmt_Id) is L : Elist_Id; begin if Is_Last_Elmt (Elmt) then L := Get_Header_From_Last_Elmt (Elmt); if Is_First_Elmt (Elmt) then Set_First_Elmt (L, No_Elmt); Set_Last_Elmt (L, No_Elmt); else Set_Elmt_Links (Prev_Elmt (Elmt), L); end if; elsif Is_First_Elmt (Elmt) then L := Get_Header_From_First_Elmt (Elmt); Set_Elmt_Links (L, Next_Elmt (Elmt)); else Set_Elmt_Links (Prev_Elmt (Elmt), Next_Elmt (Elmt)); end if; end Remove_Elmt; ---------------------- -- Remove_Next_Elmt -- ---------------------- function Remove_Next_Elmt (Elmt : Elmt_Id) return Node_Id is Nxt : Elmt_Id; begin Nxt := Next_Elmt (Elmt); if Nxt = No_Elmt then return Empty; else Lists.Table (L_Id (Elmt)).Lfield2 := Lists.Table (L_Id (Nxt)).Lfield2; return Id_Of (Nxt); end if; end Remove_Next_Elmt; ---------------------- -- Remove_Head_Elmt -- ---------------------- function Remove_Head_Elmt (List : Elist_Id) return Node_Id is N : Node_Id; begin if Is_Empty_Elmt_List (List) then return Empty; else N := Id_Of (First_Elmt (List)); Set_Elmt_Links (List, Next_Elmt (First_Elmt (List))); end if; end Remove_Head_Elmt; ---------------------------------- -- Basic Field Access Functions -- ---------------------------------- function Nkind (N : Node_Id) return Node_Kind is begin pragma Debug (Dcheck_Is_Node (N)); return Nodes.Table (N).Nkind; end Nkind; function Ekind (N : Node_Id) return Entity_Kind is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return N_To_E (Nodes.Table (N + 1).Nkind); end Ekind; function Sloc (N : Node_Id) return Source_Ptr is begin pragma Debug (Dcheck_Is_Node (N)); return Nodes.Table (N).Sloc; end Sloc; function Parent (N : Node_Id) return Node_Id is begin pragma Debug (Dcheck_Is_Node (N)); if Is_List_Member (N) then return List_Parent (List_Containing (N)); else return Node_Id (Nodes.Table (N).Link); end if; end Parent; function List_Parent (L : List_Id) return Node_Id is begin Dcheck_Is_List (L); return Lists.Table (L).Lnode; end List_Parent; function Elist_Parent (E : Elist_Id) return Node_Id is begin Dcheck_Is_Elist (E); return Lists.Table (L_Id (E)).Lnode; end Elist_Parent; -------- -- No -- -------- function No (N : Node_Id) return Boolean is begin return N = Empty; end No; ------------- -- Present -- ------------- function Present (N : Node_Id) return Boolean is begin return N /= Empty; end Present; ------------------ -- List_Present -- ------------------ function List_Present (L : List_Id) return Boolean is begin return L /= No_List; end List_Present; -------------------------- -- Field Set Procedures -- -------------------------- procedure Set_Ekind (N : Node_Id; Val : Entity_Kind) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Nkind := E_To_N (Val); end Set_Ekind; procedure Set_Sloc (N : Node_Id; Val : Source_Ptr) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Sloc := Val; end Set_Sloc; procedure Set_Parent (N : Node_Id; Val : Node_Id) is begin pragma Debug (Dcheck_Is_Node (N)); pragma Debug (Dcheck_Not_List_Member (N)); Nodes.Table (N).Link := Int (Val); end Set_Parent; procedure Set_Parent (L : List_Id; Val : Node_Id) is begin pragma Debug (Dcheck_Is_List (L)); Lists.Table (L).Lnode := Val; end Set_Parent; procedure Set_Parent (E : Elist_Id; Val : Node_Id) is begin pragma Debug (Dcheck_Is_Elist (E)); Lists.Table (L_Id (E)).Lnode := Val; end Set_Parent; ---------------------------- -- Mark_Rewrite_Insertion -- ---------------------------- procedure Mark_Rewrite_Insertion (New_Node : Node_Id) is begin Nodes.Table (New_Node).Rewrite_Ins := True; end Mark_Rewrite_Insertion; -------------------------- -- Is_Rewrite_Insertion -- -------------------------- function Is_Rewrite_Insertion (Node : Node_Id) return Boolean is begin return Nodes.Table (Node).Rewrite_Ins; end Is_Rewrite_Insertion; ----------------------------- -- Rewrite_Substitute_Tree -- ----------------------------- procedure Rewrite_Substitute_Tree (Old_Node, New_Node : Node_Id) is begin TS.Set_Substitute_Tree (Old_Node, New_Node); end Rewrite_Substitute_Tree; ----------------------------- -- Is_Rewrite_Substitution -- ----------------------------- function Is_Rewrite_Substitution (Node : Node_Id) return Boolean is begin return Nodes.Table (Node).Rewrite_Sub; end Is_Rewrite_Substitution; ------------------- -- Original_Node -- ------------------- function Original_Node (Node : Node_Id) return Node_Id is begin if Nodes.Table (Node).Rewrite_Ins then return Empty; elsif Nodes.Table (Node).Rewrite_Sub then return TS.Get_Substitute_Tree (Node); else return Node; end if; end Original_Node; ------------------------------ -- Unchecked Access Package -- ------------------------------ package body Unchecked_Access is function Field1 (N : Node_Id) return Int is begin pragma Debug (Dcheck_Is_Node (N)); return Nodes.Table (N).Field1; end Field1; function Field2 (N : Node_Id) return Int is begin pragma Debug (Dcheck_Is_Node (N)); return Nodes.Table (N).Field2; end Field2; function Field3 (N : Node_Id) return Int is begin pragma Debug (Dcheck_Is_Node (N)); return Nodes.Table (N).Field3; end Field3; function Field4 (N : Node_Id) return Int is begin pragma Debug (Dcheck_Is_Node (N)); return Nodes.Table (N).Field4; end Field4; function Field5 (N : Node_Id) return Int is begin pragma Debug (Dcheck_Is_Node (N)); return Nodes.Table (N).Field5; end Field5; function Field6 (N : Node_Id) return Int is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Nodes.Table (N + 1).Field6; end Field6; function Field7 (N : Node_Id) return Int is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Nodes.Table (N + 1).Field7; end Field7; function Field8 (N : Node_Id) return Int is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Nodes.Table (N + 1).Field8; end Field8; function Field9 (N : Node_Id) return Int is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Nodes.Table (N + 1).Field9; end Field9; function Field10 (N : Node_Id) return Int is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Nodes.Table (N + 1).Field10; end Field10; function Field11 (N : Node_Id) return Int is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Nodes.Table (N + 1).Field11; end Field11; function Field12 (N : Node_Id) return Int is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Nodes.Table (N + 1).Field12; end Field12; function Node1 (N : Node_Id) return Node_Id is begin pragma Debug (Dcheck_Is_Node (N)); return Node_Id (Nodes.Table (N).Field1); end Node1; function Node2 (N : Node_Id) return Node_Id is begin pragma Debug (Dcheck_Is_Node (N)); return Node_Id (Nodes.Table (N).Field2); end Node2; function Node3 (N : Node_Id) return Node_Id is begin pragma Debug (Dcheck_Is_Node (N)); return Node_Id (Nodes.Table (N).Field3); end Node3; function Node4 (N : Node_Id) return Node_Id is begin pragma Debug (Dcheck_Is_Node (N)); return Node_Id (Nodes.Table (N).Field4); end Node4; function Node5 (N : Node_Id) return Node_Id is begin pragma Debug (Dcheck_Is_Node (N)); return Node_Id (Nodes.Table (N).Field5); end Node5; function Node6 (N : Node_Id) return Node_Id is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Node_Id (Nodes.Table (N + 1).Field6); end Node6; function Node7 (N : Node_Id) return Node_Id is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Node_Id (Nodes.Table (N + 1).Field7); end Node7; function Node8 (N : Node_Id) return Node_Id is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Node_Id (Nodes.Table (N + 1).Field8); end Node8; function Node9 (N : Node_Id) return Node_Id is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Node_Id (Nodes.Table (N + 1).Field9); end Node9; function Node10 (N : Node_Id) return Node_Id is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Node_Id (Nodes.Table (N + 1).Field10); end Node10; function Node11 (N : Node_Id) return Node_Id is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Node_Id (Nodes.Table (N + 1).Field11); end Node11; function Node12 (N : Node_Id) return Node_Id is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Node_Id (Nodes.Table (N + 1).Field12); end Node12; function List1 (N : Node_Id) return List_Id is begin pragma Debug (Dcheck_Is_Node (N)); return List_Id (Nodes.Table (N).Field1); end List1; function List2 (N : Node_Id) return List_Id is begin pragma Debug (Dcheck_Is_Node (N)); return List_Id (Nodes.Table (N).Field2); end List2; function List3 (N : Node_Id) return List_Id is begin pragma Debug (Dcheck_Is_Node (N)); return List_Id (Nodes.Table (N).Field3); end List3; function List4 (N : Node_Id) return List_Id is begin pragma Debug (Dcheck_Is_Node (N)); return List_Id (Nodes.Table (N).Field4); end List4; function List5 (N : Node_Id) return List_Id is begin pragma Debug (Dcheck_Is_Node (N)); return List_Id (Nodes.Table (N).Field5); end List5; function List6 (N : Node_Id) return List_Id is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return List_Id (Nodes.Table (N + 1).Field6); end List6; function List7 (N : Node_Id) return List_Id is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return List_Id (Nodes.Table (N + 1).Field7); end List7; function List8 (N : Node_Id) return List_Id is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return List_Id (Nodes.Table (N + 1).Field8); end List8; function List9 (N : Node_Id) return List_Id is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return List_Id (Nodes.Table (N + 1).Field9); end List9; function List10 (N : Node_Id) return List_Id is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return List_Id (Nodes.Table (N + 1).Field10); end List10; function List11 (N : Node_Id) return List_Id is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return List_Id (Nodes.Table (N + 1).Field11); end List11; function List12 (N : Node_Id) return List_Id is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return List_Id (Nodes.Table (N + 1).Field12); end List12; function Elist1 (N : Node_Id) return Elist_Id is begin pragma Debug (Dcheck_Is_Node (N)); return Elist_Id (Nodes.Table (N).Field1); end Elist1; function Elist2 (N : Node_Id) return Elist_Id is begin pragma Debug (Dcheck_Is_Node (N)); return Elist_Id (Nodes.Table (N).Field2); end Elist2; function Elist3 (N : Node_Id) return Elist_Id is begin pragma Debug (Dcheck_Is_Node (N)); return Elist_Id (Nodes.Table (N).Field3); end Elist3; function Elist4 (N : Node_Id) return Elist_Id is begin pragma Debug (Dcheck_Is_Node (N)); return Elist_Id (Nodes.Table (N).Field4); end Elist4; function Elist5 (N : Node_Id) return Elist_Id is begin pragma Debug (Dcheck_Is_Node (N)); return Elist_Id (Nodes.Table (N).Field5); end Elist5; function Elist6 (N : Node_Id) return Elist_Id is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Elist_Id (Nodes.Table (N + 1).Field6); end Elist6; function Elist7 (N : Node_Id) return Elist_Id is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Elist_Id (Nodes.Table (N + 1).Field7); end Elist7; function Elist8 (N : Node_Id) return Elist_Id is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Elist_Id (Nodes.Table (N + 1).Field8); end Elist8; function Elist9 (N : Node_Id) return Elist_Id is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Elist_Id (Nodes.Table (N + 1).Field9); end Elist9; function Elist10 (N : Node_Id) return Elist_Id is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Elist_Id (Nodes.Table (N + 1).Field10); end Elist10; function Elist11 (N : Node_Id) return Elist_Id is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Elist_Id (Nodes.Table (N + 1).Field11); end Elist11; function Elist12 (N : Node_Id) return Elist_Id is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Elist_Id (Nodes.Table (N + 1).Field12); end Elist12; function Name1 (N : Node_Id) return Name_Id is begin pragma Debug (Dcheck_Is_Node (N)); return Name_Id (Nodes.Table (N).Field1); end Name1; function Name2 (N : Node_Id) return Name_Id is begin pragma Debug (Dcheck_Is_Node (N)); return Name_Id (Nodes.Table (N).Field2); end Name2; function Name3 (N : Node_Id) return Name_Id is begin pragma Debug (Dcheck_Is_Node (N)); return Name_Id (Nodes.Table (N).Field3); end Name3; function Name4 (N : Node_Id) return Name_Id is begin pragma Debug (Dcheck_Is_Node (N)); return Name_Id (Nodes.Table (N).Field4); end Name4; function Name5 (N : Node_Id) return Name_Id is begin pragma Debug (Dcheck_Is_Node (N)); return Name_Id (Nodes.Table (N).Field5); end Name5; function Str1 (N : Node_Id) return String_Id is begin pragma Debug (Dcheck_Is_Node (N)); return String_Id (Nodes.Table (N).Field1); end Str1; function Str2 (N : Node_Id) return String_Id is begin pragma Debug (Dcheck_Is_Node (N)); return String_Id (Nodes.Table (N).Field2); end Str2; function Str3 (N : Node_Id) return String_Id is begin pragma Debug (Dcheck_Is_Node (N)); return String_Id (Nodes.Table (N).Field3); end Str3; function Str4 (N : Node_Id) return String_Id is begin pragma Debug (Dcheck_Is_Node (N)); return String_Id (Nodes.Table (N).Field4); end Str4; function Str5 (N : Node_Id) return String_Id is begin pragma Debug (Dcheck_Is_Node (N)); return String_Id (Nodes.Table (N).Field5); end Str5; function Char_Code1 (N : Node_Id) return Char_Code is begin pragma Debug (Dcheck_Is_Node (N)); return Char_Code (Nodes.Table (N).Field1 - Char_Code_Bias); end Char_Code1; function Char_Code2 (N : Node_Id) return Char_Code is begin pragma Debug (Dcheck_Is_Node (N)); return Char_Code (Nodes.Table (N).Field2 - Char_Code_Bias); end Char_Code2; function Char_Code3 (N : Node_Id) return Char_Code is begin pragma Debug (Dcheck_Is_Node (N)); return Char_Code (Nodes.Table (N).Field3 - Char_Code_Bias); end Char_Code3; function Char_Code4 (N : Node_Id) return Char_Code is begin pragma Debug (Dcheck_Is_Node (N)); return Char_Code (Nodes.Table (N).Field4 - Char_Code_Bias); end Char_Code4; function Char_Code5 (N : Node_Id) return Char_Code is begin pragma Debug (Dcheck_Is_Node (N)); return Char_Code (Nodes.Table (N).Field5 - Char_Code_Bias); end Char_Code5; function Uint1 (N : Node_Id) return Uint is begin pragma Debug (Dcheck_Is_Node (N)); return Uint (Nodes.Table (N).Field1); end Uint1; function Uint2 (N : Node_Id) return Uint is begin pragma Debug (Dcheck_Is_Node (N)); return Uint (Nodes.Table (N).Field2); end Uint2; function Uint3 (N : Node_Id) return Uint is begin pragma Debug (Dcheck_Is_Node (N)); return Uint (Nodes.Table (N).Field3); end Uint3; function Uint4 (N : Node_Id) return Uint is begin pragma Debug (Dcheck_Is_Node (N)); return Uint (Nodes.Table (N).Field4); end Uint4; function Uint5 (N : Node_Id) return Uint is begin pragma Debug (Dcheck_Is_Node (N)); return Uint (Nodes.Table (N).Field5); end Uint5; function Uint6 (N : Node_Id) return Uint is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Uint (Nodes.Table (N + 1).Field6); end Uint6; function Uint7 (N : Node_Id) return Uint is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Uint (Nodes.Table (N + 1).Field7); end Uint7; function Uint8 (N : Node_Id) return Uint is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Uint (Nodes.Table (N + 1).Field8); end Uint8; function Uint9 (N : Node_Id) return Uint is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Uint (Nodes.Table (N + 1).Field9); end Uint9; function Uint10 (N : Node_Id) return Uint is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Uint (Nodes.Table (N + 1).Field10); end Uint10; function Uint11 (N : Node_Id) return Uint is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Uint (Nodes.Table (N + 1).Field11); end Uint11; function Uint12 (N : Node_Id) return Uint is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Uint (Nodes.Table (N + 1).Field12); end Uint12; function Flag1 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Node (N)); return Nodes.Table (N).Flag1; end Flag1; function Flag2 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Node (N)); return Nodes.Table (N).Flag2; end Flag2; function Flag3 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Node (N)); return Nodes.Table (N).Flag3; end Flag3; function Flag4 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Node (N)); return Nodes.Table (N).Flag4; end Flag4; function Flag5 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Node (N)); return Nodes.Table (N).Flag5; end Flag5; function Flag6 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Node (N)); return Nodes.Table (N).Flag6; end Flag6; function Flag7 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Node (N)); return Nodes.Table (N).Flag7; end Flag7; function Flag8 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Node (N)); return Nodes.Table (N).Flag8; end Flag8; function Flag9 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Node (N)); return Nodes.Table (N).Flag9; end Flag9; function Flag10 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Node (N)); return Nodes.Table (N).Flag10; end Flag10; function Flag11 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Node (N)); return Nodes.Table (N).Flag11; end Flag11; function Flag12 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Node (N)); return Nodes.Table (N).Flag12; end Flag12; function Flag13 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Node (N)); return Nodes.Table (N).Flag13; end Flag13; function Flag14 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Node (N)); return Nodes.Table (N).Flag14; end Flag14; function Flag15 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Node (N)); return Nodes.Table (N).Flag15; end Flag15; function Flag16 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Node (N)); return Nodes.Table (N).Flag16; end Flag16; function Flag17 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Node (N)); return Nodes.Table (N).Flag17; end Flag17; function Flag18 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Node (N)); return Nodes.Table (N).Flag18; end Flag18; function Flag19 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Node (N)); return Nodes.Table (N).Flag19; end Flag19; function Flag20 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Node (N)); return Nodes.Table (N).Flag20; end Flag20; function Flag21 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Nodes.Table (N + 1).In_List; end Flag21; function Flag22 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Nodes.Table (N + 1).Rewrite_Sub; end Flag22; function Flag23 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Nodes.Table (N + 1).Rewrite_Ins; end Flag23; function Flag24 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Nodes.Table (N + 1).Flag1; end Flag24; function Flag25 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Nodes.Table (N + 1).Flag2; end Flag25; function Flag26 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Nodes.Table (N + 1).Flag3; end Flag26; function Flag27 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Nodes.Table (N + 1).Flag4; end Flag27; function Flag28 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Nodes.Table (N + 1).Flag5; end Flag28; function Flag29 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Nodes.Table (N + 1).Flag6; end Flag29; function Flag30 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Nodes.Table (N + 1).Flag7; end Flag30; function Flag31 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Nodes.Table (N + 1).Flag8; end Flag31; function Flag32 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Nodes.Table (N + 1).Flag9; end Flag32; function Flag33 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Nodes.Table (N + 1).Flag10; end Flag33; function Flag34 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Nodes.Table (N + 1).Flag11; end Flag34; function Flag35 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Nodes.Table (N + 1).Flag12; end Flag35; function Flag36 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Nodes.Table (N + 1).Flag13; end Flag36; function Flag37 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Nodes.Table (N + 1).Flag14; end Flag37; function Flag38 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Nodes.Table (N + 1).Flag15; end Flag38; function Flag39 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Nodes.Table (N + 1).Flag16; end Flag39; function Flag40 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Nodes.Table (N + 1).Flag17; end Flag40; function Flag41 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Nodes.Table (N + 1).Flag18; end Flag41; function Flag42 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Nodes.Table (N + 1).Flag19; end Flag42; function Flag43 (N : Node_Id) return Boolean is begin pragma Debug (Dcheck_Is_Extended_Node (N)); return Nodes.Table (N + 1).Flag20; end Flag43; procedure Set_Nkind (N : Node_Id; Val : Node_Kind) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Nkind := Val; end Set_Nkind; procedure Set_Field1 (N : Node_Id; Val : Int) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field1 := Val; end Set_Field1; procedure Set_Field2 (N : Node_Id; Val : Int) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field2 := Val; end Set_Field2; procedure Set_Field3 (N : Node_Id; Val : Int) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field3 := Val; end Set_Field3; procedure Set_Field4 (N : Node_Id; Val : Int) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field4 := Val; end Set_Field4; procedure Set_Field5 (N : Node_Id; Val : Int) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field5 := Val; end Set_Field5; procedure Set_Field6 (N : Node_Id; Val : Int) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field6 := Val; end Set_Field6; procedure Set_Field7 (N : Node_Id; Val : Int) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field7 := Val; end Set_Field7; procedure Set_Field8 (N : Node_Id; Val : Int) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field8 := Val; end Set_Field8; procedure Set_Field9 (N : Node_Id; Val : Int) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field9 := Val; end Set_Field9; procedure Set_Field10 (N : Node_Id; Val : Int) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field10 := Val; end Set_Field10; procedure Set_Field11 (N : Node_Id; Val : Int) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field11 := Val; end Set_Field11; procedure Set_Field12 (N : Node_Id; Val : Int) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field12 := Val; end Set_Field12; procedure Set_Node1 (N : Node_Id; Val : Node_Id) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field1 := Int (Val); end Set_Node1; procedure Set_Node2 (N : Node_Id; Val : Node_Id) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field2 := Int (Val); end Set_Node2; procedure Set_Node3 (N : Node_Id; Val : Node_Id) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field3 := Int (Val); end Set_Node3; procedure Set_Node4 (N : Node_Id; Val : Node_Id) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field4 := Int (Val); end Set_Node4; procedure Set_Node5 (N : Node_Id; Val : Node_Id) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field5 := Int (Val); end Set_Node5; procedure Set_Node6 (N : Node_Id; Val : Node_Id) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field6 := Int (Val); end Set_Node6; procedure Set_Node7 (N : Node_Id; Val : Node_Id) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field7 := Int (Val); end Set_Node7; procedure Set_Node8 (N : Node_Id; Val : Node_Id) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field8 := Int (Val); end Set_Node8; procedure Set_Node9 (N : Node_Id; Val : Node_Id) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field9 := Int (Val); end Set_Node9; procedure Set_Node10 (N : Node_Id; Val : Node_Id) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field10 := Int (Val); end Set_Node10; procedure Set_Node11 (N : Node_Id; Val : Node_Id) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field11 := Int (Val); end Set_Node11; procedure Set_Node12 (N : Node_Id; Val : Node_Id) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field12 := Int (Val); end Set_Node12; procedure Set_List1 (N : Node_Id; Val : List_Id) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field1 := Int (Val); end Set_List1; procedure Set_List2 (N : Node_Id; Val : List_Id) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field2 := Int (Val); end Set_List2; procedure Set_List3 (N : Node_Id; Val : List_Id) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field3 := Int (Val); end Set_List3; procedure Set_List4 (N : Node_Id; Val : List_Id) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field4 := Int (Val); end Set_List4; procedure Set_List5 (N : Node_Id; Val : List_Id) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field5 := Int (Val); end Set_List5; procedure Set_List6 (N : Node_Id; Val : List_Id) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field6 := Int (Val); end Set_List6; procedure Set_List7 (N : Node_Id; Val : List_Id) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field7 := Int (Val); end Set_List7; procedure Set_List8 (N : Node_Id; Val : List_Id) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field8 := Int (Val); end Set_List8; procedure Set_List9 (N : Node_Id; Val : List_Id) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field9 := Int (Val); end Set_List9; procedure Set_List10 (N : Node_Id; Val : List_Id) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field10 := Int (Val); end Set_List10; procedure Set_List11 (N : Node_Id; Val : List_Id) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field11 := Int (Val); end Set_List11; procedure Set_List12 (N : Node_Id; Val : List_Id) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field12 := Int (Val); end Set_List12; procedure Set_Elist1 (N : Node_Id; Val : Elist_Id) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field1 := Int (Val); end Set_Elist1; procedure Set_Elist2 (N : Node_Id; Val : Elist_Id) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field2 := Int (Val); end Set_Elist2; procedure Set_Elist3 (N : Node_Id; Val : Elist_Id) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field3 := Int (Val); end Set_Elist3; procedure Set_Elist4 (N : Node_Id; Val : Elist_Id) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field4 := Int (Val); end Set_Elist4; procedure Set_Elist5 (N : Node_Id; Val : Elist_Id) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field5 := Int (Val); end Set_Elist5; procedure Set_Elist6 (N : Node_Id; Val : Elist_Id) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field6 := Int (Val); end Set_Elist6; procedure Set_Elist7 (N : Node_Id; Val : Elist_Id) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field7 := Int (Val); end Set_Elist7; procedure Set_Elist8 (N : Node_Id; Val : Elist_Id) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field8 := Int (Val); end Set_Elist8; procedure Set_Elist9 (N : Node_Id; Val : Elist_Id) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field9 := Int (Val); end Set_Elist9; procedure Set_Elist10 (N : Node_Id; Val : Elist_Id) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field10 := Int (Val); end Set_Elist10; procedure Set_Elist11 (N : Node_Id; Val : Elist_Id) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field11 := Int (Val); end Set_Elist11; procedure Set_Elist12 (N : Node_Id; Val : Elist_Id) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field12 := Int (Val); end Set_Elist12; procedure Set_Name1 (N : Node_Id; Val : Name_Id) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field1 := Int (Val); end Set_Name1; procedure Set_Name2 (N : Node_Id; Val : Name_Id) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field2 := Int (Val); end Set_Name2; procedure Set_Name3 (N : Node_Id; Val : Name_Id) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field3 := Int (Val); end Set_Name3; procedure Set_Name4 (N : Node_Id; Val : Name_Id) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field4 := Int (Val); end Set_Name4; procedure Set_Name5 (N : Node_Id; Val : Name_Id) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field5 := Int (Val); end Set_Name5; procedure Set_Str1 (N : Node_Id; Val : String_Id) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field1 := Int (Val); end Set_Str1; procedure Set_Str2 (N : Node_Id; Val : String_Id) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field2 := Int (Val); end Set_Str2; procedure Set_Str3 (N : Node_Id; Val : String_Id) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field3 := Int (Val); end Set_Str3; procedure Set_Str4 (N : Node_Id; Val : String_Id) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field4 := Int (Val); end Set_Str4; procedure Set_Str5 (N : Node_Id; Val : String_Id) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field5 := Int (Val); end Set_Str5; procedure Set_Uint1 (N : Node_Id; Val : Uint) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field1 := Int (Val); end Set_Uint1; procedure Set_Uint2 (N : Node_Id; Val : Uint) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field2 := Int (Val); end Set_Uint2; procedure Set_Uint3 (N : Node_Id; Val : Uint) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field3 := Int (Val); end Set_Uint3; procedure Set_Uint4 (N : Node_Id; Val : Uint) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field4 := Int (Val); end Set_Uint4; procedure Set_Uint5 (N : Node_Id; Val : Uint) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field5 := Int (Val); end Set_Uint5; procedure Set_Uint6 (N : Node_Id; Val : Uint) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field6 := Int (Val); end Set_Uint6; procedure Set_Uint7 (N : Node_Id; Val : Uint) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field7 := Int (Val); end Set_Uint7; procedure Set_Uint8 (N : Node_Id; Val : Uint) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field8 := Int (Val); end Set_Uint8; procedure Set_Uint9 (N : Node_Id; Val : Uint) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field9 := Int (Val); end Set_Uint9; procedure Set_Uint10 (N : Node_Id; Val : Uint) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field10 := Int (Val); end Set_Uint10; procedure Set_Uint11 (N : Node_Id; Val : Uint) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field11 := Int (Val); end Set_Uint11; procedure Set_Uint12 (N : Node_Id; Val : Uint) is begin pragma Debug (Dcheck_Is_Extended_Node (N)); Nodes.Table (N + 1).Field12 := Int (Val); end Set_Uint12; procedure Set_Char_Code1 (N : Node_Id; Val : Char_Code) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field1 := Int (Val) + Char_Code_Bias; end Set_Char_Code1; procedure Set_Char_Code2 (N : Node_Id; Val : Char_Code) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field2 := Int (Val) + Char_Code_Bias; end Set_Char_Code2; procedure Set_Char_Code3 (N : Node_Id; Val : Char_Code) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field3 := Int (Val) + Char_Code_Bias; end Set_Char_Code3; procedure Set_Char_Code4 (N : Node_Id; Val : Char_Code) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field4 := Int (Val) + Char_Code_Bias; end Set_Char_Code4; procedure Set_Char_Code5 (N : Node_Id; Val : Char_Code) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Field5 := Int (Val) + Char_Code_Bias; end Set_Char_Code5; procedure Set_Flag1 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Flag1 := Val; end Set_Flag1; procedure Set_Flag2 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Flag2 := Val; end Set_Flag2; procedure Set_Flag3 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Flag3 := Val; end Set_Flag3; procedure Set_Flag4 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Flag4 := Val; end Set_Flag4; procedure Set_Flag5 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Flag5 := Val; end Set_Flag5; procedure Set_Flag6 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Flag6 := Val; end Set_Flag6; procedure Set_Flag7 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Flag7 := Val; end Set_Flag7; procedure Set_Flag8 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Flag8 := Val; end Set_Flag8; procedure Set_Flag9 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Flag9 := Val; end Set_Flag9; procedure Set_Flag10 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Flag10 := Val; end Set_Flag10; procedure Set_Flag11 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Flag11 := Val; end Set_Flag11; procedure Set_Flag12 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Flag12 := Val; end Set_Flag12; procedure Set_Flag13 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Flag13 := Val; end Set_Flag13; procedure Set_Flag14 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Flag14 := Val; end Set_Flag14; procedure Set_Flag15 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Flag15 := Val; end Set_Flag15; procedure Set_Flag16 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Flag16 := Val; end Set_Flag16; procedure Set_Flag17 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Flag17 := Val; end Set_Flag17; procedure Set_Flag18 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Flag18 := Val; end Set_Flag18; procedure Set_Flag19 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Flag19 := Val; end Set_Flag19; procedure Set_Flag20 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N).Flag20 := Val; end Set_Flag20; procedure Set_Flag21 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N + 1).In_List := Val; end Set_Flag21; procedure Set_Flag22 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N + 1).Rewrite_Sub := Val; end Set_Flag22; procedure Set_Flag23 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N + 1).Rewrite_Ins := Val; end Set_Flag23; procedure Set_Flag24 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N + 1).Flag1 := Val; end Set_Flag24; procedure Set_Flag25 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N + 1).Flag2 := Val; end Set_Flag25; procedure Set_Flag26 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N + 1).Flag3 := Val; end Set_Flag26; procedure Set_Flag27 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N + 1).Flag4 := Val; end Set_Flag27; procedure Set_Flag28 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N + 1).Flag5 := Val; end Set_Flag28; procedure Set_Flag29 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N + 1).Flag6 := Val; end Set_Flag29; procedure Set_Flag30 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N + 1).Flag7 := Val; end Set_Flag30; procedure Set_Flag31 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N + 1).Flag8 := Val; end Set_Flag31; procedure Set_Flag32 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N + 1).Flag9 := Val; end Set_Flag32; procedure Set_Flag33 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N + 1).Flag10 := Val; end Set_Flag33; procedure Set_Flag34 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N + 1).Flag11 := Val; end Set_Flag34; procedure Set_Flag35 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N + 1).Flag12 := Val; end Set_Flag35; procedure Set_Flag36 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N + 1).Flag13 := Val; end Set_Flag36; procedure Set_Flag37 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N + 1).Flag14 := Val; end Set_Flag37; procedure Set_Flag38 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N + 1).Flag15 := Val; end Set_Flag38; procedure Set_Flag39 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N + 1).Flag16 := Val; end Set_Flag39; procedure Set_Flag40 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N + 1).Flag17 := Val; end Set_Flag40; procedure Set_Flag41 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N + 1).Flag18 := Val; end Set_Flag41; procedure Set_Flag42 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N + 1).Flag19 := Val; end Set_Flag42; procedure Set_Flag43 (N : Node_Id; Val : Boolean) is begin pragma Debug (Dcheck_Is_Node (N)); Nodes.Table (N + 1).Flag20 := Val; end Set_Flag43; procedure Set_Node1_With_Parent (N : Node_Id; Val : Node_Id) is begin if Val > Error then Set_Parent (Val, N); end if; Set_Node1 (N, Val); end Set_Node1_With_Parent; procedure Set_Node2_With_Parent (N : Node_Id; Val : Node_Id) is begin if Val > Error then Set_Parent (Val, N); end if; Set_Node2 (N, Val); end Set_Node2_With_Parent; procedure Set_Node3_With_Parent (N : Node_Id; Val : Node_Id) is begin if Val > Error then Set_Parent (Val, N); end if; Set_Node3 (N, Val); end Set_Node3_With_Parent; procedure Set_Node4_With_Parent (N : Node_Id; Val : Node_Id) is begin if Val > Error then Set_Parent (Val, N); end if; Set_Node4 (N, Val); end Set_Node4_With_Parent; procedure Set_Node5_With_Parent (N : Node_Id; Val : Node_Id) is begin if Val > Error then Set_Parent (Val, N); end if; Set_Node5 (N, Val); end Set_Node5_With_Parent; procedure Set_Node6_With_Parent (N : Node_Id; Val : Node_Id) is begin if Val > Error then Set_Parent (Val, N); end if; Set_Node6 (N, Val); end Set_Node6_With_Parent; procedure Set_Node7_With_Parent (N : Node_Id; Val : Node_Id) is begin if Val > Error then Set_Parent (Val, N); end if; Set_Node7 (N, Val); end Set_Node7_With_Parent; procedure Set_Node8_With_Parent (N : Node_Id; Val : Node_Id) is begin if Val > Error then Set_Parent (Val, N); end if; Set_Node8 (N, Val); end Set_Node8_With_Parent; procedure Set_Node9_With_Parent (N : Node_Id; Val : Node_Id) is begin if Val > Error then Set_Parent (Val, N); end if; Set_Node9 (N, Val); end Set_Node9_With_Parent; procedure Set_Node10_With_Parent (N : Node_Id; Val : Node_Id) is begin if Val > Error then Set_Parent (Val, N); end if; Set_Node10 (N, Val); end Set_Node10_With_Parent; procedure Set_Node11_With_Parent (N : Node_Id; Val : Node_Id) is begin if Val > Error then Set_Parent (Val, N); end if; Set_Node11 (N, Val); end Set_Node11_With_Parent; procedure Set_Node12_With_Parent (N : Node_Id; Val : Node_Id) is begin if Val > Error then Set_Parent (Val, N); end if; Set_Node12 (N, Val); end Set_Node12_With_Parent; procedure Set_List1_With_Parent (N : Node_Id; Val : List_Id) is begin if Val /= No_List and then Val /= Error_List then Set_Parent (Val, N); end if; Set_List1 (N, Val); end Set_List1_With_Parent; procedure Set_List2_With_Parent (N : Node_Id; Val : List_Id) is begin if Val /= No_List and then Val /= Error_List then Set_Parent (Val, N); end if; Set_List2 (N, Val); end Set_List2_With_Parent; procedure Set_List3_With_Parent (N : Node_Id; Val : List_Id) is begin if Val /= No_List and then Val /= Error_List then Set_Parent (Val, N); end if; Set_List3 (N, Val); end Set_List3_With_Parent; procedure Set_List4_With_Parent (N : Node_Id; Val : List_Id) is begin if Val /= No_List and then Val /= Error_List then Set_Parent (Val, N); end if; Set_List4 (N, Val); end Set_List4_With_Parent; procedure Set_List5_With_Parent (N : Node_Id; Val : List_Id) is begin if Val /= No_List and then Val /= Error_List then Set_Parent (Val, N); end if; Set_List5 (N, Val); end Set_List5_With_Parent; procedure Set_List6_With_Parent (N : Node_Id; Val : List_Id) is begin if Val /= No_List and then Val /= Error_List then Set_Parent (Val, N); end if; Set_List6 (N, Val); end Set_List6_With_Parent; procedure Set_List7_With_Parent (N : Node_Id; Val : List_Id) is begin if Val /= No_List and then Val /= Error_List then Set_Parent (Val, N); end if; Set_List7 (N, Val); end Set_List7_With_Parent; procedure Set_List8_With_Parent (N : Node_Id; Val : List_Id) is begin if Val /= No_List and then Val /= Error_List then Set_Parent (Val, N); end if; Set_List8 (N, Val); end Set_List8_With_Parent; procedure Set_List9_With_Parent (N : Node_Id; Val : List_Id) is begin if Val /= No_List and then Val /= Error_List then Set_Parent (Val, N); end if; Set_List9 (N, Val); end Set_List9_With_Parent; procedure Set_List10_With_Parent (N : Node_Id; Val : List_Id) is begin if Val /= No_List and then Val /= Error_List then Set_Parent (Val, N); end if; Set_List10 (N, Val); end Set_List10_With_Parent; procedure Set_List11_With_Parent (N : Node_Id; Val : List_Id) is begin if Val /= No_List and then Val /= Error_List then Set_Parent (Val, N); end if; Set_List11 (N, Val); end Set_List11_With_Parent; procedure Set_List12_With_Parent (N : Node_Id; Val : List_Id) is begin if Val /= No_List and then Val /= Error_List then Set_Parent (Val, N); end if; Set_List12 (N, Val); end Set_List12_With_Parent; end Unchecked_Access; end Atree; pragma Debug (Dcheck_Is_Node (N)); gnat-1.67-src/src/back_end.ads 444 10015 7640 3506 5506244276 11346 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- B A C K _ E N D -- -- -- -- S p e c -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Call the Back-end procedure Back_End; r-ch11.adb и par-ch12.adbag1è¸Ã par-ch13.adb ü¸Ä par-ch2.adb¸Å par-ch3.adb$¸Æ par-ch4.adb8¸Ç par-ch5.adbL¸È par-ch6.gnat-1.67-src/src/back_end.adb 444 10015 7640 13334 5506244276 11345 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- B A C K _ E N D -- -- -- -- B o d y -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Call the back end with all the information needed with Lib; use Lib; with Namet; use Namet; with Stringt; use Stringt; with System; use System; with Atree; use Atree; with Types; use Types; with Uintp; use Uintp; procedure Back_End is use Namet_Private_Part; use Atree_Private_Part; use Stringt_Private_Part; use Uintp_Private_Part; -- We need to see the internal data structures to get the table addresses -- and lengths for the Back_End call. function Count_Files return Int is Count : Int := 0; begin for I in File.First .. File.Last loop if File.Table (I).Source /= null then Count := Count + 1; end if; end loop; return Count; end Count_Files; begin declare Counter : Int; Number_Units : Int := Count_Files; -- The File_Record type has a lot of components that are meaningless -- to the back end, so a new record is created here to contain the -- needed information for each file. type Needed_File_Info_Type is record File_Name : File_Name_Type; First_Sloc : Source_Ptr; Last_Sloc : Source_Ptr; Last_Line : Line_Number_Type; end record; for Needed_File_Info_Type use record File_Name at 00 range 0 .. 31; First_Sloc at 04 range 0 .. 31; Last_Sloc at 08 range 0 .. 31; Last_Line at 12 range 0 .. 31; end record; -- Create one record of the above type and one Lines Table pointer for -- each unit. type File_Info_Array_Type is array (Int range 1 .. Number_Units) of Needed_File_Info_Type; type Lines_Ptr_Array_Type is array (Int range 1 .. Number_Units) of Address; File_Info_Array : File_Info_Array_Type; Lines_Ptr_Array : Lines_Ptr_Array_Type; procedure Gigi ( Gnu_Root : Int; Max_Gnat_Nodes : Int; Number_Names : Int; Nodes_Ptr : Address; Names_Ptr : Address; Strings_Ptr : Address; String_Chars_Ptr : Address; List_Headers_Ptr : Address; Name_Chars_Ptr : Address; Uints_Ptr : Address; Udigits_Ptr : Address; Number_Units : Int; File_Info_Ptr : Address; Lines_Ptrs : Address); pragma Interface (C, Gigi); pragma Interface_Name (Gigi, "gigi"); begin Counter := 0; for I in File.First .. File.Last loop if File.Table (I).Source /= null then Counter := Counter + 1; File_Info_Array (Counter).File_Name := File.Table (I).File_Name; File_Info_Array (Counter).First_Sloc := File.Table (I).Source'First; File_Info_Array (Counter).Last_Sloc := File.Table (I).Source'Last; File_Info_Array (Counter).Last_Line := File.Table (I).Last_Line; Lines_Ptr_Array (Counter) := File.Table (I).Lines_Table.all'Address; end if; end loop; Gigi ( Gnu_Root => Int (File.Table (Main_Unit).Cunit), Max_Gnat_Nodes => Int (Nodes.Last - Nodes.First + 1), Number_Names => Int (Name_Entries.Last - Name_Entries.First + 1), Nodes_Ptr => Nodes.Table (Nodes.First)'Address, Names_Ptr => Name_Entries.Table (Name_Entries.First)'Address, Strings_Ptr => Strings.Table (Strings.First)'Address, String_Chars_Ptr => String_Chars.Table (String_Chars.First)'Address, List_Headers_Ptr => Lists.Table (Lists.First)'Address, Name_Chars_Ptr => Name_Chars.Table (Name_Chars.First)'Address, Uints_Ptr => Uints.Table (Uints.First)'Address, Udigits_Ptr => Udigits.Table (Udigits.First)'Address, Number_Units => Number_Units, File_Info_Ptr => File_Info_Array'Address, Lines_Ptrs => Lines_Ptr_Array'Address); end; end Back_End; -- needed information for each file. type Needed_File_Info_Type is record File_Name : File_Name_Type; First_Sloc : Source_Ptr; Last_Sloc : Source_Ptr; Last_Line : Line_Number_Type; end record; for Needed_File_Info_Type use recorgnat-1.67-src/src/casing.ads 444 10015 7640 6175 5506244276 11071 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- C A S I N G -- -- -- -- S p e c -- -- -- -- $Revision: 1.4 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ package Casing is -- This package contains data and subprograms to support the feature that -- recognizes the letter case styles used in the source program being -- compiled, and uses this information for error message formatting, and -- for recognizing reserved words that are misused as identifiers. ------------------------------- -- Case Control Declarations -- ------------------------------- type Casing_Type is (All_Upper_Case, All_Lower_Case, Mixed_Case, Unknown); -- This type is used to describe the casing style for identifiers/keywords ------------------------------ -- Case Control Subprograms -- ------------------------------ function Determine_Token_Casing return Casing_Type; -- Determines the casing style of the current token, which is either a -- keyword or an identifier. For identifiers, the result may be Unknown -- (for example, the identifiers X, Y_3, M4, and A_B do not sufficiently -- distinguish between All_Upper_Case and Mixed_Case). This subprogram -- can be called only during parsing. procedure Set_Casing (C : Casing_Type; D : Casing_Type := Mixed_Case); -- Takes the name stored in the first Name_Len positions of Name_Buffer -- and modifies it to be consistent with the casing given by C, -- or, if C = Unknown, then with the casing given by D. end Casing; h9.adb `¸ø sem_eval.adsnar x¸ù sem_eval.adb152 ¸ú sem_prag.adsdef ¨¸û sem_prag.adbed_ À¸ü sem_util.ads54, Ô¸ý sem_res.adb è¸þ sem_res.ads ¸ÿ sem_util.adb,n_ ¹ sem_disp.adsmen 0¹ sem_disp.adb9,n H¹ sem_type.adsion `¹ sem_type.adbant t¹ sinfo.adsat ˆ¹ sinfo.adb:1 ¤gnat-1.67-src/src/casing.adb 444 10015 7640 11637 5506244277 11070 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- C A S E -- -- -- -- B o d y -- -- -- -- $Revision: 1.5 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Csets; use Csets; with Namet; use Namet; with Scans; use Scans; with Types; use Types; package body Casing is ---------------------------- -- Determine_Token_Casing -- ---------------------------- function Determine_Token_Casing return Casing_Type is All_Lower : Boolean := True; -- Set False if upper case letter found All_Upper : Boolean := True; -- Set False if lower case letter found Decisive : Boolean := False; -- Set True if at least one instance of letter not after underline After_Und : Boolean := True; -- True at start of string, and after an underline character begin for S in Token_Ptr .. Scan_Ptr - 1 loop if Source (S) = '_' or else Source (S) = '.' then After_Und := True; elsif Is_Lower_Case_Letter (Source (S)) then All_Upper := False; if not After_Und then Decisive := True; else After_Und := False; end if; elsif Is_Upper_Case_Letter (Source (S)) then All_Lower := False; if not After_Und then Decisive := True; else After_Und := False; end if; end if; end loop; -- Now we can figure out the result from the flags we set in that loop if All_Lower then return All_Lower_Case; elsif not Decisive then return Unknown; elsif All_Upper then return All_Upper_Case; else return Mixed_Case; end if; end Determine_Token_Casing; ---------------- -- Set_Casing -- ---------------- procedure Set_Casing (C : Casing_Type; D : Casing_Type := Mixed_Case) is Actual_Casing : Casing_Type; -- Set from C or D as appropriate After_Und : Boolean := True; -- True at start of string, and after an underline character. Note that -- for the puroses of mixed case mode, we treat < and period the same -- way as underline (deals with special names like Any_Type, and also -- with unit names which have embedded periods). begin if C /= Unknown then Actual_Casing := C; else Actual_Casing := D; end if; for I in 1 .. Name_Len loop if Name_Buffer (I) = '_' or else Name_Buffer (I) = '.' or else Name_Buffer (I) = '-' or else Name_Buffer (I) = '<' then After_Und := True; elsif Is_Lower_Case_Letter (Name_Buffer (I)) then if Actual_Casing = All_Upper_Case or else (After_Und and then Actual_Casing = Mixed_Case) then Name_Buffer (I) := Fold_Upper (Name_Buffer (I)); end if; After_Und := False; elsif Is_Upper_Case_Letter (Name_Buffer (I)) then if Actual_Casing = All_Lower_Case or else (not After_Und and then Actual_Casing = Mixed_Case) then Name_Buffer (I) := Fold_Lower (Name_Buffer (I)); end if; After_Und := False; end if; end loop; end Set_Casing; end Casing; rsion.adbnchà¹6(unchecked_deallocation.adsh¹7 unixlib.ads$¹8(uncheckegnat-1.67-src/src/comperr.adb 444 10015 7640 11020 5506244277 11255 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- C O M P E R R -- -- -- -- B o d y -- -- -- -- $Revision: 1.7 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This package contains routines called when a fatal internal compiler -- error is detected. Calls to these routines cause termination of the -- current compilation with appropriate error output. pragma Ada_9X; with Debug; use Debug; with Errcount; use Errcount; with Excep; use Excep; with Osint; use Osint; with Output; use Output; with System.Traceback; use System.Traceback; with Treepr; use Treepr; package body Comperr is -------------------- -- Compiler_Abort -- -------------------- procedure Compiler_Abort is begin -- Case of errors have been detected. In this case, we guess that the -- abort is caused by previous errors, and we don't make too much fuss -- about it, since we want to let the programmer fix the errors first. -- This treatment is disabled by debug flag -dk so that we can force -- a traceback when we are trying to get rid of cascaded bombs! if not Debug_Flag_K and then Errors_Detected /= 0 then raise Unrecoverable_Error; -- Otherwise we have a real abort. First generate software traceback -- if we are doing software tracebacks. Then do a system level abort. else if Tracebacks_Stored then Output_Traceback; -- We exit softly if we generated a software traceback, to be -- sure that buffers get flushed etc. The assumption is that -- we would not be doing a software traceback if the abort -- gave useful information! Exit_Program (E_Errors); else Exit_Program (E_Abort); end if; end if; end Compiler_Abort; procedure Compiler_Abort (N : Node_Id) is begin Compiler_Error; Print_Tree_Node (N); Compiler_Abort; end Compiler_Abort; -------------------- -- Compiler_Error -- -------------------- procedure Compiler_Error is begin -- Case of errors have been detected. In this case, we guess that the -- abort is caused by previous errors, and we don't make too much fuss -- about it, since we want to let the programmer fix the errors first. -- This treatment is disabled by debug flag -dk so that we can force -- a traceback when we are trying to get rid of cascaded bombs! if not Debug_Flag_K and then Errors_Detected /= 0 then raise Unrecoverable_Error; -- Otherwise we have a real abort. In the case of Compiler_Error, as -- opposed to Compiler_Abort, we return to the caller to generate -- additional diagnostic information (which will go to standard error) else Set_Standard_Error; return; end if; end Compiler_Error; end Comperr; e COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This package contains routines called when a fatal internal compiler -- error is detected. Calls to these routines cause termination of the -- current compilation with appropriate error output. pragma Ada_9X; with Debug; gnat-1.67-src/src/comperr.ads 444 10015 7640 5641 5506244277 11272 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- C O M P E R R -- -- -- -- S p e c -- -- -- -- $Revision: 1.3 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This package contains routines called when a fatal internal compiler -- error is detected. Calls to these routines cause termination of the -- current compilation with appropriate error output. with Types; use Types; package Comperr is procedure Compiler_Abort; -- Signals a compiler error unconditionally. Never returns control. Used -- in a case where the traceback alone is sufficient diagnostic information -- in the case where an error traceback is generated. procedure Compiler_Abort (N : Node_Id); -- This routine first calls Compiler_Error, then prints the given tree -- node, uising Print_Tree_Node, and then calls Compiler_Abort with no -- parameter to signal the compiler error. procedure Compiler_Error; -- Signals a compiler error unconditionally. Returns control if a traceback -- is to be generated. Used in a case where the traceback is to be preceded -- by additional information. The protocol is to call Compiler_Error, then -- generate the additional information required, then call Compiler_Abort. -- The additional information will always go to Standard_Error. end Comperr; em_ch6.adb ä¸ò sem_ch7.ads ø¸ó sem_ch7.adb ¸ô sem_ch8.ads ¸õ gnat-1.67-src/src/csets.ads 444 10015 7640 10077 5506244300 10746 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- C S E T S -- -- -- -- S p e c -- -- -- -- $Revision: 1.6 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Csets is -- This package contains character tables for the various character -- sets that are supported for source representation. Character and -- string literals are not affected, only identifiers. For each set, -- the table in this package gives the mapping of letters to their -- upper case equivalent. Each table thus provides the information -- for building the table used to fold lower case to upper case, and -- also the table of flags showing which characters are allowed in -- identifiers. type Translate_Table is array (Char) of Char; -- Type used to describe translate tables type Char_Array_Flags is array (Char) of Boolean; -- Type used for character attribute arrays ----------------------------------------------- -- Character Tables For Current Compilation -- ----------------------------------------------- procedure Initialize_Char_Tables; -- Routine to initialize following character tables, whose content depends -- on the character code being used to represent the source program. In -- particular, the use of the upper half of the 8-bit code set varies. -- The character set in use is specified by the value stored in -- Options.Character_Set, which has the following settings: -- '1' Latin-1 -- '2' Latin-2 -- '3' Latin-3 -- '4' Latin-4 -- 'p' PC -- 'f' Full upper set (all distinct) -- 'n' No upper characters (Ada/83 rules) function Is_Upper_Case_Letter (C : Char) return Boolean; pragma Inline (Is_Upper_Case_Letter); -- Determine if character is upper case letter function Is_Lower_Case_Letter (C : Char) return Boolean; pragma Inline (Is_Lower_Case_Letter); -- Determine if character is lower case letter Fold_Upper : Translate_Table; -- Table to fold lower case identifier letters to upper case Fold_Lower : Translate_Table; -- Table to fold upper case identifier letters to lower case Letter_Or_Digit : Char_Array_Flags; -- Test if character is either a digit or upper- or lower-case letter. Identifier_Char : Char_Array_Flags; -- This table is identical to Letter_Or_Digit, except that the entry for -- underscore is also set True, so that it includes all identifier chars. end Csets; k¸Ñ par-tchk.adbýô0¸Ò par-util.adb@¸Ópar.adbT¸Ô rtsfind.adsh¸Õ rtsfind.adbˆ¸Ö$system-traceback.adbH¨¸×$system-traceback.ads¼¸Ø scans.adsÿèи٠scans.adbÿàà¸Úscn.adsø¸Û scn-nlit.adbÿÿØ ¸Ü scn-slit.adb ¸Ýscn.adb 0¸Þsem.ads @¸ßsem.adb X¸à sem_attr.ads p¸á sem_attr.adb i ˆ¸â gnat-1.67-src/src/csets.adb 444 10015 7640 52673 5506244300 10735 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- C S E T S -- -- -- -- B o d y -- -- -- -- $Revision: 1.8 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Opt; use Opt; package body Csets is ----------------------------- -- Definitions for Latin-1 -- ----------------------------- Fold_Latin_1 : Translate_Table := Translate_Table'( 'a' => 'A', X_E0 => X_C0, X_F0 => X_D0, 'b' => 'B', X_E1 => X_C1, X_F1 => X_D1, 'c' => 'C', X_E2 => X_C2, X_F2 => X_D2, 'd' => 'D', X_E3 => X_C3, X_F3 => X_D3, 'e' => 'E', X_E4 => X_C4, X_F4 => X_D4, 'f' => 'F', X_E5 => X_C5, X_F5 => X_D5, 'g' => 'G', X_E6 => X_C6, X_F6 => X_D6, 'h' => 'H', X_E7 => X_C7, 'i' => 'I', X_E8 => X_C8, X_F8 => X_D8, 'j' => 'J', X_E9 => X_C9, X_F9 => X_D9, 'k' => 'K', X_EA => X_CA, X_FA => X_DA, 'l' => 'L', X_EB => X_CB, X_FB => X_DB, 'm' => 'M', X_EC => X_CC, X_FC => X_DC, 'n' => 'N', X_ED => X_CD, X_FD => X_DD, 'o' => 'O', X_EE => X_CE, X_FE => X_DE, 'p' => 'P', X_EF => X_CF, 'q' => 'Q', 'r' => 'R', 's' => 'S', 't' => 'T', 'u' => 'U', 'v' => 'V', 'w' => 'W', 'x' => 'X', 'y' => 'Y', 'z' => 'Z', 'A' => 'A', X_C0 => X_C0, X_D0 => X_D0, 'B' => 'B', X_C1 => X_C1, X_D1 => X_D1, 'C' => 'C', X_C2 => X_C2, X_D2 => X_D2, 'D' => 'D', X_C3 => X_C3, X_D3 => X_D3, 'E' => 'E', X_C4 => X_C4, X_D4 => X_D4, 'F' => 'F', X_C5 => X_C5, X_D5 => X_D5, 'G' => 'G', X_C6 => X_C6, X_D6 => X_D6, 'H' => 'H', X_C7 => X_C7, 'I' => 'I', X_C8 => X_C8, X_D8 => X_D8, 'J' => 'J', X_C9 => X_C9, X_D9 => X_D9, 'K' => 'K', X_CA => X_CA, X_DA => X_DA, 'L' => 'L', X_CB => X_CB, X_DB => X_DB, 'M' => 'M', X_CC => X_CC, X_DC => X_DC, 'N' => 'N', X_CD => X_CD, X_DD => X_DD, 'O' => 'O', X_CE => X_CE, X_DE => X_DE, 'P' => 'P', X_CF => X_CF, X_DF => X_DF, X_FF => X_FF, 'Q' => 'Q', 'R' => 'R', 'S' => 'S', 'T' => 'T', 'U' => 'U', 'V' => 'V', 'W' => 'W', 'X' => 'X', 'Y' => 'Y', 'Z' => 'Z', '0' => '0', '1' => '1', '2' => '2', '3' => '3', '4' => '4', '5' => '5', '6' => '6', '7' => '7', '8' => '8', '9' => '9', '_' => '_', others => ' '); ----------------------------- -- Definitions for Latin-2 -- ----------------------------- Fold_Latin_2 : Translate_Table := Translate_Table'( 'a' => 'A', X_E0 => X_C0, X_F0 => X_D0, 'b' => 'B', X_E1 => X_C1, X_F1 => X_D1, X_B1 => X_A1, 'c' => 'C', X_E2 => X_C2, X_F2 => X_D2, 'd' => 'D', X_E3 => X_C3, X_F3 => X_D3, X_B3 => X_A3, 'e' => 'E', X_E4 => X_C4, X_F4 => X_D4, 'f' => 'F', X_E5 => X_C5, X_F5 => X_D5, X_B5 => X_A5, 'g' => 'G', X_E6 => X_C6, X_F6 => X_D6, X_B6 => X_A6, 'h' => 'H', X_E7 => X_C7, 'i' => 'I', X_E8 => X_C8, X_F8 => X_D8, 'j' => 'J', X_E9 => X_C9, X_F9 => X_D9, X_B9 => X_A9, 'k' => 'K', X_EA => X_CA, X_FA => X_DA, X_BA => X_AA, 'l' => 'L', X_EB => X_CB, X_FB => X_DB, X_BB => X_AB, 'm' => 'M', X_EC => X_CC, X_FC => X_DC, X_BC => X_AC, 'n' => 'N', X_ED => X_CD, X_FD => X_DD, 'o' => 'O', X_EE => X_CE, X_FE => X_DE, X_BE => X_AE, 'p' => 'P', X_EF => X_CF, X_FF => X_DF, X_BF => X_AF, 'q' => 'Q', 'r' => 'R', 's' => 'S', 't' => 'T', 'u' => 'U', 'v' => 'V', 'w' => 'W', 'x' => 'X', 'y' => 'Y', 'z' => 'Z', 'A' => 'A', X_C0 => X_C0, X_D0 => X_D0, 'B' => 'B', X_C1 => X_C1, X_D1 => X_D1, X_A1 => X_A1, 'C' => 'C', X_C2 => X_C2, X_D2 => X_D2, 'D' => 'D', X_C3 => X_C3, X_D3 => X_D3, X_A3 => X_A3, 'E' => 'E', X_C4 => X_C4, X_D4 => X_D4, 'F' => 'F', X_C5 => X_C5, X_D5 => X_D5, X_A5 => X_A5, 'G' => 'G', X_C6 => X_C6, X_D6 => X_D6, X_A6 => X_A6, 'H' => 'H', X_C7 => X_C7, 'I' => 'I', X_C8 => X_C8, X_D8 => X_D8, 'J' => 'J', X_C9 => X_C9, X_D9 => X_D9, X_A9 => X_A9, 'K' => 'K', X_CA => X_CA, X_DA => X_DA, X_AA => X_AA, 'L' => 'L', X_CB => X_CB, X_DB => X_DB, X_AB => X_AB, 'M' => 'M', X_CC => X_CC, X_DC => X_DC, X_AC => X_AC, 'N' => 'N', X_CD => X_CD, X_DD => X_DD, 'O' => 'O', X_CE => X_CE, X_DE => X_DE, X_AE => X_AE, 'P' => 'P', X_CF => X_CF, X_DF => X_DF, X_AF => X_AF, 'Q' => 'Q', 'R' => 'R', 'S' => 'S', 'T' => 'T', 'U' => 'U', 'V' => 'V', 'W' => 'W', 'X' => 'X', 'Y' => 'Y', 'Z' => 'Z', '0' => '0', '1' => '1', '2' => '2', '3' => '3', '4' => '4', '5' => '5', '6' => '6', '7' => '7', '8' => '8', '9' => '9', '_' => '_', others => ' '); ----------------------------- -- Definitions for Latin-3 -- ----------------------------- Fold_Latin_3 : Translate_Table := Translate_Table'( 'a' => 'A', X_E0 => X_C0, 'b' => 'B', X_E1 => X_C1, X_F1 => X_D1, X_B1 => X_A1, 'c' => 'C', X_E2 => X_C2, X_F2 => X_D2, 'd' => 'D', X_F3 => X_D3, 'e' => 'E', X_E4 => X_C4, X_F4 => X_D4, 'f' => 'F', X_E5 => X_C5, X_F5 => X_D5, X_B5 => X_A5, 'g' => 'G', X_E6 => X_C6, X_F6 => X_D6, X_B6 => X_A6, 'h' => 'H', X_E7 => X_C7, 'i' => 'I', X_E8 => X_C8, X_F8 => X_D8, 'j' => 'J', X_E9 => X_C9, X_F9 => X_D9, X_B9 => X_A9, 'k' => 'K', X_EA => X_CA, X_FA => X_DA, X_BA => X_AA, 'l' => 'L', X_EB => X_CB, X_FB => X_DB, X_BB => X_AB, 'm' => 'M', X_EC => X_CC, X_FC => X_DC, X_BC => X_AC, 'n' => 'N', X_ED => X_CD, X_FD => X_DD, 'o' => 'O', X_EE => X_CE, X_FE => X_DE, 'p' => 'P', X_EF => X_CF, X_BF => X_AF, 'q' => 'Q', 'r' => 'R', 's' => 'S', 't' => 'T', 'u' => 'U', 'v' => 'V', 'w' => 'W', 'x' => 'X', 'y' => 'Y', 'z' => 'Z', 'A' => 'A', X_C0 => X_C0, 'B' => 'B', X_C1 => X_C1, X_D1 => X_D1, X_A1 => X_A1, 'C' => 'C', X_C2 => X_C2, X_D2 => X_D2, 'D' => 'D', X_D3 => X_D3, 'E' => 'E', X_C4 => X_C4, X_D4 => X_D4, 'F' => 'F', X_C5 => X_C5, X_D5 => X_D5, X_A5 => X_A5, 'G' => 'G', X_C6 => X_C6, X_D6 => X_D6, X_A6 => X_A6, 'H' => 'H', X_C7 => X_C7, 'I' => 'I', X_C8 => X_C8, X_D8 => X_D8, 'J' => 'J', X_C9 => X_C9, X_D9 => X_D9, X_A9 => X_A9, 'K' => 'K', X_CA => X_CA, X_DA => X_DA, X_AA => X_AA, 'L' => 'L', X_CB => X_CB, X_DB => X_DB, X_AB => X_AB, 'M' => 'M', X_CC => X_CC, X_DC => X_DC, X_AC => X_AC, 'N' => 'N', X_CD => X_CD, X_DD => X_DD, 'O' => 'O', X_CE => X_CE, X_DE => X_DE, 'P' => 'P', X_CF => X_CF, X_AF => X_AF, 'Q' => 'Q', 'R' => 'R', 'S' => 'S', 'T' => 'T', 'U' => 'U', 'V' => 'V', 'W' => 'W', 'X' => 'X', 'Y' => 'Y', 'Z' => 'Z', '0' => '0', '1' => '1', '2' => '2', '3' => '3', '4' => '4', '5' => '5', '6' => '6', '7' => '7', '8' => '8', '9' => '9', '_' => '_', others => ' '); ----------------------------- -- Definitions for Latin-4 -- ----------------------------- Fold_Latin_4 : Translate_Table := Translate_Table'( 'a' => 'A', X_E0 => X_C0, X_F0 => X_D0, 'b' => 'B', X_E1 => X_C1, X_F1 => X_D1, X_B1 => X_A1, 'c' => 'C', X_E2 => X_C2, X_F2 => X_D2, 'd' => 'D', X_E3 => X_C3, X_F3 => X_D3, X_B3 => X_A3, 'e' => 'E', X_E4 => X_C4, X_F4 => X_D4, 'f' => 'F', X_E5 => X_C5, X_F5 => X_D5, X_B5 => X_A5, 'g' => 'G', X_E6 => X_C6, X_F6 => X_D6, X_B6 => X_A6, 'h' => 'H', X_E7 => X_C7, 'i' => 'I', X_E8 => X_C8, X_F8 => X_D8, 'j' => 'J', X_E9 => X_C9, X_F9 => X_D9, X_B9 => X_A9, 'k' => 'K', X_EA => X_CA, X_FA => X_DA, X_BA => X_AA, 'l' => 'L', X_EB => X_CB, X_FB => X_DB, X_BB => X_AB, 'm' => 'M', X_EC => X_CC, X_FC => X_DC, X_BC => X_AC, 'n' => 'N', X_ED => X_CD, X_FD => X_DD, 'o' => 'O', X_EE => X_CE, X_FE => X_DE, X_BE => X_AE, 'p' => 'P', X_EF => X_CF, 'q' => 'Q', 'r' => 'R', 's' => 'S', 't' => 'T', 'u' => 'U', 'v' => 'V', 'w' => 'W', 'x' => 'X', 'y' => 'Y', 'z' => 'Z', 'A' => 'A', X_C0 => X_C0, X_D0 => X_D0, 'B' => 'B', X_C1 => X_C1, X_D1 => X_D1, X_A1 => X_A1, 'C' => 'C', X_C2 => X_C2, X_D2 => X_D2, 'D' => 'D', X_C3 => X_C3, X_D3 => X_D3, X_A3 => X_A3, 'E' => 'E', X_C4 => X_C4, X_D4 => X_D4, 'F' => 'F', X_C5 => X_C5, X_D5 => X_D5, X_A5 => X_A5, 'G' => 'G', X_C6 => X_C6, X_D6 => X_D6, X_A6 => X_A6, 'H' => 'H', X_C7 => X_C7, 'I' => 'I', X_C8 => X_C8, X_D8 => X_D8, 'J' => 'J', X_C9 => X_C9, X_D9 => X_D9, X_A9 => X_A9, 'K' => 'K', X_CA => X_CA, X_DA => X_DA, X_AA => X_AA, 'L' => 'L', X_CB => X_CB, X_DB => X_DB, X_AB => X_AB, 'M' => 'M', X_CC => X_CC, X_DC => X_DC, X_AC => X_AC, 'N' => 'N', X_CD => X_CD, X_DD => X_DD, 'O' => 'O', X_CE => X_CE, X_DE => X_DE, X_AE => X_AE, 'P' => 'P', X_CF => X_CF, 'Q' => 'Q', 'R' => 'R', 'S' => 'S', 'T' => 'T', 'U' => 'U', 'V' => 'V', 'W' => 'W', 'X' => 'X', 'Y' => 'Y', 'Z' => 'Z', '0' => '0', '1' => '1', '2' => '2', '3' => '3', '4' => '4', '5' => '5', '6' => '6', '7' => '7', '8' => '8', '9' => '9', '_' => '_', others => ' '); ---------------------------- -- Definitions for IBM PC -- ---------------------------- Fold_IBM_PC : Translate_Table := Translate_Table'( 'a' => 'A', 'b' => 'B', 'c' => 'C', 'd' => 'D', 'e' => 'E', 'f' => 'F', 'g' => 'G', 'h' => 'H', 'i' => 'I', 'j' => 'J', 'k' => 'K', 'l' => 'L', 'm' => 'M', 'n' => 'N', 'o' => 'O', 'p' => 'P', 'q' => 'Q', 'r' => 'R', 's' => 'S', 't' => 'T', 'u' => 'U', 'v' => 'V', 'w' => 'W', 'x' => 'X', 'y' => 'Y', 'z' => 'Z', 'A' => 'A', 'B' => 'B', 'C' => 'C', 'D' => 'D', 'E' => 'E', 'F' => 'F', 'G' => 'G', 'H' => 'H', 'I' => 'I', 'J' => 'J', 'K' => 'K', 'L' => 'L', 'M' => 'M', 'N' => 'N', 'O' => 'O', 'P' => 'P', 'Q' => 'Q', 'R' => 'R', 'S' => 'S', 'T' => 'T', 'U' => 'U', 'V' => 'V', 'W' => 'W', 'X' => 'X', 'Y' => 'Y', 'Z' => 'Z', X_80 => X_80, -- C cedilla X_81 => X_9A, -- u umlaut X_82 => X_90, -- e acute X_83 => X_83, -- a circumflex X_84 => X_8E, -- a umlaut X_85 => X_85, -- a grave X_86 => X_8F, -- a ring X_87 => X_80, -- c cedilla X_88 => X_88, -- e circumflex X_89 => X_89, -- e umlaut X_8A => X_8A, -- e grave X_8B => X_8B, -- i umlaut X_8C => X_8C, -- i circumflex X_8D => X_8D, -- i grave X_8E => X_8E, -- A umlaut X_8F => X_8F, -- A ring X_90 => X_90, -- E acute X_91 => X_92, -- ae X_92 => X_92, -- AE X_93 => X_93, -- o circumflex X_94 => X_99, -- o umlaut X_95 => X_95, -- o grave X_96 => X_96, -- u circumflex X_97 => X_97, -- u grave X_98 => X_98, -- y umlaut X_99 => X_99, -- O umlaut X_9A => X_9A, -- U umlaut X_A0 => X_A0, -- a acute X_A1 => X_A1, -- i acute X_A2 => X_A2, -- o acute X_A3 => X_A3, -- u acute X_A4 => X_A5, -- n tilde X_A5 => X_A5, -- N tilde X_A6 => X_A6, -- a underline X_A7 => X_A7, -- o underline X_E0 => X_E0, -- lower case alpha X_E1 => X_E1, -- lower case beta X_E2 => X_E2, -- upper case gamma X_E3 => X_E3, -- lower case pi X_E4 => X_E4, -- upper case sigma (lower/upper sigma not equivalent) X_E5 => X_E5, -- lower case sigma (lower/upper sigma not equivalent) X_E6 => X_E6, -- lower case mu X_E7 => X_E7, -- lower case tau X_E8 => X_E8, -- upper case phi (lower/upper phi not equivalent) X_E9 => X_E9, -- lower case theta X_EA => X_EA, -- upper case omega X_EB => X_EB, -- lower case delta X_ED => X_ED, -- lower case phi (lower/upper phi not equivalent) X_EE => X_EE, -- lower case epsilon X_FC => X_FC, -- lower case eta '0' => '0', '1' => '1', '2' => '2', '3' => '3', '4' => '4', '5' => '5', '6' => '6', '7' => '7', '8' => '8', '9' => '9', '_' => '_', others => ' '); ----------------------------------------- -- Definitions for Full Upper Half Set -- ----------------------------------------- -- The full upper half set allows all upper half characters as letters, -- and does not recognize any upper/lower case equivalences in this half. Fold_Full_Upper_Half : Translate_Table := Translate_Table'( 'a' => 'A', 'b' => 'B', 'c' => 'C', 'd' => 'D', 'e' => 'E', 'f' => 'F', 'g' => 'G', 'h' => 'H', 'i' => 'I', 'j' => 'J', 'k' => 'K', 'l' => 'L', 'm' => 'M', 'n' => 'N', 'o' => 'O', 'p' => 'P', 'q' => 'Q', 'r' => 'R', 's' => 'S', 't' => 'T', 'u' => 'U', 'v' => 'V', 'w' => 'W', 'x' => 'X', 'y' => 'Y', 'z' => 'Z', 'A' => 'A', 'B' => 'B', 'C' => 'C', 'D' => 'D', 'E' => 'E', 'F' => 'F', 'G' => 'G', 'H' => 'H', 'I' => 'I', 'J' => 'J', 'K' => 'K', 'L' => 'L', 'M' => 'M', 'N' => 'N', 'O' => 'O', 'P' => 'P', 'Q' => 'Q', 'R' => 'R', 'S' => 'S', 'T' => 'T', 'U' => 'U', 'V' => 'V', 'W' => 'W', 'X' => 'X', 'Y' => 'Y', 'Z' => 'Z', X_80 => X_80, X_90 => X_90, X_A0 => X_A0, X_B0 => X_B0, X_81 => X_81, X_91 => X_91, X_A1 => X_A1, X_B1 => X_B1, X_82 => X_82, X_92 => X_92, X_A2 => X_A2, X_B2 => X_B2, X_83 => X_83, X_93 => X_93, X_A3 => X_A3, X_B3 => X_B3, X_84 => X_84, X_94 => X_94, X_A4 => X_A4, X_B4 => X_B4, X_85 => X_85, X_95 => X_95, X_A5 => X_A5, X_B5 => X_B5, X_86 => X_86, X_96 => X_96, X_A6 => X_A6, X_B6 => X_B6, X_87 => X_87, X_97 => X_97, X_A7 => X_A7, X_B7 => X_B7, X_88 => X_88, X_98 => X_98, X_A8 => X_A8, X_B8 => X_B8, X_89 => X_89, X_99 => X_99, X_A9 => X_A9, X_B9 => X_B9, X_8A => X_8A, X_9A => X_9A, X_AA => X_AA, X_BA => X_BA, X_8B => X_8B, X_9B => X_9B, X_AB => X_AB, X_BB => X_BB, X_8C => X_8C, X_9C => X_9C, X_AC => X_AC, X_BC => X_BC, X_8D => X_8D, X_9D => X_9D, X_AD => X_AD, X_BD => X_BD, X_8E => X_8E, X_9E => X_9E, X_AE => X_AE, X_BE => X_BE, X_8F => X_8F, X_9F => X_9F, X_AF => X_AF, X_BF => X_BF, X_C0 => X_C0, X_D0 => X_D0, X_E0 => X_E0, X_F0 => X_F0, X_C1 => X_C1, X_D1 => X_D1, X_E1 => X_E1, X_F1 => X_F1, X_C2 => X_C2, X_D2 => X_D2, X_E2 => X_E2, X_F2 => X_F2, X_C3 => X_C3, X_D3 => X_D3, X_E3 => X_E3, X_F3 => X_F3, X_C4 => X_C4, X_D4 => X_D4, X_E4 => X_E4, X_F4 => X_F4, X_C5 => X_C5, X_D5 => X_D5, X_E5 => X_E5, X_F5 => X_F5, X_C6 => X_C6, X_D6 => X_D6, X_E6 => X_E6, X_F6 => X_F6, X_C7 => X_C7, X_D7 => X_D7, X_E7 => X_E7, X_F7 => X_F7, X_C8 => X_C8, X_D8 => X_D8, X_E8 => X_E8, X_F8 => X_F8, X_C9 => X_C9, X_D9 => X_D9, X_E9 => X_E9, X_F9 => X_F9, X_CA => X_CA, X_DA => X_DA, X_EA => X_EA, X_FA => X_FA, X_CB => X_CB, X_DB => X_DB, X_EB => X_EB, X_FB => X_FB, X_CC => X_CC, X_DC => X_DC, X_EC => X_EC, X_FC => X_FC, X_CD => X_CD, X_DD => X_DD, X_ED => X_ED, X_FD => X_FD, X_CE => X_CE, X_DE => X_DE, X_EE => X_EE, X_FE => X_FE, X_CF => X_CF, X_DF => X_DF, X_EF => X_EF, X_FF => X_FF, '0' => '0', '1' => '1', '2' => '2', '3' => '3', '4' => '4', '5' => '5', '6' => '6', '7' => '7', '8' => '8', '9' => '9', '_' => '_', others => ' '); --------------------------------------- -- Definitions for No Upper Half Set -- --------------------------------------- -- The no upper half set allows no upper half characters as letters, and -- thus there are no upper/lower case equivalences in this half. This set -- corresponds to the Ada 83 rules. Fold_No_Upper_Half : Translate_Table := Translate_Table'( 'a' => 'A', 'b' => 'B', 'c' => 'C', 'd' => 'D', 'e' => 'E', 'f' => 'F', 'g' => 'G', 'h' => 'H', 'i' => 'I', 'j' => 'J', 'k' => 'K', 'l' => 'L', 'm' => 'M', 'n' => 'N', 'o' => 'O', 'p' => 'P', 'q' => 'Q', 'r' => 'R', 's' => 'S', 't' => 'T', 'u' => 'U', 'v' => 'V', 'w' => 'W', 'x' => 'X', 'y' => 'Y', 'z' => 'Z', 'A' => 'A', 'B' => 'B', 'C' => 'C', 'D' => 'D', 'E' => 'E', 'F' => 'F', 'G' => 'G', 'H' => 'H', 'I' => 'I', 'J' => 'J', 'K' => 'K', 'L' => 'L', 'M' => 'M', 'N' => 'N', 'O' => 'O', 'P' => 'P', 'Q' => 'Q', 'R' => 'R', 'S' => 'S', 'T' => 'T', 'U' => 'U', 'V' => 'V', 'W' => 'W', 'X' => 'X', 'Y' => 'Y', 'Z' => 'Z', '0' => '0', '1' => '1', '2' => '2', '3' => '3', '4' => '4', '5' => '5', '6' => '6', '7' => '7', '8' => '8', '9' => '9', '_' => '_', others => ' '); ---------------------------- -- Initialize_Char_Tables -- ---------------------------- procedure Initialize_Char_Tables is begin -- Set Fold_Upper table from source code indication if Identifier_Character_Set = '1' then Fold_Upper := Fold_Latin_1; elsif Identifier_Character_Set = '2' then Fold_Upper := Fold_Latin_2; elsif Identifier_Character_Set = '3' then Fold_Upper := Fold_Latin_3; elsif Identifier_Character_Set = '4' then Fold_Upper := Fold_Latin_4; elsif Identifier_Character_Set = 'p' then Fold_Upper := Fold_IBM_PC; elsif Identifier_Character_Set = 'f' then Fold_Upper := Fold_Full_Upper_Half; else -- Identifier_Character_Set = 'n' Fold_Upper := Fold_No_Upper_Half; end if; -- Use Fold_Upper table to compute Fold_Lower table Fold_Lower := Fold_Upper; for I in Char loop if I /= Fold_Upper (I) then Fold_Lower (Fold_Upper (I)) := I; Fold_Lower (I) := I; end if; end loop; Fold_Lower (' ') := ' '; -- Build Identifier_Char table from used entries of Fold_Upper for I in Char loop Identifier_Char (I) := Fold_Upper (I) /= ' '; end loop; -- Letter_Or_Digit differs only in the entry for underline Letter_Or_Digit := Identifier_Char; Letter_Or_Digit ('_') := False; return; end Initialize_Char_Tables; -------------------------- -- Is_Upper_Case_Letter -- -------------------------- function Is_Upper_Case_Letter (C : Char) return Boolean is begin return C /= Fold_Lower (C); end Is_Upper_Case_Letter; -------------------------- -- Is_Lower_Case_Letter -- -------------------------- function Is_Lower_Case_Letter (C : Char) return Boolean is begin return C /= Fold_Upper (C); end Is_lower_Case_Letter; end Csets; _A5, -- N tilde X_A6 => X_A6, -- a underline X_A7 => X_gnat-1.67-src/src/debug.adb 444 10015 7640 13731 5506244300 10672 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- D E B U G -- -- -- -- B o d y -- -- -- -- $Revision: 1.9 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Output; use Output; package body Debug is ---------------------- -- Debug Flag Usage -- ---------------------- -- Documentation of debug flags for compiler -- da Generate messages tracking semantic analyzer progress -- db Generate software traceback code -- dc List names of units as they are compiled -- dd Dynamic allocation of tables messages generated -- de List the entity table -- df Full tree/source print (includes withed units) -- dg For source trees, print only generated (rewritten) tree -- dh Force unit loads even in syntax only mode -- di Generate messages for visibility linking/delinking -- dj Generate continuous traceback output -- dk Kill with traceback if compiler error (even if errors) -- dl Generate unit load trace messages -- dm -- dn Generate messages for node/list allocation -- do For source trees, print only original tree -- dp Generate messages for parser scope stack push/pops -- dq -- dr Generate parser resynchronization messages -- ds Print source from tree after last phase -- dt Print full tree after last phase -- du Print full tree after Par (before Sem) -- dv Generate file name/version variables -- dw Print source from tree after Par (before Sem) -- dx Force expansion on, even if no code being generated -- dy Print tree of package Standard -- dz Print source of package Standard -- d1 Error msgs have node numbers where possible -- d2 -- d3 -- d4 -- d5 -- d6 -- d7 -- d8 -- d9 -- Documentation of debug flags for binder -- da -- db -- dc List units as they are chosen -- dd -- de -- df -- dg -- dh -- di -- dj -- dk -- dl -- dm -- dn List details of manipulation of Num_Pred values -- do -- dp -- dq -- dr -- ds -- dt -- du -- dv -- dw -- dx -- dy -- dz -- d1 -- d2 -- d3 -- d4 -- d5 -- d6 -- d7 -- d8 -- d9 ---------------------- -- Get_Debug_Flag_K -- ---------------------- function Get_Debug_Flag_K return Boolean is begin return Debug_Flag_K; end Get_Debug_Flag_K; -------------------- -- Set_Debug_Flag -- -------------------- procedure Set_Debug_Flag (C : Char; Val : Boolean := True) is subtype Dig is Char range '1' .. '9'; subtype Let is Char range 'a' .. 'z'; begin if C in Dig then case Dig (C) is when '1' => Debug_Flag_1 := Val; when '2' => Debug_Flag_2 := Val; when '3' => Debug_Flag_3 := Val; when '4' => Debug_Flag_4 := Val; when '5' => Debug_Flag_5 := Val; when '6' => Debug_Flag_6 := Val; when '7' => Debug_Flag_7 := Val; when '8' => Debug_Flag_8 := Val; when '9' => Debug_Flag_9 := Val; end case; else case Let (C) is when 'a' => Debug_Flag_A := Val; when 'b' => Debug_Flag_B := Val; when 'c' => Debug_Flag_C := Val; when 'd' => Debug_Flag_D := Val; when 'e' => Debug_Flag_E := Val; when 'f' => Debug_Flag_F := Val; when 'g' => Debug_Flag_G := Val; when 'h' => Debug_Flag_H := Val; when 'i' => Debug_Flag_I := Val; when 'j' => Debug_Flag_J := Val; when 'k' => Debug_Flag_K := Val; when 'l' => Debug_Flag_L := Val; when 'm' => Debug_Flag_M := Val; when 'n' => Debug_Flag_N := Val; when 'o' => Debug_Flag_O := Val; when 'p' => Debug_Flag_P := Val; when 'q' => Debug_Flag_Q := Val; when 'r' => Debug_Flag_R := Val; when 's' => Debug_Flag_S := Val; when 't' => Debug_Flag_T := Val; when 'u' => Debug_Flag_U := Val; when 'v' => Debug_Flag_V := Val; when 'w' => Debug_Flag_W := Val; when 'x' => Debug_Flag_X := Val; when 'y' => Debug_Flag_Y := Val; when 'z' => Debug_Flag_Z := Val; end case; end if; end Set_Debug_Flag; end Debug; 'I' => 'I', 'J' => 'J', 'K'gnat-1.67-src/src/debug.ads 444 10015 7640 10374 5506244301 10714 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- D E B U G -- -- -- -- S p e c -- -- -- -- $Revision: 1.21 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Debug is -- This package contains global flags used to control the inclusion -- of debugging code in various phases of the compiler. ------------------------- -- Dynamic Debug Flags -- ------------------------- -- Thirty six flags that can be used to active various specialized -- debugging output information. The flags are preset to False, which -- corresponds to the given output being suppressed. The individual -- flags can be turned on using the undocumented switch /dxxx where -- xxx is a string of letters for flags to be turned on. Documentation -- on the current usage of these flags is contained in the body of Debug -- rather than the spec, so that we don't have to recompile the world -- when a new debug flag is added Debug_Flag_A : Boolean := False; Debug_Flag_B : Boolean := False; Debug_Flag_C : Boolean := False; Debug_Flag_D : Boolean := False; Debug_Flag_E : Boolean := False; Debug_Flag_F : Boolean := False; Debug_Flag_G : Boolean := False; Debug_Flag_H : Boolean := False; Debug_Flag_I : Boolean := False; Debug_Flag_J : Boolean := False; Debug_Flag_K : Boolean := False; Debug_Flag_L : Boolean := False; Debug_Flag_M : Boolean := False; Debug_Flag_N : Boolean := False; Debug_Flag_O : Boolean := False; Debug_Flag_P : Boolean := False; Debug_Flag_Q : Boolean := False; Debug_Flag_R : Boolean := False; Debug_Flag_S : Boolean := False; Debug_Flag_T : Boolean := False; Debug_Flag_U : Boolean := False; Debug_Flag_V : Boolean := False; Debug_Flag_W : Boolean := False; Debug_Flag_X : Boolean := False; Debug_Flag_Y : Boolean := False; Debug_Flag_Z : Boolean := False; Debug_Flag_1 : Boolean := False; Debug_Flag_2 : Boolean := False; Debug_Flag_3 : Boolean := False; Debug_Flag_4 : Boolean := False; Debug_Flag_5 : Boolean := False; Debug_Flag_6 : Boolean := False; Debug_Flag_7 : Boolean := False; Debug_Flag_8 : Boolean := False; Debug_Flag_9 : Boolean := False; function Get_Debug_Flag_K return Boolean; -- This function is called from C code to get the setting of the K flag -- (it does not work to try to access a constant object directly). procedure Set_Debug_Flag (C : Char; Val : Boolean := True); -- Where C is 0-9 or a-z, sets the corresponding debug flag to the -- given value. In the checks off version of debug, the call to -- Set_Debug_Flag is always a null operation. end Debug; ¹!a-ada.h¹" sysid~u.ads(¹# system.adsH¹$$system-assertions.ads\¹% table.adsllp¹& table.adb b„¹' tbuild.ads;˜¹( tbuild.adbe¬¹) treepr.ads À¹* treepr.adbSÔ¹+ gnat-1.67-src/src/debug_sem.ads 444 10015 7640 5634 5506244301 11543 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- D E B U G _ S E M -- -- -- -- S p e c -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This package contains data and subprograms to support the A debug switch -- that is used to generate output showing what node is being analyzed, -- resolved, evaluated, or expanded. with Types; use Types; package Debug_Sem is procedure Debug_A_Entry (S : Str; N : Node_Id); -- Generates a message prefixed by a sequence of bars showing the nesting -- depth (depth increases by 1 for a Debug_A_Entry call and is decreased -- by the corresponding Debug_A_Exit call). Then the string is output -- (analyzing, expanding etc), followed by the node number and its kind. -- This output is generated only if the debug A flag is set. If the debug -- A flag is not set, then the call has no effect. procedure Debug_A_Exit (S : Str; N : Node_Id; Comment : Str); -- Generates the corresponding termination message. The message is preceded -- by a sequence of bars, followed by the string S, the node number, and -- a trailing comment (e.g. " (already evaluated)"). This output is -- generated only if the debug A flag is set. If the debug A flag is not -- set, then the call has no effect. end Debug_Sem;  sem_ch9.ads H¸÷ sem_ch9.adb `¸ø sem_eval.adsÿæà x¸ù sem_eval.adb< gnat-1.67-src/src/debug_sem.adb 444 10015 7640 10627 5506244301 11540 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- D E B U G _ S E M -- -- -- -- B o d y -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Debug; use Debug; with Sinfo; use Sinfo; with Sinput; use Sinput; with Output; use Output; package body Debug_Sem is Debug_A_Depth : Nat := 0; -- Output for the debug A flag is preceded by a sequence of vertical bar -- characters corresponding to the recursion depth of the actions being -- recorded (analysis, expansion, resolution and evaluation of nodes) -- This variable records the depth. ----------------------- -- Local Subprograms -- ----------------------- procedure Debug_Output_Astring; -- Outputs Debug_A_Depth number of vertical bars, used to preface messages ------------------- -- Debug_A_Entry -- ------------------- procedure Debug_A_Entry (S : Str; N : Node_Id) is begin if Debug_Flag_A then Debug_Output_Astring; Write_Str (S); Write_Str ("Node_Id = "); Write_Int (Int (N)); Write_Location (Sloc (N)); Write_String (" "); Write_String (Node_Kind'Image (Nkind (N))); Write_Eol; Debug_A_Depth := Debug_A_Depth + 1; end if; end Debug_A_Entry; ------------------ -- Debug_A_Exit -- ------------------ procedure Debug_A_Exit (S : Str; N : Node_Id; Comment : Str) is begin if Debug_Flag_A then Debug_A_Depth := Debug_A_Depth - 1; Debug_Output_Astring; Write_Str (S); Write_Str ("Node_Id = "); Write_Int (Int (N)); Write_Str (Comment); Write_Eol; end if; end Debug_A_Exit; -------------------------- -- Debug_Output_Astring -- -------------------------- procedure Debug_Output_Astring is Vbars : constant Str := "|||||||||||||||||||||||||"; begin if Debug_A_Depth > Vbars'Length then for I in Vbars'Length .. Debug_A_Depth loop Write_Char ('|'); end loop; Write_Str (Vbars); else Write_Str (Vbars (1 .. Debug_A_Depth)); end if; end Debug_Output_Astring; end Debug_Sem; dt¹< a-adaint.cdˆ¹= a-gtran3.ctœ¹> a-gtran3.h3°¹?a-misc.can3Ĺ@gnat-1.67-src/src/einfo.ads 444 10015 7640 223712 5506244303 10752 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E I N F O -- -- -- -- S p e c -- -- -- -- $Revision: 1.155 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Einfo is -- This package defines the annotations to the abstract syntax tree that -- are are needed to support semantic processing of an Ada compilation. -- These annotations are for the most part attributes of declared entities, -- and they correspond to conventional symbol table information. Other -- attributes include sets of meanings for overloaded names, possible -- types for overloaded expressions, flags to indicate deferred constants, -- incomplete types, etc. These attributes are stored in available fields -- in tree nodes (i.e. fields not used by the parser, as defined by the -- Sinfo package specification), and accessed by means of a set of -- subprograms which define an abstract interface. -- There are two kinds of semantic information -- First, the tree nodes with the following Nkind values: -- N_Defining_Identifier -- N_Defining_Character_Literal -- N_Defining_Operator_Symbol -- are called Entities, and constitute the information that would often -- be stored separately in a symbol table. These nodes are all extended -- to provide extra space, and contain fields which depend on the entity -- kind, as defined by the contents of the Ekind field. The use of the -- Ekind field, and the associated fields in the entity, are defined -- in this package, as are the access functions to these fields. -- Second, in some cases semantic information is stored directly in other -- kinds of nodes, e.g. the Etype field, used to indicate the type of an -- expression. The access functions to these fields are defined in the -- Sinfo package, but their full documentation is to be found in -- the Einfo package specification. -- Declaration processing places information in the nodes of their defining -- identifiers. Name resolution places in all other occurences of an -- identifier a pointer to the corresponding defining occurrence. -- ------------------------------ -- -- Common Entity Attributes -- -- ------------------------------ -- All entities have the following common attributes -- Chars (Name1) -- Source identifier or designator of entity. It is an entry into the -- names table, and it is set by the parser. -- Ekind -- An element of the type Entity_Kind defined below. -- Etype (Node5) -- Declared type of an entity. Also an entity. For a type entity, -- this pointer is self-referential. -- Has_Address_Clause (Flag28) -- Flag set if Address clause given for object or subprogram. Always -- False for other entity kinds. -- Has_Homonym (Flag12) -- A flag to indicate that an entity has a homonym in the same scope. -- scope. Used by Gigi to generate unique expanded names for such -- entities. -- Has_Master_Entity (Flag21) -- A flag present on entities that can appear in the scope stack (see -- Sem spec). It is set if a task master entity (_Master) has been -- declared and initialized in the corresponding scope. -- Has_Size_Clause (Flag29) -- Flag set if Size clause given for object or type. Always false for -- other kinds of entities. This is used to prevent multiple Size -- clauses for a given entity, and is always initially cleared for a -- derived type (even though the Size, if set, is inherited by the -- derived type). -- Has_Storage_Size_Clause (Flag23) -- Flag set if Storage_Size clause given for a task type. Always False -- for other kinds of entities. This is used to prevent multiple -- Storage_Size clauses for a given task type. -- Has_Tasks (Flag30) -- A flag that is set on task types themselves, and also (recursively) -- on any composite type which has a component that has this flag set. -- The meaning is that an allocator of such an object must create -- the required tasks. Note that the flag is not set on access types, -- even if they designate tasks. -- Homonym (Node4) -- A link to chain entities that are homonyms and that are declared in -- the same or enclosing scopes (Homonyms in the same scope are -- overloaded) -- Is_Delayed (Flag18) -- Indicates that the elaboration of the declaration for the entity -- must be deferred in Gigi, until the completion of some other entity -- (typically a private type) is encountered. -- Is_Directly_Visible (Flag7) -- Indicates whether entity is defined in some currently open scope. -- Is_Imported (Flag24) -- Set if the entity is imported. For now we only allow the import of -- functions and procedures, but that may well change later on, which -- is why this field is present in all entity types. -- Is_Internal (Flag2) -- Set to indicate an entity created during semantic processing (e.g. -- an implicit type). -- Is_Private (Flag13) -- Indicates whether entity is defined in the private part of a -- package. -- Is_Public (FLag10) -- To indicate that an external symbol must be created for this -- entity, because it may be referenced from another object file. -- Is_Use_Visible (Flag9) -- Indicates whether entity is defined in a package that appears in -- currently active use clause. -- Next_Entity (Node6) -- The entities of a scope are chained, with the head of the list -- being in the First_Entity field of the scope entity. All entities -- use the Next_Entity field as a forward pointer for this list, with -- Empty indicating the end of the list. -- Parent -- As usual, this field points to the syntactic parent of the node, -- which for an entity is the declaration that declares the entity. -- Scope (Node3) -- Points to the entity for the scope (block, loop, subprogram, -- package etc.) in which the entity is declared. -- -------------------------------- -- -- Entity-Specific Attributes -- -- -------------------------------- -- These fields only exist for certain kinds of entities, so access to -- these fields should check for appropriate Ekind values first. This -- list only includes fields that are directly defined in the entities. -- For syntactic access functions, see specs of the functions themselves. -- Alias (Node7) -- Present in overloadable entities (enumeration literals, functions, -- procedures). Points to parent subprogram of a derived subprogram. -- Component_Type (Node10) -- Present in array types and subtypes, and also in the special -- enumeration table type created for enumeration type. References -- the entity for the component type. -- Corresponding_Task_Type (Node7) -- Present in record types that are constructed by the expander to -- represent task types (Is_Task_Record_Type flag True). Points to the -- entity for the corresponding task type. Note that such records are -- untagged, so it is safe to overlap the Primitive_Operations field -- which is only used for tagged record types. -- Directly_Designated_Type (Node10) -- Present in access types. This field points to the type that is -- directly designated by the access type. In the case of an access -- type to an incomplete type, this field references the incomplete -- type. Note that in the semantic processing, what is useful in -- nearly all cases is the full type designated by the access type. -- The function Designated_Type obtains this full type in the case of -- access to an incomplete type. -- Default_Value (Node10) -- Present in IN parameters. Points to the node representing the -- expression for the default value for the parameter. Empty if the -- parameter has no default value. -- Discriminal (Node9) -- Present in discriminants (Discriminant formal: GNAT's first -- coinage). The entity used as a formal parameter that corresponds -- to a discriminant. See section "Use of Discriminants" for details. -- Discriminant_Default_Value (Node10) -- Present in discriminants. Points to the node representing the -- expression for the default value of the discriminant. Set to -- Empty if the discriminant has no default value. -- Discriminant_Constraint (Elist2) -- Present in entities that can have discriminant constraints (task -- types and subtypes, record types and subtypes, private types, -- limited private types and incomplete types). Points to an element -- list containing the discriminant constraint (list of discriminant -- associations) for a record (sub)type. -- Discriminant_Checking_Func (Node10) -- Present in components. Points to the defining identifier of the -- function built by the expander returns a Boolean indicating whether -- the given record component exists for the current discriminant -- values. -- Enumeration_Pos (Uint11) -- Present in enumeration literals. Contains the position number -- corresponding to the value of the enumeration literal. -- Enumeration_Rep (Uint12) -- Present in enumeration literals. Contains the representation that -- corresponds to the value of the the enumeration literal. Note that -- this is normally the same as Enumeration_Pos except in the presence -- of representation clauses, where Pos will still represent the -- position of the literal within the type and Rep will have be the -- value given in the representation clause. -- Entry_Index (Uint11) -- Present in entries and entry families. For an entry, contains the -- entry index, which is the ordinal position of the entry among the -- entries declared in the task definition, excluding any entry -- families (the first entry is numbered 1). In an entry family, this -- field contains the entry index of the first entry among any of the -- entry families of a task definition (i.e. the value is the same -- for all entry families in one task definition, and is one greater -- than the largest entry index value for any non-family entry, or 1 -- if only entry families are present. -- Equivalent_Type (Node7) -- Present in class subtypes. Points to a type entity created by the -- expander which gives Gigi an easily understandable equivalent of -- the class subtype with a known size (given by an initial value). -- See Exp_Util.Expand_Class_Subtype for further details. -- Esize (Node12) -- Present in all types and subtypes, an also for components, tags, -- constants and variables. Contains the size of a type or object. -- A value of zero is used in the case of composite types or objects -- for which no size clause has been given (i.e. those types for which -- only Gigi knows the allocated size) -- First_Entity (Node9) -- Present in all entities which act as scopes to which a list of -- associated entities is attached (blocks, class subtypes and types, -- entries, functions, loops, packages, procedures, protected objects, -- record types and subtypes, task types and subtypes). Points to a -- list of associated entities chained through the Next_Entity field -- with Empty marking the end of the list. -- First_Private_Entity (Node11) -- Present in all entities containing private parts (packages, -- protected types and subtypes, task types and subtypes). The -- entities on the entity chain are in order of declaration, so the -- entries for private entities are at the end of the chain. This -- field points to the first entity for the private part. It is -- Empty if there are no entities declared in the private part or -- if there is no private part. -- Full_Declaration (Node11) -- Present in incomplete types, private types, limited private types, -- and deferred constants. Points to the entity for the corresponding -- full type declaration. -- Has_Completion (Flag26) -- Present in all entities that require a completion (functions, -- procedures, private types, limited private types, incomplete types, -- and packages that require a body). Set if the completion has been -- encountered and analyzed. -- Has_Discriminants (Flag5) -- Present in all entities that can have discriminants (record types -- and subtypes, task types and subtypes, protected types and subtypes, -- private types, limited private types, and incomplete types). Set if -- known discriminants are present. -- Interface_Name (Node12) -- Present in functions and procedures, contains Empty unless a pragma -- Interface_Name or Import has been given, in which case it points to -- the N_String_Literal node for the specified link name. -- Internal_Access_Disp_Table (Node11) -- The entity which represents the dispatch table access associated -- with the given tagged type. This field is not directly in the -- corresponding Record_Type entity because there is not enough room, -- it rather is in the Tag component (whose name is Name_uTag) of this -- record. -- Is_Abstract (Flag19) -- Present in all types, and also for functions and procedures. Set -- for abstract types and abstract subprograms. -- Is_Aliased (Flag15) -- Present on objects whose declarations carry the keyword aliased, -- and on record components that have the keyword. For arrays with an -- aliased component declaration, the flag is on the array type itself. -- Is_Intrinsic (Flag27) -- Present in functions and procedures. Set if a pragma Convention -- Intrinsic has been given for the subprogram. -- Init_Proc (Node8) -- Present in all type entities. Points to the entity for the -- Initialization procedure if one is required. If this field is -- Empty, then no Initialization proc is defined for the type. Note -- that subtyupes and implicit types do not have this field set. -- Subtype objects are initialized using the initialization procedure -- of the base type. A special case arises for task types. The -- Init_Proc field of task types is Empty, but initialization is -- required. The initialization procedure used is the one for the -- corresponding record type (see Base_Init_Proc). -- Is_Inlined (Flag11) -- Present in functions and procedures. Set if a pragma Inline applies -- to the subprogram. For subprograms created during expansion, this -- flag may be set directly by the expander to request inlining. -- Is_Limited_Type (Flag25) -- Present in all type entities. Set if the type is a limited type -- (private type, limited private type, task type, protected type, -- composite containing a limited component, or subtypes of any of -- these types). -- Is_Package_Body (Flag5) -- Need documentation for this field ??? -- Is_Private_Type (Flag14) -- Present in all type entities. Set if the type is private or if it -- depends on a private type. -- Is_Private_Descendant (Flag14) -- Present in entities that can represent library units (packages, -- functions, procedures). Set if the library unit is itself a private -- child unit, or if it is the descendent of a private child unit. -- Is_Pure (Flag3) -- Present in functions and procedures. Set by the semantic processing -- to indicate that the subprogram is known to be pure, i.e. to have no -- side effects. -- Is_Task_Record_Type (Flag20) -- Present in record types and subtypes. Set if the type was created -- by the expander to represent a task type. For every task type, -- type, such as record type is constructed, and task objects are -- instances of this record type at runtime (Gigi will replace -- declarations of the task type by declarations of the corresponding -- record type. See package Exp_Ch9 for further details. -- Is_Volatile (Flag16) -- Present in all type entities, and also in constants, components and -- variables. Set if a pragma Volatile applies to the entity. -- Last_Entity (Node10) -- Present in all entities which act as scopes to which a list of -- associated entities is attached (blocks, class subtypes and types, -- entries, functions, loops, packages, procedures, protected objects, -- record types and subtypes, task types and subtypes). Points to the -- last entry in the list of associated entities chained through the -- Next_Entity field. Empty if no entities are chained. -- Lit_Name_Table (Node7) -- Present in enumeration types and subtypes. Points to the entity -- (which is of the special type E_Enum_Table_Type) for a table of -- accesses to strings, generated by Gigi for each enumeration type. -- The table is an array whose index values are 'Pos values and whose -- entries are access to string, where each string is the 'Image value. -- Master_Id (Node9) -- Present in access types and subtypes. . Empty unless Has_Tasks is -- set for the designated type, in which case it points to the entity -- for the Master_Id for the access type master. -- Needs_Discr_Check (Flag5) -- Present in components. Set if the references to this component need -- a discriminant check. -- Original_Record_Component (Node8) -- Present for components. When this component is inherited in a record -- extension, it points to the original component (the entity of the -- ancestor component which is not itself inherited) otherwise it points -- to itself. Gigi uses this attribute to implement the automatic -- dereference in the extension and to apply the transformation: -- Rec_Ext.Comp ===> Rec_Ext.Parent. ... .Parent.Comp -- Parent_Subtype (Node11) -- Defined for all scalar types and subtypes. Always Empty for types. -- For subtypes, references the entity for the type or subtype from -- which the subtype was immediately obtained. This attribute is used -- in recognizing some cases of range checking which can be eliminated -- at compile time. -- Primitive_Operations (Elist7) -- Present in tagged record types and subtypes and in tagged private -- types. Points to an element list of entities for primitive operations -- for the tagged type. Not present in untagged types. -- Renamed_Object (Node7) -- Present in constants and variables. References the entity for the -- renamed object. -- Scalar_Range (Node10) -- Present in all scalar types (including modular types, where the -- bounds are 0 .. modulus - 1). References a node in the tree that -- contains the bounds for the range. Note that this information -- could be obtained by rummaging around the tree, but it is more -- convenient to have it immediately at hand in the entity. -- String_Literal_Length (Uint11) -- Present in string literal subtypes (which are created to correspond -- to string literals in the program). Contains the length of the string -- literal. -- Slice_Range (Node11) -- Present in slice subtypes, which are created to represent the type -- of slices appearing in the program. References the N_Discrete_Range -- node of the slice for which this subtype was created. -- Table_High_Bound (Node11) -- Present in the special Enum_Table_Type entities created to -- represent the Lit_Name_Table created by Gigi. Contains the high -- bound (i.e. number of entries minus one) of the created table. -- Equal to Enum_Type'Pos (Enum_Type'Last). -- Task_Value_Type (Node7) -- Present in task types and subtypes. References the entity for the -- corresponding record type constructed by the expander (see Exp_Ch9). -- This type is used to represent values of the task type. -- Each identifier which is not a defining occurrence holds a pointer -- to its defining occurrence (its Entity). -- Type checking and overload resolution decorate each identifier and each -- expression with a type as well. ------------------ -- Access Kinds -- ------------------ -- The following three entity kinds are introduced by the corresponding -- type definitions: -- E_Access_Type, E_General_Access_Type, E_Anonymous_Access_Type. -- In addition, we define the kind E_Allocator_Type to label allocators -- and attribute references with 'Access. This is because special -- resolution rules apply to these constructs. Eventually the constructs -- are labelled with the access type imposed by the context. Gigi should -- never see the type E_Allocator. -- Finally, the type Any_Access is used to label -null- during type -- resolution. Any_Access is also replaced by the context type after -- resolution. -------------------------------------------------------------- -- Description of Defined Access Functions for Entity_Kinds -- -------------------------------------------------------------- -- For each enumeration value defined in Entity_Kind we list all -- the access functions defined in Einfo which can legally be applied -- to an entity of that kind. The implementation of the access functions -- themselves is given in the Einfo body. Many of these access functions -- are simply references to fields in the entity, and in this case the -- corresponding field is given in the description. If no field is given, -- then the access function involves more processing than simply accessing -- a single field or flag. -- The following list of access functions applies to all entities for -- types and subtypes. References to this list appear subsequently as -- as "(plus type functions)" for each appropriate Entity_Kind. -- Base_Type -- Esize (Uint12) -- Init_Proc (Node8) -- Is_Abstract (Flag19) -- Is_Access_Type -- Is_Array_Type -- Is_Boolean_Type -- Is_Character_Type -- Is_Composite_Type -- Is_Discrete_Type -- Is_Elementary_Type -- Is_Enumeration_Type -- Is_Fixed_Type -- Is_Float_Type -- Is_Frozen (Flag4) -- Is_Generic_Type (Flag6) -- Is_Incomplete_Type -- Is_Integer_Type -- Is_Internal (Flag2) -- Is_Limited_Type -- Is_Numeric_Type -- Is_Packed -- Is_Private_Type -- Is_Protected_Type -- Is_Real_Type -- Is_Record_Type -- Is_Scalar_Type -- Is_String_Type -- Is_Task_Type -- Is_Tagged_Type (Flag8) -- Is_Type -- Is_Volatile (Flag16) -- Next_Index -- Root_Type -- Applicable access functions by entity kind -- E_Access_Subprogram_Type -- Directly_Designated_Type (Node10) -- (plus type functions) -- E_Access_Type -- E_Access_Subtype -- Master_Id (Node9) -- Directly_Designated_Type (Node10) -- (plus type functions) -- E_Allocator_Type -- Directly_Designated_Type (Node10) -- (plus type functions) -- E_Array_Type -- E_Array_Subtype -- Component_Type (Node10) -- First_Index (Node9) -- Is_Constrained (Flag3) -- Number_Dimensions -- (plus type functions) -- E_Anonymous_Access_Type -- Directly_Designated_Type (Node10) -- (plus type functions) -- E_Block -- First_Entity (Node9) -- Last_Entity (Node10) -- E_Boolean_Type -- First_Literal (Node9) -- Parent_Subtype (Node11) -- Scalar_Range (Node10) -- Type_Low_Bound -- Type_High_Bound -- (plus type functions) -- E_Character_Type -- First_Literal (Node9) -- Parent_Subtype (Node11) -- Scalar_Range (Node10) -- Type_Low_Bound -- Type_High_Bound -- (plus type functions) -- E_Class_Subtype -- First_Component -- Equivalent_Type (Node7) -- First_Entity (Node9) -- Last_Entity (Node10) -- (plus type functions) -- E_Class_Type -- First_Component -- First_Entity (Node9) -- Last_Entity (Node10) -- (plus type functions) -- E_Component -- Discriminant_Checking_Func (Node10) -- Internal_Access_Disp_Table (Node11) -- Esize (Uint12) -- Is_Volatile (Flag16) -- Needs_Discr_Check (Flag5) -- Next_Component -- Original_Record_Component (Node8) -- E_Constant -- Esize (Uint12) -- Full_Declaration (Node11) -- Is_Volatile (Flag16) -- Renamed_Object (Node7) -- E_Decimal_Type -- E_Decimal_Subype -- To be specified ??? -- E_Discriminant -- Discriminant_Default_Value (Node10) -- Next_Discriminant -- Discriminal -- E_Entry -- First_Formal -- First_Entity (Node9) -- Last_Entity (Node10) -- Entry_Index (Uint11) -- E_Entry_Family -- Entry_Index (Uint11) -- E_Enumeration_Literal -- Alias (Node7) -- Enumeration_Pos (Uint11) -- Enumeration_Rep (Uint12) -- Next_Literal -- E_Enumeration_Type -- E_Enumeration_Subtype -- First_Literal (Node9) -- Lit_Name_Table (Node7) -- Parent_Subtype (Node11) -- Scalar_Range (Node10) -- Type_Low_Bound -- Type_High_Bound -- (plus type functions) -- E_Enum_Table_Type -- Component_Type (Node10) -- Table_High_Bound (Node11) -- E_Exception -- E_Exception_Type -- (no additional fields) -- E_Fixed_Type -- E_Fixed_Subtype -- Parent_Subtype (Node11) -- Scalar_Range (Node10) -- Type_Low_Bound -- Type_High_Bound -- (plus type functions) -- E_Float_Type -- E_Float_Subtype -- Parent_Subtype (Node11) -- Scalar_Range (Node10) -- Type_Low_Bound -- Type_High_Bound -- (plus type functions) -- E_Formal_Derived_Type -- E_Formal_Generic_Package -- E_Function -- E_Generic_Function -- Alias (Node7) -- First_Entity (Node9) -- First_Formal -- Has_Completion (Flag26) -- Has_Subprogram_Body (Flag5) -- Interface_Name (Node12) -- Is_Intrinsic (Flag27) -- Is_Dispatching_Operation (Flag6) -- Is_Inlined (Flag11) -- Is_Private_Descendant (Flag14) -- Is_Pure (Flag3) -- Is_Abstract (Flag19) -- Last_Entity -- E_General_Access_Type -- Master_Id (Node9) -- Directly_Designated_Type (Node10) -- (plus type functions) -- E_Incomplete_Type -- Discriminant_Constraint (Elist2) -- First_Discriminant -- Full_Declaration (Node11) -- Has_Discriminants (Flag5) -- (plus type functions) -- E_In_Parameter -- E_Generic_In_Parameter -- Default_Value (Node10) -- Parameter_Mode -- E_In_Out_Parameter -- E_Generic_In_Out_Parameter -- Parameter_Mode -- E_Integer_Type -- E_Integer_Subtype -- Parent_Subtype (Node11) -- Scalar_Range (Node10) -- Type_Low_Bound -- Type_High_Bound -- (plus type functions) -- E_Label -- Reachable (Flag5) -- E_Limited_Private_Type -- Discriminant_Constraint (Elist2) -- First_Discriminant -- Full_Declaration (Node11) -- Has_Completion (Flag26) -- Has_Discriminants (Flag5) -- (plus type functions) -- E_Limited_Type -- E_Loop -- Has_Exit (Flag5) -- E_Modular_Type -- E_Modular_Subtype -- Modulus (Uint9) -- Scalar_Range (Node10) -- Parent_Subtype (Node11) -- Type_Low_Bound -- Type_High_Bound -- (plus type functions) -- E_Named_Integer -- (no additional fields) -- E_Named_Real -- (no additional fields) -- E_Out_Parameter -- Parameter_Mode -- E_Package -- E_Generic_Package -- First_Entity (Node9) -- First_Private_Entity (Node11) -- Has_Completion (Flag26) -- In_Private_Part (Flag4) -- In_Use (Flag8) -- Is_Package_Body (Flag5) -- Is_Private_Descendant (Flag14) -- Last_Entity (Node10) -- E_Package_Body -- (no additional fields) -- E_Private_Type -- Discriminant_Constraint (Elist2) -- First_Discriminant -- Full_Declaration (Node11) -- Has_Completion (Flag26) -- Has_Discriminants (Flag5) -- Primitive_Operations (Elist7) [if Is_Tagged] -- (plus type functions) -- E_Procedure -- E_Generic_Procedure -- Alias (Node7) -- First_Entity (Node9) -- Interface_Name (Node12) -- First_Formal -- Has_Completion (Flag26) -- Has_Subprogram_Body (Flag5) -- Is_Intrinsic (Flag27) -- Is_Dispatching_Operation (Flag6) -- Is_Inlined (Flag11) -- Is_Private_Descendant (Flag14) -- Is_Pure (Flag3) -- Is_Abstract (Flag19) -- Last_Entity -- E_Protected_Body -- (no additional fields) -- E_Protected_Object -- First_Entity (Node9) -- Last_Entity (Node10) -- E_Protected_Type -- E_Protected_Subtype -- First_Private_Entity (Node11) -- Has_Discriminants (Flag5) -- E_Record_Type -- E_Record_Subtype -- Discriminant_Constraint (Elist2) -- Access_Disp_Table -- First_Component -- First_Discriminant -- First_Entity (Node9) -- Has_Discriminants (Flag5) -- Is_Constrained (Flag3) -- Is_Task_Record_Type (Flag20) -- Last_Entity (Node10) -- Primitive_Operations (Elist7) [if Is_Tagged] -- Corresponding_Task_Type (Node7) [if not Is_Tagged] -- Tag_Component -- (plus type functions) -- E_Slice_Subtype -- Component_Type (Node10) -- Slice_Range (Node11) -- (plus type functions) -- E_String_Type -- E_String_Subtype -- Component_Type (Node10) -- First_Index (Node9) -- Is_Constrained (Flag3) -- Number_Dimensions -- (plus type functions) -- E_String_Literal_Subtype -- Component_Type (Node10) -- String_Literal_Length (Uint11) -- (plus type functions) -- E_Subprogram_Body -- (no additional fields) -- E_Subprogram_Type -- Directly_Designated_Type (Node10) -- First_Formal -- (plus type functions) -- E_Task_Body -- (no additional fields) -- E_Task_Type -- E_Task_Subtype -- Discriminant_Constraint (Elist2) -- First_Entity (Node9) -- Has_Discriminants (Flag5) -- Last_Entity (Node10) -- Task_Value_Type (Node7) -- First_Private_Entity (Node11) -- (plus type functions) -- E_Variable -- Esize (Uint12) -- Is_Volatile (Flag16) -- Renamed_Object (Node7) -- E_Void -------------------------------- -- Classification of Entities -- -------------------------------- -- The classification of program entities which follows is a refinement of -- the list given in RM 3.1(1). E.g., separate entities denote subtypes of -- different type classes. Ada9X entities include class_wide types, -- protected types, subprogram types, generalized access types, generic -- formal derived types and generic formal packages. -- The order chosen for these kinds allows us to classify related entities -- sp that they are contiguous. As a result, they do not appear in the -- exact same order as their order of first appearance in the LRM (For -- example, private types are listed before packages). The contiguity -- allows us to define useful subtypes (see below) such as type entities, -- overloaded entities, etc. -- Each entity (explicitly or implicitly declared) has a kind, which is -- a value of the following type: type Entity_Kind is ( E_Void, E_Variable, E_Component, E_Constant, E_Named_Integer, E_Named_Real, -- Type entities E_Enumeration_Type, E_Enumeration_Subtype, E_Character_Type, E_Boolean_Type, -- Numeric types E_Integer_Type, E_Integer_Subtype, E_Modular_Type, E_Modular_Subtype, E_Float_Type, E_Float_Subtype, E_Fixed_Type, E_Fixed_Subtype, E_Decimal_Type, E_Decimal_Subtype, -- Access types E_Access_Type, E_Access_Subtype, E_Allocator_Type, E_General_Access_Type, E_Access_Subprogram_Type, E_Anonymous_Access_Type, -- Composite types E_Array_Type, E_Array_Subtype, E_String_Type, E_String_Subtype, E_String_Literal_Subtype, E_Enum_Table_Type, E_Slice_Subtype, E_Record_Type, E_Class_Subtype, -- Ada9x (Internal) E_Class_Type, -- Ada9X E_Record_Subtype, E_Incomplete_Type, E_Private_Type, E_Limited_Private_Type, E_Limited_Type, E_Task_Type, E_Task_Subtype, E_Protected_Type, E_Protected_Subtype, E_Exception_Type, E_Subprogram_Type, E_Discriminant, E_Loop, E_Loop_Parameter, E_Block, E_Label, -- Overloadable entities E_Enumeration_Literal, E_Function, E_Operator, E_Procedure, E_Entry, -- Parameter entities E_In_Parameter, E_Out_Parameter, E_In_Out_Parameter, -- Other entities E_Package, E_Package_Body, E_Protected_Body, E_Protected_Object, E_Entry_Family, E_Exception, E_Generic_Package, E_Generic_Function, E_Generic_Procedure, E_Generic_In_Parameter, E_Generic_In_Out_Parameter, E_Formal_Derived_Type, E_Formal_Generic_Package, E_Task_Body, E_Subprogram_Body ); subtype Type_Kind is Entity_Kind range E_Enumeration_Type .. -- E_Enumeration_Subtype -- E_Boolean_Type -- E_Integer_Type -- E_Integer_Subtype -- E_Modular_Type -- E_Modular_Subtype -- E_Float_Type -- E_Float_Subtype -- E_Fixed_Type -- E_Fixed_Subtype -- E_Decimal_Type -- E_Decimal_Subtype -- E_Access_Type -- E_Access_Subprogram_Type, -- E_Allocator_Type, -- E_General_Access_Type -- E_Anonymous_Access_Type -- E_Array_Type -- E_Array_Subtype -- E_Record_Type -- E_Class_Subtype -- E_Class_Type -- E_Record_Subtype -- E_Incomplete_Type -- E_Private_Type -- E_Limited_Private_Type -- E_Limited_Type -- E_Task_Type -- E_Task_Subtype -- E_Protected_Type -- E_Protected_Subtype -- E_Exception_Type E_Subprogram_Type; subtype Boolean_Kind is Entity_Kind range E_Boolean_Type .. E_Boolean_Type; subtype Integer_Kind is Entity_Kind range E_Integer_Type .. -- E_Integer_Subtype -- E_Modular_Type E_Modular_Subtype; subtype Signed_Integer_Kind is Entity_Kind range E_Integer_Type .. E_Integer_Subtype; subtype Modular_Kind is Entity_Kind range E_Modular_Type .. E_Modular_Subtype; subtype Discrete_Kind is Entity_Kind range E_Enumeration_Type .. -- E_Enumeration_Subtype -- E_Integer_Type -- E_Integer_Subtype -- E_Modular_Type E_Modular_Subtype; subtype Enumeration_Kind is Entity_Kind range E_Enumeration_Type .. -- E_Enumeration_Subtype -- E_Character_Type E_Boolean_Type; subtype Real_Kind is Entity_Kind range E_Float_Type .. -- E_Float_Subtype -- E_Fixed_Type -- E_Fixed_Subtype -- E_Decimal_Type E_Decimal_Subtype; subtype Float_Kind is Entity_Kind range E_Float_Type .. E_Float_Subtype; subtype Fixed_Kind is Entity_Kind range E_Fixed_Type .. -- E_Fixed_Subtype -- E_Decimal_Type E_Decimal_Subtype; subtype Protected_Kind is Entity_Kind range E_Protected_Type .. E_Protected_Subtype; subtype Task_Kind is Entity_Kind range E_Task_Type .. E_Task_Subtype; subtype Numeric_Kind is Entity_Kind range E_Integer_Type .. -- E_Integer_Subtype -- E_Modular_Type -- E_Modular_Subtype -- E_Float_Type -- E_Float_Subtype -- E_Fixed_Type -- E_Fixed_Subtype -- E_Decimal_Type E_Decimal_Subtype; subtype Scalar_Kind is Entity_Kind range E_Enumeration_Type .. -- E_Enumeration_Subtype -- E_Boolean_Type -- E_Integer_Type -- E_Integer_Subtype -- E_Modular_Type -- E_Modular_Subtype -- E_Float_Type -- E_Float_Subtype -- E_Fixed_Type -- E_Fixed_Subtype -- E_Decimal_Type E_Decimal_Subtype; subtype Access_Kind is Entity_Kind range E_Access_Type .. -- E_Access_Subtype -- E_Allocator_Type -- E_General_Access_Type -- E_Access_Subprogram_Type E_Anonymous_Access_Type; subtype Incomplete_Kind is Entity_Kind range E_Incomplete_Type .. -- E_Private_Type -- E_Limited_Private_Type E_Limited_Type; subtype Private_Kind is Entity_Kind range E_Private_Type .. E_Limited_Private_Type; subtype Overloaded_Kind is Entity_Kind range E_Enumeration_Literal .. -- E_Function -- E_Procedure E_Entry; subtype Subprogram_Kind is Entity_Kind range E_Function .. E_Procedure; subtype Formal_Kind is Entity_Kind range E_In_Parameter .. -- E_Out_Parameter E_In_Out_Parameter; subtype Named_Kind is Entity_Kind range E_Named_Integer .. E_Named_Real; subtype Array_Kind is Entity_Kind range E_Array_Type .. -- E_Array_Subtype -- E_String_Type -- E_String_Subtype -- E_String_Literal_Subtype E_Slice_Subtype; subtype Record_Kind is Entity_Kind range E_Record_Type .. -- E_Class_Type -- E_Class_Subtype E_Record_Subtype; subtype String_Kind is Entity_Kind range E_String_Type .. -- E_String_Subtype E_String_Literal_Subtype; subtype Composite_Kind is Entity_Kind range E_Array_Type .. -- E_Array_Subtype -- E_String_Type -- E_String_Subtype -- E_String_Literal_Subtype -- E_Slice_Subtype -- E_Record_Type -- E_Class_Type -- E_Class_Subtype -- E_Record_Subtype -- E_Incomplete_Type -- E_Private_Type -- E_Limited_Private_Type -- E_Limited_Type -- E_Task_Type -- E_Task_Subtype, -- E_Protected_Type, E_Protected_Subtype; --------------- -- Iterators -- --------------- -- In addition to attributes that are stored as plain data, other -- attributes are procedural, and require some small amount of -- computation. Of course, from the point of view of a user of this -- package, the distinction is not visible (even the field information -- provided below should be disregarded, as it is subject to change -- without notice!). A number of attributes appear as lists: lists of -- formals, lists of actuals, of discriminants, etc. For these, pairs -- of functions are defined, which take the form: -- function First_Thing (E : Enclosing_Construct) return Thing; -- function Next_Thing (T : Thing) return Thing; -- The end of iteration is always signalled by a value of Empty, so that -- loops over these chains invariably have the form: -- This : Thing; -- ... -- This := First_Thing (E); -- while Present (This) loop -- Do_Something_With (This); -- ... -- This := Next_Thing (This); -- end loop; ----------------------------------- -- Handling of Check Suppression -- ----------------------------------- -- There are three ways that checks can be suppressed: -- 1. At the command line level. Package Opt contains global Boolean -- flags with names Suppress_Options.xxx_Checks, where xxx is the -- name of one of the checks that can be suppressed (excluding -- All_Checks, which is simply reflected by setting all the -- individual flags) -- 2. At the scope level. The body of Sem contains flags with names -- Suppress.xxx_Checks which are set to indicate that the given -- check is suppressed for the current scope. These flags are -- saved in the scope stack on entry to a scope and restored on -- exit from the scope. -- 3. At the entity level. Each entity contains a set of flags named -- Suppress_xxx_Checks which suppress the given check for that -- particularly entity (of course not all flags are meaningful for -- all entities). ------------------------------- -- Handling of Discriminants -- ------------------------------- -- During semantic processing, discriminants are separate entities which -- reflect the semantic properties and allowed usage of discriminants in -- the language. -- In the case of discriminants used as bounds, the references are handled -- directly, since special processing is needed in any case. However, there -- are two circumstances in which discriminants are referenced in a quite -- general manner, like any other variables: -- In initialization expressions for records. Note that the expressions -- in Priority and Task_Stack_Size pragmas are effectively in this -- category, since these pragmas are converted to initialized record -- fields in the Task_Value_Type. -- In task and protected bodies, where the discriminant values may be -- referenced freely within these bodies. -- In both these cases, the discriminants must be treated essentially as -- objects. The following approach is used to simplify and minimize the -- special processing that is required. -- When a record type with discriminants is processed, the semantic -- processing creates the entities for the discriminants. It also creates -- an additional set of entities, called discriminals, one for each of -- the discriminants, and the Discriminal field of the discriminant entity -- points to this additional entity, which is initially created as an -- uninitialized (E_Void) entity. -- During expansion of expressions, any discriminant reference is replaced -- by a reference to the corresponding discriminal. When the initialization -- procedure for the record is created (there will always be one, since -- discriminants are present, see Exp_Ch3 for further details), the -- discriminals are used as the entities for the formal parameters of -- this initialization procedure. The references to these discriminants -- have already been replaced by references to these discriminals, which -- are now the formal parameters corresponding to the required objects. -- In the case of a task or protected body, the semantics similarly -- creates a set of discriminals for the discriminants of the task or -- protected type. When the procedure is created for the task body, -- the parameter passed in is a reference to the task value type, which -- contains the required discriminant values. The expander creates a -- set of declarations of the form: -- discriminal : constant dtype renames _Task.discriminant; -- where disriminal is the discriminal entity referenced by the task -- discriminant, and _Task is the task value passed in as the parameter. -- Again, any references to discriminants in the task body have been -- replaced by the discriminal reference, which is now an object that -- contains the required value. -- This approach for tasks means that two sets of discriminals are needed -- for a task type, one for the initialization procedure, and one for the -- task body. This works out nicely, since the semantics allocates one set -- for the task itself, and one set for the corresponding record. -- The one bit of trickiness arises in making sure that the right set of -- discriminals is used at the right time. First the task definition is -- processed. Any references to discriminants here are replaced by the -- the corresponding *task* discriminals (the record type doesn't even -- exist yet, since it is constructed as part of the expansion of the -- task declaration, which happens after the semantic processing of the -- task definition). -- Just before the record initialization routine is constructed, the -- expander exchanges the task and record discriminals. This has two -- effects. First the generation of the record initialization routine -- uses the discriminals that are now on the record, which is the set -- that used to be on the task, which is what we want. -- Second, a new set of (so far unused) discriminals is now on the task -- discriminants, and it is this set that will be used for expanding the -- task body, and also for the discriminal declarations at the start of -- the task body. ----------------------- -- Access Functions -- ----------------------- -- All attributes are manipulated through a procedural interface. This -- section contains the functions used to obtain attribute values. function Corresponding_Task_Type (Id : Entity_Id) return Entity_Id; function Homonym (Id : Entity_Id) return Entity_Id; function Scope (Id : Entity_Id) return Entity_Id; function Next_Entity (Id : Entity_Id) return Entity_Id; function First_Entity (Scope_Id : Entity_Id) return Entity_Id; function Last_Entity (Scope_Id : Entity_Id) return Entity_Id; function Master_Id (Access_Id : Entity_Id) return Entity_Id; function Is_Directly_Visible (Id : Entity_Id) return Boolean; function Is_Use_Visible (Id : Entity_Id) return Boolean; function Has_Homonym (Id : Entity_Id) return Boolean; function Has_Completion (Id : Entity_Id) return Boolean; function Has_Master_Entity (Id : Entity_Id) return Boolean; function Has_Tasks (Id : Entity_Id) return Boolean; function Constant_Value (Constant_Id : Entity_Id) return Node_Id; function Renamed_Object (Id : Entity_Id) return Node_Id; function Root_Type (Type_Id : Entity_Id) return Entity_Id; function Esize (Type_Id : Entity_Id) return Uint; function Is_Delayed (E : Entity_Id) return Boolean; function Is_Generic_Type (Type_Id : Entity_Id) return Boolean; function Is_Frozen (Type_Id : Entity_Id) return Boolean; function First_Literal (Type_Id : Entity_Id) return Entity_Id; function Next_Literal (Id : Entity_Id) return Entity_Id; function Lit_Name_Table (Id : Entity_Id) return Entity_Id; function Scalar_Range (Type_Id : Entity_Id) return Node_Id; function Modulus (Type_Id : Entity_Id) return Uint; function Type_Low_Bound (Type_Id : Entity_Id) return Node_Id; function Type_High_Bound (Type_Id : Entity_Id) return Node_Id; -- These functions return the low and high bounds of a scalar type. -- The returned values are literals for a base type, but maybe expressions -- in the case of a subtype with dynamic bounds. function Number_Dimensions (Array_Id : Entity_Id) return Pos; function Component_Type (Array_Id : Entity_Id) return Entity_Id; function First_Index (Array_Id : Entity_Id) return Node_Id; -- By introducing implicit subtypes for the index constraints, -- we obtain the same structure for constrained and unconstrained -- arrays: subtype marks and discrete ranges are both lists of -- subtypes. First_Index returns the tree node corresponding to the -- Subtype_Marks (index_subtype_definition) in the case of -- E_Array_Type and Discrete_Subtype_Definitions (index constraint) -- in the case of an E_Array_Subtype. To get the defining occurence -- representing the type or subtype corresponding to the first index -- it is necessary to retrieve the Etype (First_Index (Array_Id)). function Next_Index (Index_Id : Entity_Id) return Node_Id; -- Return the tree node (in a way similar to First_Index) of the next -- index_subtype_definition or index_constraint. function Is_Constrained (Type_Id : Entity_Id) return Boolean; function Has_Discriminants (Type_Id : Entity_Id) return Boolean; function First_Discriminant (Type_Id : Entity_Id) return Entity_Id; -- The discriminants are always the first entities declared in a -- record type except in the case of tagged types. For tagged -- types, the tag is prepended to the front of the entity chain -- during Expander phase of compilation. Therefore the First_Entity -- needs to be checked if it is a tag and if so the Next_Entity -- must be returned. This check must be explicit since even for -- tagged types the tag will not exist during the Sem phase. -- The caller of First_Discriminant should always make sure -- that the record type has discriminants (either by the explicit -- context or by calling Has_Discriminants). A debug check is made -- to trap violations of this rule. function Next_Discriminant (Id : Entity_Id) return Entity_Id; -- Follow the chain of declared entities as long as the kind of -- the entity corresponds to a discriminant. Note that the -- discriminants might be the only components of the record. function Init_Proc (Type_Id : Entity_Id) return Entity_Id; function Base_Init_Proc (Type_Id : Entity_Id) return Entity_Id; -- Gets the Init_Proc field from the base type of Type_Id, and also -- deals with going indirect through the Task_Value_Type field for -- tasks (tasks are initialized using the initialization routine -- for the associated record type). function Primitive_Operations (Id : Entity_Id) return Elist_Id; function Discriminant_Constraint (Type_Id : Entity_Id) return Elist_Id; function Internal_Access_Disp_Table (Component_Id : Entity_Id) return Entity_Id; -- Only used on the component "_Tag" of a tagged type by Access_Disp_Table. function Access_Disp_Table (Rec_Id : Entity_Id) return Entity_Id; -- Gives the pointer to the Dispatch Table associated with a tagged type function Is_Dispatching_Operation (Overloaded_Id : Entity_Id) return Boolean; function Tag_Component (Rec_Id : Entity_Id) return Entity_Id; function First_Component (Rec_Id : Entity_Id) return Entity_Id; -- Follow the chain of declared entities for the record until the -- first component is found (one with an Ekind of E_Variable). -- The discriminants are skipped over. Note that the record might -- be null, in which case Empty will be returned. function Next_Component (Id : Entity_Id) return Entity_Id; -- Follow the chain of declared entities until one is found -- which corresponds to a component (Ekind is E_Variable). Any -- internal types generated from the subtype indications of the -- record components are skipped. function Directly_Designated_Type (Access_Id : Entity_Id) return Entity_Id; function Designated_Type (Access_Id : Entity_Id) return Entity_Id; -- Differs from Directly_Designated_Type in that if the access type refers -- to an incomplete type, and the full type is available, then this full -- type is returned instead of the incomplete type. function Full_Declaration (Private_Id : Entity_Id) return Entity_Id; function Discriminant_Checking_Func (Id : Entity_Id) return Entity_Id; function Discriminant_Default_Value (Id : Entity_Id) return Node_Id; function Discriminal (Id : Entity_Id) return Node_Id; function Has_Address_Clause (Id : Entity_Id) return Boolean; function Has_Size_Clause (Id : Entity_Id) return Boolean; function Has_Storage_Size_Clause (Id : Entity_Id) return Boolean; function Is_Elementary_Type (Type_Id : Entity_Id) return Boolean; function Is_Scalar_Type (Type_Id : Entity_Id) return Boolean; function Is_Discrete_Type (Type_Id : Entity_Id) return Boolean; function Is_Enumeration_Type (Type_Id : Entity_Id) return Boolean; function Is_Boolean_Type (Type_Id : Entity_Id) return Boolean; function Is_Character_Type (Type_Id : Entity_Id) return Boolean; function Is_Integer_Type (Type_Id : Entity_Id) return Boolean; function Is_Real_Type (Type_Id : Entity_Id) return Boolean; function Is_Fixed_Type (Type_Id : Entity_Id) return Boolean; function Is_Float_Type (Type_Id : Entity_Id) return Boolean; function Is_Numeric_Type (Type_Id : Entity_Id) return Boolean; function Is_Composite_Type (Type_Id : Entity_Id) return Boolean; function Is_Array_Type (Type_Id : Entity_Id) return Boolean; function Is_String_Type (Type_Id : Entity_Id) return Boolean; function Is_Record_Type (Type_Id : Entity_Id) return Boolean; function Is_Access_Type (Type_Id : Entity_Id) return Boolean; function Is_Task_Type (Type_Id : Entity_Id) return Boolean; function Is_Tagged_Type (Type_Id : Entity_Id) return Boolean; function Is_Task_Record_Type (Type_Id : Entity_Id) return Boolean; function Is_Protected_Type (Type_Id : Entity_Id) return Boolean; function Is_Limited_Type (Type_Id : Entity_Id) return Boolean; function Is_Incomplete_Type (Type_Id : Entity_Id) return Boolean; function Is_Internal (Type_Id : Entity_Id) return Boolean; function Is_Packed (Type_Id : Entity_Id) return Boolean; function Is_Private_Type (Type_Id : Entity_Id) return Boolean; function Is_Subprogram (Type_Id : Entity_Id) return Boolean; function Is_Named_Number (Type_Id : Entity_Id) return Boolean; function Is_Abstract (Id : Entity_Id) return Boolean; function Is_Aliased (Id : Entity_Id) return Boolean; function Is_Imported (Id : Entity_Id) return Boolean; function Is_Inlined (Id : Entity_Id) return Boolean; function Is_Private (Id : Entity_Id) return Boolean; function Is_Public (Id : Entity_Id) return Boolean; function Is_Pure (Proc_Id : Entity_Id) return Boolean; function Is_Type (Id : Entity_Id) return Boolean; function Is_Volatile (Id : Entity_Id) return Boolean; function Parent_Subtype (Id : Entity_Id) return Entity_Id; function Reachable (Label_Id : Entity_Id) return Boolean; function Slice_Range (Id : Entity_Id) return Node_Id; function String_Literal_Length (Id : Entity_Id) return Uint; function Subtype_Kind (K : Entity_Kind) return Entity_Kind; -- Given an entity_kind K this function returns the entity_kind -- corresponding to subtype kind of the type represented by K. -- So for example if K is E_Integer_Type then E_Integer_Subtype is -- returned. If K is already a subtype kind it itself is returned. An -- internal error is generated if no such correspondence exists for K. function Table_High_Bound (Id : Entity_Id) return Node_Id; function Needs_Discr_Check (Id : Entity_Id) return Boolean; function Has_Exit (Loop_Id : Entity_Id) return Boolean; function First_Formal (Overloaded_Id : Entity_Id) return Entity_Id; -- Return first formal of a subprogram or subprogram type. The formals -- are the first entities declared in a subprogram, or in a subprogram -- type (the designated type of an Access_To_Subprogram definition. function Next_Formal (Formal_Id : Entity_Id) return Entity_Id; -- Returns next formal of a subprogram or subprogram type. Returns -- Empty if Formal_Id is the last formal. function Parameter_Mode (Formal_Id : Entity_Id) return Formal_Kind; function Next_Overloads (Overloaded_Id : Entity_Id) return Entity_Id; function Alias (Overloaded_Id : Entity_Id) return Entity_Id; -- Return the parent subprogram of a derived subprogram function Needs_No_Actuals (Overloaded_Id : Entity_Id) return Boolean; function Interface_Name (Proc_Id : Entity_Id) return Node_Id; function Is_Intrinsic (Proc_Id : Entity_Id) return Boolean; function First_Actual (Node : Node_Id) return Node_Id; -- If positional parameters are present, then the first of these is -- returned, otherwise First_Named_Actual is used to find the first -- named parameter in declaration order. If there are no parameters, -- (i.e. the call is a parameterless call), then Empty is returned. -- Note that because the parameters are returned in declaration order, -- not in the call order, this does not correspond to simply taking the -- first entry in the Parameter_Associations list. function Next_Actual (Actual_Id : Node_Id) return Node_Id; -- Find next actual parameter in declaration order. Again since we use -- declaration order, rather than call order, this does not correspond -- to simply taking the next entry of the Parameter_Associations list. function Is_Overloadable (Id : Entity_Id) return Boolean; function Entry_Index (Id : Entity_Id) return Uint; function Enumeration_Pos (Enum_Id : Entity_Id) return Uint; function Enumeration_Rep (Enum_Id : Entity_Id) return Uint; function Has_Subprogram_Body (Subprogram_Id : Entity_Id) return Boolean; function Default_Value (In_Id : Entity_Id) return Node_Id; function Is_Package_Body (Package_Id : Entity_Id) return Boolean; function In_Private_Part (Package_Id : Entity_Id) return Boolean; function In_Use (Package_Id : Entity_Id) return Boolean; function Is_Private_Descendant (Id : Entity_Id) return Boolean; function Base_Type (Type_Id : Entity_Id) return Entity_Id; -- Return base type of a type or subtype. The base type of a type is -- the type itself. The base of a subtype is the type that it constrains function First_Private_Entity (Package_Id : Entity_Id) return Entity_Id; function Original_Record_Component (Id : Entity_Id) return Entity_Id; function Task_Value_Type (Id : Entity_Id) return Entity_Id; function Suppress_Access_Checks (E : Entity_Id) return Boolean; function Suppress_Accessibility_Checks (E : Entity_Id) return Boolean; function Suppress_Discriminant_Checks (E : Entity_Id) return Boolean; function Suppress_Division_Checks (E : Entity_Id) return Boolean; function Suppress_Elaboration_Checks (E : Entity_Id) return Boolean; function Suppress_Index_Checks (E : Entity_Id) return Boolean; function Suppress_Length_Checks (E : Entity_Id) return Boolean; function Suppress_Overflow_Checks (E : Entity_Id) return Boolean; function Suppress_Range_Checks (E : Entity_Id) return Boolean; function Suppress_Storage_Checks (E : Entity_Id) return Boolean; function Suppress_Tag_Checks (E : Entity_Id) return Boolean; function Is_Class_Type (T : Entity_Id) return Boolean; -- true for E_Class_Type and E_Class_Subtype function Classwide_Type (T : Entity_Id) return Entity_Id; -- given a tagged type, find the implicitly defined classwide -- type for it. function Equivalent_Type (Sub_Class : Entity_Id) return Entity_Id; ------------------------------------------ -- Procedures to Set Entity Attributes -- ------------------------------------------ procedure Set_Corresponding_Task_Type (Id : Entity_Id; T : Entity_Id); procedure Set_Scope (Id : Entity_Id; S : Entity_Id); procedure Set_Homonym (Id : Entity_Id; T : Entity_Id); procedure Set_Esize (Type_Id : Entity_Id; S : Uint); procedure Set_Is_Delayed (E : Entity_Id; Status : Boolean := True); procedure Set_Is_Generic_Type (Type_Id : Entity_Id; Status : Boolean := True); procedure Set_Is_Frozen (Type_Id : Entity_Id; Status : Boolean := True); procedure Set_Has_Address_Clause (Id : Entity_Id; Status : Boolean := True); procedure Set_Has_Size_Clause (Id : Entity_Id; Status : Boolean := True); procedure Set_Has_Storage_Size_Clause (Id : Entity_Id; Status : Boolean := True); procedure Set_Has_Homonym (Id : Entity_Id; Status : Boolean := True); procedure Set_Has_Completion (Id : Entity_Id; Status : Boolean := True); procedure Set_Has_Master_Entity (Id : Entity_Id; Status : Boolean := True); procedure Set_Has_Tasks (Id : Entity_Id; Status : Boolean := True); procedure Set_First_Entity (Scope_Id : Entity_Id; Id : Entity_Id); procedure Set_Next_Entity (Prev : Entity_Id; Id : Entity_Id); procedure Set_Renamed_Object (Id : Entity_Id; Object : Node_Id); procedure Set_Scalar_Range (Type_Id : Entity_Id; R_Node : Node_Id); procedure Set_Modulus (Type_Id : Entity_Id; Mod_Value : Uint); procedure Set_Lit_Name_Table (Type_Id : Entity_Id; Table : Entity_Id); procedure Set_First_Index (Array_Id : Entity_Id; Index : Node_Id); procedure Set_First_Literal (Type_Id : Entity_Id; Id : Entity_Id); procedure Set_Is_Constrained (Type_Id : Entity_Id; Status : Boolean := True); procedure Set_Is_Internal (Type_Id : Entity_Id; Status : Boolean := True); procedure Set_Is_Limited_Type (Type_Id : Entity_Id; Status : Boolean := True); procedure Set_Is_Packed (Type_Id : Entity_Id; Status : Boolean := True); procedure Set_Is_Private_Type (Type_Id : Entity_Id; Status : Boolean := True); procedure Set_Is_Private (Id : Entity_Id; Status : Boolean := True); procedure Set_Is_Public (Id : Entity_Id; Status : Boolean := True); procedure Set_Is_Abstract (Id : Entity_Id; Status : Boolean := True); procedure Set_Is_Aliased (Id : Entity_Id; Status : Boolean := True); procedure Set_Is_Imported (Id : Entity_Id; Status : Boolean := True); procedure Set_Is_Inlined (Id : Entity_Id; Status : Boolean := True); procedure Set_Is_Pure (Proc_Id : Entity_Id; Status : Boolean := True); procedure Set_Is_Volatile (Id : Entity_Id; Status : Boolean := True); procedure Set_Is_Tagged_Type (Type_Id : Entity_Id; Status : Boolean := True); procedure Set_Is_Task_Record_Type (Type_Id : Entity_Id; Status : Boolean := True); procedure Set_Has_Discriminants (Type_Id : Entity_Id; Status : Boolean := True); procedure Set_Discriminant_Constraint (Type_Id : Entity_Id; Elist : Elist_Id); procedure Set_Primitive_Operations (Id : Entity_Id; Elist : Elist_Id); procedure Set_Internal_Access_Disp_Table (Component_Id : Entity_Id; Id : Entity_Id); procedure Set_Access_Disp_Table (Rec_Id : Entity_Id; Id : Entity_Id); procedure Set_Is_Dispatching_Operation (Overloaded_Id : Entity_Id; Status : Boolean := True); procedure Set_Init_Proc (Type_Id : Entity_Id; P : Entity_Id); procedure Set_Component_Type (Array_Id : Entity_Id; Ct : Entity_Id); procedure Set_Directly_Designated_Type (Access_Id : Entity_Id; Dt : Entity_Id); procedure Set_Parent_Subtype (Id : Entity_Id; Parent_Id : Entity_Id); procedure Set_Reachable (Label_Id : Entity_Id; Status : Boolean := True); procedure Set_Needs_Discr_Check (Id : Entity_Id; Status : Boolean := True); procedure Set_Has_Exit (Loop_Id : Entity_Id; Status : Boolean := True); procedure Set_Full_Declaration (Private_Id : Entity_Id; Fd : Entity_Id); procedure Set_Discriminant_Default_Value (Id : Entity_Id; Val : Node_Id); procedure Set_Discriminal (Id : Entity_Id; Formal : Entity_Id); procedure Set_Discriminant_Checking_Func (Id : Entity_Id; Proc_Id : Entity_Id); procedure Set_Default_Value (In_Id : Entity_Id; Val : Node_Id); procedure Set_Alias (Overloaded_Id : Entity_Id; Id : Entity_Id); procedure Set_Needs_No_Actuals (Overloaded_Id : Entity_Id; Status : Boolean := True); procedure Set_Interface_Name (Proc_Id : Entity_Id; Lit_Node : Node_Id); procedure Set_Is_Intrinsic (Proc_Id : Entity_Id); procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id); -- The arguments may be parameter associations, whose descendants -- are the optional formal name and the actual parameter. Positional -- parameters are already members of a list, and do not need to be -- chained separately. procedure Set_Entry_Index (Id : Entity_Id; Ev : Uint); procedure Set_Enumeration_Pos (Enum_Id : Entity_Id; Ev : Uint); procedure Set_Enumeration_Rep (Enum_Id : Entity_Id; Ev : Uint); procedure Set_Slice_Range (Id : Entity_Id; R_Node : Node_Id); procedure Set_String_Literal_Length (Id : Entity_Id; Val : Uint); procedure Set_Table_High_Bound (Id : Entity_Id; Val : Node_Id); procedure Set_Has_Subprogram_Body (Subprogram_Id : Entity_Id; Status : Boolean := True); procedure Set_Is_Package_Body (Package_Id : Entity_Id; Status : Boolean := True); procedure Set_In_Private_Part (Package_Id : Entity_Id; Status : Boolean := True); procedure Set_In_Use (Package_Id : Entity_Id; Status : Boolean := True); procedure Set_Is_Private_Descendant (Id : Entity_Id; Status : Boolean := True); procedure Set_Last_Entity (Scope_Id : Entity_Id; Id : Entity_Id); procedure Set_Master_Id (Access_Id : Entity_Id; Id : Entity_Id); procedure Append_Entity (Id : Entity_Id; Scope_Id : Entity_Id); -- Add an entity to the list of entities declared in the given scope procedure Set_Is_Directly_Visible (Id : Entity_Id; Status : Boolean := True); procedure Set_Is_Use_Visible (Id : Entity_Id; Status : Boolean := True); procedure Set_First_Private_Entity (Package_Id : Entity_Id; Id : Entity_Id); procedure Set_Original_Record_Component (Id : Entity_Id; Orig_Id : Entity_Id); procedure Set_Task_Value_Type (Id : Entity_Id; Ent : Entity_Id); procedure Write_Entity_Info (Id : Entity_Id; Prefix : Str); -- A debugging procedure to write out information about an entity procedure Set_Suppress_Access_Checks (E : Entity_Id; V : Boolean := True); procedure Set_Suppress_Accessibility_Checks (E : Entity_Id; V : Boolean := True); procedure Set_Suppress_Discriminant_Checks (E : Entity_Id; V : Boolean := True); procedure Set_Suppress_Division_Checks (E : Entity_Id; V : Boolean := True); procedure Set_Suppress_Elaboration_Checks (E : Entity_Id; V : Boolean := True); procedure Set_Suppress_Index_Checks (E : Entity_Id; V : Boolean := True); procedure Set_Suppress_Length_Checks (E : Entity_Id; V : Boolean := True); procedure Set_Suppress_Overflow_Checks (E : Entity_Id; V : Boolean := True); procedure Set_Suppress_Range_Checks (E : Entity_Id; V : Boolean := True); procedure Set_Suppress_Storage_Checks (E : Entity_Id; V : Boolean := True); procedure Set_Suppress_Tag_Checks (E : Entity_Id; V : Boolean := True); procedure Set_Equivalent_Type (Sub_Class : Entity_Id; Typ : Entity_Id); --------------------- -- Inline Pragmas -- --------------------- private pragma Inline (Access_Disp_Table); pragma Inline (Alias); pragma Inline (Component_Type); pragma Inline (Corresponding_Task_Type); pragma Inline (Default_Value); pragma Inline (Directly_Designated_Type); pragma Inline (Discriminal); pragma Inline (Discriminant_Checking_Func); pragma Inline (Discriminant_Constraint); pragma Inline (Discriminant_Default_Value); pragma Inline (Enumeration_Pos); pragma Inline (Enumeration_Rep); pragma Inline (Equivalent_Type); pragma Inline (Esize); pragma Inline (First_Entity); pragma Inline (First_Index); pragma Inline (First_Literal); pragma Inline (First_Private_Entity); pragma Inline (Has_Address_Clause); pragma Inline (Has_Completion); pragma Inline (Has_Discriminants); pragma Inline (Has_Exit); pragma Inline (Has_Homonym); pragma Inline (Has_Master_Entity); pragma Inline (Has_Size_Clause); pragma Inline (Has_Storage_Size_Clause); pragma Inline (Has_Subprogram_Body); pragma Inline (Has_Tasks); pragma Inline (Homonym); pragma Inline (In_Private_Part); pragma Inline (In_Use); pragma Inline (Init_Proc); pragma Inline (Interface_Name); pragma Inline (Internal_Access_Disp_Table); pragma Inline (Is_Abstract); pragma Inline (Is_Access_Type); pragma Inline (Is_Aliased); pragma Inline (Is_Array_Type); pragma Inline (Is_Boolean_Type); pragma Inline (Is_Character_Type); pragma Inline (Is_Composite_Type); pragma Inline (Is_Constrained); pragma Inline (Is_Delayed); pragma Inline (Is_Directly_Visible); pragma Inline (Is_Discrete_Type); pragma Inline (Is_Dispatching_Operation); pragma Inline (Is_Enumeration_Type); pragma Inline (Is_Fixed_Type); pragma Inline (Is_Float_Type); pragma Inline (Is_Frozen); pragma Inline (Is_Generic_Type); pragma Inline (Is_Imported); pragma Inline (Is_Incomplete_Type); pragma Inline (Is_Inlined); pragma Inline (Is_Integer_Type); pragma Inline (Is_Internal); pragma Inline (Is_Intrinsic); pragma Inline (Is_Limited_Type); pragma Inline (Is_Named_Number); pragma Inline (Is_Numeric_Type); pragma Inline (Is_Overloadable); pragma Inline (Is_Package_Body); pragma Inline (Is_Packed); pragma Inline (Is_Private); pragma Inline (Is_Private_Descendant); pragma Inline (Is_Private_Type); pragma Inline (Is_Protected_Type); pragma Inline (Is_Public); pragma Inline (Is_Pure); pragma Inline (Is_Real_Type); pragma Inline (Is_Record_Type); pragma Inline (Is_Scalar_Type); pragma Inline (Is_Subprogram); pragma Inline (Is_Tagged_Type); pragma Inline (Is_Task_Record_Type); pragma Inline (Is_Task_Type); pragma Inline (Is_Type); pragma Inline (Is_Use_Visible); pragma Inline (Is_Volatile); pragma Inline (Last_Entity); pragma Inline (Lit_Name_Table); pragma Inline (Master_Id); pragma Inline (Modulus); pragma Inline (Needs_Discr_Check); pragma Inline (Needs_No_Actuals); pragma Inline (Next_Entity); pragma Inline (Next_Index); pragma Inline (Next_Literal); pragma Inline (Next_Overloads); pragma Inline (Original_Record_Component); pragma Inline (Parameter_Mode); pragma Inline (Parent_Subtype); pragma Inline (Primitive_Operations); pragma Inline (Reachable); pragma Inline (Renamed_Object); pragma Inline (Scalar_Range); pragma Inline (Scope); pragma Inline (Slice_Range); pragma Inline (String_Literal_Length); pragma Inline (Suppress_Access_Checks); pragma Inline (Suppress_Accessibility_Checks); pragma Inline (Suppress_Discriminant_Checks); pragma Inline (Suppress_Division_Checks); pragma Inline (Suppress_Elaboration_Checks); pragma Inline (Suppress_Index_Checks); pragma Inline (Suppress_Length_Checks); pragma Inline (Suppress_Overflow_Checks); pragma Inline (Suppress_Range_Checks); pragma Inline (Suppress_Storage_Checks); pragma Inline (Suppress_Tag_Checks); pragma Inline (Table_High_Bound); pragma Inline (Task_Value_Type); pragma Inline (Type_High_Bound); pragma Inline (Type_Low_Bound); end Einfo; xit (Loop_Id : Entity_Id; Status : Boolean := True); gnat-1.67-src/src/einfo.adb 444 10015 7640 252622 5506244304 10734 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E I N F O -- -- -- -- B o d y -- -- -- -- $Revision: 1.146 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Comperr; use Comperr; with Debug; use Debug; with Namet; use Namet; with Sinfo; use Sinfo; with Snames; use Snames; with Output; use Output; package body Einfo is use Atree.Unchecked_Access; -- This is one of the packages that is allowed direct untyped access to -- the fields in a node, since it provides the next level abstraction -- which incorporates appropriate checks. ---------------------------------------------- -- Usage of Fields in Defining Entity Nodes -- ---------------------------------------------- -- Chars Name1 -- Discriminant_Constraint Elist2 -- Scope Node3 -- Homonym Node4 -- Etype Node5 -- Next_Entity Node6 -- Alias Node7 -- Corresponding_Task_Type Node7 -- Equivalent_Type Node7 -- Lit_Name_Table Node7 -- Primitive_Operations Elist7 -- Renamed_Object Node7 -- Task_Value_Type Node7 -- Init_Proc Node8 -- Original_Record_Component Node8 -- Discriminal Node9 -- First_Entity Node9 -- First_Index Node9 -- First_Literal Node9 -- Modulus Uint9 -- Master_Id Node9 -- Component_Type Node10 -- Default_Value Node10 -- Discriminant_Checking_Func Node10 -- Discriminant_Default_Value Node10 -- Directly_Designated_Type Node10 -- Last_Entity Node10 -- Scalar_Range Node10 -- Internal_Access_Disp_Table Node11 -- Enumeration_Pos Uint11 -- Entry_Index Uint11 -- First_Private_Entity Node11 -- Full_Declaration Node11 -- Parent_Subtype Node11 -- Slice_Range Node11 -- String_Literal_Length Uint11 -- Table_High_Bound Node11 -- Esize Uint12 -- Enumeration_Rep Uint12 -- Interface_Name Node12 --------------------------------------------- -- Usage of Flags in Defining Entity Nodes -- --------------------------------------------- -- (unused) Flag1 -- Is_Internal Flag2 -- Is_Constrained Flag3 -- Is_Pure Flag3 -- In_Private_Part Flag4 -- Is_Frozen Flag4 -- Has_Discriminants Flag5 -- Has_Subprogram_Body Flag5 -- Has_Exit Flag5 -- Is_Package_Body Flag5 -- Reachable Flag5 -- Needs_Discr_Check Flag5 -- Is_Dispatching_Operation Flag6 -- Is_Generic_Type Flag6 -- Is_Directly_Visible Flag7 -- In_Use Flag8 -- Is_Tagged_Type Flag8 -- Needs_No_Actuals Flag8 -- Is_Use_Visible Flag9 -- Is_Public Flag10 -- Is_Inlined Flag11 -- Is_Packed Flag11 -- Has_Homonym Flag12 -- Is_Private Flag13 -- Is_Private_Descendant Flag14 -- Is_Private_Type Flag14 -- Is_Aliased Flag15 -- Is_Volatile Flag16 -- (unused) Flag17 -- Is_Delayed Flag18 -- Is_Abstract Flag19 -- Is_Task_Record_Type Flag20 -- Has_Master_Entity Flag21 -- (unused) Flag22 -- Has_Storage_Size_Clause Flag23 -- Is_Imported Flag24 -- Is_Limited_Type Flag25 -- Has_Completion Flag26 -- Is_Intrinsic Flag27 -- Has_Address_Clause Flag28 -- Has_Size_Clause Flag29 -- Has_Tasks Flag30 -- Suppress_Access_Checks Flag31 -- Suppress_Accessibility_Checks Flag32 -- Suppress_Discriminant_Checks Flag33 -- Suppress_Division_Checks Flag34 -- Suppress_Elaboration_Checks Flag35 -- Suppress_Index_Checks Flag36 -- Suppress_Length_Checks Flag37 -- Suppress_Overflow_Checks Flag38 -- Suppress_Range_Checks Flag39 -- Suppress_Storage_Checks Flag40 -- Suppress_Tag_Checks Flag41 -------------------------- -- Debugging Procedures -- -------------------------- -- These procedures are called only if assertions are enabled procedure Check_Defining_Occurrence (Id : Entity_Id); -- Debug procedure used to check that a given node denotes the defining -- occurrence of an entity. procedure Check_Type (Id : Entity_Id); -- Debug procedure used to check that a given node denotes the defining -- occurrence of an entity for a type or subtype. procedure Check_Discriminated_Type (Id : Entity_Id); -- Debug procedure used to check that an entity denotes a type that -- can have discriminants (composite type that is not an array type, -- or incomplete type). procedure Check_Entity_Kind (Id : Entity_Id; Kind : Entity_Kind); -- Debug procedure used to check that a given node denotes a defining -- occurrence of a particular Entity_Kind procedure Check_Record_Or_Incomplete_Kind (Id : Entity_Id); -- Debug procedure used to check that a given node denotes a defining -- occurrence which is a record type or an incomplete type. ------------------------------- -- Check_Defining_Occurrence -- ------------------------------- procedure Check_Defining_Occurrence (Id : Entity_Id) is begin if Nkind (Id) not in N_Entity then Compiler_Error; Write_Eol; Write_String ("Not a defining occurence: Node_Id = "); Write_Int (Int (Id)); Write_Eol; Compiler_Abort; end if; end Check_Defining_Occurrence; ----------------------- -- Check_Entity_Kind -- ----------------------- procedure Check_Entity_Kind (Id : Entity_Id; Kind : Entity_Kind) is begin Check_Defining_Occurrence (Id); if Ekind (Id) /= Kind then Compiler_Error; Write_Eol; Write_String ("Occurence of "); Write_String (Entity_Kind'Image (Ekind (Id))); Write_String (" instead of "); Write_String (Entity_Kind'Image (Kind)); Write_Eol; Compiler_Abort; end if; end Check_Entity_Kind; ---------------- -- Check_Type -- ---------------- procedure Check_Type (Id : Entity_Id) is begin Check_Defining_Occurrence (Id); if Ekind (Id) not in Type_Kind then Compiler_Error; Write_Eol; Write_String ("not a type "); Write_String (Entity_Kind'Image (Ekind (Id))); Write_Eol; Compiler_Abort; end if; end Check_Type; ------------------------------ -- Check_Discriminated_Type -- ------------------------------ procedure Check_Discriminated_Type (Id : Entity_Id) is begin Check_Defining_Occurrence (Id); if not Is_Composite_Type (Id) or else Is_Array_Type (Id) then Compiler_Error; Write_Eol; Write_String ("not a discriminated type "); Write_String (Entity_Kind'Image (Ekind (Id))); Write_Eol; Compiler_Abort; end if; end Check_Discriminated_Type; ------------------------------------- -- Check_Record_Or_Incomplete_Kind -- ------------------------------------- procedure Check_Record_Or_Incomplete_Kind (Id : Entity_Id) is begin Check_Defining_Occurrence (Id); if not (Is_Record_Type (Id) or else Is_Incomplete_Type (Id)) then Compiler_Error; Write_Eol; Write_String ("Not a record or incomplete occurence: "); Write_String (Entity_Kind'Image (Ekind (Id))); Write_Eol; Compiler_Abort; end if; end Check_Record_Or_Incomplete_Kind; --------------------------- -- Check_Overloaded_Kind -- --------------------------- procedure Check_Overloaded_Kind (Id : Entity_Id) is begin Check_Defining_Occurrence (Id); if not Is_Overloadable (Id) and then Ekind (Id) /= E_Subprogram_Type then Compiler_Error; Write_Eol; Write_String ("Not a subprogram or enumeration literal : "); Write_String (Entity_Kind'Image (Ekind (Id))); Write_Eol; Compiler_Abort; end if; end Check_Overloaded_Kind; ---------------------- -- Access Functions -- ---------------------- ----------------------------- -- Corresponding_Task_Type -- ----------------------------- function Corresponding_Task_Type (Id : Entity_Id) return Entity_Id is begin pragma Assert (Is_Record_Type (Id) and then not Is_Tagged_Type (Id), Compiler_Abort (Id)); return Node7 (Id); end Corresponding_Task_Type; ------------- -- Homonym -- ------------- function Homonym (Id : Entity_Id) return Entity_Id is begin pragma Debug (Check_Defining_Occurrence (Id)); return Node4 (Id); end Homonym; -------------------- -- Has_Completion -- -------------------- function Has_Completion (Id : Entity_Id) return Boolean is begin pragma Debug (Check_Defining_Occurrence (Id)); return Flag26 (Id); end Has_Completion; --------------- -- Has_Tasks -- --------------- function Has_Tasks (Id : Entity_Id) return Boolean is begin pragma Debug (Check_Defining_Occurrence (Id)); return Flag30 (Id); end Has_Tasks; ----------------------- -- Has_Master_Entity -- ----------------------- function Has_Master_Entity (Id : Entity_Id) return Boolean is begin pragma Debug (Check_Defining_Occurrence (Id)); return Flag21 (Id); end Has_Master_Entity; ------------------------ -- Has_Address_Clause -- ------------------------ function Has_Address_Clause (Id : Entity_Id) return Boolean is begin pragma Debug (Check_Defining_Occurrence (Id)); return Flag28 (Id); end Has_Address_Clause; ----------------- -- Has_Homonym -- ----------------- function Has_Homonym (Id : Entity_Id) return Boolean is begin pragma Debug (Check_Defining_Occurrence (Id)); return Flag12 (Id); end Has_Homonym; --------------------- -- Has_Size_Clause -- --------------------- function Has_Size_Clause (Id : Entity_Id) return Boolean is begin pragma Debug (Check_Defining_Occurrence (Id)); return Flag29 (Id); end Has_Size_Clause; ---------------------------- -- Has_Storage_Size_Clause -- ---------------------------- function Has_Storage_Size_Clause (Id : Entity_Id) return Boolean is begin pragma Debug (Check_Defining_Occurrence (Id)); return Flag23 (Id); end Has_Storage_Size_Clause; ----------------- -- Next_Entity -- ----------------- function Next_Entity (Id : Entity_Id) return Entity_Id is begin pragma Debug (Check_Defining_Occurrence (Id)); return Node6 (Id); end Next_Entity; ------------------ -- First_Entity -- ------------------ function First_Entity (Scope_Id : Entity_Id) return Entity_Id is begin pragma Debug (Check_Defining_Occurrence (Scope_Id)); return Node9 (Scope_Id); end First_Entity; ----------------- -- Last_Entity -- ----------------- function Last_Entity (Scope_Id : Entity_Id) return Entity_Id is begin pragma Debug (Check_Defining_Occurrence (Scope_Id)); return Node10 (Scope_Id); end Last_Entity; --------------- -- Master_Id -- --------------- function Master_Id (Access_Id : Entity_Id) return Entity_Id is begin pragma Debug (Check_Defining_Occurrence (Access_Id)); return Node9 (Access_Id); end Master_Id; ----------- -- Scope -- ----------- function Scope (Id : Entity_Id) return Entity_Id is begin pragma Debug (Check_Defining_Occurrence (Id)); return Node3 (Id); end Scope; ----------- -- Esize -- ----------- function Esize (Type_Id : Entity_Id) return Uint is begin pragma Debug (Check_Defining_Occurrence (Type_Id)); return Uint12 (Type_Id); end Esize; --------------- -- Root_Type -- --------------- function Root_Type (Type_Id : Entity_Id) return Entity_Id is T : Entity_Id; begin pragma Debug (Check_Defining_Occurrence (Type_Id)); T := Type_Id; while T /= Etype (T) loop T := Etype (T); end loop; return T; end Root_Type; ---------------- -- Is_Delayed -- ---------------- function Is_Delayed (E : Entity_Id) return Boolean is begin pragma Debug (Check_Defining_Occurrence (E)); return Flag18 (E); end Is_Delayed; --------------------- -- Is_Generic_Type -- --------------------- function Is_Generic_Type (Type_Id : Entity_Id) return Boolean is begin pragma Debug (Check_Defining_Occurrence (Type_Id)); return Flag6 (Type_Id); end Is_Generic_Type; --------------- -- Is_Frozen -- --------------- function Is_Frozen (Type_Id : Entity_Id) return Boolean is begin pragma Debug (Check_Defining_Occurrence (Type_Id)); return Flag4 (Type_Id); end Is_Frozen; ------------------- -- First_Literal -- ------------------- function First_Literal (Type_Id : Entity_Id) return Entity_Id is begin pragma Debug (Check_Defining_Occurrence (Type_Id)); return Node9 (Type_Id); end First_Literal; ------------------ -- Next_literal -- ------------------ function Next_Literal (Id : Entity_Id) return Entity_Id is begin pragma Debug (Check_Defining_Occurrence (Id)); return Next (Id); end Next_Literal; -------------------- -- Lit_Name_Table -- -------------------- function Lit_Name_Table (Id : Entity_Id) return Entity_Id is begin pragma Debug (Check_Defining_Occurrence (Id)); return Node7 (Id); end Lit_Name_Table; ------------------------- -- Has_Subprogram_Body -- ------------------------- function Has_Subprogram_Body (Subprogram_Id : Entity_Id) return Boolean is begin return Flag5 (Subprogram_Id); end Has_Subprogram_Body; ------------------ -- Scalar_Range -- ------------------ function Scalar_Range (Type_Id : Entity_Id) return Node_Id is begin pragma Debug (Check_Defining_Occurrence (Type_Id)); return Node10 (Type_Id); end Scalar_Range; ------------- -- Modulus -- ------------- function Modulus (Type_Id : Entity_Id) return Uint is begin pragma Debug (Check_Defining_Occurrence (Type_Id)); return Uint9 (Type_Id); end Modulus; -------------------- -- Type_Low_Bound -- -------------------- function Type_Low_Bound (Type_Id : Entity_Id) return Node_Id is begin return Low_Bound (Scalar_Range (Type_Id)); end Type_Low_Bound; --------------------- -- Type_High_Bound -- --------------------- function Type_High_Bound (Type_Id : Entity_Id) return Node_Id is begin return High_Bound (Scalar_Range (Type_Id)); end Type_High_Bound; ----------------------- -- Number_Dimensions -- ----------------------- function Number_Dimensions (Array_Id : Entity_Id) return Pos is N : Int; T : Node_Id; begin pragma Debug (Check_Defining_Occurrence (Array_Id)); N := 0; T := First_Index (Array_Id); while Present (T) loop N := N + 1; T := Next (T); end loop; return N; end Number_Dimensions; -------------------- -- Component_type -- -------------------- function Component_Type (Array_Id : Entity_Id) return Entity_Id is begin pragma Debug (Check_Defining_Occurrence (Array_Id)); return Node10 (Array_Id); end Component_Type; ----------------- -- First_Index -- ----------------- function First_Index (Array_Id : Entity_Id) return Node_Id is begin pragma Debug (Check_Defining_Occurrence (Array_Id)); return Node9 (Array_Id); end First_Index; ---------------- -- Next_Index -- ---------------- function Next_Index (Index_Id : Entity_Id) return Node_Id is begin return Next (Index_Id); end Next_Index; -------------------- -- Is_Constrained -- -------------------- function Is_Constrained (Type_Id : Entity_Id) return Boolean is begin return Flag3 (Type_Id); end Is_Constrained; ------------------------ -- First_Discriminant -- ------------------------ function First_Discriminant (Type_Id : Entity_Id) return Entity_Id is Id : Entity_Id; begin pragma Assert (Has_Discriminants (Type_Id), Compiler_Abort (Type_Id)); Id := First_Entity (Type_Id); if Chars (Id) = Name_uTag then pragma Assert (Is_Tagged_Type (Type_Id), Compiler_Abort (Type_Id)); return Next_Entity (Id); else return Id; end if; end First_Discriminant; ----------------------- -- Next_Discriminant -- ----------------------- function Next_Discriminant (Id : Entity_Id) return Entity_Id is D : constant Entity_Id := Next_Entity (Id); begin pragma Debug (Check_Entity_Kind (Id, E_Discriminant)); if Present (D) and then Ekind (D) = E_Discriminant then return D; else return Empty; end if; end Next_Discriminant; ----------------------------- -- Discriminant_Constraint -- ----------------------------- function Discriminant_Constraint (Type_Id : Entity_Id) return Elist_Id is begin pragma Debug (Check_Discriminated_Type (Type_Id)); return Elist2 (Type_Id); end Discriminant_Constraint; --------------- -- Init_Proc -- --------------- function Init_Proc (Type_Id : Entity_Id) return Entity_Id is begin pragma Debug (Check_Type (Type_Id)); return Node8 (Type_Id); end Init_Proc; -------------------- -- Base_Init_Proc -- -------------------- function Base_Init_Proc (Type_Id : Entity_Id) return Entity_Id is begin pragma Debug (Check_Type (Type_Id)); if Is_Task_Type (Type_Id) then return Init_Proc (Task_Value_Type (Base_Type (Type_Id))); else return Init_Proc (Base_Type (Type_Id)); end if; end Base_Init_Proc; -------------------------- -- Primitive_Operations -- -------------------------- function Primitive_Operations (Id : Entity_Id) return Elist_Id is begin pragma Assert (Is_Tagged_Type (Id), Compiler_Abort (Id)); return Elist7 (Id); end Primitive_Operations; -------------------------------- -- Internal_Access_Disp_Table -- -------------------------------- function Internal_Access_Disp_Table (Component_Id : Entity_Id) return Entity_Id is begin pragma Debug (Check_Entity_Kind (Component_Id, E_Component)); return Node11 (Component_Id); end Internal_Access_Disp_Table; ----------------------- -- Access_Disp_Table -- ----------------------- function Access_Disp_Table (Rec_Id : Entity_Id) return Entity_Id is begin pragma Assert (Is_Tagged_Type (Rec_Id), Compiler_Abort (Rec_Id)); return Internal_Access_Disp_Table (Tag_Component (Rec_Id)); end Access_Disp_Table; ------------------------------ -- Is_Dispatching_Operation -- ------------------------------ function Is_Dispatching_Operation (Overloaded_Id : Entity_Id) return Boolean is begin pragma Debug (Check_Overloaded_Kind (Overloaded_Id)); return Flag6 (Overloaded_Id); end Is_Dispatching_Operation; ------------------- -- Tag_Component -- ------------------- function Tag_Component (Rec_Id : Entity_Id) return Entity_Id is E : Entity_Id; begin pragma Assert (Is_Tagged_Type (Rec_Id), Compiler_Abort (Rec_Id)); E := First_Entity (Rec_Id); while Present (E) loop if Chars (E) = Name_uTag then return E; end if; E := Next_Entity (E); end loop; -- Here if no _Tag component found (some kind of compiler error!) Compiler_Abort; end Tag_Component; ----------------------- -- Has_Discriminants -- ----------------------- function Has_Discriminants (Type_Id : Entity_Id) return Boolean is begin pragma Debug (Check_Defining_Occurrence (Type_Id)); return Flag5 (Type_Id); end Has_Discriminants; --------------------- -- First_Component -- --------------------- function First_Component (Rec_Id : Entity_Id) return Entity_Id is Comp_Id : Entity_Id; begin pragma Debug (Check_Record_Or_Incomplete_Kind (Rec_Id)); Comp_Id := First_Entity (Rec_Id); while Present (Comp_Id) loop exit when Ekind (Comp_Id) = E_Component; Comp_Id := Next_Entity (Comp_Id); end loop; return Comp_Id; end First_Component; -------------------- -- Next_Component -- -------------------- function Next_Component (Id : Entity_Id) return Entity_Id is Comp_Id : Entity_Id; begin pragma Debug (Check_Defining_Occurrence (Id)); Comp_Id := Next_Entity (Id); while Present (Comp_Id) loop exit when Ekind (Comp_Id) = E_Component; Comp_Id := Next_Entity (Comp_Id); end loop; return Comp_Id; end Next_Component; ------------------------------ -- Directly_Designated_Type -- ------------------------------ function Directly_Designated_Type (Access_Id : Entity_Id) return Entity_Id is begin pragma Debug (Check_Defining_Occurrence (Access_Id)); return Node10 (Access_Id); end Directly_Designated_Type; --------------------- -- Designated_Type -- --------------------- function Designated_Type (Access_Id : Entity_Id) return Entity_Id is Desig_Type : Entity_Id; begin pragma Debug (Check_Defining_Occurrence (Access_Id)); Desig_Type := Node10 (Access_Id); if (Ekind (Desig_Type) = E_Incomplete_Type and then Present (Full_Declaration (Desig_Type))) then return Full_Declaration (Desig_Type); elsif Is_Class_Type (Desig_Type) and then Ekind (Etype (Desig_Type)) = E_Incomplete_Type and then Present (Full_Declaration (Etype (Desig_Type))) then return Classwide_Type (Full_Declaration (Etype (Desig_Type))); else return Desig_Type; end if; end Designated_Type; ---------------------- -- Full_Declaration -- ---------------------- function Full_Declaration (Private_Id : Entity_Id) return Entity_Id is Decl : Entity_Id; begin pragma Debug (Check_Defining_Occurrence (Private_Id)); Decl := Node11 (Private_Id); -- If a type DT is derived in package CP from a private type T -- defined in an ancestor of CP, then the full declaration of DT -- may point to the private declaration of T rather than to the -- full declaration. In that case, follow the link to the current -- location of the full declaration. if Present (Decl) and then (Ekind (Decl) = E_Private_Type or else Ekind (Decl) = E_Limited_Private_Type) then Decl := Node11 (Decl); end if; return Decl; end Full_Declaration; -------------------------------- -- Discriminant_Checking_Func -- -------------------------------- function Discriminant_Checking_Func (Id : Entity_Id) return Entity_Id is begin pragma Debug (Check_Entity_Kind (Id, E_Component)); return Node10 (Id); end Discriminant_Checking_Func; ------------------------- -- Is_Directly_Visible -- ------------------------- function Is_Directly_Visible (Id : Entity_Id) return Boolean is begin return Flag7 (Id); end Is_Directly_Visible; -------------------- -- Is_Use_Visible -- -------------------- function Is_Use_Visible (Id : Entity_Id) return Boolean is begin return Flag9 (Id); end Is_Use_Visible; -------------------- -- Constant_Value -- -------------------- function Constant_Value (Constant_Id : Entity_Id) return Node_Id is begin if Nkind (Parent (Constant_Id)) = N_Object_Renaming_Declaration then return Renamed_Object (Constant_Id); else if Present (Expression (Parent (Constant_Id))) then return (Expression (Parent (Constant_Id))); elsif Present (Full_Declaration (Constant_Id)) then return (Expression (Parent (Full_Declaration (Constant_Id)))); end if; end if; end Constant_Value; -------------------- -- Renamed_Object -- -------------------- function Renamed_Object (Id : Entity_Id) return Node_Id is begin return Node7 (Id); end Renamed_Object; -------------------------------- -- Discriminant_Default_Value -- -------------------------------- function Discriminant_Default_Value (Id : Entity_Id) return Node_Id is begin pragma Debug (Check_Entity_Kind (Id, E_Discriminant)); return Node10 (Id); end Discriminant_Default_Value; ----------------- -- Discriminal -- ----------------- function Discriminal (Id : Entity_Id) return Node_Id is begin pragma Debug (Check_Entity_Kind (Id, E_Discriminant)); return Node9 (Id); end Discriminal; ------------- -- Is_Type -- ------------- function Is_Type (Id : Entity_Id) return Boolean is begin pragma Debug (Check_Defining_Occurrence (Id)); return Ekind (Id) in Type_Kind; end Is_Type; -------------------- -- Parent_Subtype -- -------------------- function Parent_Subtype (Id : Entity_Id) return Entity_Id is begin pragma Assert (Ekind (Id) in Scalar_Kind, Compiler_Abort (Id)); return Node11 (Id); end Parent_Subtype; ------------------------ -- Is_Elementary_Type -- ------------------------ function Is_Elementary_Type (Type_Id : Entity_Id) return Boolean is begin return Ekind (Type_Id) in Scalar_Kind or else Ekind (Type_Id) in Access_Kind; end Is_Elementary_Type; -------------------- -- Is_Scalar_Type -- -------------------- function Is_Scalar_Type (Type_Id : Entity_Id) return Boolean is begin return Ekind (Type_Id) in Scalar_Kind; end Is_Scalar_Type; ---------------------- -- Is_Discrete_Type -- ---------------------- function Is_Discrete_Type (Type_Id : Entity_Id) return Boolean is begin return Ekind (Type_Id) in Discrete_Kind; end Is_Discrete_Type; ------------------------- -- Is_Enumeration_Type -- ------------------------- function Is_Enumeration_Type (Type_Id : Entity_Id) return Boolean is begin return Ekind (Type_Id) in Enumeration_Kind; end Is_Enumeration_Type; --------------------- -- Is_Boolean_Type -- --------------------- function Is_Boolean_Type (Type_Id : Entity_Id) return Boolean is begin return Ekind (Base_Type (Type_Id)) = E_Boolean_Type; end Is_Boolean_Type; ----------------------- -- Is_Character_Type -- ----------------------- function Is_Character_Type (Type_Id : Entity_Id) return Boolean is begin return Ekind (Base_Type (Type_Id)) = E_Character_Type; end Is_Character_Type; --------------------- -- Is_Integer_Type -- --------------------- function Is_Integer_Type (Type_Id : Entity_Id) return Boolean is begin return Ekind (Type_Id) in Integer_Kind; end Is_Integer_Type; ------------------ -- Is_Real_Type -- ------------------ function Is_Real_Type (Type_Id : Entity_Id) return Boolean is begin return Ekind (Type_Id) in Real_Kind; end Is_Real_Type; ------------------- -- Is_Fixed_Type -- ------------------- function Is_Fixed_Type (Type_Id : Entity_Id) return Boolean is begin return Ekind (Type_Id) in Fixed_Kind; end Is_Fixed_Type; ------------------- -- Is_Float_Type -- ------------------- function Is_Float_Type (Type_Id : Entity_Id) return Boolean is begin return Ekind (Type_Id) in Float_Kind; end Is_Float_Type; --------------------- -- Is_Numeric_Type -- --------------------- function Is_Numeric_Type (Type_Id : Entity_Id) return Boolean is begin return Ekind (Type_Id) in Numeric_Kind; end Is_Numeric_Type; ----------------------- -- Is_Composite_Type -- ----------------------- function Is_Composite_Type (Type_Id : Entity_Id) return Boolean is begin return Ekind (Type_Id) in Composite_Kind; end Is_Composite_Type; ------------------- -- Is_Array_Type -- ------------------- function Is_Array_Type (Type_Id : Entity_Id) return Boolean is begin return Ekind (Type_Id) in Array_Kind; end Is_Array_Type; -------------------- -- Is_String_Type -- -------------------- function Is_String_Type (Type_Id : Entity_Id) return Boolean is begin return Ekind (Type_Id) in String_Kind or else (Ekind (Type_Id) = E_Slice_Subtype and then Is_String_Type (Base_Type (Type_Id))) or else (Is_Array_Type (Type_Id) and then Number_Dimensions (Type_Id) = 1 and then Is_Character_Type (Component_Type (Type_Id))); end Is_String_Type; -------------------- -- Is_Record_Type -- -------------------- function Is_Record_Type (Type_Id : Entity_Id) return Boolean is begin return Ekind (Type_Id) in Record_Kind; end Is_Record_Type; -------------------- -- Is_Access_Type -- -------------------- function Is_Access_Type (Type_Id : Entity_Id) return Boolean is begin return Ekind (Type_Id) in Access_Kind; end Is_Access_Type; ----------------- -- Is_Abstract -- ----------------- function Is_Abstract (Id : Entity_Id) return Boolean is begin pragma Debug (Check_Defining_Occurrence (Id)); return Flag19 (Id); end Is_Abstract; ---------------- -- Is_Aliased -- ---------------- function Is_Aliased (Id : Entity_Id) return Boolean is begin pragma Debug (Check_Defining_Occurrence (Id)); return Flag15 (Id); end Is_Aliased; ------------------- -- Is_Subprogram -- ------------------- function Is_Subprogram (Type_Id : Entity_Id) return Boolean is begin return Ekind (Type_Id) in Subprogram_Kind; end Is_Subprogram; --------------------- -- Is_Named_Number -- --------------------- function Is_Named_Number (Type_Id : Entity_Id) return Boolean is begin return Ekind (Type_Id) in Named_Kind; end Is_Named_Number; ------------------ -- Is_Task_Type -- ------------------ function Is_Task_Type (Type_Id : Entity_Id) return Boolean is begin return Ekind (Type_Id) in Task_Kind; end Is_Task_Type; ----------------------- -- Is_Protected_Type -- ----------------------- function Is_Protected_Type (Type_Id : Entity_Id) return Boolean is begin return Ekind (Type_Id) in Protected_Kind; end Is_Protected_Type; -------------------- -- Is_Tagged_Type -- -------------------- function Is_Tagged_Type (Type_Id : Entity_Id) return Boolean is begin return Flag8 (Type_Id); end Is_Tagged_Type; ------------------------- -- Is_Task_Record_Type -- ------------------------- function Is_Task_Record_Type (Type_Id : Entity_Id) return Boolean is begin return Flag20 (Type_Id); end Is_Task_Record_Type; --------------------- -- Is_Limited_Type -- --------------------- function Is_Limited_Type (Type_Id : Entity_Id) return Boolean is begin return Flag25 (Type_Id); end Is_Limited_Type; ------------------------ -- Is_Incomplete_Type -- ------------------------ function Is_Incomplete_Type (Type_Id : Entity_Id) return Boolean is begin return Ekind (Type_Id) in Incomplete_Kind; end Is_Incomplete_Type; ----------------- -- Is_Internal -- ----------------- function Is_Internal (Type_Id : Entity_Id) return Boolean is begin return Flag2 (Type_Id); end Is_Internal; --------------- -- Is_Packed -- --------------- function Is_Packed (Type_Id : Entity_Id) return Boolean is begin return Flag11 (Type_Id); end Is_Packed; ---------------- -- Is_Private -- ---------------- function Is_Private (Id : Entity_Id) return Boolean is begin return Flag13 (Id); end Is_Private; --------------------- -- Is_Private_Type -- --------------------- function Is_Private_Type (Type_Id : Entity_Id) return Boolean is begin return Flag14 (Type_Id); end Is_Private_Type; --------------- -- Is_Public -- --------------- function Is_Public (Id : Entity_Id) return Boolean is begin return Flag10 (Id); end Is_Public; ------------- -- Is_Pure -- ------------- function Is_Pure (Proc_Id : Entity_Id) return Boolean is begin return Flag3 (Proc_Id); end Is_Pure; ----------------- -- Is_Imported -- ----------------- function Is_Imported (Id : Entity_Id) return Boolean is begin pragma Debug (Check_Defining_Occurrence (Id)); return Flag24 (Id); end Is_Imported; ---------------- -- Is_Inlined -- ---------------- function Is_Inlined (Id : Entity_Id) return Boolean is begin pragma Debug (Check_Overloaded_Kind (Id)); return Flag11 (Id); end Is_Inlined; ----------------- -- Is_Volatile -- ----------------- function Is_Volatile (Id : Entity_Id) return Boolean is begin pragma Debug (Check_Defining_Occurrence (Id)); return Flag16 (Id); end Is_Volatile; ------------------------------- -- Original_Record_Component -- ------------------------------- function Original_Record_Component (Id : Entity_Id) return Entity_Id is begin -- needs double check E_Component or E_Discriminant ??? -- pragma Debug (Check_Entity_Kind (Id, E_Component)); return Node8 (Id); end Original_Record_Component; --------------------- -- Task_Value_Type -- --------------------- function Task_Value_Type (Id : Entity_Id) return Entity_Id is begin pragma Debug (Check_Defining_Occurrence (Id)); return Node7 (Id); end Task_Value_Type; -------------- -- Reachable -- --------------- function Reachable (Label_Id : Entity_Id) return Boolean is begin return Flag5 (Label_Id); end Reachable; ----------------- -- Slice_Range -- ----------------- function Slice_Range (Id : Entity_Id) return Node_Id is begin return Node11 (Id); end Slice_Range; --------------------------- -- String_Literal_Length -- --------------------------- function String_Literal_Length (Id : Entity_Id) return Uint is begin return Uint11 (Id); end String_Literal_Length; ------------------ -- Subtype_Kind -- ------------------ function Subtype_Kind (K : Entity_Kind) return Entity_Kind is Kind : Entity_Kind; begin case K is when Access_Kind => Kind := E_Access_Subtype; when E_Array_Type | E_Array_Subtype => Kind := E_Array_Subtype; when E_Class_Type | E_Class_Subtype => Kind := E_Class_Subtype; when E_Decimal_Type | E_Decimal_Subtype => Kind := E_Decimal_Subtype; when E_Fixed_Type | E_Fixed_Subtype => Kind := E_Fixed_Subtype; when E_Record_Type | E_Record_Subtype => Kind := E_Record_Subtype; when E_String_Type | E_String_Subtype => Kind := E_String_Subtype; when Enumeration_Kind => Kind := E_Enumeration_Subtype; when Float_Kind => Kind := E_Float_Subtype; when Signed_Integer_Kind => Kind := E_Integer_Subtype; when Modular_Kind => Kind := E_Modular_Subtype; when Protected_Kind => Kind := E_Protected_Subtype; when Task_Kind => Kind := E_Task_Subtype; when others => Compiler_Error; Write_String (Entity_Kind'Image (K)); Write_String (" has no appropriate subtype"); Write_Eol; Compiler_Abort; end case; return Kind; end Subtype_Kind; ----------------------- -- Table_High_Bounds -- ----------------------- function Table_High_Bound (Id : Entity_Id) return Node_Id is begin return Node11 (Id); end Table_High_Bound; ----------------------- -- Needs_Discr_Check -- ----------------------- function Needs_Discr_Check (Id : Entity_Id) return Boolean is begin return Flag5 (Id); end Needs_Discr_Check; -------------- -- Has_Exit -- -------------- function Has_Exit (Loop_Id : Entity_Id) return Boolean is begin return Flag5 (Loop_Id); end Has_Exit; ------------------ -- First_Formal -- ------------------ function First_Formal (Overloaded_Id : Entity_Id) return Entity_Id is Formal : Entity_Id; begin pragma Debug (Check_Overloaded_Kind (Overloaded_Id)); if Ekind (Overloaded_Id) = E_Enumeration_Literal then return Empty; else Formal := First_Entity (Overloaded_Id); if Present (Formal) and then Ekind (Formal) in E_In_Parameter .. E_In_Out_Parameter then return Formal; else return Empty; end if; end if; end First_Formal; ----------------- -- Next_Formal -- ----------------- function Next_Formal (Formal_Id : Entity_Id) return Entity_Id is P : Entity_Id; begin pragma Debug (Check_Defining_Occurrence (Formal_Id)); -- Follow the chain of declared entities as long as the kind of -- the entity corresponds to a formal parameter. Skip internal -- entities that may have been created for implicit subtypes, -- in the process of analyzing default expressions. P := Next_Entity (Formal_Id); if Present (P) and then Ekind (P) in E_In_Parameter .. E_In_Out_Parameter then return P; elsif Is_Internal (P) then while Present (P) and then Is_Internal (P) loop P := Next_Entity (P); end loop; if Present (P) and then Ekind (P) in E_In_Parameter .. E_In_Out_Parameter then return P; else return Empty; end if; else return Empty; end if; end Next_Formal; -------------------- -- Parameter_Mode -- -------------------- function Parameter_Mode (Formal_Id : Entity_Id) return Formal_Kind is begin pragma Debug (Check_Defining_Occurrence (Formal_Id)); return Ekind (Formal_Id); end Parameter_Mode; ------------------ -- First_Actual -- ------------------ function First_Actual (Node : Node_Id) return Node_Id is N : Node_Id; begin if Parameter_Associations (Node) = No_List then return Empty; end if; N := First (Parameter_Associations (Node)); if Nkind (N) = N_Parameter_Association then return First_Named_Actual (Node); else return N; end if; end First_Actual; ----------------- -- Next_Actual -- ----------------- function Next_Actual (Actual_Id : Node_Id) return Node_Id is N : Node_Id; begin -- If we are pointing at a positional parameter, it is a member of -- a node list (the list of parameters), and the next parameter -- is the next node on the list, unless we hit a parameter -- association, in which case we shift to using the chain whose -- head is the First_Named_Actual in the parent, and then is -- threaded using the Next_Named_Actual of the Parameter_Association. -- All this fiddling is because the original node list is in the -- textual call order, and what we need is the declaration order. if Is_List_Member (Actual_Id) then N := Next (Actual_Id); if Nkind (N) = N_Parameter_Association then return First_Named_Actual (Parent (Actual_Id)); else return N; end if; else return Next_Named_Actual (Parent (Actual_Id)); end if; end Next_Actual; -------------------- -- Next_Overloads -- -------------------- function Next_Overloads (Overloaded_Id : Entity_Id) return Entity_Id is begin pragma Debug (Check_Overloaded_Kind (Overloaded_Id)); return Homonym (Overloaded_Id); end Next_Overloads; ----------- -- Alias -- ----------- function Alias (Overloaded_Id : Entity_Id) return Entity_Id is begin pragma Debug (Check_Overloaded_Kind (Overloaded_Id)); return Node7 (Overloaded_Id); end Alias; ---------------------- -- Needs_No_Actuals -- ---------------------- function Needs_No_Actuals (Overloaded_Id : Entity_Id) return Boolean is begin pragma Debug (Check_Overloaded_Kind (Overloaded_Id)); return Flag8 (Overloaded_Id); end Needs_No_Actuals; ------------------ -- Is_Intrinsic -- ------------------ function Is_Intrinsic (Proc_Id : Entity_Id) return Boolean is begin pragma Debug (Check_Defining_Occurrence (Proc_Id)); return Flag27 (Proc_Id); end Is_Intrinsic; -------------------- -- Interface_Name -- -------------------- function Interface_Name (Proc_Id : Entity_Id) return Node_Id is begin pragma Debug (Check_Defining_Occurrence (Proc_Id)); return Node12 (Proc_Id); end Interface_Name; --------------------- -- Is_Overloadable -- --------------------- function Is_Overloadable (Id : Entity_Id) return Boolean is begin return Ekind (Id) in Overloaded_Kind; end Is_Overloadable; ----------------- -- Entry_Index -- ----------------- function Entry_Index (Id : Entity_Id) return Uint is begin return Uint11 (Id); end Entry_Index; --------------------- -- Enumeration_Pos -- --------------------- function Enumeration_Pos (Enum_Id : Entity_Id) return Uint is begin return Uint11 (Enum_Id); end Enumeration_Pos; --------------------- -- Enumeration_Rep -- --------------------- function Enumeration_Rep (Enum_Id : Entity_Id) return Uint is begin return Uint12 (Enum_Id); end Enumeration_Rep; ------------------- -- Default_Value -- ------------------- function Default_Value (In_Id : Entity_Id) return Node_Id is begin pragma Debug (Check_Entity_Kind (In_Id, E_In_Parameter)); return Node10 (In_Id); end Default_Value; --------------------- -- Is_Package_Body -- --------------------- function Is_Package_Body (Package_Id : Entity_Id) return Boolean is begin pragma Debug (Check_Defining_Occurrence (Package_Id)); return Flag5 (Package_Id); end Is_Package_Body; --------------------- -- In_Private_Part -- --------------------- function In_Private_Part (Package_Id : Entity_Id) return Boolean is begin pragma Debug (Check_Defining_Occurrence (Package_Id)); return Flag4 (Package_Id); end In_Private_Part; ------------ -- In_Use -- ------------ function In_Use (Package_Id : Entity_Id) return Boolean is begin pragma Debug (Check_Defining_Occurrence (Package_Id)); return Flag8 (Package_Id); end In_Use; --------------------------- -- Is_Private_Descendant -- --------------------------- function Is_Private_Descendant (Id : Entity_Id) return Boolean is begin pragma Debug (Check_Defining_Occurrence (Id)); return Flag14 (Id); end Is_Private_Descendant; --------------- -- Base_Type -- --------------- function Base_Type (Type_Id : Entity_Id) return Entity_Id is begin pragma Debug (Check_Defining_Occurrence (Type_Id)); case Ekind (Type_Id) is when E_Enumeration_Subtype | E_Integer_Subtype | E_Modular_Subtype | E_Float_Subtype | E_Fixed_Subtype | E_Decimal_Subtype | E_Array_Subtype | E_String_Subtype | E_Record_Subtype | E_Access_Subtype | E_Protected_Subtype | E_Task_Subtype | E_String_Literal_Subtype => return Etype (Type_Id); when E_Slice_Subtype => return Base_Type (Etype (Type_Id)); when others => return Type_Id; end case; end Base_Type; -------------------------- -- First_Private_Entity -- -------------------------- function First_Private_Entity (Package_Id : Entity_Id) return Entity_Id is begin pragma Debug (Check_Defining_Occurrence (Package_Id)); return Node11 (Package_Id); end First_Private_Entity; ---------------------------- -- Suppress_Access_Checks -- ---------------------------- function Suppress_Access_Checks (E : Entity_Id) return Boolean is begin return Flag31 (E); end Suppress_Access_Checks; ----------------------------------- -- Suppress_Accessibility_Checks -- ----------------------------------- function Suppress_Accessibility_Checks (E : Entity_Id) return Boolean is begin return Flag32 (E); end Suppress_Accessibility_Checks; ---------------------------------- -- Suppress_Discriminant_Checks -- ---------------------------------- function Suppress_Discriminant_Checks (E : Entity_Id) return Boolean is begin return Flag33 (E); end Suppress_Discriminant_Checks; ------------------------------ -- Suppress_Division_Checks -- ------------------------------ function Suppress_Division_Checks (E : Entity_Id) return Boolean is begin return Flag34 (E); end Suppress_Division_Checks; --------------------------------- -- Suppress_Elaboration_Checks -- --------------------------------- function Suppress_Elaboration_Checks (E : Entity_Id) return Boolean is begin return Flag35 (E); end Suppress_Elaboration_Checks; --------------------------- -- Suppress_Index_Checks -- --------------------------- function Suppress_Index_Checks (E : Entity_Id) return Boolean is begin return Flag36 (E); end Suppress_Index_Checks; ---------------------------- -- Suppress_Length_Checks -- ---------------------------- function Suppress_Length_Checks (E : Entity_Id) return Boolean is begin return Flag37 (E); end Suppress_Length_Checks; ------------------------------ -- Suppress_Overflow_Checks -- ------------------------------ function Suppress_Overflow_Checks (E : Entity_Id) return Boolean is begin return Flag38 (E); end Suppress_Overflow_Checks; --------------------------- -- Suppress_Range_Checks -- --------------------------- function Suppress_Range_Checks (E : Entity_Id) return Boolean is begin return Flag39 (E); end Suppress_Range_Checks; ----------------------------- -- Suppress_Storage_Checks -- ----------------------------- function Suppress_Storage_Checks (E : Entity_Id) return Boolean is begin return Flag40 (E); end Suppress_Storage_Checks; ------------------------- -- Suppress_Tag_Checks -- ------------------------- function Suppress_Tag_Checks (E : Entity_Id) return Boolean is begin return Flag41 (E); end Suppress_Tag_Checks; --------------------- -- Equivalent_Type -- --------------------- function Equivalent_Type (Sub_Class : Entity_Id) return Entity_Id is begin pragma Assert (Ekind (Sub_Class) = E_Class_Subtype, Compiler_Abort (Sub_Class)); return Node7 (Sub_Class); end Equivalent_Type; ----------------------------------------- -- Procedures to Set Entity Attributes -- ----------------------------------------- -- There is one procedure to set each basic attribute. Attributes that -- are retrieved from other tree nodes (for example, the first parameter -- of a subprogram) are purely syntactic and do not require setting -- procedures. --------------------------------- -- Set_Corresponding_Task_Type -- --------------------------------- procedure Set_Corresponding_Task_Type (Id : Entity_Id; T : Entity_Id) is begin pragma Assert (Is_Record_Type (Id) and then not Is_Tagged_Type (Id) and then Is_Task_Type (T), Compiler_Abort (Id)); Set_Node7 (Id, T); end Set_Corresponding_Task_Type; --------------- -- Set_Scope -- --------------- procedure Set_Scope (Id : Entity_Id; S : Entity_Id) is begin pragma Debug (Check_Defining_Occurrence (Id)); Set_Node3 (Id, S); end Set_Scope; ----------------- -- Set_Homonym -- ----------------- procedure Set_Homonym (Id : Entity_Id; T : Entity_Id) is begin pragma Debug (Check_Defining_Occurrence (Id)); Set_Node4 (Id, T); end Set_Homonym; ------------------------- -- Set_Has_Completion -- ------------------------- procedure Set_Has_Completion (Id : Entity_Id; Status : Boolean := True) is begin pragma Debug (Check_Defining_Occurrence (Id)); Set_Flag26 (Id, Status); end Set_Has_Completion; -------------------- -- Set_Has_Tasks -- -------------------- procedure Set_Has_Tasks (Id : Entity_Id; Status : Boolean := True) is begin pragma Debug (Check_Defining_Occurrence (Id)); Set_Flag30 (Id, Status); end Set_Has_Tasks; ---------------------------- -- Set_Has_Master_Entity -- ---------------------------- procedure Set_Has_Master_Entity (Id : Entity_Id; Status : Boolean := True) is begin pragma Debug (Check_Defining_Occurrence (Id)); Set_Flag21 (Id, Status); end Set_Has_Master_Entity; ----------------------------- -- Set_Has_Address_Clause -- ----------------------------- procedure Set_Has_Address_Clause (Id : Entity_Id; Status : Boolean := True) is begin pragma Debug (Check_Defining_Occurrence (Id)); Set_Flag28 (Id, Status); end Set_Has_Address_Clause; ---------------------- -- Set_Has_Homonym -- ---------------------- procedure Set_Has_Homonym (Id : Entity_Id; Status : Boolean := True) is begin pragma Debug (Check_Defining_Occurrence (Id)); Set_Flag12 (Id, Status); end Set_Has_Homonym; -------------------------- -- Set_Has_Size_Clause -- -------------------------- procedure Set_Has_Size_Clause (Id : Entity_Id; Status : Boolean := True) is begin pragma Debug (Check_Defining_Occurrence (Id)); Set_Flag29 (Id, Status); end Set_Has_Size_Clause; ---------------------------------- -- Set_Has_Storage_Size_Clause -- ---------------------------------- procedure Set_Has_Storage_Size_Clause (Id : Entity_Id; Status : Boolean := True) is begin pragma Debug (Check_Defining_Occurrence (Id)); Set_Flag23 (Id, Status); end Set_Has_Storage_Size_Clause; -------------- -- Set_Esize -- -------------- procedure Set_Esize (Type_Id : Entity_Id; S : Uint) is begin pragma Debug (Check_Defining_Occurrence (Type_Id)); Set_Uint12 (Type_Id, S); end Set_Esize; ---------------------- -- Set_First_Entity -- ---------------------- procedure Set_First_Entity (Scope_Id : Entity_Id; Id : Entity_Id) is begin Set_Node9 (Scope_Id, Id); end Set_First_Entity; --------------------- -- Set_Next_Entity -- --------------------- procedure Set_Next_Entity (Prev : Entity_Id; Id : Entity_Id) is begin Set_Node6 (Prev, Id); end Set_Next_Entity; ------------------------- -- Set_Renamed_Object -- ------------------------- procedure Set_Renamed_Object (Id : Entity_Id; Object : Node_Id) is begin Set_Node7 (Id, Object); end Set_Renamed_Object; --------------------- -- Set_First_Index -- --------------------- procedure Set_First_Index (Array_Id : Entity_Id; Index : Node_Id) is begin Set_Node9 (Array_Id, Index); end Set_First_Index; ---------------------- -- Set_First_Literal -- ---------------------- procedure Set_First_Literal (Type_Id : Entity_Id; Id : Entity_Id) is begin Set_Node9 (Type_Id, Id); end Set_First_Literal; ------------------------ -- Set_Is_Constrained -- ------------------------ procedure Set_Is_Constrained (Type_Id : Entity_Id; Status : Boolean := True) is begin Set_Flag3 (Type_Id, Status); end Set_Is_Constrained; --------------------------- -- Set_Has_Discriminants -- --------------------------- procedure Set_Has_Discriminants (Type_Id : Entity_Id; Status : Boolean := True) is begin Set_Flag5 (Type_Id, Status); end Set_Has_Discriminants; -------------------- -- Set_Is_Delayed -- -------------------- procedure Set_Is_Delayed (E : Entity_Id; Status : Boolean := True) is begin pragma Debug (Check_Defining_Occurrence (E)); Set_Flag18 (E, Status); end Set_Is_Delayed; ------------------------- -- Set_Is_Generic_Type -- ------------------------- procedure Set_Is_Generic_Type (Type_Id : Entity_Id; Status : Boolean := True) is begin pragma Debug (Check_Defining_Occurrence (Type_Id)); Set_Flag6 (Type_Id, Status); end Set_Is_Generic_Type; ------------------- -- Set_Is_Frozen -- ------------------- procedure Set_Is_Frozen (Type_Id : Entity_Id; Status : Boolean := True) is begin pragma Debug (Check_Defining_Occurrence (Type_Id)); Set_Flag4 (Type_Id, Status); end Set_Is_Frozen; ---------------------- -- Set_Scalar_Range -- ---------------------- procedure Set_Scalar_Range (Type_Id : Entity_Id; R_Node : Node_Id) is begin pragma Debug (Check_Defining_Occurrence (Type_Id)); Set_Node10 (Type_Id, R_Node); end Set_Scalar_Range; ----------------- -- Set_Modulus -- ----------------- procedure Set_Modulus (Type_Id : Entity_Id; Mod_Value : Uint) is begin pragma Debug (Check_Defining_Occurrence (Type_Id)); Set_Uint9 (Type_Id, Mod_Value); end Set_Modulus; ------------------------ -- Set_Lit_Name_Table -- ------------------------ procedure Set_Lit_Name_Table (Type_Id : Entity_Id; Table : Entity_Id) is begin pragma Debug (Check_Defining_Occurrence (Type_Id)); Set_Node7 (Type_Id, Table); end Set_Lit_Name_Table; ------------------------- -- Set_Is_Limited_Type -- ------------------------- procedure Set_Is_Limited_Type (Type_Id : Entity_Id; Status : Boolean := True) is begin Set_Flag25 (Type_Id, Status); end Set_Is_Limited_Type; ------------------------ -- Set_Is_Tagged_Type -- ------------------------ procedure Set_Is_Tagged_Type (Type_Id : Entity_Id; Status : Boolean := True) is begin Set_Flag8 (Type_Id, Status); end Set_Is_Tagged_Type; ----------------------------- -- Set_Is_Task_Record_Type -- ----------------------------- procedure Set_Is_Task_Record_Type (Type_Id : Entity_Id; Status : Boolean := True) is begin Set_Flag20 (Type_Id, Status); end Set_Is_Task_Record_Type; --------------------- -- Set_Is_Internal -- --------------------- procedure Set_Is_Internal (Type_Id : Entity_Id; Status : Boolean := True) is begin Set_Flag2 (Type_Id, Status); end Set_Is_Internal; ------------------- -- Set_Is_Packed -- ------------------- procedure Set_Is_Packed (Type_Id : Entity_Id; Status : Boolean := True) is begin Set_Flag11 (Type_Id, Status); end Set_Is_Packed; -------------------- -- Set_Is_Private -- -------------------- procedure Set_Is_Private (Id : Entity_Id; Status : Boolean := True) is begin Set_Flag13 (Id, Status); end Set_Is_Private; --------------------- -- Set_Is_Abstract -- --------------------- procedure Set_Is_Abstract (Id : Entity_Id; Status : Boolean := True) is begin Set_Flag19 (Id, Status); end Set_Is_Abstract; -------------------- -- Set_Is_Aliased -- -------------------- procedure Set_Is_Aliased (Id : Entity_Id; Status : Boolean := True) is begin Set_Flag15 (Id, Status); end Set_Is_Aliased; ------------------------- -- Set_Is_Private_Type -- ------------------------- procedure Set_Is_Private_Type (Type_Id : Entity_Id; Status : Boolean := True) is begin Set_Flag14 (Type_Id, Status); end Set_Is_Private_Type; ------------------- -- Set_Is_Public -- ------------------- procedure Set_Is_Public (Id : Entity_Id; Status : Boolean := True) is begin Set_Flag10 (Id, Status); end Set_Is_Public; ----------------- -- Set_Is_Pure -- ----------------- procedure Set_Is_Pure (Proc_Id : Entity_Id; Status : Boolean := True) is begin Set_Flag3 (Proc_Id, Status); end Set_Is_Pure; --------------------- -- Set_Is_Imported -- --------------------- procedure Set_Is_Imported (Id : Entity_Id; Status : Boolean := True) is begin pragma Debug (Check_Defining_Occurrence (Id)); Set_Flag24 (Id, Status); end Set_Is_Imported; -------------------- -- Set_Is_Inlined -- -------------------- procedure Set_Is_Inlined (Id : Entity_Id; Status : Boolean := True) is begin pragma Debug (Check_Overloaded_Kind (Id)); Set_Flag11 (Id, Status); end Set_Is_Inlined; --------------------- -- Set_Is_Volatile -- --------------------- procedure Set_Is_Volatile (Id : Entity_Id; Status : Boolean := True) is begin Set_Flag16 (Id, Status); end Set_Is_Volatile; ------------------------ -- Set_Parent_Subtype -- ------------------------ procedure Set_Parent_Subtype (Id : Entity_Id; Parent_Id : Entity_Id) is begin pragma Assert (Ekind (Id) in Scalar_Kind, Compiler_Abort (Id)); Set_Node11 (Id, Parent_Id); end Set_Parent_Subtype; ------------------- -- Set_Reachable -- ------------------- procedure Set_Reachable (Label_Id : Entity_Id; Status : Boolean := True) is begin pragma Debug (Check_Defining_Occurrence (Label_Id)); Set_Flag5 (Label_Id, Status); end Set_Reachable; --------------------------- -- Set_Needs_Discr_Check -- --------------------------- procedure Set_Needs_Discr_Check (Id : Entity_Id; Status : Boolean := True) is begin pragma Debug (Check_Entity_Kind (Id, E_Component)); pragma Assert (Ekind (Scope (Id)) in Record_Kind, Compiler_Abort (Id)); Set_Flag5 (Id, Status); end Set_Needs_Discr_Check; ------------------ -- Set_Has_Exit -- ------------------ procedure Set_Has_Exit (Loop_Id : Entity_Id; Status : Boolean := True) is begin pragma Debug (Check_Defining_Occurrence (Loop_Id)); Set_Flag5 (Loop_Id, Status); end Set_Has_Exit; --------------------------------- -- Set_Discriminant_Constraint -- --------------------------------- procedure Set_Discriminant_Constraint (Type_Id : Entity_Id; Elist : Elist_Id) is begin Set_Elist2 (Type_Id, Elist); end Set_Discriminant_Constraint; ------------------- -- Set_Init_Proc -- ------------------- procedure Set_Init_Proc (Type_Id : Entity_Id; P : Entity_Id) is begin pragma Debug (Check_Type (Type_Id)); Set_Node8 (Type_Id, P); end Set_Init_Proc; ------------------------------ -- Set_Primitive_Operations -- ------------------------------ procedure Set_Primitive_Operations (Id : Entity_Id; Elist : Elist_Id) is begin pragma Assert (Is_Tagged_Type (Id), Compiler_Abort (Id)); Set_Elist7 (Id, Elist); end Set_Primitive_Operations; ------------------------------------ -- Set_Internal_Access_Disp_Table -- ------------------------------------ procedure Set_Internal_Access_Disp_Table (Component_Id : Entity_Id; Id : Entity_Id) is begin pragma Debug (Check_Entity_Kind (Component_Id, E_Component)); Set_Node11 (Component_Id, Id); end Set_Internal_Access_Disp_Table; --------------------------- -- Set_Access_Disp_Table -- --------------------------- procedure Set_Access_Disp_Table (Rec_Id : Entity_Id; Id : Entity_Id) is begin pragma Assert (Is_Tagged_Type (Rec_Id), Compiler_Abort (Rec_Id)); Set_Internal_Access_Disp_Table (Tag_Component (Rec_Id), Id); end Set_Access_Disp_Table; ---------------------------------- -- Set_Is_Dispatching_Operation -- ---------------------------------- procedure Set_Is_Dispatching_Operation (Overloaded_Id : Entity_Id; Status : Boolean := True) is begin pragma Debug (Check_Overloaded_Kind (Overloaded_Id)); Set_Flag6 (Overloaded_Id, Status); end Set_Is_Dispatching_Operation; ------------------------ -- Set_Component_Type -- ------------------------ procedure Set_Component_Type (Array_Id : Entity_Id; Ct : Entity_Id) is begin pragma Debug (Check_Defining_Occurrence (Array_Id)); Set_Node10 (Array_Id, Ct); end Set_Component_Type; ---------------------------------- -- Set_Directly_Designated_Type -- ---------------------------------- procedure Set_Directly_Designated_Type (Access_Id : Entity_Id; Dt : Entity_Id) is begin pragma Debug (Check_Defining_Occurrence (Access_Id)); Set_Node10 (Access_Id, Dt); end Set_Directly_Designated_Type; -------------------------- -- Set_Full_Declaration -- -------------------------- procedure Set_Full_Declaration (Private_Id : Entity_Id; Fd : Entity_Id) is begin pragma Debug (Check_Defining_Occurrence (Private_Id)); Set_Node11 (Private_Id, Fd); end Set_Full_Declaration; --------------------- -- Set_Discriminal -- --------------------- procedure Set_Discriminal (Id : Entity_Id; Formal : Entity_Id) is begin pragma Debug (Check_Entity_Kind (Id, E_Discriminant)); Set_Node9 (Id, Formal); end Set_Discriminal; ------------------------------------ -- Set_Discriminant_Default_Value -- ------------------------------------ procedure Set_Discriminant_Default_Value (Id : Entity_Id; Val : Node_Id) is begin -- It is too strict to include a call to Check_Entity_Kind -- (E_Discriminant) here as a debugging check since at the -- point the default value is set the discriminant has -- an Ekind of E_Void to prevent its premature use. So simply -- check that it is a defining identifier. pragma Debug (Check_Defining_Occurrence (Id)); Set_Node10 (Id, Val); end Set_Discriminant_Default_Value; ------------------------------------ -- Set_Discriminant_Checking_Func -- ------------------------------------ procedure Set_Discriminant_Checking_Func (Id : Entity_Id; Proc_Id : Entity_Id) is begin pragma Debug (Check_Entity_Kind (Id, E_Component)); pragma Assert (Ekind (Scope (Id)) in Record_Kind, Compiler_Abort (Id)); Set_Node10 (Id, Proc_Id); end Set_Discriminant_Checking_Func; ----------------------- -- Set_Default_Value -- ----------------------- procedure Set_Default_Value (In_Id : Entity_Id; Val : Node_Id) is begin pragma Debug (Check_Entity_Kind (In_Id, E_In_Parameter)); Set_Node10 (In_Id, Val); end Set_Default_Value; ----------------------------- -- Set_Is_Directly_Visible -- ----------------------------- procedure Set_Is_Directly_Visible (Id : Entity_Id; Status : Boolean := True) is begin Set_Flag7 (Id, Status); end Set_Is_Directly_Visible; ------------------------ -- Set_Is_Use_Visible -- ------------------------ procedure Set_Is_Use_Visible (Id : Entity_Id; Status : Boolean := True) is begin Set_Flag9 (Id, Status); end Set_Is_Use_Visible; --------------------- -- Set_Next_Actual -- --------------------- procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is begin if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then Set_Node4 (Parent (Ass1_Id), Ass2_Id); else null; end if; end Set_Next_Actual; --------------- -- Set_Alias -- --------------- procedure Set_Alias (Overloaded_Id : Entity_Id; Id : Entity_Id) is begin pragma Debug (Check_Overloaded_Kind (Overloaded_Id)); Set_Node7 (Overloaded_Id, Id); end Set_Alias; -------------------------- -- Set_Needs_No_Actuals -- -------------------------- procedure Set_Needs_No_Actuals (Overloaded_Id : Entity_Id; Status : Boolean := True) is begin pragma Debug (Check_Overloaded_Kind (Overloaded_Id)); Set_Flag8 (Overloaded_Id, Status); end Set_Needs_No_Actuals; ---------------------- -- Set_Is_Intrinsic -- ---------------------- procedure Set_Is_Intrinsic (Proc_Id : Entity_Id) is begin pragma Debug (Check_Defining_Occurrence (Proc_Id)); Set_Flag27 (Proc_Id, True); end Set_Is_Intrinsic; ------------------------ -- Set_Interface_Name -- ------------------------ procedure Set_Interface_Name (Proc_Id : Entity_Id; Lit_Node : Node_Id) is begin pragma Debug (Check_Defining_Occurrence (Proc_Id)); Set_Node12 (Proc_Id, Lit_Node); end Set_Interface_Name; --------------------- -- Set_Entry_Index -- --------------------- procedure Set_Entry_Index (Id : Entity_Id; Ev : Uint) is begin Set_Uint11 (Id, Ev); end Set_Entry_Index; ------------------------- -- Set_Enumeration_Pos -- ------------------------- procedure Set_Enumeration_Pos (Enum_Id : Entity_Id; Ev : Uint) is begin Set_Uint11 (Enum_Id, Ev); end Set_Enumeration_Pos; ------------------------- -- Set_Enumeration_Rep -- ------------------------- procedure Set_Enumeration_Rep (Enum_Id : Entity_Id; Ev : Uint) is begin Set_Uint12 (Enum_Id, Ev); end Set_Enumeration_Rep; --------------------- -- Set_Slice_Range -- --------------------- procedure Set_Slice_Range (Id : Entity_Id; R_Node : Node_Id) is begin pragma Debug (Check_Entity_Kind (Id, E_Slice_Subtype)); Set_Node11 (Id, R_Node); end Set_Slice_Range; ------------------------------- -- Set_String_Literal_Length -- ------------------------------- procedure Set_String_Literal_Length (Id : Entity_Id; Val : Uint) is begin pragma Debug (Check_Entity_Kind (Id, E_String_Literal_Subtype)); Set_Uint11 (Id, Val); end Set_String_Literal_Length; --------------------------- -- Set_Table_High_Bounds -- --------------------------- procedure Set_Table_High_Bound (Id : Entity_Id; Val : Node_Id) is begin pragma Debug (Check_Entity_Kind (Id, E_Enum_Table_Type)); Set_Node11 (Id, Val); end Set_Table_High_Bound; ----------------------------- -- Set_Has_Subprogram_Body -- ----------------------------- procedure Set_Has_Subprogram_Body (Subprogram_Id : Entity_Id; Status : Boolean := True) is begin Set_Flag5 (Subprogram_Id, Status); end Set_Has_Subprogram_Body; ------------------------- -- Set_Is_Package_Body -- ------------------------- procedure Set_Is_Package_Body (Package_Id : Entity_Id; Status : Boolean := True) is begin Set_Flag5 (Package_Id, Status); end Set_Is_Package_Body; ------------------------- -- Set_In_Private_Part -- ------------------------- procedure Set_In_Private_Part (Package_Id : Entity_Id; Status : Boolean := True) is begin Set_Flag4 (Package_Id, Status); end Set_In_Private_Part; ---------------- -- Set_In_Use -- ---------------- procedure Set_In_Use (Package_Id : Entity_Id; Status : Boolean := True) is begin Set_Flag8 (Package_Id, Status); end Set_In_Use; ------------------------------- -- Set_Is_Private_Descendant -- ------------------------------- procedure Set_Is_Private_Descendant (Id : Entity_Id; Status : Boolean := True) is begin Set_Flag14 (Id, Status); end Set_Is_Private_Descendant; ----------------------------------- -- Set_Original_Record_Component -- ----------------------------------- procedure Set_Original_Record_Component (Id : Entity_Id; Orig_Id : Entity_Id) is begin -- needs double check E_Component or E_Discriminant ??? -- pragma Debug (Check_Entity_Kind (Id, E_Component)); Set_Node8 (Id, Orig_Id); end Set_Original_Record_Component; ------------------------- -- Set_Task_Value_Type -- ------------------------- procedure Set_Task_Value_Type (Id : Entity_Id; Ent : Entity_Id) is begin pragma Debug (Check_Defining_Occurrence (Id)); pragma Debug (Check_Defining_Occurrence (Ent)); Set_Node7 (Id, Ent); end Set_Task_Value_Type; ------------------- -- Append_Entity -- ------------------- procedure Append_Entity (Id : Entity_Id; Scope_Id : Entity_Id) is begin pragma Debug (Check_Defining_Occurrence (Id)); if Last_Entity (Scope_Id) = Empty then Set_First_Entity (Scope_Id, Id); else Set_Next_Entity (Last_Entity (Scope_Id), Id); end if; Set_Next_Entity (Id, Empty); Set_Scope (Id, Scope_Id); Set_Node10 (Scope_Id, Id); end Append_Entity; --------------------- -- Set_Last_Entity -- --------------------- procedure Set_Last_Entity (Scope_Id : Entity_Id; Id : Entity_Id) is begin pragma Debug (Check_Defining_Occurrence (Scope_Id)); Set_Node10 (Scope_Id, Id); end Set_Last_Entity; ------------------- -- Set_Master_Id -- ------------------- procedure Set_Master_Id (Access_Id : Entity_Id; Id : Entity_Id) is begin pragma Debug (Check_Defining_Occurrence (Access_Id)); Set_Node9 (Access_Id, Id); end Set_Master_Id; ------------------------------ -- Set_First_Private_Entity -- ------------------------------ procedure Set_First_Private_Entity (Package_Id : Entity_Id; Id : Entity_Id) is begin Set_Node11 (Package_Id, Id); end Set_First_Private_Entity; -------------------------------- -- Set_Suppress_Access_Checks -- -------------------------------- procedure Set_Suppress_Access_Checks (E : Entity_Id; V : Boolean := True) is begin Set_Flag31 (E, V); end Set_Suppress_Access_Checks; --------------------------------------- -- Set_Suppress_Accessibility_Checks -- --------------------------------------- procedure Set_Suppress_Accessibility_Checks (E : Entity_Id; V : Boolean := True) is begin Set_Flag32 (E, V); end Set_Suppress_Accessibility_Checks; -------------------------------------- -- Set_Suppress_Discriminant_Checks -- -------------------------------------- procedure Set_Suppress_Discriminant_Checks (E : Entity_Id; V : Boolean := True) is begin Set_Flag33 (E, V); end Set_Suppress_Discriminant_Checks; ---------------------------------- -- Set_Suppress_Division_Checks -- ---------------------------------- procedure Set_Suppress_Division_Checks (E : Entity_Id; V : Boolean := True) is begin Set_Flag34 (E, V); end Set_Suppress_Division_Checks; ------------------------------------- -- Set_Suppress_Elaboration_Checks -- ------------------------------------- procedure Set_Suppress_Elaboration_Checks (E : Entity_Id; V : Boolean := True) is begin Set_Flag35 (E, V); end Set_Suppress_Elaboration_Checks; ------------------------------- -- Set_Suppress_Index_Checks -- ------------------------------- procedure Set_Suppress_Index_Checks (E : Entity_Id; V : Boolean := True) is begin Set_Flag36 (E, V); end Set_Suppress_Index_Checks; -------------------------------- -- Set_Suppress_Length_Checks -- -------------------------------- procedure Set_Suppress_Length_Checks (E : Entity_Id; V : Boolean := True) is begin Set_Flag37 (E, V); end Set_Suppress_Length_Checks; ---------------------------------- -- Set_Suppress_Overflow_Checks -- ---------------------------------- procedure Set_Suppress_Overflow_Checks (E : Entity_Id; V : Boolean := True) is begin Set_Flag38 (E, V); end Set_Suppress_Overflow_Checks; ------------------------------- -- Set_Suppress_Range_Checks -- ------------------------------- procedure Set_Suppress_Range_Checks (E : Entity_Id; V : Boolean := True) is begin Set_Flag39 (E, V); end Set_Suppress_Range_Checks; --------------------------------- -- Set_Suppress_Storage_Checks -- --------------------------------- procedure Set_Suppress_Storage_Checks (E : Entity_Id; V : Boolean := True) is begin Set_Flag40 (E, V); end Set_Suppress_Storage_Checks; ----------------------------- -- Set_Suppress_Tag_Checks -- ----------------------------- procedure Set_Suppress_Tag_Checks (E : Entity_Id; V : Boolean := True) is begin Set_Flag41 (E, V); end Set_Suppress_Tag_Checks; ------------------------- -- Set_Equivalent_Type -- ------------------------- procedure Set_Equivalent_Type (Sub_Class : Entity_Id; Typ : Entity_Id) is begin pragma Assert (Ekind (Sub_Class) = E_Class_Subtype, Compiler_Abort (Sub_Class)); Set_Node7 (Sub_Class, Typ); end Set_Equivalent_Type; ------------------- -- Is_Class_Type -- ------------------- function Is_Class_Type (T : Entity_Id) return Boolean is begin pragma Debug (Check_Defining_Occurrence (T)); return Ekind (T) = E_Class_Type or else Ekind (T) = E_Class_Subtype; end Is_Class_Type; -------------------- -- Classwide_Type -- -------------------- function Classwide_Type (T : Entity_Id) return Entity_Id is E : Entity_Id; begin -- The Class_Type of a type is introduced after the type declaration. -- Scan entity list forward from the type. E := Next_Entity (T); while not Is_Class_Type (E) or else Etype (E) /= T loop E := Next_Entity (E); end loop; pragma Assert (Present (E)); return E; end Classwide_Type; ----------------------- -- Write_Entity_Info -- ----------------------- procedure Write_Entity_Info (Id : Entity_Id; Prefix : Str) is procedure Write_Kind (Id : Entity_Id) is K : constant String := Entity_Kind'Image (Ekind (Id)); begin Write_Str (Prefix); Write_Str (" Kind "); if Is_Type (Id) and then Is_Tagged_Type (Id) then Write_Str ("TAGGED "); end if; Write_String (K (3 .. K'Length)); Write_Str (" "); if Is_Type (Id) and then Is_Private_Type (Id) then Write_Str ("Is_Private_Type "); end if; end Write_Kind; procedure Write_Attribute (Which : Str; Nam : Entity_Id) is begin Write_Str (Prefix); Write_Str (Which); Write_Int (Int (Nam)); Write_Str (" "); Write_Name (Chars (Nam)); Write_Str (" "); end Write_Attribute; begin Write_Eol; Write_Attribute ("Name ", Id); Write_Int (Int (Id)); Write_Eol; Write_Kind (Id); Write_Eol; Write_Attribute (" Type ", Etype (Id)); Write_Eol; Write_Attribute (" Scope ", Scope (Id)); Write_Eol; case Ekind (Id) is when Discrete_Kind => Write_Str ("Bounds: Id = "); if Present (Scalar_Range (Id)) then Write_Int (Int (Type_Low_Bound (Id))); Write_Str (" .. Id = "); Write_Int (Int (Type_High_Bound (Id))); else Write_Str ("Empty"); end if; Write_Eol; when Array_Kind => declare Index : Entity_Id; begin Write_Attribute (" Component Type ", Component_Type (Id)); Write_Eol; Write_Str (Prefix); Write_Str (" Indices "); Index := First_Index (Id); while Present (Index) loop Write_Attribute (" ", Etype (Index)); Index := Next_Index (Index); end loop; Write_Eol; end; when Access_Kind => Write_Attribute (" Directly Designated Type ", Directly_Designated_Type (Id)); Write_Eol; when Overloaded_Kind => if Present (Homonym (Id)) then Write_Str (" Homonym "); Write_Name (Chars (Homonym (Id))); Write_Str (" "); Write_Int (Int (Homonym (Id))); Write_Eol; end if; Write_Eol; when E_Component => if Ekind (Scope (Id)) in Record_Kind then Write_Attribute ( " Original_Record_Component ", Original_Record_Component (Id)); Write_Int (Int (Original_Record_Component (Id))); Write_Eol; end if; when others => null; end case; end Write_Entity_Info; end Einfo; ------- -- Set_First_Private_Entity -- ------------------------------ procedure Set_First_Pgnat-1.67-src/src/errout.ads 444 10015 7640 46100 5506244305 11146 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E R R O U T -- -- -- -- S p e c -- -- -- -- $Revision: 1.31 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Table; with Types; use Types; package Errout is -- This package contains the routines to output error messages. They -- are basically system independent, however in some environments, e.g. -- when the parser is embedded into an editor, it may be appropriate -- to replace the implementation of this package. type Compiler_State_Type is (Parsing, Analyzing, Expanding); Compiler_State : Compiler_State_Type; -- Indicates current state of compilation. This is put in the Errout -- spec because it affects the action of the error message handling. -- In particular, an attempt is made to suppress cascaded error -- messages in Parsing mode, but not in the other modes. ----------------------------------- -- Suppression of Error Messages -- ----------------------------------- -- In an effort to reduce the impact of redundant error messages, the -- error output routines in this package normally suppress certain -- classes of messages as follows: -- 1. Identical messages placed at the same point in the text. Such -- duplicate error message result for example from rescanning -- sections of the text that contain lexical errors. Only one of -- such a set of duplicate messages is output, and the rest are -- suppressed. -- 2. If more than one parser message is generated for a single source -- line, then only the first message is output, the remaining -- messages on the same line are suppressed. -- 3. If a message is posted on a node for which a message has been -- previously posted, then only the first message is retained. The -- Error_Posted flag is used to detect such multiple postings. Note -- that this only applies to semantic messages, since otherwise -- for parser messages, this would be a special case of case 2. -- 4. If a message is posted on a node whose Etype or Entity -- fields reference entities on which an error message has -- already been placed, as indicated by the Error_Posted flag -- being set on these entities, then the message is suppressed. -- 5. If a message attempts to insert an Error node, or a direct -- reference to the Any_Type node, then the message is suppressed. -- This normal suppression action may be overridden in cases 2-5 (but not -- in case 1) by setting All_Errors mode, or by setting the special -- unconditional message insertion character (!) at the end of the message -- text as described below. --------------------------------------------------------- -- Error Message Text and Message Insertion Characters -- --------------------------------------------------------- -- Error message text strings are composed of lower case letters, digits -- and the special characters space, comma, period, colon and semicolon, -- apostrophe and parentheses. Special insertion characters can also -- appear which cause the error message circuit to modify the given -- string as follows: -- Insertion character % (Percent: insert name from Names table) -- The character % is replaced by the text for the name specified by -- the Name_Id value stored in Error_Msg_Name_1, as generated by the -- routine Get_Name_String stored in Error_Msg_Name_1. A blank precedes -- the name if it is preceded by a non-blank character other than a -- left parenthesis. The name is enclosed in quotes unless manual -- quotation mode is set. If the Name_Id is set to No_Name, then -- no insertion occurs; if the Name_Id is set to Error_Name, then -- the string is inserted. A second % may appear in a single -- message in which case it is similarly replaced by the name which -- is specified by the Name_Id value stored in Error_Msg_Name_2. -- THe name is cased according to the current identifier casing mode. -- Insertion character $ (Dollar: insert unit name from Names table) -- The character $ is treated similarly to %, except that the name -- is obtained from the Unit_Name_Type value in Error_Msg_Unit_1 -- and Error_Msg_Unit_2, as provided by Get_Unit_Name_String in -- package Uname. -- Insertion character { (Left brace: insert file name from names table) -- The character { is treated similarly to %, except that the -- name is output literally as stored in the names table without -- adjusting the casing. -- Insertion character * (Asterisk, insert reserved word name) -- The insertion character * is treated exactly like % except that -- the resulting name is cased according to the default conventions -- for reserved words (see package Scans). -- Insertion character & (Ampersand: insert name from node) -- The insertion character & is treated similarly to %, except that -- the name is taken from the Chars field of the given node, and may -- refer to a child unit name, or a selected component. The casing -- is, if possible, taken from the original source reference, which -- is obtained from the Sloc field of the given node or nodes. If no -- Sloc is available (happens e.g. for nodes in package Standard), -- then the default case (see Scans spec) is used. The nodes to be -- used are stored in Error_Msg_Node_1, Error_Msg_Node_2. No insertion -- occurs for the Empty node, and the Error node results in the -- insertion of the characters . -- Insertion character # (Pound: insert line number reference) -- The character # is replaced by the decimal line number of the -- location containing the source position stored in Error_Msg_Sloc_1. -- If this location is in a different file than the error message -- flag location, "in file xxx" is appended to designate the file. -- Insertion character @ (At: insert column number reference) -- The character @ is replaced by null if the RM_Column_Check mode is -- off (False). If the switch is on (True), then @ is replaced by the -- text string " in column nnn" where nnn is the decimal representation -- of the column number stored in Error_Msg_Col plus one (the plus one -- is because the number is stored 0-origin and displayed 1-origin). -- Insertion character ^ (Carret: insert integer value) -- The character ^ is replaced by the decimal conversion of the Uint -- value stored in Error_Msg_Uint_1, with a possible leading minus. -- A second ^ may occur in the message, in which case it is replaced -- by the decimal conversion of the Uint value in Error_Msg_Uint_2. -- Insertion character ! (Exclamation: unconditional message) -- The character ! appearing as the last character of a message makes -- the message unconditional which means that it is output even if it -- would normally be suppressed. See section above for a description -- of the cases in which messages are normally suppressed. -- Insertion character ~ (Tilde: fatal error message) -- The character ~ appearing anywhere in a message makes the message -- a fatal error message. Eventually the plan is that only fatal errors -- will cause subsequent semantic analysis to be suppressed, but for -- now fatal error messages are equivalent to normal unconditional -- messages, since all errors cause OK to be reset in the file table. -- Insertion character ? (Question: warning message) -- The character ? appearing anywhere in a message makes the message -- a warning instead of a normal error message, and the text of the -- message will be preceded by "Warning:" instead of "Error:" The -- handling of warnings if further controlled by the Warning_Mode -- option (-w switch), see package Opt for further details. -- Insertion character A-Z (Upper case letter: Ada reserved word) -- If two or more upper case letters appear in the message, they are -- taken as an Ada reserved word, and are converted to the default -- case for reserved words (see Scans package spec). Surrounding -- quotes are added unless manual quotation mode is currently set. -- Insertion character ` (Backquote: set manual quotation mode) -- The backquote character always appears in pairs. Each backquote -- of the pair is replaced by a double quote character. In addition, -- Any reserved keywords, or name insertions between these backquotes -- are not surrounded by the usual automatic double quotes. See the -- section below on manual quotation mode for further details. -- Insertion character ' (Quote: literal character) -- Precedes a character which is placed literally into the message. -- Used to insert characters into messages that are one of the -- insertion characters defined here. ----------------------------------------------------- -- Global Values Used for Error Message Insertions -- ----------------------------------------------------- -- The following global variables are essentially additional parameters -- passed to the error message routine for insertion sequences described -- above. The reason these are passed globally is that the insertion -- mechanism is essentially an untyped one in which the appropriate -- variables are set dependingon the specific insertion characters used. Error_Msg_Col : Column_Number_Type; -- Column for @ insertion character in message Error_Msg_Uint_1 : Uint; Error_Msg_Uint_2 : Uint; -- Uint values for ^ insertion characters in message Error_Msg_Sloc_1 : Source_Ptr; Error_Msg_Sloc_2 : Source_Ptr; -- Source location for # insertion character in message Error_Msg_Name_1 : Name_Id; Error_Msg_Name_2 : Name_Id; -- Name_Id values for % insertion characters in message Error_Msg_Unit_1 : Name_Id; Error_Msg_Unit_2 : Name_Id; -- Name_Id values for $ insertion characters in message Error_Msg_Node_1 : Node_Id; Error_Msg_Node_2 : Node_Id; -- Node_Id values for & insertion characters in message ----------------------------------------------------- -- Format of Messages and Manual Quotation Control -- ----------------------------------------------------- -- Messages are generally all in lower case, except for inserted names -- and appear in one of the following three forms: -- fatal error: text -- error: text -- warning: text -- The prefixes fatal error, error and warning are supplied automatically -- (depending on the use of the ? and ~ insertion characters), and the -- call to the error message supplies the text. -- Reserved Ada keywords in the message are in the default keyword case -- (determined from the given source program), surrounded by quotation -- marks. This is achieved by spelling the reserved word in upper case -- letters, which is recognized as a request for insertion of quotation -- marks by the error text processor. Thus for example: -- Error_Msg_AP ("IS expected"); -- would result in the output of one of the following: -- error: "is" expected -- error: "IS" expected -- error: "Is" expected -- the choice between these being made by looking at the casing convention -- used for keywords (actually the first compilation unit keyword) in the -- source file. -- In the case of names, the default mode for the error text processor -- is to surround the name by quotation marks automatically. The case -- used for the identifier names is taken from the source program where -- possible, and otherwise is the default casing convention taken from -- the source file usage. -- In some cases, better control over the placement of quote marks is -- required. This is achieved using manual quotation mode. In this mode, -- one or more insertion sequences is surrounded by backquote characters. -- The backquote characters are output as double quote marks, and normal -- automatic insertion of quotes is suppressed between the double quotes. -- For example: -- Error_Msg_AP ("`END&;` expected"); -- generates a message like -- error: "end Open_Scope;" expected -- where the node specifying the name Open_Scope has been stored in -- Error_Msg_Node_1 prior to the call. The great majority of error -- messages operates in normal quotation mode. ---------------------------- -- Message ID Definitions -- ---------------------------- type Error_Msg_Id is new Int; -- A type used to represent specific error messages. Used by the clients -- of this package only in the context of the Get_Error_Id and -- Change_Error_Text subprograms. No_Error_Msg : constant Error_Msg_Id := 0; -- A constant which is different from any value returned by Get_Error_Id. -- Typically used by a client to indicate absense of a saved Id value. function Get_Msg_Id return Error_Msg_Id; -- Returns the Id of the message most recently posted using one of the -- Error_Msg routines. ------------------------ -- List Pragmas Table -- ------------------------ -- When a pragma Page or pragma List is encountered by the parser, an -- entry is made in the following table. This table is then used to -- control the full listing if one is being generated. Note that the -- reason we do the processing in the parser is so that we get proper -- listing control even in syntax check only mode. type List_Pragma_Type is (List_On, List_Off, Page); type List_Pragma_Record is record Ptyp : List_Pragma_Type; Ploc : Source_Ptr; end record; -- Note: Ploc points to the terminating semicolon in the List_Off and -- Page cases, and to the pragma keyword for List_On. In the case of -- a pragma List_Off, a List_On entry is also made in the table, -- pointing to the pragma keyword. This ensures that, as required, -- a List (Off) pragma is listed even in list off mode. package List_Pragmas is new Table ( Component_Type => List_Pragma_Record, Index_Type => Int, Low_Bound => 1, Initial => 50, Increment => 200, Table_Name => "List_Pragmas"); ------------------------------ -- Error Output Subprograms -- ------------------------------ procedure Initialize_Errout; -- Initializes for output of error messages. Must be called for each -- source file before using any of the other routines in the package. procedure Finalize_Error_Output; -- Finalize processing of error messages for one file and output message -- indicating the number of detected errors. procedure Error_Msg (Msg : Str; Flag_Location : Source_Ptr); -- Output a message at specified location. Can be called from the parser -- or the semantic analyzer. procedure Error_Msg_S (Msg : Str); -- Output a message at current scan pointer location. This routine can be -- called only from the parser, since it references Scan_Ptr. procedure Error_Msg_AP (Msg : Str); -- Output a message just after the previous token. This routine can be -- called only from the parser, since it references Prev_Token_Ptr. procedure Error_Msg_BC (Msg : Str); -- Output a message just before the current token. Note that the important -- difference between this and the previous routine is that the BC case -- posts a flag on the current line, whereas AP can post a flag at the -- end of the preceding line. This routine can be called only from the -- parser, since it references Token_Ptr. procedure Error_Msg_SC (Msg : Str); -- Output a message at the start of the current token, unless we are at -- the end of file, in which case we always output the message after the -- last real token in the file. This routine can be called only from the -- parser, since it references Token_Ptr. procedure Error_Msg_SP (Msg : Str); -- Output a message at the start of the previous token. This routine can -- be called only from the parser, since it references Prev_Token_Ptr. procedure Error_Msg_N (Msg : Str; N : Node_Id); -- Output a message at the Sloc of the given node. This routine can be -- called from the parser or the semantic analyzer, although the call -- from the latter is much more common (and is the most usual way of -- generating error messages from the analyzer). The message text may -- contain a single & insertion, which will reference the given node. procedure Error_Msg_NE (Msg : Str; N : Node_Id; E : Entity_Id); -- Output a message at the Sloc of the given node, with an insertion of -- the name from the given entity node. This is used by the semantic -- routines, where this is a common error message situation. The Msg -- text will contain a & as usual to mark the name insert point. This -- routine can be called from the parser or the analyzer. procedure Change_Error_Text (Error_Id : Error_Msg_Id; New_Msg : Str); -- The error message text of the message identified by Id is replaced by -- the given text. This text may contain insertion characters in the -- usual manner, and need not be the same length as the original text. end Errout; ribed -- above. The reason these are passed globally is that the insertion -- mechanism is essentially an untyped one in which the appropriate -- variables are set dependingon the specific insertion characters used. Error_Msg_Col : Column_Number_Type; -- Column for @ insertion character in message Error_Msg_Uint_1 : Uint; Error_Msg_Uint_2 : Uint; -- Uint values for ^ insertion characters in message Error_Msg_Sgnat-1.67-src/src/errout.adb 444 10015 7640 136447 5506244306 11164 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E R R O U T -- -- -- -- B o d y -- -- -- -- $Revision: 1.57 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Casing; use Casing; with Csets; use Csets; with Debug; use Debug; with Einfo; use Einfo; with Errcount; use Errcount; with Excep; use Excep; with Exp_Util; use Exp_Util; with Lib; use Lib; with Limits; use Limits; with Namet; use Namet; with Opt; use Opt; with Output; use Output; with Scans; use Scans; with Sinput; use Sinput; with Sinfo; use Sinfo; with Stand; use Stand; with Uintp; use Uintp; with Uname; use Uname; package body Errout is Max_Msg_Length : constant := 80 + 2 * Max_Line_Length; -- Maximum length of error message. The addition of Max_Line_Length -- ensures that two insertion tokens of maximum length can be accomodated. Msg_Buffer : Str (1 .. Max_Msg_Length); -- Buffer used to prepare error messages Msg_Len : Int; -- Number of characters currently stored in the message buffer Flag_Unit : Unit_Number_Type; -- Unit number for file where error is being posted Is_Warning_Msg : Boolean; -- Set by Set_Msg_Text to indicate if current message is warning message Is_Fatal_Msg : Boolean; -- Set by Set_Msg_Text to indicate if current message is fatal message Is_Unconditional_Msg : Boolean; -- Set by Set_Msg_Text to indicate if current message is unconditional Cur_Msg : Error_Msg_Id; -- Id of most recently posted error message Current_Error_Unit : Unit_Number_Type; -- Id of current messages. Used to post file name when unit changes. This -- is initialized to Main_Unit at the start of a compilation, which means -- that no file names will be output unless there are errors in units -- other than the main unit. Manual_Quote_Mode : Boolean; -- Set True in manual quotation mode List_Pragmas_Index : Int; -- Index into List_Pragmas table List_Pragmas_Mode : Boolean; -- Starts True, gets set False by pragma List (Off), True by List (On) Suppress_Message : Boolean; -- A flag used to suppress certain obviously redundant messages (i.e. -- those referring to a node whose type is Any_Type). This suppression -- is effective only if All_Errors_Mode is off. ----------------------------------- -- Error Message Data Structures -- ----------------------------------- -- The error messages are stored as a linked list of error message objects -- sorted into ascending order by the source location (Sloc). Each object -- records the text of the message and its source location. -- The following record type and table are used to represent error -- messages, with one entry in the table being allocated for each message. type Error_Msg_Object is record Text : Name_Id; -- Text of error message Next : Error_Msg_Id; -- Pointer to next message Unit : Unit_Number_Type; -- Unit number of source file Sptr : Source_Ptr; -- Flag pointer Line : Line_Number_Type; -- Line number Col : Column_Number_Type; -- Column number Warn : Boolean; -- True if warning message Fatal : Boolean; -- True if fatal message Uncond : Boolean; -- True if unconditional message end record; package Errors is new Table ( Component_Type => Error_Msg_Object, Index_Type => Error_Msg_Id, Low_Bound => 1, Initial => 200, Increment => 200, Table_Name => "Error"); Error_Msgs : Error_Msg_Id; -- The list of error messages ----------------------- -- Local Subprograms -- ----------------------- procedure Debug_Output (N : Node_Id); -- Called from Error_Msg_N and Error_Msg_NE to generate line of debug -- output giving node number (of node N) if the debug X switch is set. function OK_Node (N : Node_Id) return Boolean; -- Determines if a node is an OK node to place an error message on (return -- True) or if the error message should be suppressed (return False). A -- message is suppressed if the node already has an error posted on it, -- or if it refers to an Etype that has an error posted on it, or if -- it references an Entity that has an error posted on it. procedure Output_Error_Msgs (E : in out Error_Msg_Id); -- Output source line, error flag, and text of stored error message and -- all subsequent messages for the same line and unit. On return E is -- set to be one higher than the last message output. procedure Output_Line_Number (L : Line_Number_Type); -- Output a line number as six digits (with leading zeroes suppressed), -- followed by a period and a blank (note that this is 8 characters which -- means that tabs in the source line will not get messed up). procedure Output_Msg_Text (E : Error_Msg_Id); -- Outputs characters of text in the text of the error message E, excluding -- any final exclamation point, followed by a new line. procedure Output_Source_Line (L : Line_Number_Type; U : Unit_Number_Type; Errs : Boolean); -- Outputs text of source line L, in unit U, together with preceding line -- number, as described above for Output_Line_Number. The Errs parameter -- indicates if there are errors attached to the line, which forces -- listing on, even in the presence of pragma List (Off). procedure Set_Msg_Text (Text : Str; Flag : Source_Ptr); -- Add a sequence of characters to the current message. The characters may -- be one of the special insertion characters (see documentation in spec). -- Flag is the location at which the error is to be posted, which is used -- to determine whether or not the # insertion needs a file name. The -- global variables Msg_Buffer, Msg_Len, Is_Warning_Msg, Is_Fatal_Msg, -- and Is_Unconditional_Msg are set on return. procedure Set_Msg_Insertion_Column; -- Handle column number insertion (@ insertion character) procedure Set_Msg_Insertion_Name; -- Handle name insertion (% insertion character) procedure Set_Msg_Insertion_Line_Number (Flag : Source_Ptr); -- Handle line number insertion (# insertion character). Flag is passed as -- a parameter to determine whether or not to add "in file xxx" to msg. procedure Set_Msg_Insertion_Node; -- Handle node (name from node) insertion (& insertion character) procedure Set_Msg_Insertion_Reserved_Name; -- Handle insertion of reserved word name (* insertion character). procedure Set_Msg_Insertion_Reserved_Word (Text : Str; I : in out Int); -- Handle reserved word insertion (upper case letters). The Text argument -- is the current error message input text, and I is an index which on -- entry points to the first character of the reserved word, and on exit -- points past the last character of the reserved word. procedure Set_Msg_Insertion_Uint; -- Handle Uint insertion (^ insertion character) procedure Set_Msg_Insertion_Unit_Name; -- Handle unit name insertion ($ insertion character) procedure Set_Msg_Insertion_File_Name; -- Handle file name insertion ({ insertion character) procedure Set_Msg_Blank; -- Sets a single blank in the message if the preceding character is a -- non-blank character other than a left parenthesis. procedure Set_Msg_Char (C : Char); -- Add a single character to the current message. This routine does not -- check for special insertion characters (they are just treated as text -- characters if they occur). procedure Set_Msg_Int (Line : Int); -- Set the decimal representation of the argument in the error message -- buffer with no leading zeroes output. procedure Set_Msg_Name_Buffer; -- Output name from Name_Buffer, with surrounding quotes unless manual -- quotation mode is in effect. procedure Set_Msg_Node (Node : Node_Id); -- Add the sequence of characters for the name associated with the -- given node to the current message. procedure Set_Msg_Quote; -- Set quote if in normal quote mode, nothing if in manual quote mode procedure Set_Msg_Str (Text : Str); -- Add a sequence of characters to the current message. This routine does -- not check for special insertion characters (they are just treated as -- text characters if they occur). ----------------------- -- Initialize_Errout -- ----------------------- procedure Initialize_Errout is begin Errors.Init; Error_Msgs := No_Error_Msg; Errors_Detected := 0; Warnings_Detected := 0; Cur_Msg := No_Error_Msg; Current_Error_Unit := Main_Unit; List_Pragmas.Init; end Initialize_Errout; --------------------------- -- Finalize_Error_Output -- --------------------------- procedure Finalize_Error_Output is E : Error_Msg_Id; Err_Flag : Boolean; begin -- Brief Error mode if Brief_Output or (not Full_List and not Verbose_Mode) then E := Error_Msgs; Set_Standard_Error; while E /= No_Error_Msg loop Write_Char ('"'); Write_Name (File.Table (Errors.Table (E).Unit).Full_File_Name); Write_String (""", line "); Write_Int (Int (Errors.Table (E).Line)); Write_Char ('('); Write_Int (Int (Errors.Table (E).Col)); Write_Str ("): "); Output_Msg_Text (E); E := Errors.Table (E).Next; end loop; Set_Standard_Output; end if; -- Full source listing case if Full_List then List_Pragmas_Index := 1; List_Pragmas_Mode := True; E := Error_Msgs; -- First list main source file with its error messages for N in 1 .. File.Table (Main_Unit).Last_Line loop Err_Flag := E /= No_Error_Msg and then Errors.Table (E).Line = N and then Errors.Table (E).Unit = Main_Unit; Output_Source_Line (N, Main_Unit, Err_Flag); if Err_Flag then Output_Error_Msgs (E); Write_Eol; end if; end loop; -- Then output errors, if any, for subsidiary units while E /= No_Error_Msg and then Errors.Table (E).Unit /= Main_Unit loop Write_Eol; Output_Source_Line (Errors.Table (E).Line, Errors.Table (E).Unit, True); Output_Error_Msgs (E); end loop; end if; -- Verbose mode (error lines only with error flags) if Verbose_Mode and not Full_List then E := Error_Msgs; -- Loop through error lines while E /= No_Error_Msg loop Write_Eol; Output_Source_Line (Errors.Table (E).Line, Errors.Table (E).Unit, True); Output_Error_Msgs (E); end loop; end if; -- Output error summary if verbose or full list mode if Verbose_Mode or else Full_List then -- Extra blank line if error messages or source listing were output if Errors_Detected + Warnings_Detected > 0 or else Full_List then Write_Eol; end if; -- Message giving total number of lines Write_Str (" "); Write_Int (Int (File.Table (Main_Unit).Last_Line)); if File.Table (Main_Unit).Last_Line = 1 then Write_Str (" line: "); else Write_Str (" lines: "); end if; -- Message giving number of errors detected. This normally goes to -- Standard_Output. The exception is when brief mode is not set, -- verbose mode (or full list mode) is set, and there are errors. -- In this case we send the message to standard error to make sure -- that *something* appears on standard error in an error situation. if Errors_Detected + Warnings_Detected /= 0 and then not Brief_Output and then (Verbose_Mode or Full_List) then Set_Standard_Error; end if; if Errors_Detected = 0 then Write_String ("No errors"); elsif Errors_Detected = 1 then Write_String ("1 error"); else Write_Int (Errors_Detected); Write_String (" errors"); end if; if Warnings_Detected = 1 then Write_String (", 1 warning"); elsif Warnings_Detected > 1 then Write_String (", "); Write_Int (Warnings_Detected); Write_String (" warnings"); end if; Write_Eol; Set_Standard_Output; end if; end Finalize_Error_Output; ---------------- -- Get_Msg_Id -- ---------------- function Get_Msg_Id return Error_Msg_Id is begin return Cur_Msg; end Get_Msg_Id; --------------- -- Error_Msg -- --------------- procedure Error_Msg (Msg : Str; Flag_Location : Source_Ptr) is Next_Msg : Error_Msg_Id; -- Pointer to next message at insertion point Prev_Msg : Error_Msg_Id; -- Pointer to previous message at insertion point Temp_Msg : Error_Msg_Id; begin Suppress_Message := False; Set_Msg_Text (Msg, Flag_Location); -- Return without doing anything if message is suppressed if Suppress_Message and not All_Errors_Mode and not (Msg (Msg'Last) = '!') then return; end if; -- Immediate return if warning message and warnings are suppressed if Is_Warning_Msg and then Warning_Mode = Suppress then Cur_Msg := No_Error_Msg; return; end if; -- Otherwise build error message object for new message Name_Buffer (1 .. Msg_Len) := Msg_Buffer (1 .. Msg_Len); Name_Len := Msg_Len; Errors.Increment_Last; Cur_Msg := Errors.Last; Errors.Table (Cur_Msg).Text := Name_Enter; Errors.Table (Cur_Msg).Next := No_Error_Msg; Errors.Table (Cur_Msg).Sptr := Flag_Location; Errors.Table (Cur_Msg).Unit := Get_Sloc_Unit_Number (Flag_Location); Errors.Table (Cur_Msg).Line := Get_Line_Number (Flag_Location); Errors.Table (Cur_Msg).Col := Get_Col_Number (Flag_Location); Errors.Table (Cur_Msg).Warn := Is_Warning_Msg; Errors.Table (Cur_Msg).Fatal := Is_Fatal_Msg; Errors.Table (Cur_Msg).Uncond := Is_Unconditional_Msg; -- If immediate errors mode set, output error message now. Also output -- now if the -d1 debug flag is set (so node number message comes out -- just before actual error message) if Immediate_Errors or else Debug_Flag_1 then Write_Eol; Output_Source_Line (Errors.Table (Cur_Msg).Line, Errors.Table (Cur_Msg).Unit, True); Temp_Msg := Cur_Msg; Output_Error_Msgs (Temp_Msg); -- If not in immediate errors mode, then we insert the message in the -- error chain for later output by Finalize_Error_Output. The messages -- are sorted first by unit (main unit comes first), and within a unit -- by source location (earlier flag location first in the chain). else Prev_Msg := No_Error_Msg; Next_Msg := Error_Msgs; while Next_Msg /= No_Error_Msg loop exit when Errors.Table (Cur_Msg).Unit < Errors.Table (Next_Msg).Unit; if Errors.Table (Cur_Msg).Unit = Errors.Table (Next_Msg).Unit then exit when Flag_Location < Errors.Table (Next_Msg).Sptr; end if; Prev_Msg := Next_Msg; Next_Msg := Errors.Table (Next_Msg).Next; end loop; -- The possible insertion point for the new message is after Prev_Msg -- and before Next_Msg. However, there are some cases in which we do -- not insert the message on the grounds that it is redundant with -- respect to the previous message. We only consider deleting the -- message if it is for the same line and unit as the previous one. if Prev_Msg /= No_Error_Msg and then Errors.Table (Prev_Msg).Line = Errors.Table (Cur_Msg).Line and then Errors.Table (Prev_Msg).Unit = Errors.Table (Cur_Msg).Unit then -- Definitely delete a complete duplicate (i.e. one where the -- error text matches as well). Such duplicates are typically -- lexical messages from tokens that are rescanned. Note that -- such complete duplicates are deleted even if All_Errors -- mode is set on, since they can't possibly give any useful -- information under any circumstances. if Length_Of_Name (Errors.Table (Prev_Msg).Text) = Length_Of_Name (Errors.Table (Cur_Msg).Text) and then Errors.Table (Prev_Msg).Text = Errors.Table (Cur_Msg).Text then return; end if; -- Remaining case is where we are parsing and we are not in -- all errors mode (in semantics, don't delete any messages) if not All_Errors_Mode and then Compiler_State = Parsing then -- Don't delete unconditional or fatal messages if not Errors.Table (Cur_Msg).Fatal and then not Errors.Table (Cur_Msg).Uncond then -- Don't delete if prev msg is warning and new msg is -- an error. This is because we don't want a real error -- masked by a warning. In all other cases (that is parse -- errors for the same line that are not unconditional -- or fatal) we do delete the message. This helps to avoid -- junk extra messages from cascaded parsing errors if not Errors.Table (Prev_Msg).Warn or else Errors.Table (Cur_Msg).Warn then -- All tests passed, delete the message by simply -- returning without any further processing. return; end if; end if; end if; end if; -- Come here if message is to be inserted in the error chain if Prev_Msg = No_Error_Msg then Error_Msgs := Cur_Msg; else Errors.Table (Prev_Msg).Next := Cur_Msg; end if; Errors.Table (Cur_Msg).Next := Next_Msg; end if; -- Bump appropriate statistics count if Errors.Table (Cur_Msg).Warn and then Warning_Mode /= Treat_As_Error then Warnings_Detected := Warnings_Detected + 1; else Errors_Detected := Errors_Detected + 1; -- Turn off code generation if not done already if Operating_Mode = Generate_Code then Operating_Mode := Check_Semantics; Expander_Active := False; end if; -- If fatal message then set fatal flag in the File.Table entry for -- the appropriate unit. For now, we also set this flag for all other -- error messages as well unless Try_Semantics is set to True. if Is_Fatal_Msg or not Try_Semantics then File.Table (Errors.Table (Cur_Msg).Unit).Fatal_Error := True; end if; end if; -- Terminate if max errors reached if Errors_Detected = Maximum_Errors then Write_String ("fatal error: maximum errors reached"); Write_Eol; raise Unrecoverable_Error; end if; end Error_Msg; ----------------- -- Error_Msg_S -- ----------------- procedure Error_Msg_S (Msg : Str) is begin Error_Msg (Msg, Scan_Ptr); end Error_Msg_S; ------------------ -- Error_Msg_AP -- ------------------ procedure Error_Msg_AP (Msg : Str) is S1 : Source_Ptr; C : Char; begin -- If we had saved the Scan_Ptr value after scanning the previous -- token, then we would have exactly the right place for putting -- the flag immediately at hand. However, that would add at least -- two instructions to a Scan call *just* to service the possibility -- of an Error_Msg_AP call. So instead we reconstruct that value. -- We have two possibilities, start with Prev_Token_Ptr and skip over -- the current token, which is made harder by the possibility that this -- token may be in error, or start with Token_Ptr and work backwards. -- We used to take the second approach, but it's hard because of -- comments, and harder still because things that look like comments -- can appear inside strings. So now we take the second approach. -- Note: in the case where there is no previous token, Prev_Token_Ptr -- is set to Source'First, which is a reasonable position for the -- error flag in this situation. S1 := Prev_Token_Ptr; C := Source (S1); -- If the previous token is a string literal, we need a special approach -- since there may be white space inside the literal and we don't want -- to stop on that white space. if Prev_Token = Tok_String_Literal then loop S1 := S1 + 1; if Source (S1) = C then S1 := S1 + 1; exit when Source (S1) /= C; elsif Source (S1) in Line_Terminator then exit; end if; end loop; -- Character literal also needs special handling elsif Prev_Token = Tok_Char_Literal then S1 := S1 + 3; -- Otherwise we search forward for the end of the current token, marked -- by a line terminator, white space, a comment symbol or if we bump -- into the following token (i.e. the current token) else while Source (S1) not in Line_Terminator and then Source (S1) /= ' ' and then Source (S1) /= HT and then Source (S1 .. S1 + 1) /= "--" and then S1 /= Token_Ptr loop S1 := S1 + 1; end loop; end if; -- S1 is now set to the location for the flag Error_Msg (Msg, S1); end Error_Msg_AP; ------------------ -- Error_Msg_BC -- ------------------ procedure Error_Msg_BC (Msg : Str) is begin -- If we are at end of file, post the flag after the previous token if Token = Tok_EOF then Error_Msg_AP (Msg); -- If we are at start of file, post the flag at the current token elsif Token_Ptr = Source'First then Error_Msg_SC (Msg); -- If the character before the current token is a space or a horizontal -- tab, then we place the flag on this character (in the case of a tab -- we would really like to place it in the "last" character of the tab -- space, but that it too much trouble to worry about). elsif Source (Token_Ptr - 1) = ' ' or else Source (Token_Ptr - 1) = HT then Error_Msg (Msg, Token_Ptr - 1); -- If there is no space or tab before the current token, then there is -- no room to place the flag before the token, so we place it on the -- token instead (this happens for example at the start of a line). else Error_Msg (Msg, Token_Ptr); end if; end Error_Msg_BC; ------------------ -- Error_Msg_SC -- ------------------ procedure Error_Msg_SC (Msg : Str) is begin -- If we are at end of file, post the flag after the previous token if Token = Tok_EOF then Error_Msg_AP (Msg); -- For all other cases the message is posted at the current token -- pointer position else Error_Msg (Msg, Token_Ptr); end if; end Error_Msg_SC; ------------------ -- Error_Msg_SP -- ------------------ procedure Error_Msg_SP (Msg : Str) is begin -- Note: in the case where there is no previous token, Prev_Token_Ptr -- is set to Source'First, which is a reasonable position for the -- error flag in this situation Error_Msg (Msg, Prev_Token_Ptr); end Error_Msg_SP; ----------------- -- Error_Msg_N -- ----------------- procedure Error_Msg_N (Msg : Str; N : Node_Id) is begin if All_Errors_Mode or else Msg (Msg'Last) = '!' or else OK_Node (N) then Debug_Output (N); Error_Msg_Node_1 := N; Error_Msg (Msg, Sloc (N)); end if; Set_Error_Posted (N, True); end Error_Msg_N; ------------------ -- Error_Msg_NE -- ------------------ procedure Error_Msg_NE (Msg : Str; N : Node_Id; E : Entity_Id) is begin if All_Errors_Mode or else Msg (Msg'Last) = '!' or else OK_Node (N) then Debug_Output (N); Error_Msg_Node_1 := E; Error_Msg (Msg, Sloc (N)); end if; Set_Error_Posted (N, True); end Error_Msg_NE; ----------------------- -- Change_Error_Text -- ----------------------- procedure Change_Error_Text (Error_Id : Error_Msg_Id; New_Msg : Str) is Save_Next : Error_Msg_Id; Err_Id : Error_Msg_Id := Error_Id; begin Set_Msg_Text (New_Msg, Errors.Table (Error_Id).Sptr); Name_Len := Msg_Len; Name_Buffer (1 .. Name_Len) := Msg_Buffer (1 .. Msg_Len); Errors.Table (Error_Id).Text := Name_Enter; -- If in immediate error message mode, output modified error message now -- This is just a bit tricky, because we want to output just a single -- message, and the messages we modified is already linked in. We solve -- this by temporarily resetting its forward pointer to empty. if Immediate_Errors then Save_Next := Errors.Table (Error_Id).Next; Errors.Table (Error_Id).Next := No_Error_Msg; Write_Eol; Output_Source_Line (Errors.Table (Error_Id).Line, Errors.Table (Error_Id).Unit, True); Output_Error_Msgs (Err_Id); Errors.Table (Error_Id).Next := Save_Next; end if; end Change_Error_Text; ------------------ -- Debug_Output -- ------------------ procedure Debug_Output (N : Node_Id) is begin if Debug_Flag_1 then Write_String ("*** following error message posted on node id = #"); Write_Int (Int (N)); Write_String (" ***"); Write_Eol; end if; end Debug_Output; ------------- -- OK_Node -- ------------- function OK_Node (N : Node_Id) return Boolean is K : constant Node_Kind := Nkind (N); begin if Error_Posted (N) then return False; elsif K in N_Has_Etype and then Present (Etype (N)) and then Error_Posted (Etype (N)) then return False; elsif (K in N_Op or else K = N_Attribute_Reference or else K = N_Character_Literal or else K = N_Expanded_Name or else K = N_Identifier or else K = N_Operator_Symbol) and then Present (Entity (N)) and then Error_Posted (Entity (N)) then return False; else return True; end if; end OK_Node; ----------------------- -- Output_Error_Msgs -- ----------------------- procedure Output_Error_Msgs (E : in out Error_Msg_Id) is P : Source_Ptr; T : Error_Msg_Id; Flag_Num : Pos; Mult_Flags : Boolean := False; begin -- Figure out if we will place more than one error flag on this line T := E; while T /= No_Error_Msg and then Errors.Table (T).Line = Errors.Table (E).Line and then Errors.Table (T).Unit = Errors.Table (E).Unit loop if Errors.Table (T).Sptr > Errors.Table (E).Sptr then Mult_Flags := True; end if; T := Errors.Table (T).Next; end loop; -- Output the error flags. The circuit here makes sure that the tab -- characters in the original line are properly accounted for. The -- eight blanks at the start are to match the line number. Write_Str (" "); P := File.Table (Errors.Table (E).Unit).Lines_Table (Errors.Table (E).Line); Flag_Num := 1; -- Loop through error messages for this line to place flags T := E; while T /= No_Error_Msg and then Errors.Table (T).Line = Errors.Table (E).Line and then Errors.Table (T).Unit = Errors.Table (E).Unit loop -- Loop to output blanks till current flag position while P < Errors.Table (T).Sptr loop if File.Table (Errors.Table (T).Unit).Source (P) = HT then Write_Char (HT); else Write_Char (' '); end if; P := P + 1; end loop; -- Output flag (unless already output, this happens if more than -- one error message occurs at the same flag position). if P = Errors.Table (T).Sptr then if (Flag_Num = 1 and then not Mult_Flags) or else Flag_Num > 9 then Write_Char ('|'); else Write_Char (Char'Val (Char'Pos ('0') + Flag_Num)); end if; P := P + 1; end if; T := Errors.Table (T).Next; Flag_Num := Flag_Num + 1; end loop; Write_Eol; -- Now output the error messages T := E; while T /= No_Error_Msg and then Errors.Table (T).Line = Errors.Table (E).Line and then Errors.Table (T).Unit = Errors.Table (E).Unit loop Write_Str (" "); Output_Msg_Text (T); T := Errors.Table (T).Next; end loop; E := T; end Output_Error_Msgs; ------------------------ -- Output_Line_Number -- ------------------------ procedure Output_Line_Number (L : Line_Number_Type) is D : Int; -- next digit C : Char; -- next character Z : Boolean; -- flag for zero suppress N, M : Int; -- temporaries begin Z := False; N := Int (L); M := 100_000; while M /= 0 loop D := Int (N / M); N := N rem M; M := M / 10; if D = 0 then if Z then C := '0'; else C := ' '; end if; else Z := True; C := Char'VAL (D + 48); end if; Write_Char (C); end loop; Write_Str (". "); end Output_Line_Number; --------------------- -- Output_Msg_Text -- --------------------- procedure Output_Msg_Text (E : Error_Msg_Id) is begin if Errors.Table (E).Fatal then Write_String ("fatal: "); elsif Errors.Table (E).Warn then Write_String ("warning: "); else if not Brief_Output then Write_String ("error: "); end if; end if; Write_Name (Errors.Table (E).Text); Write_Eol; end Output_Msg_Text; ------------------------ -- Output_Source_Line -- ------------------------ procedure Output_Source_Line (L : Line_Number_Type; U : Unit_Number_Type; Errs : Boolean) is S : Source_Ptr; C : Char; Line_Number_Output : Boolean := False; -- Set True once line number is output begin if U /= Current_Error_Unit then Write_String ("--------------Error messages for source file: "); Write_Name (File.Table (U).Full_File_Name); Write_String ("--------------"); Write_Eol; Current_Error_Unit := U; end if; if Errs or List_Pragmas_Mode then Output_Line_Number (L); Line_Number_Output := True; end if; S := File.Table (U).Lines_Table (L); loop C := File.Table (U).Source (S); exit when C = LF or else C = CR or else C = EOF; -- Deal with matching entry in List_Pragmas table if Full_List and then List_Pragmas_Index <= List_Pragmas.Last and then S = List_Pragmas.Table (List_Pragmas_Index).Ploc then case List_Pragmas.Table (List_Pragmas_Index).Ptyp is when Page => Write_Char (C); if not Errs then -- ignore if on line with errors Write_Char (FF); -- so that error flags get properly end if; -- listed with the error line when List_On => List_Pragmas_Mode := True; if not Line_Number_Output then Output_Line_Number (L); Line_Number_Output := True; end if; Write_Char (C); when List_Off => Write_Char (C); List_Pragmas_Mode := False; end case; List_Pragmas_Index := List_Pragmas_Index + 1; -- Normal case (no matching entry in List_Pragmas table) else if Errs or List_Pragmas_Mode then Write_Char (C); end if; end if; S := S + 1; end loop; if Line_Number_Output then Write_Eol; end if; end Output_Source_Line; ------------------ -- Set_Msg_Text -- ------------------ procedure Set_Msg_Text (Text : Str; Flag : Source_Ptr) is C : Char; -- Current character I : Int; -- Current index; begin Manual_Quote_Mode := False; Is_Warning_Msg := False; Is_Fatal_Msg := False; Is_Unconditional_Msg := False; Msg_Len := 0; Flag_Unit := Get_Sloc_Unit_Number (Flag); I := Text'First; while I <= Text'Last loop C := Text (I); I := I + 1; -- Check for insertion character if C = '%' then Set_Msg_Insertion_Name; elsif C = '$' then Set_Msg_Insertion_Unit_Name; elsif C = '{' then Set_Msg_Insertion_File_Name; elsif C = '*' then Set_Msg_Insertion_Reserved_Name; elsif C = '&' then Set_Msg_Insertion_Node; elsif C = '#' then Set_Msg_Insertion_Line_Number (Flag); elsif C = '@' then Set_Msg_Insertion_Column; elsif C = '^' then Set_Msg_Insertion_Uint; elsif C = '`' then Manual_Quote_Mode := not Manual_Quote_Mode; Set_Msg_Char ('"'); elsif C = '!' then Is_Unconditional_Msg := True; elsif C = '?' then Is_Warning_Msg := True; elsif C = '~' then Is_Fatal_Msg := True; elsif C = ''' then Set_Msg_Char (Text (I)); I := I + 1; -- Upper case letter (start of reserved word if 2 or more) elsif C in 'A' .. 'Z' and then I <= Text'Last and then Text (I) in 'A' .. 'Z' then I := I - 1; Set_Msg_Insertion_Reserved_Word (Text, I); -- Normal character with no special treatment else Set_Msg_Char (C); end if; end loop; end Set_Msg_Text; ------------------------------ -- Set_Msg_Insertion_Column -- ------------------------------ procedure Set_Msg_Insertion_Column is begin if RM_Column_Check then Set_Msg_Str (" in column "); Set_Msg_Int (Int (Error_Msg_Col) + 1); end if; end Set_Msg_Insertion_Column; --------------------------------- -- Set_Msg_Insertion_File_Name -- --------------------------------- procedure Set_Msg_Insertion_File_Name is begin if Error_Msg_Name_1 = No_Name then null; elsif Error_Msg_Name_1 = Error_Name then Set_Msg_Blank; Set_Msg_Str (""); else Set_Msg_Blank; Get_Name_String (Error_Msg_Name_1); Set_Msg_Quote; Set_Msg_Name_Buffer; Set_Msg_Quote; end if; -- The following assignment ensures that a second percent insertion -- character will correspond to the Error_Msg_Name_2 parameter. Error_Msg_Name_1 := Error_Msg_Name_2; end Set_Msg_Insertion_File_Name; ----------------------------------- -- Set_Msg_Insertion_Line_Number -- ----------------------------------- procedure Set_Msg_Insertion_Line_Number (Flag : Source_Ptr) is begin Set_Msg_Int (Int (Get_Line_Number (Error_Msg_Sloc_1))); -- Add file name if reference is to other than the source -- file in which the error message is placed. if Error_Msg_Sloc_1 not in File.Table (Get_Sloc_Unit_Number (Flag)).Source'range then Set_Msg_Str (" in file "); Get_Name_String (File.Table (Get_Sloc_Unit_Number (Error_Msg_Sloc_1)).File_Name); Set_Msg_Quote; Set_Msg_Name_Buffer; Set_Msg_Quote; end if; -- The following assignment ensures that a second pound insertion -- character will correspond to the Error_Msg_Sloc_2 parameter. Error_Msg_Sloc_1 := Error_Msg_Sloc_2; end Set_Msg_Insertion_Line_Number; ---------------------------- -- Set_Msg_Insertion_Name -- ---------------------------- procedure Set_Msg_Insertion_Name is begin if Error_Msg_Name_1 = No_Name then null; elsif Error_Msg_Name_1 = Error_Name then Set_Msg_Blank; Set_Msg_Str (""); else Set_Msg_Blank; Get_Name_String (Error_Msg_Name_1); -- If operator name, just print it as is if Name_Buffer (1) = '"' then Set_Msg_Name_Buffer; -- Else output with surrounding quotes in proper casing mode else Set_Casing (File.Table (Flag_Unit).Identifier_Casing, Mixed_Case); Set_Msg_Quote; Set_Msg_Name_Buffer; Set_Msg_Quote; end if; end if; -- The following assignment ensures that a second percent insertion -- character will correspond to the Error_Msg_Name_2 parameter. Error_Msg_Name_1 := Error_Msg_Name_2; end Set_Msg_Insertion_Name; ---------------------------- -- Set_Msg_Insertion_Node -- ---------------------------- procedure Set_Msg_Insertion_Node is begin Suppress_Message := Error_Msg_Node_1 = Error or else Error_Msg_Node_1 = Any_Type; if Error_Msg_Node_1 = Empty then Set_Msg_Blank; Set_Msg_Str (""); elsif Error_Msg_Node_1 = Error then Set_Msg_Blank; Set_Msg_Str (""); else Set_Msg_Blank; -- Skip quotes for operator case if Nkind (Error_Msg_Node_1) in N_Op then Set_Msg_Node (Error_Msg_Node_1); else Set_Msg_Quote; Set_Msg_Node (Error_Msg_Node_1); Set_Msg_Quote; end if; end if; -- The following assignment ensures that a second ampersand insertion -- character will correspond to the Error_Msg_Node_2 parameter. Error_Msg_Node_1 := Error_Msg_Node_2; end Set_Msg_Insertion_Node; ------------------------------------- -- Set_Msg_Insertion_Reserved_Name -- ------------------------------------- procedure Set_Msg_Insertion_Reserved_Name is begin Set_Msg_Blank; Get_Name_String (Error_Msg_Name_1); Set_Msg_Quote; Set_Casing (File.Table (Flag_Unit).Keyword_Casing, All_Lower_Case); Set_Msg_Name_Buffer; Set_Msg_Quote; end Set_Msg_Insertion_Reserved_Name; ------------------------------------- -- Set_Msg_Insertion_Reserved_Word -- ------------------------------------- procedure Set_Msg_Insertion_Reserved_Word (Text : Str; I : in out Int) is begin Set_Msg_Blank; Name_Len := 0; while I <= Text'Last and then Text (I) in 'A' .. 'Z' loop Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := Text (I); I := I + 1; end loop; Set_Casing (File.Table (Flag_Unit).Keyword_Casing, All_Lower_Case); Set_Msg_Quote; Set_Msg_Name_Buffer; Set_Msg_Quote; end Set_Msg_Insertion_Reserved_Word; ---------------------------- -- Set_Msg_Insertion_Uint -- ---------------------------- procedure Set_Msg_Insertion_Uint is begin Get_Name_String (UI_Image (Error_Msg_Uint_1)); Set_Msg_Name_Buffer; -- The following assignment ensures that a second carret insertion -- character will correspond to the Error_Msg_Uint_2 parameter. Error_Msg_Uint_1 := Error_Msg_Uint_2; end Set_Msg_Insertion_Uint; --------------------------------- -- Set_Msg_Insertion_Unit_Name -- --------------------------------- procedure Set_Msg_Insertion_Unit_Name is begin if Error_Msg_Unit_1 = No_Name then null; elsif Error_Msg_Unit_1 = Error_Name then Set_Msg_Blank; Set_Msg_Str (""); else Get_Unit_Name_String (Error_Msg_Unit_1); Set_Msg_Blank; Set_Msg_Quote; Set_Msg_Name_Buffer; Set_Msg_Quote; end if; -- The following assignment ensures that a second percent insertion -- character will correspond to the Error_Msg_Name_2 parameter. Error_Msg_Unit_1 := Error_Msg_Unit_2; end Set_Msg_Insertion_Unit_Name; ------------------- -- Set_Msg_Blank -- ------------------- procedure Set_Msg_Blank is begin if Msg_Len > 0 and then Msg_Buffer (Msg_Len) /= ' ' and then Msg_Buffer (Msg_Len) /= '(' and then Msg_Buffer (Msg_Len) /= '"' then Set_Msg_Char (' '); end if; end Set_Msg_Blank; ------------------ -- Set_Msg_Char -- ------------------ procedure Set_Msg_Char (C : Char) is begin -- The check for message buffer overflow is needed to deal with cases -- where insertions get too long (in particular a child unit name can -- be very long). if Msg_Len < Max_Msg_Length then Msg_Len := Msg_Len + 1; Msg_Buffer (Msg_Len) := C; end if; end Set_Msg_Char; ----------------- -- Set_Msg_Int -- ----------------- procedure Set_Msg_Int (Line : Int) is begin if Line > 9 then Set_Msg_Int (Line / 10); end if; Set_Msg_Char (Char'VAL (Char'Pos ('0') + (Line rem 10))); end Set_Msg_Int; ------------------------- -- Set_Msg_Name_Buffer -- ------------------------- procedure Set_Msg_Name_Buffer is begin for I in 1 .. Name_Len loop Set_Msg_Char (Name_Buffer (I)); end loop; end Set_Msg_Name_Buffer; ------------------ -- Set_Msg_Node -- ------------------ procedure Set_Msg_Node (Node : Node_Id) is S, Sptr : Source_Ptr; I : Int; Sbuffer : Source_Buffer_Ptr; Ent : Entity_Id; begin if Nkind (Node) = N_Designator then Set_Msg_Node (Name (Node)); Set_Msg_Char ('.'); Set_Msg_Node (Identifier (Node)); elsif Nkind (Node) = N_Defining_Program_Unit_Name then Set_Msg_Node (Name (Node)); Set_Msg_Char ('.'); Set_Msg_Node (Defining_Identifier (Node)); elsif Nkind (Node) = N_Selected_Component then Set_Msg_Node (Prefix (Node)); Set_Msg_Char ('.'); Set_Msg_Node (Selector_Name (Node)); -- Here we have a simple identifier else Get_Name_String (Chars (Node)); -- A special check. If we have an implicit general access type, then -- the insertion becomes access to "xxx" where xxx is the designated -- type of the implicit general access type. if Name_Buffer (1 .. 6) = "ityp__" then if Nkind (Node) = N_Identifier then Ent := Entity (Node); else Ent := Node; end if; if Ekind (Ent) = E_General_Access_Type then if Msg_Buffer (Msg_Len) = '"' then Msg_Len := Msg_Len - 1; Set_Msg_Str ("access to """); else Set_Msg_Str ("access to "); end if; Get_Name_String (Chars (Directly_Designated_Type (Ent))); end if; end if; -- Now we have to set the proper case. If we have a source location -- then do a check to see if the name in the source is the same name -- as the name in the Names table, except for possible differences -- in case, which is the case when we can copy from the source. S := Sloc (Error_Msg_Node_1); I := 1; if S /= No_Location and then S /= Standard_Location then Sbuffer := File.Table (Get_Sloc_Unit_Number (S)).Source; Sptr := S; while I <= Name_Len loop exit when Fold_Lower (Sbuffer (Sptr)) /= Fold_Lower (Name_Buffer (I)); I := I + 1; Sptr := Sptr + 1; end loop; end if; -- If we get through the loop without a mismatch, then output -- the name the way it is spelled in the source program if I > Name_Len then Sptr := S; for I in 1 .. Name_Len loop Name_Buffer (I) := Sbuffer (Sptr); Sptr := Sptr + 1; end loop; -- Otherwise we set the casing using the default identifier casing else Set_Casing (File.Table (Flag_Unit).Identifier_Casing, Mixed_Case); end if; Set_Msg_Name_Buffer; end if; end Set_Msg_Node; ------------------- -- Set_Msg_Quote -- ------------------- procedure Set_Msg_Quote is begin if not Manual_Quote_Mode then Set_Msg_Char ('"'); end if; end Set_Msg_Quote; ----------------- -- Set_Msg_Str -- ----------------- procedure Set_Msg_Str (Text : Str) is begin for I in Text'range loop Set_Msg_Char (Text (I)); end loop; end Set_Msg_Str; end Errout; assignment ensures that a second percent insertion -- character will correspond to the Error_Msg_Name_2 parameter. Error_Msg_Name_1 := Error_Msg_Name_2; end Set_Msg_Insertion_Name; --------------gnat-1.67-src/src/lib.ads 444 10015 7640 47635 5506244307 10414 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- L I B -- -- -- -- S p e c -- -- -- -- $Revision: 1.29 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Casing; use Casing; with Table; with Types; use Types; package Lib is -- This package contains routines for accessing and outputting the library -- information. It contains the routine to load subsidiary units. -------------------------------------------- -- General Approach to Library Management -- -------------------------------------------- -- As described in GNote #1, when a unit is compiled, all its subsidiary -- units are recompiled, including the following: -- (a) Corresponding spec for a body -- (b) Parent spec of a child library spec -- (d) With'ed specs -- (d) Parent body of a subunit -- (e) Subunits corresponding to any specified stubs -- (f) Bodies of inlined subprograms that are called -- (g) Bodies of generic subprograms or packages that are instantiated -- (h) Bodies of packages containing either of the above two items -- (i) Specs and bodies of runtime units -- (j) Parent specs for with'ed child library units -- If a unit is being compiled only for syntax checking, then no subsidiary -- units are loaded, the the syntax check applies only to the main unit, -- i.e. the one contained in the source submitted to the library. -- If a unit is being compiled for syntax and semantic checking, then only -- cases (a)-(d) loads are performed, since the full semantic checking can -- be carried out without needing (e)-(i) loads. In this case no object -- file, or library information file, is generated, so the missing units -- do not affect the results. -- Specifications of library subprograms, subunits, and generic specs -- and bodies, can only be compiled in syntax/semantic checking mode, -- since no code is ever generated directly for these units. In the case -- of subunits, only the compilation of the ultimate parent unit generates -- actual code. If a subunit is submitted to the compiler in syntax/ -- semantic checking mode, the parent (or parents in the nested case) are -- semantically checked only up to the point of the corresponding stub. -- If code is being generated, then all the above units are required, -- although the need for bodies of inlined procedures can be suppressed -- by the use of a switch that sets the mode to ignore pragma Inline -- statements. -- The two main sections of the font end, Par and Sem, are recursive. -- Compilation proceeds unit by unit making recursive calls as necessary. -- The process is controlled from the GNAT main program, which makes calls -- to Par and Sem sequence for the main unit. -- Par parses the given unit, and then, after the parse is complete, uses -- the Par.Load subprogram to load all its subsidiary units in categories -- (a)-(d) above, installing pointers to the loaded units in the parse -- tree, as described in a later section of this spec. If any of these -- required units is missing, a fatal error is signalled, so that no -- attempt is made to run Sem in such cases, since it is assumed that -- too many cascaded errors would result, and the confusion would not -- be helpful. -- Following the call to Par on the main unit, the entire tree of required -- units is thus loaded, and Sem is called on the main unit. The parameter -- passed to Sem is the unit to be analyzed. The visibility table, which -- is a single global structure, starts out containing only the entries -- for the visible entities in Standard. Every call to Sem establishes a -- new scope stack table, pushing an entry for Standard on entry to provide -- the proper initial scope environment. -- Sem first proceeds to perform semantic analysis on the currently loaded -- units as follows: -- In the case of a body (case (a) above), Sem analyzes the corresponding -- spec, using a recursive call to Sem. As is always expected to be the -- case with calls to Sem, any entities installed in the visibility table -- are removed on exit from Sem, so that these entities have to be -- reinstalled on return to continue the analysis of the body which of -- course needs visibility of these entities. -- -- In the case of the parent of a child spec (case (b) above), a similar -- call is made to Sem to analyze the parent. Again, on return, the -- entities from the analyzed parent spec have to be installed in the -- visibility table of the caller (the child unit), which must have -- visibility to the entities in its parent spec. -- For with'ed specs (case (c) above), a recursive call to Sem is made -- to analyze each spec in turn. After all the spec's have been analyzed, -- but not till that point, the entities from all the with'ed units are -- reinstalled in the visibility table so that the caller can proceed -- with the analysis of the unit doing the with's with the necessary -- entities made either use visible or visible by selection as needed. -- Case (d) arises when Sem is passed a subunit to analyze. This means -- that the main unit is a subunit, and the unit passed to Sem is either -- the main unit, or one of its ancestors that is still a subunit. Since -- analysis must start at the top of the tree, Sem essentially cancels -- the current call by immediately making a call to analyze the parent -- (when this call is finished it immediately returns, so logically this -- call is like a goto). The subunit will then be analyzed at the proper -- time as described for the stub case. Note that we also turn off the -- indication that code should be generated in this case, since the only -- time we generate code for subunits is when compiling the main parent. -- Case (e), subunits corresponding to stubs, are handled as the stubs -- are encountered. There are three sub-cases: -- If the subunit has already been loaded, then this means that the -- main unit was a subunit, and we are back on our way down to it -- after following the initial processing described for case (d). -- In this case we analyze this particular subunit, as described -- for the case where we are generating code, but when we get back -- we are all done, since the rest of the parent is irrelevant. To -- get out of the parent, we raise the exception Subunit_Found, which -- is handled at the outer level of Sem. -- The cases where the subunit has not already been loaded correspond -- to cases where the main unit was a parent. In this case the action -- depends on whether or not we are generating code. If we are not -- generating code, then this is the case where we can simply ignore -- the subunit, since in checking mode we don't even want to insist -- that the subunit exist, much less waste time checking it. -- If we are generating code, then we need to load and analyze -- all subunits. This is achieved with a call to Lib.Load to load -- and parse the unit, followed by processing that installs the -- context clause of the subunit, analyzes the subunit, and then -- removes the context clause (from the visibility chains of the -- parent). Note that we do *not* do a recursive call to Sem in -- this case, precisely because we need to do the analysis of the -- subunit with the current visibility table and scope stack. -- Case (f) applies only to subprograms for which a pragma Inline is -- given, providing that the compiler is operating in the mode where -- pragma Inline's are activated. When the expander encounters a call -- to such a subprogram, it loads the body of the subprogram if it has -- not already been loaded, and calls Sem to process it. -- Case (g) is similar to case (f), except that the body of a generic -- is unconditionally required, regardless of compiler mode settings. -- As in the subprogram case, when the expander encounters a generic -- instantiation, it loads the generic body of the subprogram if it -- has not already been loaded, and calls Sem to process it. -- Case (h) arises when a package contains either an inlined subprogram -- which is called, or a generic which is instantiated. In this case the -- body of the package must be loaded and analyzed with a call to Sem. -- Case (i) is handled by adding implicit with clauses to the context -- clauses of all units that potentially reference the relevant runtime -- entities. Note that since we have the full set of units available, -- the parser can always determine the set of runtime units that is -- needed. These with clauses do not have associated use clauses, so -- all references to the entities must be by selection. Once the with -- clauses have been added, subsequent processing is as for normal -- with clauses. -- Case (j) is also handled by adding appropriate implicit with clauses -- to any unit that withs a child unit. Again there is no use clause, -- and subsequent processing proceeds as for an explicit with clause. -- Sem thus completes the loading of all required units, except those -- required for inline subprogram bodies or inlined generics. If any -- of these load attempts fails, then the expander will not be called, -- even if code was to be generated. If the load attempts all succeed -- then the expander is called, though the attempt to generate code may -- still fail if an error occurs during a load attempt for an inlined -- body or a generic body. ---------------- -- File Table -- ---------------- -- The file table has an entry for each source file accessed for the -- current compilation. The table is indexed by the unit number value, -- since there is a one-to-one correspondence between files and units. -- The first entry in the table, subscript 0, is for the main file. type File_Record is record Unit_Name : Unit_Name_Type; -- Unit name for this entry File_Name : File_Name_Type; -- Corresponding file name (simple name with no directory info) Full_File_Name : Name_Id; -- Full file name (full name with directory info), used for -- generation of error messages (and not for any other purpose) Loading : Boolean; -- A flag that is used to catch circular WITH dependencies. It is set -- True when an entry is initially created in the file table, and set -- False when the load is completed, or ends with an error. Source : Source_Buffer_Ptr; -- Text of source file. Set to null if a file is not found. Version : Str (1 .. 6); -- Six character version identifier, set by the scanner if a revision -- number is present in the file header, and the -dv debug switch is -- set, otherwise it is set to all blanks. Time_Stamp : Time_Stamp_Type; -- Time stamp of the source file (not initialized if file not found) Lines_Table : Lines_Table_Ptr; -- Pointer to lines table for this source Last_Line : Line_Number_Type; -- Subscript of last entry in Lines_Table (may be different from 'Last -- value because of the use of expandable tables in package Lines). On -- completion of compilation of a unit (status = loaded), this is the -- number of source lines in the file. Cunit : Node_Id; -- Pointer to N_Compilation_Unit node if Status = Compiled Entity : Node_Id; -- Pointer to defining entity node for compilation unit if compiled Not_Found_Msg : Boolean; -- A flag used to suppress multiple not-found messages for the same -- file. Set False when an entry is created, and then set True when -- a file not found message is generated (in response to a Load -- call with Required set to True and file not found). Body_Spec : Boolean; -- This flag is set by the caller if the loaded unit is a procedure -- body that is used as a spec (because the spec is not present). It -- is initialized to False by Lib, and read by the Writ routine to -- mark this special dependency in the ALI file. Fatal_Error : Boolean; -- A flag that is initialized to False, and gets set to True if a fatal -- error occurs during the processing of a unit. A fatal error is one -- defined as serious enough to stop the next phase of the compiler -- from running (i.e. fatal error during parsing stops semantics, -- fatal error during semantics stops code generation). Note that -- currently, errors of any kind cause Fatal_Error to be set, but -- eventually perhaps only errors labeled as Fatal_Errors should be -- this severe if we decide to try Sem on sources with minor errors. Keyword_Casing : Casing_Type; -- Casing style used in file for keyword casing. This is initialized -- to Unknown, and then set from the first occurrence of a keyword. This -- value is used only for formatting of error messages. Identifier_Casing : Casing_Type; -- Casing style used in file for identifier casing. This is initialized -- to Unknown, and then set from an identifier in the program as soon as -- one is found whose casing is sufficiently clear to make a decision. -- This value is used for formatting of error messages, and also is used -- in the detection of keywords misused as identifiers. Generate_Code : Boolean; -- This flag is set True for all units in the current file for which -- code is to be generated. This includes the units explicitly compiled, -- together with their corresponding specifications if they exist). end record; -- The following is the file table itself package File is new Table ( Component_Type => File_Record, Index_Type => Unit_Number_Type, Low_Bound => 0, Initial => 50, Increment => 100, Table_Name => "Lib.File"); function Get_Sloc_Unit_Number (S : Source_Ptr) return Unit_Number_Type; -- Return unit number of file identified by given source pointer value. -- This call must always succeed, since any valid source pointer value -- belongs to some previously loaded module. function Get_Cunit_Unit_Number (N : Node_Id) return Unit_Number_Type; -- Return unit number of file containing the unit whose N_Compilation_Unit -- node is the one passed as an argument. This must always succeed since -- the node could not have been built without making an entry in the -- file table. --------------------------------- -- Initialization/Finalization -- --------------------------------- procedure Initialize_Lib; -- Called at the start of compiling a new main source unit to initialize -- the library processing for the new main source. Establishes and -- initializes the File.Table entry for the new main unit (leaving -- File.Table (Main_Unit).File_Name set to No_File if there are no more -- files. Otherwise the main source file has been opened and read and -- then closed on return. procedure Finalize_Lib; -- Called at the end of compiling a main source unit to terminate the -- library processing and free up its dynamically allocated storage. --------------------------------------- -- Loading Separately Compiled Units -- --------------------------------------- function Load (Uname : Unit_Name_Type; Required : Boolean; Enode : Node_Id) return Unit_Number_Type; -- This function loads and parses the unit specified by Unit_Name_Type -- (or returns the unit number for the previously constructed File.Table -- entry if this is not the first call for this unit). The value returned -- is the unit number that indexes the corresponding entry in File.Table. -- The Fatal_Error flag of this entry is set if a serious enough parser -- error occurs to prevent subsequent semantic analysis. If the file that -- corresponds to Uname is not found, then No_Unit is returned as a result. -- The Required parameter is accessed only in this file-not-found case to -- indicate whether or not an error message should be generated. At most -- one such error message is generated for any given file, and only if -- Required is set to True. The Enode parameter is used in this case and -- in the circular dependency case. It indicates the source location to -- which these error messages are to be attached but *only* if this -- location is in the main source (at lower levels, the source message is -- always attached to the Enode value from the main source call. Enode is -- also used to allow Load to set the Fatal_Error flag of the calling unit -- if the loaded unit has a fatal error. A special case allows Enode to -- be set to Empty. The result is that Load will simply signal unit not -- found without issuing an error message on any error. In this case the -- caller is expected to treat the unit not found error as fatal (this -- happens in the case of calls from Rtsload). -- Note: in the current version of GNAT, any parse error, or parse warning -- with treat-warnings-as-errors mode set causes Fatal_Error to be set, -- but this may change in some future version if we get confident enough -- to analyze bad units! function Is_Loaded (Uname : Unit_Name_Type) return Boolean; -- Determines if unit with given name is already loaded, i.e. there is -- already an entry in the file table with this unit name for which the -- corresponding file was found and parsed. Note that the Fatal_Error flag -- of this entry must be checked before proceeding with further processing. procedure List; -- Lists units in active library (i.e. generates output consisting of a -- sorted listing of the units represented in File table, with the -- exception of the main unit). --------------------------------- -- Writing Library Information -- --------------------------------- procedure Writ; -- This procedure writes the library information for the current main unit end Lib; name (simple name with no directory info) Full_File_Name : Name_Id; -- Full file namgnat-1.67-src/src/errcount.ads 444 10015 7640 4633 5506244307 11456 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E R R C O U N T -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Errcount is -- This package contains global variables which hold the number of errors -- and warnings detected so far. It is separated off from errout so that -- it can be with'ed without bringing in all the stuff that Errout drags -- in, which is important because it allows the binder, which uses modules -- that with Errcount (notably Comperr), to avoid dragging in this stuff. -- In the case of the binder, these error counts are maintained by Binderr. Errors_Detected : Int; -- Number of errors detected so far Warnings_Detected : Int; -- Number of warnings detected end Errcount; -- -- S pgnat-1.67-src/src/excep.ads 444 10015 7640 6331 5506244307 10716 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X C E P -- -- -- -- S p e c -- -- -- -- $Revision: 1.8 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ package Excep is -- This package contains declarations for all exceptions handled -- or raised explicitly (with raise statements) by the compiler. Error_Resync : exception; -- This exception is raised and handled by the parser to control -- syntactic error recovery. For details on the use of this exception, -- see the description of the error recovery approach in Parse. Unrecoverable_Error : exception; -- This exception is raised to immediately terminate the compilation -- of the current source program. Uses at the moment are to catch the -- maximum errors exceeded situation, and to deal with failure to locate -- a required runtime entity. Compile_Time_Constraint_Error : exception; -- This exception is raised by the compiler during constant folding of -- expressions in Sem.Eval when the result of such expression evaluation -- would result in a raise of Constraint_Error during run-time. An example -- is division, rem or mod where the right operand is zero. At the point -- where the operation is attempted the exception is raised and is then -- handled in a higher level procedure where the node containing the -- result would normally be created. -- Note: Constraint_Error should never be raised by the compiler. It if -- is raised, it indicates a logic error in the compiler. The compiler -- does not have handlers for this, or any other predefined exception. end Excep; input.adba ü¹  snames.adsa ¹  snames.adba $¹  sprint.adsa 8¹  sprint.adba L¹ stand.ads.a `¹ stand.adbad t¹ stringt.ads ˆ¹ stringt.adb œ¹ switch.ads. °¹ switch.adba й$system_environment.ads ð¹ gnat-1.67-src/src/expand.adb 444 10015 7640 12542 5506244310 11063 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P A N D -- -- -- -- B o d y -- -- -- -- $Revision: 1.35 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Debug_Sem; use Debug_Sem; with Exp_Attr; use Exp_Attr; with Exp_Ch2; use Exp_Ch2; with Exp_Ch3; use Exp_Ch3; with Exp_Ch4; use Exp_Ch4; with Exp_Ch5; use Exp_Ch5; with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; with Exp_Ch8; use Exp_Ch8; with Exp_Ch9; use Exp_Ch9; with Exp_Ch10; use Exp_Ch10; with Exp_Ch11; use Exp_Ch11; with Exp_Ch12; use Exp_Ch12; with Exp_Ch13; use Exp_Ch13; with Exp_Prag; use Exp_Prag; with Exp_Util; use Exp_Util; with Opt; use Opt; with Output; use Output; with Sinfo; use Sinfo; with Sinput; use Sinput; procedure Expand (N : Node_Id) is begin if Expander_Active then pragma Debug (Debug_A_Entry ("expanding ", N)); -- Processing depends on node kind. For full details on the expansion -- activity required in each case, see bodies of corresponding routines case Nkind (N) is when N_Allocator => Expand_N_Allocator (N); when N_Assignment_Statement => Expand_N_Assignment_Statement (N); when N_Attribute_Definition_Clause => Expand_N_Attribute_Definition_Clause (N); when N_Attribute_Reference => Expand_N_Attribute_Reference (N); when N_Block_Statement => Expand_N_Block_Statement (N); when N_Case_Statement => Expand_N_Case_Statement (N); when N_Expanded_Name => Expand_N_Expanded_Name (N); when N_Freeze_Entity => Expand_N_Freeze_Entity (N); when N_Full_Type_Declaration => Expand_N_Full_Type_Declaration (N); when N_Function_Call => Expand_N_Function_Call (N); when N_If_Statement => Expand_N_If_Statement (N); when N_Identifier => Expand_N_Identifier (N); when N_Object_Declaration => Expand_N_Object_Declaration (N); when N_Op_And => Expand_N_Op_And (N); when N_Op_Eq => Expand_N_Op_Eq (N); when N_Op_Expon => Expand_N_Op_Expon (N); when N_Op_Ge => Expand_N_Op_Ge (N); when N_Op_Gt => Expand_N_Op_Gt (N); when N_Op_In => Expand_N_Op_In (N); when N_Op_Le => Expand_N_Op_Le (N); when N_Op_Lt => Expand_N_Op_Lt (N); when N_Op_Not => Expand_N_Op_Not (N); when N_Op_Not_In => Expand_N_Op_Not_In (N); when N_Op_Or => Expand_N_Op_Or (N); when N_Op_Xor => Expand_N_Op_Xor (N); when N_Package_Body => Expand_N_Package_Body (N); when N_Parenthesized_Expression => Expand_N_Parenthesized_Expression (N); when N_Pragma => Expand_N_Pragma (N); when N_Procedure_Call_Statement => Expand_N_Procedure_Call_Statement (N); when N_Slice => Expand_N_Slice (N); when N_Subprogram_Body => Expand_N_Subprogram_Body (N); when N_Single_Task_Declaration => Expand_N_Single_Task_Declaration (N); when N_Task_Body => Expand_N_Task_Body (N); when N_Task_Type_Declaration => Expand_N_Task_Type_Declaration (N); when N_Variant_Part => Expand_N_Variant_Part (N); -- For all other node kinds, no expansion activity is required when others => null; end case; pragma Debug (Debug_A_Exit ("expanding ", N, " (done)")); end if; end Expand; Sinput; use Sinput; procedure Expand (N : Node_Id) is begin if Expander_Active then pragma Debug (Debug_A_Entry ("expanding ", N)); -- gnat-1.67-src/src/expand.ads 444 10015 7640 14104 5506244310 11100 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P A N D -- -- -- -- S p e c -- -- -- -- $Revision: 1.5 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This procedure performs any required expansion for the specified node. -- The argument is the node that is a candidate for possible expansion. -- If no expansion is required, then Expand returns without doing anything. -- If the node does need expansion, then the subtree is replaced by the -- tree corresponding to the required rewriting. This tree is a syntactic -- tree, except that all Entity fields must be correctly set on all -- direct names, since the expander presumably knows what it wants, and in -- any case it doesn't work to have the semantic analyzer perform visibility -- analysis on these trees (they may have references to non-visible runtime -- routines etc.) There are a few exceptions to this rule in special cases, -- but they must be documented clearly. -- Expand is called in two different situations: -- Nodes that are not subexpressions (Nkind not in N_Subexpr) -- In this case, Expand is called from the body of Sem, immediately -- after completing semantic analysis by calling the corresponding -- Analyze_N_xxx procedure. If expansion occurs, the given node must -- be replaced with another node that is also not a subexpression. -- This seems naturally to be the case, since it is hard to imagine any -- situation in which it would make sense to replace a non-expression -- subtree with an expression. Once the substitution is completed, the -- Expand routine must call Analyze on the resulting node to do any -- required semantic analysis. Note that references to children copied -- from the old tree won't be reanalyzed, since their Analyze flag is set. -- Nodes that are subexpressions (Nkind in N_Subexpr) -- In this case, Expand is called from Sem_Res.Resolve_Subexpr after -- completing the resolution of the subexpression (this means that the -- expander sees the fully typed subtree). If expansion occurs, the -- given node must be replaced by a node that is also a subexpression. -- Again it is hard to see how this restriction could possibly be -- violated (in the case where statements are required, they appear in -- an N_Expression_Actions node, which is a subexpression). Once the -- substitution is completed, the Expand routine must first call Analyze -- on the resulting node to do any required semantic analysis, and then -- call Resolve_Subexpr on the node to set the type (typically the type -- will be the same as the original type of the input node). -- Note that in both cases, the expander must use Rewrite_Substitute_Tree -- or Copy_Node to achieve the actual replacement of the node, since it is -- only passed the Id of the node to be expanded, and the resulting expanded -- node Id must be the same (the parameter to Expand is mode in, not mode -- in-out). It is not necessary to preserve the original tree in the Expand -- routines, unlike the case for tree manipulation routines in the Analyzer. -- This is because anyone interested in working with the original tree (like -- ASIS) is required to compile in semantic checks only mode. -- Note: the front end avoids calls to any of the expand routines if code -- is not being generated. This is done for three reasons: -- 1. Make sure tree does not get mucked up by the expander if no -- code is being generated, and is thus usable by ASIS etc. -- 2. Save time, since expansion is not needed if a compilation is -- being done only to check the semantics, or if code generation -- has been canceled due to previously detected errors. -- 3. Allow the expand routines to assume that the tree is error free. -- This results from the fact that code generation mode is always -- cancelled when any error occurs. -- If we ever decide to implement a feature allowing object modules to be -- generated even if errors have been detected, then point 3 will no longer -- hold, and the expand routines will have to be modified to operate properly -- in the presence of errors (for many reasons this is not currently true). -- Note: a consequence of this approach is that error messages must never -- be generated in the expander, since this would mean that such error -- messages are not generated when the expander is not being called. with Types; use Types; procedure Expand (N : Node_Id); the Free -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 witgnat-1.67-src/src/exp_ch10.ads 444 10015 7640 3553 5506244310 11216 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ C H 1 0 -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Expand routines for chapter 10 constructs package Exp_Ch10 is end Exp_Ch10; bENT¨¸×$system-traceback.ads ¼¸Ø scans.ads и٠scans.adb à¸Úscn.adsø¸Û scn-nlit.adb ¸Ü gnat-1.67-src/src/exp_ch11.ads 444 10015 7640 3554 5506244311 11221 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ C H 1 1 -- -- -- -- S p e c -- -- -- -- $Revision: 1.3 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Expand routines for chapter 11 constructs package Exp_Ch11 is end Exp_Ch11; back.ads¸×¼¸Ø scans.adsdsи٠scans.adbadà¸Úscn.adsø¸Û scn-nlit.adbds ¸Ü scn-slit.adb ¸Ýgnat-1.67-src/src/exp_ch12.ads 444 10015 7640 3553 5506244311 11221 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ C H 1 2 -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Expand routines for chapter 12 constructs package Exp_Ch12 is end Exp_Ch12; -- -- GNAT is free software; you can redistribute it and/or modify it under gnat-1.67-src/src/exp_ch13.ads 444 10015 7640 3771 5506244311 11224 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ C H 1 3 -- -- -- -- S p e c -- -- -- -- $Revision: 1.3 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Expand routines for chapter 13 constructs with Types; use Types; package Exp_Ch13 is procedure Expand_N_Attribute_Definition_Clause (N : Node_Id); procedure Expand_N_Freeze_Entity (N : Node_Id); end Exp_Ch13; X¸àgnat-1.67-src/src/exp_ch2.adb 444 10015 7640 7611 5506244311 11116 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ C H 2 -- -- -- -- B o d y -- -- -- -- $Revision: 1.4 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Einfo; use Einfo; with Sinfo; use Sinfo; package body Exp_Ch2 is ----------------------- -- Local Subprograms -- ----------------------- procedure Expand_Name (N : Node_Id); -- An occurence of a discriminant within a discriminated type is replaced -- with the corresponding discriminal, that is to say the formal parameter -- of the initialization procedure for the type that is associated with -- that particular discriminant. This is replacement is not performed for -- discriminants of records that appear in constraints of component of the -- record, because Gigi uses the discriminant name to retrieve its value. -- See Einfo.ads for additional details, and Exp_ch3, Exp_ch9 for examples -- of use. ----------------- -- Expand_Name -- ----------------- procedure Expand_Name (N : Node_Id) is begin if Ekind (Entity (N)) = E_Discriminant then if Ekind (Scope (Entity (N))) = E_Record_Type and then (Nkind (Parent (N)) = N_Range or else Nkind (Parent (N)) = N_Index_Or_Discriminant_Constraint) then null; else Set_Entity (N, Discriminal (Entity (N))); end if; end if; end Expand_Name; ---------------------------- -- Expand_N_Expanded_Name -- ---------------------------- -- Performs discriminal replacement as described for Expand_Name above -- Should really be a renaming of Expand_Name, but this doesn't work yet??? procedure Expand_N_Expanded_Name (N : Node_Id) is begin if Ekind (Entity (N)) = E_Discriminant then Expand_Name (N); end if; end Expand_N_Expanded_Name; ------------------------- -- Expand_N_Identifier -- ------------------------- -- Performs discriminal replacement as described for Expand_Name above -- Should really be a renaming of Expand_Name, but this doesn't work yet??? procedure Expand_N_Identifier (N : Node_Id) is begin if Ekind (Entity (N)) = E_Discriminant then Expand_Name (N); end if; end Expand_N_Identifier; end Exp_Ch2; ¹6(unchecked_deallocation.ads¹7 unixlib.ads$¹8(unchecked_deallocation.adb8¹9 unixlib.gnat-1.67-src/src/exp_ch2.ads 444 10015 7640 3751 5506244312 11141 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ C H 2 -- -- -- -- S p e c -- -- -- -- $Revision: 1.3 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Expand routines for chapter 2 constructs with Types; use Types; package Exp_Ch2 is procedure Expand_N_Expanded_Name (N : Node_Id); procedure Expand_N_Identifier (N : Node_Id); end Exp_Ch2;  sem_attr.adbGõ ˆgnat-1.67-src/src/exp_ch5.adb 444 10015 7640 17707 5506244312 11151 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ C H 5 -- -- -- -- B o d y -- -- -- -- $Revision: 1.12 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Einfo; use Einfo; with Exp_Ch9; use Exp_Ch9; with Exp_Util; use Exp_Util; with Nmake; use Nmake; with Rtsfind; use Rtsfind; with Sinfo; use Sinfo; with Sem; use Sem; with Sem_Util; use Sem_Util; with Snames; use Snames; with Tbuild; use Tbuild; package body Exp_Ch5 is ----------------------------------- -- Expand_N_Assignment_Statement -- ----------------------------------- -- For tagged types re-assign the original Tag of the target. -- ??? Could be implemented more efficiently as a kind of record slice -- assignment but there no simple way to express this for the back-end. procedure Expand_N_Assignment_Statement (N : Node_Id) is Local_Tag_Name : Name_Id; Loc : constant Source_Ptr := Sloc (N); New_Assign : Node_Id; New_Name : Node_Id; New_Exp : Node_Id; Statements : List_Id; begin if Is_Tagged_Type (Etype (Name (N))) then -- Generate the code -- declare -- tag__nn : Ada.Tags.Tag := lhs._tag; -- begin -- -- if tag__nn /= rhs._tag then -- raise constraint_Error; -- end if; -- -- lhs := rhs; -- lhs._tag := tag__nn; -- end; New_Name := New_Copy (Name (N)); New_Exp := New_Copy (Expression (N)); New_Assign := New_Copy (N); Set_Name (New_Assign, New_Name); Set_Expression (New_Assign, New_Exp); -- ??? New_Name may contain some side-effect expression so it should -- be evauate once. But if this flag is set, the assignment does -- not work at all so it is removed till further investigation. -- Set_Evaluate_Once (New_Name, True); Set_Evaluate_Once (New_Exp, True); Local_Tag_Name := New_Internal_Name ("tag"); -- New_Assign is marked as already analyzed in order to avoid -- a recursive re-expansion. Set_Analyzed (New_Assign, True); Statements := New_List; if Is_Class_Type (Etype (New_Name)) and then (not Tag_Checks_Suppressed (Etype (New_Name))) then Append_To (Statements, Make_If_Statement (Loc, Condition => Make_Op_Ne (Loc, Left_Opnd => Make_Identifier (Loc, Local_Tag_Name), Right_Opnd => Make_Selected_Component (Loc, Prefix => New_Exp, Selector_Name => Make_Identifier (Loc, Name_uTag))), Then_Statements => New_List_1 (New_Constraint_Error (Loc)))); end if; Append_To (Statements, New_Assign); Append_To (Statements, Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, Prefix => New_Name, Selector_Name => Make_Identifier (Loc, Name_uTag)), Expression => Make_Identifier (Loc, Local_Tag_Name))); Rewrite_Substitute_Tree (N, Make_Block_Statement (Loc, Identifier => Empty, Declarations => New_List_1 (Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Local_Tag_Name), Object_Definition => New_Reference_To (RTE (RE_Tag), Loc), Expression => Make_Selected_Component (Loc, Prefix => New_Name, Selector_Name => Make_Identifier (Loc, Name_uTag)))), Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Statements))); Analyze (N); end if; end Expand_N_Assignment_Statement; ------------------------------ -- Expand_N_Block_Statement -- ------------------------------ -- Establish master if the block is a master -- Activate tasks if the block is an activator procedure Expand_N_Block_Statement (N : Node_Id) is begin Build_Task_Activation_Call (N); if Is_Task_Master (N) then Establish_Task_Master (N); end if; end Expand_N_Block_Statement; ----------------------------- -- Expand_N_Case_Statement -- ----------------------------- -- If the last alternative is not an Others choice replace it with an -- N_Others_Choice. Note that we do not bother to call Analyze on the -- modified case statement, since it's only effect would be to compute -- the contents of the Others_Discrete_Choices node laboriously, and of -- course we already know the list of choices that corresponds to the -- others choice (it's the list we are replacing!) procedure Expand_N_Case_Statement (N : Node_Id) is Altnode : constant Node_Id := Last (Alternatives (N)); Others_Node : Node_Id; begin if Nkind (First (Discrete_Choices (Altnode))) /= N_Others_Choice then Others_Node := Make_Others_Choice (Sloc (Altnode)); Set_Others_Discrete_Choices (Others_Node, Discrete_Choices (Altnode)); Set_Discrete_Choices (Altnode, New_List_1 (Others_Node)); end if; end Expand_N_Case_Statement; --------------------------- -- Expand_N_If_Statement -- --------------------------- -- Add traceback before the IF. In addition, if an ELSE/ELSIF parts -- are present, add traceback calls at the start of the THEN, ELSIF -- and ELSE statements, so we know which way control went. procedure Expand_N_If_Statement (N : Node_Id) is Elsf : Node_Id; begin Traceback_Store (N); Traceback_Store (First (Then_Statements (N))); if List_Present (Elsif_Parts (N)) then Elsf := First (Elsif_Parts (N)); while Present (Elsf) loop Traceback_Store (First (Then_Statements (Elsf))); Elsf := Next (Elsf); end loop; end if; if List_Present (Else_Statements (N)) then Traceback_Store (First (Else_Statements (N))); end if; end Expand_N_If_Statement; end Exp_Ch5; -- if tag__nn /= rhs._tag then -- gnat-1.67-src/src/exp_ch6.ads 444 10015 7640 4503 5506244312 11141 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ C H 6 -- -- -- -- S p e c -- -- -- -- $Revision: 1.5 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Expand routines for chapter 6 constructs with Types; use Types; package Exp_Ch6 is procedure Expand_N_Function_Call (N : Node_Id); procedure Expand_N_Subprogram_Body (N : Node_Id); procedure Expand_N_Procedure_Call_Statement (N : Node_Id); procedure Expand_Dispatch_Call (Call_Node : Node_Id); -- The subprogram call (Call_Node) is replaced a by a call to the correct -- primitive operation whose access is stored in the dispatch table pointed -- by the tag of the controlling argument. end Exp_Ch6; ð sem_ch6.ads иñ sem_ch6.adb ä¸ò sem_ch7.ads ø¸ó sem_ch7.adb ¸ô sem_ch8.ads ¸õ sem_ch8.adb 4¸ö sem_ch9.ads H¸÷ sem_ch9.adb `gnat-1.67-src/src/exp_ch7.ads 444 10015 7640 3663 5506244313 11151 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ C H 7 -- -- -- -- S p e c -- -- -- -- $Revision: 1.4 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Expand routines for chapter 7 constructs with Types; use Types; package Exp_Ch7 is procedure Expand_N_Package_Body (N : Node_Id); end Exp_Ch7; -- -- S pgnat-1.67-src/src/exp_ch8.ads 444 10015 7640 3550 5506244313 11145 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ C H 8 -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Expand routines for chapter 8 constructs package Exp_Ch8 is end Exp_Ch8; ¸à sem_attr.ads X p¸á sem_attr.adb p ˆ¸â sem_ch10.ads ˆ  ¸ã sem_ch10.adb   ¸¸ä sem_ch11.ads ¸ иå sem_gnat-1.67-src/src/exp_ch7.adb 444 10015 7640 4244 5506244313 11124 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ C H 7 -- -- -- -- B o d y -- -- -- -- $Revision: 1.8 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Exp_Ch9; use Exp_Ch9; package body Exp_Ch7 is --------------------------- -- Expand_N_Package_Body -- --------------------------- -- Add call to Activate_Tasks if body is an activator (actuall processing -- is in chapter 9). procedure Expand_N_Package_Body (N : Node_Id) is begin Build_Task_Activation_Call (N); end Expand_N_Package_Body; end Exp_Ch7; ch4.ads €¸í sem_ch4.adb ”¸î sem_ch5.ads ¨¸ï sem_ch5.adb ¼¸ð sem_ch6.ads иñ sem_ch6.adb ä¸ò sem_ch7.ads ø¸ó sem_ch7.adb ¸ô sem_ch8.ads ¸õ sem_ch8.adb 4¸ö sem_ch9.ads H¸÷ sem_ch9.adb `¸ø sem_eval.ads ` x¸ù sem_eval.adb x ¸ú sem_praggnat-1.67-src/src/exp_ch4.ads 444 10015 7640 5521 5506244314 11142 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ C H 4 -- -- -- -- S p e c -- -- -- -- $Revision: 1.8 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Expand routines for chapter 4 constructs with Types; use Types; package Exp_Ch4 is procedure Expand_N_Allocator (N : Node_Id); procedure Expand_N_Op_And (N : Node_Id); procedure Expand_N_Op_Expon (N : Node_Id); procedure Expand_N_Op_Eq (N : Node_Id); procedure Expand_N_Op_Ge (N : Node_Id); procedure Expand_N_Op_Gt (N : Node_Id); procedure Expand_N_Op_In (N : Node_Id); procedure Expand_N_Op_Le (N : Node_Id); procedure Expand_N_Op_Lt (N : Node_Id); procedure Expand_N_Op_Not (N : Node_Id); procedure Expand_N_Op_Not_In (N : Node_Id); procedure Expand_N_Op_Or (N : Node_Id); procedure Expand_N_Op_Xor (N : Node_Id); procedure Expand_N_Parenthesized_Expression (N : Node_Id); procedure Expand_N_Slice (N : Node_Id); end Exp_Ch4; ESS 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 witgnat-1.67-src/src/exp_ch9.ads 444 10015 7640 16201 5506244314 11164 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ C H 9 -- -- -- -- S p e c -- -- -- -- $Revision: 1.14 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Expand routines for chapter 9 constructs with Types; use Types; package Exp_Ch9 is procedure Build_Activation_Chain_Entity (N : Node_Id); -- Given a declaration N of an object that is a task, or contains tasks -- (other than allocators to tasks) this routine ensures that an activation -- chain has been declared in the appropriate scope, building the required -- declaration for the chain variable if not. The name of this variable -- is always _Chain and it is accessed by name. This procedure also adds -- an appropriate call to Activate_Tasks to activate the tasks for this -- activation chain. It does not however deal with the call needed in the -- case of allocators to Expunge_Unactivated_Tasks, this is separately -- handled in the Expand_Task_Allocator routine. function Build_Call_With_Task (N : Node_Id; E : Entity_Id) return Node_Id; -- N is a node representing the name of a task or an access to a task. -- The value returned is a call to the function whose name is the entity -- E (typically a runtime routine entity obtained using RTE) with the -- Task_Id of the associated task as the parameter. The caller is -- responsible for analyzing and resolving the resulting tree. procedure Build_Master_Entity (E : Entity_Id); -- Given an entity E for the declaration of an object containing tasks -- or of a type declaration for an allocator whose designated type is a -- task or contains tasks, this routine marks the appropriate enclosing -- context as a master, and also declares a variable called _Master in -- the current declarative part which captures the value of Current_Master -- (if not already built by a prior call). We build this object (instead -- of just calling Current_Master) for two reasons. First it is clearly -- more efficient to call Current_Master only once for a bunch of tasks -- in the same declarative part, and second it makes things easier in -- generating the initialization routines, since they can just reference -- the object _Master by name, and they will get the proper Current_Master -- value at the outer level, and copy in the parameter value for the outer -- initialization call if the call is for a nested component). Note that -- in the case of nested packages, we only really need to make one such -- object at the outer level, but it is much easier to generate one per -- declarative part. procedure Build_Task_Activation_Call (N : Node_Id); -- This procedure is called for constructs that can be task activators -- i.e. task bodies, subprogram bodies, package bodies and blocks. If -- the construct is a task activator (as indicated by the non-empty -- setting of Activation_Chain_Entity, either in the construct, or, in -- the case of a package body, in its associated package spec), then -- a call to Activate_Tasks with this entity as the single parameter -- is inserted at the start of the statements of the activator. procedure Build_Task_Allocate_Block (Actions : List_Id; N : Node_Id; Args : List_Id); -- This routine is used in the case of allocators where the designated -- type is a task or contains tasks. In this case, the normal initialize -- call is replaced by: -- blockname : label; -- blockname : declare -- _Chain : Activation_Chain; -- procedure _Expunge is -- begin -- Expunge_Unactivated_Tasks (_Chain); -- end; -- begin -- Init (Args); -- Activate_Tasks (_Chain); -- at end -- _Expunge; -- end; -- to get the task or tasks created and initialized. The expunge call -- ensures that any tasks that get created but not activated due to an -- exception are properly expunged (it has no effect in the normal case) -- The argument N is the allocator, and Args is the list of arguments -- for the initialization call, constructed by the caller, which uses -- the Master_Id of the access type as the _Master parameter, and _Chain -- (defined above) as the _Chain parameter. function Convert_Task (N : Node_Id; Typ : Entity_Id) return Node_Id; -- N is an expression of type Typ. If the type is not a task type then -- it is returned unchanged. If it is a task reference, Convert_Task -- creates an unchecked conversion node from this expression to the -- corresponding task record type value. We need this in any situation -- where the task is used, because the actual task object is an object -- of the corresponding record type, and manipulations on the task object -- actually manipulate the corresponding object of the record type. procedure Establish_Task_Master (N : Node_Id); -- Given a subprogram body, or a block statement, or a task body, this -- proccedure makes the necessary transformations required of a task -- master (add Enter_Master call at start, and establish a cleanup -- routine to make sure Complete_Master is called on exit). function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id; -- Given the entity of the record type created for a task type, build -- the call to Create_Task procedure Expand_N_Single_Task_Declaration (N : Node_Id); procedure Expand_N_Task_Body (N : Node_Id); procedure Expand_N_Task_Type_Declaration (N : Node_Id); end Exp_Ch9; (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 witgnat-1.67-src/src/exp_ch3.ads 444 10015 7640 11160 5506244314 11155 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ C H 3 -- -- -- -- S p e c -- -- -- -- $Revision: 1.14 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Expand routines for chapter 3 constructs with Types; use Types; package Exp_Ch3 is procedure Expand_N_Object_Declaration (N : Node_Id); procedure Expand_N_Variant_Part (N : Node_Id); procedure Expand_N_Full_Type_Declaration (N : Node_Id); procedure Build_Discr_Checking_Funcs (N : Node_Id); -- Builds function which checks whether the component name is consistent -- with the current discriminants. N is the full type declaration node, -- and the discriminant checking functions are inserted after this node. function Build_Initialization_Call (Loc : Source_Ptr; Id_Ref : Node_Id; Typ : Entity_Id) return Node_Id; -- Builds a call to the initialization procedure of the Id entity. -- Id_Ref is either a new reference to Id (for record fields), or an -- indexed component (for array elements). Loc is the source location for -- the constructed tree, and Typ is the type of the entity (the -- initialization procedure of the base type is the procedure that -- actually gets called). function Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id) return Node_Id; -- Build the initialization procedure for record types. N is the record -- type definition node, and Pe is an entity used to indicate whether the -- procedure should be made public or not (the procedure entity will be -- made public if and only the entity Pe is public). The result is Error -- if no record initialization procedure is required for the record type, -- and otherwise points to the constructed procedure body, which has -- already been analyzed. It is tthe caller's responsibility to insert -- the procedure into the proper declaration list. In addition, the -- Initialization field of the record type is set to reference the -- procedure. Note that it is not really an error for there to be -- no record initialization procedure, but this makes it easier for the -- caller to do a conditional insertion into the declaration list, since -- the list insertion routines ignore Error. function Expand_Dispatch_Table (Tagged_Type : Entity_Id) return List_Id; -- This function generates the code for the dispatch table associated -- with the Tagged_Type. This dispatch table is a record containing : -- - the inheritence depth (number of ascendants till the root type) -- - a pointer to a table containing the tags of all the ancestors -- - an access to each primitive operation of the tagged type -- The accesses to the primitives are used to implement the dispatching -- calls. The tags of ancestors and the inheritance depth are defined for -- the sake of the membership test. procedure Freeze_Type (N : Node_Id); -- This procedure executes the freezing actions associated with the -- given freeze type node N. end Exp_Ch3; ¹] bindgen.adb¹^ bindusg.ads,¹_ bindusg.adb@¹` butil.adsbT¹a butil.adb l¹b gnatbind.adbl„¹c frontdrv.ads„œ¹d frontdrv.adbœ°¹exref.ads Ĺfxref.adb ܹg xref_tab.adsܹh xref_tab.adb¹i xrefprov.adb,¹j sysid~d.adsD¹k Makefile.os2D`¹l gnat-1.67-src/src/exp_ch3.adb 444 10015 7640 222564 5506244316 11172 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ C H 3 -- -- -- -- B o d y -- -- -- -- $Revision: 1.66 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Comperr; use Comperr; with Einfo; use Einfo; with Exp_Ch9; use Exp_Ch9; with Exp_Util; use Exp_Util; with Namet; use Namet; with Nmake; use Nmake; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Ch3; use Sem_Ch3; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Stand; use Stand; with Snames; use Snames; with Tbuild; use Tbuild; with Uintp; use Uintp; package body Exp_Ch3 is ------------------------- -- Locals Subprograms -- ------------------------- function Predefined_Primitive_Specs (Tag_Typ : Entity_Id) return List_Id; -- Create a list with the specs of the predefined primitive operations. -- This list contains _size and _equality which are the dispatching -- versions of 'Size and "=". These specs must be inserted just after -- the tagged type definition. The rest of the code relies on the fact -- that _Size is first in the dispatch table and _equality is 2nd. -- Here is the generated code : -- -- function _Size (X : Tag_Typ) return Long_Long_Integer; -- function "=" (X : Tag_Typ; Y : Tag_Typ) return Boolean; function Predefined_Primitive_Bodies (Tag_Typ : Entity_Id) return List_Id; -- Create the bodies of the predefined primitives which are to be inserted -- just after the expansion of the Dispatch Table (as soon as the type -- is frozen). Here is the generated code : -- -- function _Size (X : Tag_Typ) return Long_Long_Integer is -- begin -- return X'Size; -- end _size; -- -- function "=" (X : Tag_Typ; Y : Tag_Typ) return Boolean is -- begin -- return ; -- end "="; function Build_Discriminant_Formals (Rec_Id : Entity_Id; Use_Dl : Boolean) return List_Id; -- This function uses the discriminants of a type to build a list -- of formal parameters, used in the following function. If the flag -- -Use_Dl- is set, the list is built using the already defined -- discriminals of the type. Otherwise new identifiers are created, -- with the source name of the discriminants. function Init_Formals (Typ : Entity_Id) return List_Id; -- This function builds the list of formals for an initialization routine. -- The first formal is always _Init with the given type. For task value -- record types and types containing tasks, two additional formals are -- added: -- -- _Master : Master_Id -- _Chain : in out Activation_Chain -- -- The caller must append additional entries for discriminants if required. ---------------------------- -- Build_Array_Init_Proc -- ---------------------------- function Build_Array_Init_Proc (A_Type : Entity_Id) return Node_Id is Comp_Type : constant Entity_Id := Component_Type (A_Type); Loc : constant Source_Ptr := Sloc (A_Type); Index_List : List_Id; Proc_Id : Entity_Id; Proc_Body : Node_Id; function Init_Component return Node_Id; -- Create one statement to initialize one array component, designated -- by a full set of indices. function Init_One_Dimension (N : Int) return Node_Id; -- Create loop to initialize one dimension of the array. The single -- statement in the body of the loop initializes the inner dimensions if -- any,or else a single component. -------------------- -- Init_Component -- -------------------- function Init_Component return Node_Id is Comp : Node_Id; begin Comp := Make_Indexed_Component (Loc, Prefix => Make_Identifier (Loc, Name_uInit), Expressions => Index_List); if Is_Access_Type (Comp_Type) then return Make_Assignment_Statement (Loc, Name => Comp, Expression => Make_Null (Loc)); else return Build_Initialization_Call (Loc, Comp, Comp_Type); end if; end Init_Component; ------------------------ -- Init_One_Dimension -- ------------------------ function Init_One_Dimension (N : Int) return Node_Id is Index : Entity_Id; begin if N > Number_Dimensions (A_Type) then return Init_Component; else Index := Make_Defining_Identifier (Loc, New_Internal_Name ("index")); Append (New_Reference_To (Index, Loc), Index_List); return Make_Loop_Statement (Loc, Identifier => Empty, Iteration_Scheme => Make_Iteration_Scheme (Loc, Loop_Parameter_Specification => Make_Loop_Parameter_Specification (Loc, Defining_Identifier => Index, Discrete_Subtype_Definition => Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Name_uInit), Identifier => Make_Identifier (Loc, Name_Range), Expression => Make_Integer_Literal (Loc, UI_From_Int (N))))), Statements => New_List_1 (Init_One_Dimension (N + 1))); end if; end Init_One_Dimension; ------------------------------------------ -- Processing for Build_Array_Init_Proc -- ------------------------------------------ begin Index_List := New_List; if Present (Init_Proc (Comp_Type)) or else Is_Access_Type (Comp_Type) or else Has_Tasks (Comp_Type) then Proc_Id := Make_Defining_Identifier (Loc, Chars => New_External_Name (Chars (A_Type), "init")); Proc_Body := Make_Subprogram_Body (Loc, Specification => Make_Procedure_Specification (Loc, Defining_Unit_Name => Proc_Id, Parameter_Specifications => Init_Formals (A_Type)), Declarations => New_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List_1 (Init_One_Dimension (1)))); Analyze (Proc_Body); Set_Init_Proc (A_Type, Proc_Id); Set_Is_Public (Proc_Id, Is_Public (A_Type)); Set_Is_Inlined (Proc_Id, True); Set_Is_Internal (Proc_Id, True); Set_Has_Completion (Proc_Id, True); return Proc_Body; -- Return Error if no initialization procedure generated (not really an -- error, just a convenient trick so that the attempt to insert the -- result into the declaration list is simply ignored). else return Error; end if; end Build_Array_Init_Proc; --------------------------------- -- Build_Discriminant_Formals -- --------------------------------- function Build_Discriminant_Formals (Rec_Id : Entity_Id; Use_Dl : Boolean) return List_Id is D : Entity_Id; Formal : Entity_Id; Loc : constant Source_Ptr := Sloc (Rec_Id); Param_Spec_Node : Node_Id; Parameter_List : List_Id := New_List; begin if Has_Discriminants (Rec_Id) then D := First_Discriminant (Rec_Id); while Present (D) loop if Use_Dl then Formal := Discriminal (D); else Formal := Make_Defining_Identifier (Loc, Chars (D)); end if; Param_Spec_Node := Make_Parameter_Specification (Loc, Defining_Identifier => Formal, Parameter_Type => New_Reference_To (Etype (D), Loc)); Append (Param_Spec_Node, Parameter_List); D := Next_Discriminant (D); end loop; end if; return Parameter_List; end Build_Discriminant_Formals; -------------------------------- -- Build_Discr_Checking_Funcs -- -------------------------------- procedure Build_Discr_Checking_Funcs (N : Node_Id) is Rec_Id : Entity_Id; Loc : Source_Ptr; Enclosing_Func_Id : Entity_Id; Insertion_Node : Node_Id := N; Sequence : Nat := 1; Type_Def : Node_Id; V : Node_Id; ----------------------- -- Local Subprograms -- ----------------------- function Build_Case_Statement (Case_Id : Entity_Id; Variant : Node_Id) return Node_Id; -- TBSL need documentation for this spec function Build_Function (Case_Id : Entity_Id; Variant : Node_Id) return Entity_Id; -- Build the discriminant checking function for a given variant procedure Build_Functions (Variant_Part_Node : Node_Id); -- Builds the discriminant checking function for each variant of the -- given variant part of the record type. procedure Build_Functions (Variant_Part_Node : Node_Id) is Component_List_Node : Node_Id; Decl : Entity_Id; Discr_Name : Entity_Id; Func_Id : Entity_Id; Variant : Node_Id; Saved_Enclosing_Func_Id : Entity_Id; begin -- Build the discriminant checking function for each variant, label -- all components of that variant with the function's name. Discr_Name := Entity (Name (Variant_Part_Node)); Variant := First (Variants (Variant_Part_Node)); while Present (Variant) loop Func_Id := Build_Function (Discr_Name, Variant); Component_List_Node := Component_List (Variant); if not Null_Present (Component_List_Node) then Decl := First (Component_Declarations (Component_List_Node)); while Present (Decl) loop Set_Discriminant_Checking_Func (Defining_Identifier (Decl), Func_Id); Decl := Next (Decl); end loop; if Present (Variant_Part (Component_List_Node)) then Saved_Enclosing_Func_Id := Enclosing_Func_Id; Enclosing_Func_Id := Func_Id; Build_Functions (Variant_Part (Component_List_Node)); Enclosing_Func_Id := Saved_Enclosing_Func_Id; end if; end if; Variant := Next (Variant); end loop; end Build_Functions; function Build_Function (Case_Id : Entity_Id; Variant : Node_Id) return Entity_Id is Body_Node : Node_Id; Buf : Str (1 .. 6); Func_Id : Entity_Id; Parameter_List : List_Id; Spec_Node : Node_Id; V : Nat := Sequence; begin Body_Node := New_Node (N_Subprogram_Body, Loc); Buf (1) := 'd'; -- Add decimal representation of V to characters in name buffer, -- updating Name_Len to reflect the stored digits. for I in reverse Pos range 2 .. 6 loop Buf (I) := Char'Val (Char'Pos ('0') + V rem 10); V := V / 10; end loop; Sequence := Sequence + 1; Func_Id := Make_Defining_Identifier (Loc, Chars => New_External_Name (Chars (Rec_Id), Buf)); Spec_Node := New_Node (N_Function_Specification, Loc); Set_Defining_Unit_Name (Spec_Node, Func_Id); Parameter_List := Build_Discriminant_Formals (Rec_Id, False); Set_Parameter_Specifications (Spec_Node, Parameter_List); Set_Subtype_Mark (Spec_Node, New_Reference_To (Standard_Boolean, Loc)); Set_Specification (Body_Node, Spec_Node); Set_Declarations (Body_Node, New_List); Set_Handled_Statement_Sequence (Body_Node, Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List_1 ( Build_Case_Statement (Case_Id, Variant)))); Analyze (Body_Node); Set_Is_Inlined (Func_Id); Set_Is_Pure (Func_Id); -- Make the discriminant checking function have the same public -- status as that of the record type which it checkes. Set_Is_Public (Func_Id, Is_Public (Rec_Id)); Set_Is_Internal (Func_Id); Insert_After (Insertion_Node, Body_Node); Insertion_Node := Body_Node; return Func_Id; end Build_Function; function Build_Case_Statement (Case_Id : Entity_Id; Variant : Node_Id) return Node_Id is Actuals_List : List_Id; Alt_List : List_Id := New_List; Case_Node : Node_Id; Case_Alt_Node : Node_Id; Choice : Node_Id; Choice_List : List_Id; D : Entity_Id; Return_Node : Node_Id; begin -- Build a case statement containing only two alternatives. The -- first alternative corresponds exactly to the discrete choices -- given on the variant with contains the components that we are -- generating the checks for. If the discriminant is one of these -- return False. The other alternative consists of the choice -- "Others" and will return True indicating the discriminant did -- not match. Case_Node := New_Node (N_Case_Statement, Loc); -- Replace the discriminant which controls the variant, with the -- name of the formal of the checking function. Set_Expression (Case_Node, Make_Identifier (Loc, Chars (Case_Id))); Choice := First (Discrete_Choices (Variant)); if Nkind (Choice) = N_Others_Choice then Choice_List := New_List_Copy (Others_Discrete_Choices (Choice)); else Choice_List := New_List_Copy (Discrete_Choices (Variant)); end if; Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc); Set_Discrete_Choices (Case_Alt_Node, Choice_List); -- In case this is a nested variant, we need to return the result -- of the discriminant checking function for the immediately -- enclosing variant. if Present (Enclosing_Func_Id) then Actuals_List := New_List; D := First_Discriminant (Rec_Id); while Present (D) loop Append (Make_Identifier (Loc, Chars (D)), Actuals_List); D := Next_Discriminant (D); end loop; Return_Node := Make_Return_Statement (Loc, Expression => Make_Function_Call (Loc, Name => New_Reference_To (Enclosing_Func_Id, Loc), Parameter_Associations => Actuals_List)); else Return_Node := Make_Return_Statement (Loc, Expression => New_Reference_To (Standard_False, Loc)); end if; Set_Statements (Case_Alt_Node, New_List_1 (Return_Node)); Append (Case_Alt_Node, Alt_List); Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc); Choice_List := New_List_1 (New_Node (N_Others_Choice, Loc)); Set_Discrete_Choices (Case_Alt_Node, Choice_List); Return_Node := Make_Return_Statement (Loc, Expression => New_Reference_To (Standard_True, Loc)); Set_Statements (Case_Alt_Node, New_List_1 (Return_Node)); Append (Case_Alt_Node, Alt_List); Set_Alternatives (Case_Node, Alt_List); return Case_Node; end Build_Case_Statement; -- Start of processing for Build_Discr_Checking_Funcs begin Type_Def := Type_Definition (N); if Nkind (Type_Def) = N_Record_Definition then if No (Component_List (Type_Def)) then -- null record. return; else V := Variant_Part (Component_List (Type_Def)); end if; elsif Nkind (Type_Def) = N_Derived_Type_Definition then if No (Component_List (Record_Extension_Part (Type_Def))) then return; else V := Variant_Part (Component_List (Record_Extension_Part (Type_Def))); end if; else Compiler_Abort; end if; if Present (V) then Loc := Sloc (N); Enclosing_Func_Id := Empty; Rec_Id := Defining_Identifier (N); Build_Functions (V); end if; end Build_Discr_Checking_Funcs; ---------------------------- -- Build_Record_Init_Proc -- ---------------------------- function Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (N); Proc_Id : Entity_Id; Rec_Type : Entity_Id; -------------------------------------------------- -- Local Subprograms for Build_Record_Init_Proc -- -------------------------------------------------- function Build_Init_Actuals (Id : Entity_Id) return List_Id; -- Build the list of actual parameters for the call to the -- initialization procedure for a component of a record which is -- itself a record type or subtype. function Build_Assignment (Id : Entity_Id; N : Node_Id) return Node_Id; -- Build a assignment statement node which assigns to record component -- its default expression if defined. procedure Build_Discriminant_Assignments (Statement_List : List_Id); -- If the record has discriminants, adds assignment statements to -- statement list to initialize the discriminant values from the -- arguments of the initialization procedure. function Build_Init_Call (Id : Entity_Id) return Node_Id; -- Build the tree representing a call to a record initialization -- procedure along with the appropriate actual parameters. function Build_Init_Statements (Comp_List : Node_Id) return List_Id; -- Build a list representing a sequence of statements which initialize -- components of the given component list. This may involve building -- case statements for the variant parts. function Build_Init_Procedure return Node_Id; -- Build the tree corresponding to the procedure specification and body -- of the initialization procedure (by calling all the preceding -- auxillary routines). function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean; -- Determines whether a record initialization procedure needs to be -- generated for the given record type. ---------------------- -- Build_Assignment -- ---------------------- function Build_Assignment (Id : Entity_Id; N : Node_Id) return Node_Id is Assign_Node : Node_Id; Selector_Node : Node_Id; begin Selector_Node := New_Node (N_Selected_Component, Loc); Set_Prefix (Selector_Node, Make_Identifier (Loc, Name_uInit)); Set_Selector_Name (Selector_Node, New_Occurrence_Of (Id, Loc)); Assign_Node := New_Node (N_Assignment_Statement, Loc); Set_Name (Assign_Node, Selector_Node); Set_Expression (Assign_Node, N); return Assign_Node; end Build_Assignment; ------------------------ -- Build_Init_Actuals -- ------------------------ -- References to a discriminant inside the record type declaration -- can appear either in the subtype_indication to constrain a -- record or an array, or as part of a larger expression given for -- the initial value of a component. In both of these cases N appears -- in the record initialization procedure and needs to be replaced by -- the formal parameter of the initialization procedure which -- corresponds to that discriminant. -- In the example below, references to D1 and D2 in proc_1 are -- replaced by references to In_3 and In_4 respectively. -- A similar replacement is done for calls to any record -- initialization procedure for any components that are themselves -- of a record type. -- type R (D1, D2 : Integer) is record -- X : Integer := F * D1; -- Y : Integer := F * D2; -- end record; -- procedure proc_1 (Out_2 : out R; D1 : Integer; D2 : Integer) is -- begin -- Out_2.D1 := D1; -- Out_2.D2 := D2; -- Out_2.X := F * D1; -- Out_2.Y := F * D2; -- end; function Build_Init_Actuals (Id : Entity_Id) return List_Id is Elmt : Elmt_Id; Exp_Node : Node_Id; Parameter_List : List_Id; Selector_Node : Node_Id; Typ : constant Entity_Id := Etype (Id); begin -- First actual is _Init, the component to be initialized Parameter_List := New_List; Selector_Node := New_Node (N_Selected_Component, Loc); Set_Prefix (Selector_Node, Make_Identifier (Loc, Name_uInit)); Set_Selector_Name (Selector_Node, New_Occurrence_Of (Id, Loc)); Append (Convert_Task (Selector_Node, Typ), Parameter_List); -- For the task case, pass _Master as the value of the _Master -- parameter, and _Chain as the value of the _Chain parameter. -- In other words we are just passing down the parameters that -- were passed to the record initialization procedure itself. if Has_Tasks (Typ) then Append_To (Parameter_List, Make_Identifier (Loc, Name_uMaster)); Append_To (Parameter_List, Make_Identifier (Loc, Name_uChain)); end if; -- Add discriminant values if discriminants are present if Is_Record_Type (Typ) and then Has_Discriminants (Typ) then Elmt := First_Elmt (Discriminant_Constraint (Etype (Id))); while Elmt /= No_Elmt loop Exp_Node := Id_Of (Elmt); -- Replace any possible references to the discriminant in the -- call to the record initialization procedure with references -- to the appropriate formal parameter. if Nkind (Exp_Node) = N_Identifier and then Ekind (Entity (Exp_Node)) = E_Discriminant then Append_To (Parameter_List, New_Reference_To ( Discriminal (Entity (Exp_Node)), Loc)); else Append_To (Parameter_List, New_Copy (Exp_Node)); end if; Elmt := Next_Elmt (Elmt); end loop; end if; return Parameter_List; end Build_Init_Actuals; --------------------- -- Build_Init_Call -- --------------------- function Build_Init_Call (Id : Entity_Id) return Node_Id is Call_Node : Node_Id; begin Call_Node := Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (Base_Init_Proc (Etype (Id)), Loc), Parameter_Associations => Build_Init_Actuals (Id)); return Call_Node; end Build_Init_Call; --------------------------- -- Build_Init_Statements -- --------------------------- function Build_Init_Statements (Comp_List : Node_Id) return List_Id is Alt_List : List_Id; Case_Node : Node_Id; Case_Alt_Node : Node_Id; Choice : Node_Id; Choice_List : List_Id; Decl : Node_Id; Exp_Node : Node_Id; Id : Node_Id; Statement_List : List_Id; Variant : Node_Id; begin if Null_Present (Comp_List) then return New_List_1 (Make_Null_Statement (Loc)); end if; Statement_List := New_List; Decl := First (Component_Declarations (Comp_List)); while Present (Decl) loop Id := Defining_Identifier (Decl); if Present (Expression (Decl)) then Exp_Node := New_Copy (Expression (Decl)); Append (Build_Assignment (Id, Exp_Node), Statement_List); elsif Is_Access_Type (Etype (Id)) then Append_To (Statement_List, Build_Assignment (Id, Make_Null (Loc))); elsif Is_Record_Type (Etype (Id)) and then Present (Base_Init_Proc (Etype (Id))) then Append (Build_Init_Call (Id), Statement_List); elsif Is_Array_Type (Etype (Id)) and then Present (Base_Init_Proc (Etype (Id))) then Append (Build_Init_Call (Id), Statement_List); elsif Has_Tasks (Etype (Id)) then Append (Build_Init_Call (Id), Statement_List); -- Case of no initialization procedure present for the a -- record type having no default expressions or discriminants. else null; end if; Decl := Next (Decl); end loop; -- Process the variant part if Present (Variant_Part (Comp_List)) then Case_Node := New_Node (N_Case_Statement, Loc); Alt_List := New_List; Variant := First (Variants (Variant_Part (Comp_List))); while Present (Variant) loop Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Loc); Choice_List := New_List; Choice := First (Discrete_Choices (Variant)); while Present (Choice) loop Append (New_Copy (Choice), Choice_List); Choice := Next (Choice); end loop; Set_Discrete_Choices (Case_Alt_Node, Choice_List); Append (Case_Alt_Node, Alt_List); Set_Statements (Case_Alt_Node, Build_Init_Statements (Component_List (Variant))); Variant := Next (Variant); end loop; Set_Expression ( Case_Node, New_Reference_To (Discriminal ( Entity (Name (Variant_Part (Comp_List)))), Loc)); -- The expression of the case statement which is a reference to -- one of the discriminants is replaced by the appropriate formal -- parameter of the initialization procedure. Set_Alternatives (Case_Node, Alt_List); Append (Case_Node, Statement_List); end if; -- For a task record type, add the task create call if Is_Task_Record_Type (Rec_Type) then Append (Make_Task_Create_Call (Rec_Type), Statement_List); end if; -- If no initializations when generated for component declarations -- corresponding to this Statement_List, append a null statement -- to the Statement_List to make it a valid Ada tree. if Is_Empty_List (Statement_List) then Append (New_Node (N_Null_Statement, Loc), Statement_List); end if; return Statement_List; end Build_Init_Statements; -------------------------- -- Build_Init_Procedure -- -------------------------- function Build_Init_Procedure return Node_Id is Body_Node : Node_Id; Handled_Stmt_Node : Node_Id; Parameters : List_Id; Proc_Spec_Node : Node_Id; Statement_List : List_Id; Record_Extension_Node : Node_Id; begin Statement_List := New_List; Body_Node := New_Node (N_Subprogram_Body, Loc); Proc_Id := Make_Defining_Identifier (Loc, Chars => New_External_Name (Chars (Rec_Type), "Init")); Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc); Set_Defining_Unit_Name (Proc_Spec_Node, Proc_Id); Set_Init_Proc (Rec_Type, Proc_Id); Build_Discriminant_Assignments (Statement_List); Parameters := Init_Formals (Rec_Type); Append_List_To (Parameters, Build_Discriminant_Formals (Rec_Type, True)); Set_Parameter_Specifications (Proc_Spec_Node, Parameters); Set_Specification (Body_Node, Proc_Spec_Node); Set_Declarations (Body_Node, New_List); if Nkind (Type_Definition (N)) = N_Record_Definition then if not Null_Present (Type_Definition (N)) then Append_List_To (Statement_List, Build_Init_Statements ( Component_List (Type_Definition (N)))); end if; else -- N is a Derived_Type_Definition with a possible non-empty -- extension. The initialization of a type extension consists -- in the initialization of the components in the extension. Record_Extension_Node := Record_Extension_Part (Type_Definition (N)); if not Null_Present (Record_Extension_Node) then Append_List_To (Statement_List, Build_Init_Statements (Component_List (Record_Extension_Node))); end if; end if; -- Add here the assignment to instantiate the Tag -- This instantiation is done at the end because the instantiation -- of the __Parent field calls the Record_Init_Proc for the parent -- Parent which instaciate the Tag with a wrong value. -- The assignement corresponds to the code: -- Out__XXX._Tag := System.Tag (_Dispatch_Table_Ptr_XXX); -- where _Dispatch_Table_Ptr__XXX is an access to the correct -- dispatch table (see Expand_Dispatch_Table for details). if Is_Tagged_Type (Rec_Type) then Append_To (Statement_List, Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_uInit), Selector_Name => New_Reference_To (Tag_Component (Rec_Type), Loc)), Expression => Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (RTE (RE_Tag), Loc), Expression => New_Reference_To (Access_Disp_Table (Rec_Type), Loc)))); end if; Handled_Stmt_Node := New_Node (N_Handled_Sequence_Of_Statements, Loc); Set_Statements (Handled_Stmt_Node, Statement_List); Set_Exception_Handlers (Handled_Stmt_Node, No_List); Set_Handled_Statement_Sequence (Body_Node, Handled_Stmt_Node); return Body_Node; end Build_Init_Procedure; ------------------------------------ -- Build_Discriminant_Assignments -- ------------------------------------ procedure Build_Discriminant_Assignments (Statement_List : List_Id) is Assign_Node : Node_Id; D : Entity_Id; begin if Has_Discriminants (Rec_Type) then D := First_Discriminant (Rec_Type); while Present (D) loop Assign_Node := Build_Assignment (D, New_Reference_To (Discriminal (D), Loc)); Set_Assignment_OK (Assign_Node, True); Append (Assign_Node, Statement_List); D := Next_Discriminant (D); end loop; end if; end Build_Discriminant_Assignments; ------------------------ -- Requires_Init_Proc -- ------------------------ function Requires_Init_Proc (Rec_Id : Entity_Id) return Boolean is Comp_Decl : Node_Id; Id : Entity_Id; begin -- An initialization procedure needs to be generated only if at -- least one of the following applies: -- 1. Discriminants are present, since they need to be initialized -- with the appropriate discriminant constraint expressions. -- 2. The type is a tagged type, since the implicit Tag component -- needs to be initialized with a pointer to the dispatch table. -- 3. The type contains tasks -- 4. One or more components has an initial value -- 5. One or more components is for a type which itself requires -- an initialization procedure. -- 6. One or more components is an access type (which needs to be -- initialized to null). -- 7. The type is the record type built for a task type (since at -- the very least, Create_Task must be called) if Has_Discriminants (Rec_Id) or else Is_Tagged_Type (Rec_Id) or else Is_Task_Record_Type (Rec_Id) or else Has_Tasks (Rec_Id) then return True; end if; Id := First_Component (Rec_Id); while Present (Id) loop Comp_Decl := Parent (Id); if Present (Expression (Comp_Decl)) or else Present (Base_Init_Proc (Etype (Id))) or else Is_Access_Type (Etype (Id)) then return True; end if; Id := Next_Component (Id); end loop; return False; end Requires_Init_Proc; ------------------------------------------- -- Processing for Build_Record_Init_Proc -- ------------------------------------------- begin Rec_Type := Defining_Identifier (N); -- Case of declaration for a record type, but this may be the -- This may be full declaration of a private type, in which case -- the visible entity is a record, and the private entity has been -- exchanged with it in the private part of the current package. -- The initialization procedure is built for the record type, which -- is retrievable from the private entity. if Ekind (Rec_Type) in Incomplete_Kind then Rec_Type := Full_Declaration (Rec_Type); end if; -- Derived types that have no type extension can use the initialization -- procedure of their parent and do not need a procedure of their own. -- In that case set the Init_Proc attribute to reference the name of the -- parent's initialization procedure. Otherwise generate a new procedure if Nkind (Type_Definition (N)) = N_Derived_Type_Definition and not Is_Tagged_Type (Rec_Type) then Set_Init_Proc (Rec_Type, Base_Init_Proc (Root_Type (Rec_Type))); return Error; -- Otherwise if we need an initialization procedure, then build one, -- mark it as public and inlinable and as having a completion. elsif Requires_Init_Proc (Rec_Type) then declare Rec_Init : constant Node_Id := Build_Init_Procedure; begin -- Another freezing kludge, make sure the task body procedure -- spec gets analyzed before the record task type, so that the -- reference to the body in the latter works correctly. if Is_Task_Record_Type (Rec_Type) then Analyze (Next (N)); end if; Analyze (Rec_Init); Set_Is_Public (Proc_Id, Is_Public (Pe)); Set_Is_Inlined (Proc_Id, True); Set_Is_Internal (Proc_Id, True); Set_Has_Completion (Proc_Id, True); -- Return resulting record initialization procedure body. Note -- that we don't call Analyze, since the body will be inserted -- into the declaration list past the current point, so we will -- encounter it and analyze it in the normal course of processing -- declarations sequentially. return Rec_Init; end; -- Here if no record initialization procedure is required. We return -- Error (although it's not really an error, just a trick to make it -- easy for the caller to ignore this case, since an attempt to stick -- Error into the declaration list will be ignored). else return Error; end if; end Build_Record_Init_Proc; ----------------- -- Freeze_Type -- ----------------- -- Full type declarations are expanded at the point at which the type -- is frozen. The formal N is the Freeze_Node for the type, and the -- various initialization procedures generated by the expansion are -- inserted at the point of freezing, i.e. before or after N. procedure Freeze_Type (N : Node_Id) is Def_Id : constant Entity_Id := Entity (N); Type_Decl : Node_Id := Parent (Def_Id); Type_Def : Node_Id; Parent_E : Entity_Id; begin --------------------------------------------------- -- Freeze Processing for Record Type Declaration -- --------------------------------------------------- if Ekind (Def_Id) = E_Record_Type and then Nkind (Type_Decl) /= N_Implicit_Type then if Nkind (Type_Decl) = N_Private_Type_Declaration then -- Scan the declarative part to find the entity that points -- to the current full type. The full declaration for the type -- is found there. declare E : Entity_Id := Next_Entity (Def_Id); begin while Present (E) loop if Ekind (E) in Incomplete_Kind and then Full_Declaration (E) = Def_Id then Type_Decl := Parent (E); exit; end if; E := Next_Entity (E); end loop; end; end if; Type_Def := Type_Definition (Type_Decl); if Is_Tagged_Type (Def_Id) then Insert_List_Before (N, Expand_Dispatch_Table (Def_Id)); end if; -- Before building the record initialization procedure, if we -- are dealing with a task record value type, then we must go -- through the discriminants, exchanging discriminals between -- the task type and the task record value type. See the section -- "Handling of Discriminants" in the Einfo spec for details. if Is_Task_Record_Type (Def_Id) and then Has_Discriminants (Def_Id) then declare Ttyp : constant Entity_Id := Corresponding_Task_Type (Def_Id); Task_Discr : Entity_Id; Rec_Discr : Entity_Id; Temp : Entity_Id; begin Task_Discr := First_Discriminant (Ttyp); Rec_Discr := First_Discriminant (Def_Id); while Present (Task_Discr) loop Temp := Discriminal (Task_Discr); Set_Discriminal (Task_Discr, Discriminal (Rec_Discr)); Set_Discriminal (Rec_Discr, Temp); Task_Discr := Next_Discriminant (Task_Discr); Rec_Discr := Next_Discriminant (Rec_Discr); end loop; end; end if; Insert_After (N, Build_Record_Init_Proc (Type_Decl, Def_Id)); Build_Discr_Checking_Funcs (Type_Decl); -------------------------------------------------- -- Freeze Processing for Array Type Declaration -- -------------------------------------------------- -- Build initialization procedure if one is required elsif Is_Array_Type (Def_Id) then if (No (Init_Proc (Base_Type (Def_Id)))) then Insert_After (N, Build_Array_Init_Proc (Base_Type (Def_Id))); end if; end if; end Freeze_Type; ------------------------------------ -- Expand_N_Full_Type_Declaration -- ------------------------------------ procedure Expand_N_Full_Type_Declaration (N : Node_Id) is Def_Id : constant Entity_Id := Defining_Identifier (N); begin -------------------------------------- -- Type Declaration For Tagged Type -- -------------------------------------- -- For tagged types, create the specification for the _Size function, -- the implicit primitive operation used to compute the Size attribute. if Is_Tagged_Type (Def_Id) then Insert_List_After (N, Predefined_Primitive_Specs (Def_Id)); -------------------------------------- -- Type Declaration for Access Type -- -------------------------------------- -- If the designated types is a task type or contains tasks, then -- we make sure that a _Master variable is declared in the current -- scope, and then declare a renaming for it: -- atype___Master : Master_Id renames _Master; -- where atyp is the name of the access type. This declaration is -- used when an allocator for the access type is expanded elsif Is_Access_Type (Def_Id) then if Has_Tasks (Designated_Type (Def_Id)) then Build_Master_Entity (Def_Id); declare Loc : constant Source_Ptr := Sloc (Def_Id); Id : constant Entity_Id := Make_Defining_Identifier (Loc, New_External_Name (Chars (Def_Id), "master")); begin Insert_After (N, Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Id, Subtype_Mark => New_Reference_To (RTE (RE_Master_Id), Loc), Name => Make_Identifier (Loc, Name_uMaster))); Set_Master_Id (Def_Id, Id); end; end if; end if; end Expand_N_Full_Type_Declaration; --------------------------------- -- Expand_N_Object_Declaration -- --------------------------------- -- First we do special processing for objects of a tagged type where this -- is the point at which the type is frozen. The creation of the dispatch -- table and the initialization procedure have to be deffered to this -- point, since we reference previously declared primitive subprograms. -- For all types, we call an initialization procedure if there is one procedure Expand_N_Object_Declaration (N : Node_Id) is Typ : constant Entity_Id := Etype (Defining_Identifier (N)); Obj_Def : constant Node_Id := Object_Definition (N); Expr : constant Node_Id := Expression (N); Loc : constant Source_Ptr := Sloc (N); New_Expr : Node_Id; begin -- If tasks being declared, make sure we have an activation chain -- defined for the tasks (has no effect if we already have one), and -- also that a Master variable is established and that the appropriate -- enclosing construct is established as a task master. if Has_Tasks (Typ) then Build_Activation_Chain_Entity (N); Build_Master_Entity (Typ); end if; -- Call type initialization procedure if there is one. We build -- the call and put it immediately after the object declaration, -- so that it will be expanded in the usual manner. Note that this -- will result in proper handling of defaulted discriminants. if Present (Base_Init_Proc (Typ)) and then No (Expr) then Insert_After (N, Build_Initialization_Call (Loc, New_Reference_To (Defining_Identifier (N), Loc), Typ)); end if; -- If the type is a class type (which of course must have an initial -- value specified), we first make sure that the expression has a -- class-wide type by forcing an unchecked conversion if needed. That -- is important because the expression may come from a view conversion -- in which case its static type doesn't correspond to its tag. Then we -- generate the equivalent record whose size is the actual size -- of the initial value. if Ekind (Typ) = E_Class_Subtype then if not Is_Class_Type (Etype (Expr)) then New_Expr := Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (Etype (Obj_Def), Loc), Expression => New_Copy (Expr)); Analyze (New_Expr); Resolve_Subexpr (New_Expr, Typ); else New_Expr := New_Copy (Expr); end if; Insert_List_Before (N, Expand_Class_Subtype (Loc, Typ, New_Expr)); -- Now convert the expression to the new equivalent type. Rewrite_Substitute_Tree (Expr, Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (Equivalent_Type (Typ), Loc), Expression => New_Expr)); Analyze (Expr); Resolve_Subexpr (Expr, Equivalent_Type (Typ)); end if; end Expand_N_Object_Declaration; ------------------------------- -- Build_Initialization_Call -- ------------------------------- function Build_Initialization_Call (Loc : Source_Ptr; Id_Ref : Node_Id; Typ : Entity_Id) return Node_Id is Args : List_Id; Discr : Elmt_Id; begin -- First argument (_Init) is the object to be initialized, which is -- passed as the second parameter of the call to this procedure. Args := New_List_1 (Convert_Task (Id_Ref, Typ)); -- In the tasks case, add _Master as the value of the _Master parameter -- and _Chain as the value of the _Chain parameter. At the outer level, -- these will be variables holding the corresponding values obtained -- from GNARL. At inner levels, they will be the parameters passed down -- through the outer routines. if Has_Tasks (Typ) then Append_To (Args, Make_Identifier (Loc, Name_uMaster)); Append_To (Args, Make_Identifier (Loc, Name_uChain)); end if; -- Add discriminant values if discriminants are present if Has_Discriminants (Typ) then Discr := First_Elmt (Discriminant_Constraint (Typ)); while Discr /= No_Elmt loop Append (New_Copy (Id_Of (Discr)), Args); Discr := Next_Elmt (Discr); end loop; end if; -- Return the node for the call to the initialization procedure return Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (Base_Init_Proc (Typ), Loc), Parameter_Associations => Args); end Build_Initialization_Call; -------------------------------- -- Predefined_Primitive_Specs -- -------------------------------- function Predefined_Primitive_Specs (Tag_Typ : Entity_Id) return List_Id is Loc : constant Source_Ptr := Sloc (Tag_Typ); Param1 : Entity_Id; Param2 : Entity_Id; F_Id : Entity_Id; Decl : Node_Id; Res : List_Id := New_List; begin -- Spec of _Size Param1 := Make_Defining_Identifier (Loc, Name_X); F_Id := Make_Defining_Identifier (Loc, Name_uSize); Decl := Make_Subprogram_Declaration (Loc, Specification => Make_Function_Specification (Loc, Defining_Unit_Name => F_Id, Parameter_Specifications => New_List_1 ( Make_Parameter_Specification (Loc, Defining_Identifier => Param1, Parameter_Type => New_Reference_To (Tag_Typ, Loc))), Subtype_Mark => New_Reference_To (Standard_Long_Long_Integer, Loc))); Analyze (Decl); Set_Is_Public (F_Id, Is_Public (Tag_Typ)); Append_To (Res, Decl); -- Spec of "=" if not Is_Limited_Type (Tag_Typ) then Param1 := Make_Defining_Identifier (Loc, Name_X); Param2 := Make_Defining_Identifier (Loc, Name_Y); F_Id := Make_Defining_Identifier (Loc, Name_Op_Eq); Decl := Make_Subprogram_Declaration (Loc, Specification => Make_Function_Specification (Loc, Defining_Unit_Name => F_Id, Parameter_Specifications => New_List_2 ( Make_Parameter_Specification (Loc, Defining_Identifier => Param1, Parameter_Type => New_Reference_To (Tag_Typ, Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => Param2, Parameter_Type => New_Reference_To (Tag_Typ, Loc))), Subtype_Mark => New_Reference_To (Standard_Boolean, Loc))); Analyze (Decl); Set_Is_Public (F_Id, Is_Public (Tag_Typ)); Set_Is_Internal (F_Id); Append_To (Res, Decl); end if; return Res; end Predefined_Primitive_Specs; --------------------------------- -- Predefined_Primitive_Bodies -- --------------------------------- function Predefined_Primitive_Bodies (Tag_Typ : Entity_Id) return List_Id is Loc : constant Source_Ptr := Sloc (Tag_Typ); Param1 : Entity_Id; Param2 : Entity_Id; F_Id : Entity_Id; Decl : Node_Id; Res : List_Id := New_List; Prim : Elmt_Id; begin -- Body of _Size Param1 := Make_Defining_Identifier (Loc, Name_X); F_Id := Make_Defining_Identifier (Loc, Name_uSize); Decl := Make_Subprogram_Body (Loc, Specification => Make_Function_Specification (Loc, Defining_Unit_Name => F_Id, Parameter_Specifications => New_List_1 ( Make_Parameter_Specification (Loc, Defining_Identifier => Param1, Parameter_Type => New_Reference_To (Tag_Typ, Loc))), Subtype_Mark => New_Reference_To (Standard_Long_Long_Integer, Loc)), Declarations => Empty_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, New_List_1 ( Make_Return_Statement (Loc, Expression => Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Name_X), Identifier => Make_Identifier (Loc, Name_Size)))))); Analyze (Decl); Set_Is_Public (F_Id, Is_Public (Tag_Typ)); Append_To (Res, Decl); -- Body of "=". -- It has to be supplied only if the type is not limited and -- there is no user-defined "=". if not Is_Limited_Type (Tag_Typ) then Prim := First_Elmt (Primitive_Operations (Tag_Typ)); while Chars (Id_Of (Prim)) /= Name_Op_Eq loop Prim := Next_Elmt (Prim); pragma Assert (Prim /= No_Elmt); end loop; if Is_Internal (Id_Of (Prim)) then Param1 := Make_Defining_Identifier (Loc, Name_X); Param2 := Make_Defining_Identifier (Loc, Name_Y); F_Id := Make_Defining_Identifier (Loc, Name_Op_Eq); Decl := Make_Subprogram_Body (Loc, Specification => Make_Function_Specification (Loc, Defining_Unit_Name => F_Id, Parameter_Specifications => New_List_2 ( Make_Parameter_Specification (Loc, Defining_Identifier => Param1, Parameter_Type => New_Reference_To (Tag_Typ, Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => Param2, Parameter_Type => New_Reference_To (Tag_Typ, Loc))), Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)), Declarations => Empty_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, New_List_1 ( Make_Return_Statement (Loc, Expression => Expand_Record_Equality (Loc, Typ => Tag_Typ, Lhs => Make_Identifier (Loc, Name_X), Rhs => Make_Identifier (Loc, Name_Y)))))); Analyze (Decl); Set_Is_Public (F_Id, Is_Public (Tag_Typ)); Append_To (Res, Decl); end if; end if; return Res; end Predefined_Primitive_Bodies; --------------------------- -- Expand_N_Variant_Part -- --------------------------- -- If the last variant does not contain the Others choice, replace -- it with an N_Others_Choice node since Gigi always wants an Others. -- Note that we do not bother to call Analyze on the modified variant -- part, since it's only effect would be to compute the contents of -- the Others_Discrete_Choices node laboriously, and of course we -- already know the list of choices that corresponds to the others -- choice (it's the list we are replacing!) procedure Expand_N_Variant_Part (N : Node_Id) is Last_Var : constant Node_Id := Last (Variants (N)); Others_Node : Node_Id; begin if Nkind (First (Discrete_Choices (Last_Var))) /= N_Others_Choice then Others_Node := Make_Others_Choice (Sloc (Last_Var)); Set_Others_Discrete_Choices (Others_Node, Discrete_Choices (Last_Var)); Set_Discrete_Choices (Last_Var, New_List_1 (Others_Node)); end if; end Expand_N_Variant_Part; ---------------------------- -- Expand_Dispatch_Table -- ---------------------------- -- The following code is built to generate the dispatch table. Note that -- the types for access to primitives are constructed as implicit types -- (i.e. the full tree for the type, as implied by the documentation -- given here is not in fact constructed, but the required entities are -- constructed). -- Note also the pragma Suppress on the index type of tha Ancestor tag -- table. It is needed for the sake of class-wide objects ; as a matter -- of fact these values use the root Dispatch Table type, but their actual -- Dispatch Table can contain a Table of Ancestor bigger than the Root one -- and in this case we don't want to generate an index constraint error. -- type {Tname}___prim_ptr_1 is access {profile of 1st primitive}; -- type {Tname}___prim_ptr_2 is access {profile of 2nd primitive}; -- ... -- type {Tname}___prim_ptr_n is access {profile of nth primitive}; -- -- type {Tname}___TT_Type is -- array (0 .. {_Idepth}) of Ada.Tags.Tag; -- pragma Suppress (Index_Check, {Tname}___TT_Type); -- -- type {Tname}___TT_Ptr_Type is access {Tname}___TT_Type; -- {Tname}___Tag_Table : aliased {Tname}___TT_Type; -- -- type DT_Type is record -- _Idepth : Natural := {inheritance depth}; -- _Tags : {Tname}___TT_Ptr_Type := {Tname}___Tag_Table'access; -- f_1 : {Tname}___prim_ptr_1 := f'access; -- g_2 : {Tname}___prim_ptr_2 := g'access; -- ... -- h_n : {Tname}___prim_ptr_n := h'access; -- end record; -- -- type {Tname}___DT_Ptr_Type is access {Tname}___DT_Type; -- -- {Tname}___Disp_Table : aliased {Tname}___DT_Type; -- {Tname}___DT_Ptr : {Tname}___DT_Ptr_Type := -- {Tname}___Disp_Table'access; -- -- {Tname}___Tag_Table (0) := Ada.Tags.Tag ({Tname}___DT_Ptr); -- {Tname}___Tag_Table (1) := {Tname}___DT_Ptr._Tags (0); -- {Tname}___Tag_Table (2) := {Tname}___DT_Ptr._Tags (1); -- ... -- {Tname}___Tag_Table (n) := {Tname}___DT_Ptr._Tags (n - 1); function Expand_Dispatch_Table (Tagged_Type : Entity_Id) return List_Id is Loc : constant Source_Ptr := Sloc (Tagged_Type); Tname : constant Name_Id := Chars (Tagged_Type); -- TT stands for (ancestor) Tag Table -- DT stands for Dispatch Table Name_TTT : constant Name_Id := New_External_Name (Tname, "tt_type"); Name_TTI : constant Name_Id := New_External_Name (Tname, "tt_type_ind"); Name_TT : constant Name_Id := New_External_Name (Tname, "tag_table"); Name_TTPT : constant Name_Id := New_External_Name (Tname, "tt_ptr_type"); Name_DTT : constant Name_Id := New_External_Name (Tname, "dt_type"); Name_DT : constant Name_Id := New_External_Name (Tname, "disp_table"); Name_DTPT : constant Name_Id := New_External_Name (Tname, "dt_ptr_type"); Name_DTP : constant Name_Id := New_External_Name (Tname, "dt_ptr"); TT_Type : constant Node_Id := Make_Defining_Identifier (Loc, Name_TTT); TT_Type_Index : constant Node_Id := Make_Defining_Identifier (Loc, Name_TTI); Tag_Table : constant Node_Id := Make_Defining_Identifier (Loc, Name_TT); TT_Ptr_Type : constant Node_Id := Make_Defining_Identifier (Loc, Name_TTPT); Tags : constant Node_Id := Make_Defining_Identifier (Loc, Name_uTags); DT_Type : constant Node_Id := Make_Defining_Identifier (Loc, Name_DTT); Dispatch_Table : constant Node_Id := Make_Defining_Identifier (Loc, Name_DT); DT_Ptr_Type : constant Node_Id := Make_Defining_Identifier (Loc, Name_DTPT); DT_Ptr : constant Node_Id := Make_Defining_Identifier (Loc, Name_DTP); Inh_Dep : constant Node_Id := Make_Defining_Identifier (Loc, Name_uIdepth); Access_Prim : Node_Id; Desig_Type : Node_Id; Prim_Field : Node_Id; D : Node_Id; Nb_Primitives : Nat; Inheritance_Depth : Nat; Primitives_List : Elist_Id := Primitive_Operations (Tagged_Type); I_Elmt : Elmt_Id; Parent_Type : Entity_Id; New_Prim_List : List_Id := New_List; New_Tree_List : List_Id := New_List; New_Comp_List : List_Id := New_List; Prim : Entity_Id; Old_Formal : Entity_Id; New_Formal : Entity_Id; Field_Name : Name_Id; Def_Exp : Node_Id; begin -- Count the primitives and generate the corresponding access type Nb_Primitives := 0; I_Elmt := First_Elmt (Primitives_List); while (I_Elmt /= No_Elmt) loop Prim := Id_Of (I_Elmt); Nb_Primitives := Nb_Primitives + 1; -- The following code doesn't create the tree corresponding -- to the statement: -- type {Tname}___prim_ptr_XX is access {profile of prim1}; -- because of visibility problems. -- Thus, only the entities necessary are created to cause subsequent -- GNAT processing to act as if such type declaration as been done. -- This code is NOT analyzed -- Create a defining identifier for each access Access_Prim := Make_Defining_Identifier (Loc, Chars => New_External_Name (Tname, "prim_ptr", Nb_Primitives)); -- Make the identifier visible Enter_Name (Access_Prim); Desig_Type := New_Implicit_Type (Loc, Tagged_Type, "prim_ptr_", Nb_Primitives); Set_Ekind (Desig_Type, E_Subprogram_Type); if Ekind (Prim) = E_Function then Set_Etype (Desig_Type, Etype (Prim)); elsif Ekind (Prim) = E_Procedure then Set_Etype (Desig_Type, Standard_Void_Type); else Compiler_Abort; end if; -- Create a new list of parameters which is a copy of the old formal -- list including the creation of a new set of matching entities. Old_Formal := First_Formal (Prim); if Present (Old_Formal) then New_Formal := New_Copy (Old_Formal); Set_First_Entity (Desig_Type, New_Formal); Old_Formal := Next_Formal (Old_Formal); while Present (Old_Formal) loop Set_Next_Entity (New_Formal, New_Copy (Old_Formal)); New_Formal := Next_Entity (New_Formal); Old_Formal := Next_Formal (Old_Formal); end loop; end if; Set_Ekind (Access_Prim, E_Access_Subprogram_Type); Set_Etype (Access_Prim, Access_Prim); Set_Directly_Designated_Type (Access_Prim, Desig_Type); -- Create the code for the dispatch table: -- f__{N} : {Tname}___prim_ptr_N := f'access; -- where N is Nb_Primitives and 'f' is the name of the primitive if -- it is not an operator. This code is stored in a list that will be -- inserted at the end of the components list of the dispatch table. -- If f is abstract, f'access is replaced by null. if Is_Operator_Symbol_Name (Chars (Prim)) then Field_Name := New_External_Name (Name_F, "", Nb_Primitives); else Field_Name := New_External_Name (Chars (Prim), "", Nb_Primitives); end if; if Is_Abstract (Prim) then Def_Exp := Make_Null (Loc); else Def_Exp := Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Prim, Loc), Identifier => Make_Identifier (Loc, Name_Access), Expression => Empty); end if; Prim_Field := Make_Component_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Field_Name), Aliased_Present => False, Subtype_Indication => New_Reference_To (Access_Prim, Loc), Expression => Def_Exp); if Chars (Prim) = Name_uSize then Prepend_To (New_Prim_List, Prim_Field); else Append_To (New_Prim_List, Prim_Field); end if; I_Elmt := Next_Elmt (I_Elmt); end loop; -- Count ancestors to compute the inheritance depth Inheritance_Depth := 0; Parent_Type := Tagged_Type; while Parent_Type /= Etype (Parent_Type) loop Inheritance_Depth := Inheritance_Depth + 1; Parent_Type := Etype (Parent_Type); end loop; -- Generate the array of tags of ancestors: -- subtype {Tname}___TT_Type_Ind is -- Integer range 0 .. Inheritance_Depth; Append_To (New_Tree_List, Make_Subtype_Declaration (Loc, Defining_Identifier => TT_Type_Index, Subtype_Indication => Make_Subtype_Indication (Loc, Subtype_Mark => New_Reference_To (Standard_Integer, Loc), Constraint => Make_Range_Constraint (Loc, Range_Expression => Make_Range (Loc, Low_Bound => Make_Integer_Literal (Loc, Uint_0), High_Bound => Make_Integer_Literal (Loc, UI_From_Int (Int (Inheritance_Depth)))))))); -- pragma Suppress (Index_Check, {Tname}___TT_Type_Ind); Append_To (New_Tree_List, Make_Pragma (Loc, Identifier => Make_Identifier (Loc, Name_Suppress), Pragma_Argument_Associations => New_List_2 ( Make_Pragma_Argument_Association (Loc, Expression => Make_Identifier (Loc, Name_Index_Check)), Make_Pragma_Argument_Association (Loc, Expression => New_Reference_To (TT_Type_Index, Loc))))); -- type {Tname}___TT_Type is -- array ({Tname}___TT_Type_Ind) of Ada.Tags.Tag; Append_To (New_Tree_List, Make_Full_Type_Declaration (Loc, Defining_Identifier => TT_Type, Discriminant_Specifications => No_List, Type_Definition => Make_Constrained_Array_Definition (Loc, Discrete_Subtype_Definitions => New_List_1 (New_Reference_To (TT_Type_Index, Loc)), Aliased_Present => False, Subtype_Indication => New_Reference_To (RTE (RE_Tag), Loc)))); -- type {Tname}___TT_Ptr_Type is access {Tname}___TT_Type; Append_To (New_Tree_List, Make_Full_Type_Declaration (Loc, Defining_Identifier => TT_Ptr_Type, Discriminant_Specifications => No_List, Type_Definition => Make_Access_To_Object_Definition (Loc, All_Present => False, Subtype_Indication => New_Reference_To (TT_Type, Loc), Constant_Present => False))); -- {Tname}___Tag_Table : aliased {Tname}___TT_Type; Append_To (New_Tree_List, Make_Object_Declaration (Loc, Defining_Identifier => Tag_Table, Aliased_Present => True, Constant_Present => False, Object_Definition => New_Reference_To (TT_Type, Loc), Expression => Empty)); -- Generate the code for the dispatch table itself. First step is -- to create the list of components and the dispatch table type. -- First component of the record for dispatch_table: -- _Idepth : Natural := {Inheritance_Depth}; Append_To (New_Comp_List, Make_Component_Declaration (Loc, Defining_Identifier => Inh_Dep, Aliased_Present => False, Subtype_Indication => New_Reference_To (Standard_Natural, Loc), Expression => Make_Integer_Literal (Loc, UI_From_Int (Int (Inheritance_Depth))))); -- Second component of the record od the dispatch table: -- _Tags : {Tname}___TT_Ptr_Type := {Tname}___Tag_Table'access; Append_To (New_Comp_List, Make_Component_Declaration (Loc, Defining_Identifier => Tags, Aliased_Present => False, Subtype_Indication => New_Reference_To (TT_Ptr_Type, Loc), Expression => Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Tag_Table, Loc), Identifier => Make_Identifier (Loc, Name_Access), Expression => Empty))); -- Add the accesses to any primitives operations created before if not Is_Empty_List (New_Prim_List) then Append_List (New_Prim_List, New_Comp_List); end if; -- Now the list of components is complete so we create the dispatch -- table type: -- type DT_Type is record -- uIdepth : Natural := {Inheritance_Depth}; -- _Tags : {Tname}___TT_Ptr_Type := {Tname}___Tag_Table'access; -- f_1 : {Tname}___prim_ptr_1 := f'access; -- g_2 : {Tname}___prim_ptr_2 := g'access; -- ... -- h_n : {Tname}___prim_ptr_n := h'access; -- end record; Append_To (New_Tree_List, Make_Full_Type_Declaration (Loc, Defining_Identifier => DT_Type, Discriminant_Specifications => No_List, Type_Definition => Make_Record_Definition (Loc, Tagged_Present => False, Limited_Present => False, Component_List => Make_Component_List (Loc, Component_Declarations => New_Comp_List, Variant_Part => Empty, Null_Present => False)))); -- type {Tname}___DT_Ptr_Type is access {Tname}___DT_Type; Append_To (New_Tree_List, Make_Full_Type_Declaration (Loc, Defining_Identifier => DT_Ptr_Type, Discriminant_Specifications => No_List, Type_Definition => Make_Access_To_Object_Definition (Loc, All_Present => False, Subtype_Indication => New_Reference_To (DT_Type, Loc), Constant_Present => False))); -- {Tname}___Disp_Table : aliased {Tname}___DT_Type; Append_To (New_Tree_List, Make_Object_Declaration (Loc, Defining_Identifier => Dispatch_Table, Aliased_Present => True, Constant_Present => False, Object_Definition => New_Reference_To (DT_Type, Loc), Expression => Empty)); -- {Tname}___DT_Ptr : {Tname}___DT_Ptr_Type := -- {Tname}___Disp_Table'access; Append_To (New_Tree_List, Make_Object_Declaration (Loc, Defining_Identifier => DT_Ptr, Aliased_Present => False, Constant_Present => False, Object_Definition => New_Reference_To (DT_Ptr_Type, Loc), Expression => Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Dispatch_Table, Loc), Identifier => Make_Identifier (Loc, Name_Access), Expression => Empty))); -- Set Access_Disp_Table field to be the dispatch table pointer Set_Access_Disp_Table (Tagged_Type, DT_Ptr); -- Initialize the Tag_Table: -- {Tname}___Tag_Table (0) := System.Tag ({Tname}___DT_Ptr); Append_To (New_Tree_List, Make_Assignment_Statement (Loc, Name => Make_Indexed_Component (Loc, Prefix => New_Reference_To (Tag_Table, Loc), Expressions => New_List_1 ( Make_Integer_Literal (Loc, Uint_0))), Expression => Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (RTE (RE_Tag), Loc), Expression => New_Reference_To (DT_Ptr, Loc)))); Parent_Type := Etype (Tagged_Type); for I in 1 .. Inheritance_Depth loop -- {Tname}___Tag_Table (I) := {Tname}___DT_Ptr._Tags (I - 1); Append_To (New_Tree_List, Make_Assignment_Statement (Loc, Name => Make_Indexed_Component (Loc, Prefix => New_Reference_To (Tag_Table, Loc), Expressions => New_List_1 ( Make_Integer_Literal (Loc, UI_From_Int (Int (I))))), Expression => Make_Indexed_Component (Loc, Prefix => Make_Selected_Component (Loc, Prefix => New_Reference_To (Access_Disp_Table (Parent_Type), Loc), Selector_Name => Make_DT_Component (Loc, Parent_Type, 2)), Expressions => New_List_1 ( Make_Integer_Literal (Loc, UI_From_Int (Int (I) - 1)))))); end loop; D := First (New_Tree_List); while Present (D) loop Analyze (D); Install_Implicit_Types (D); D := Next (D); end loop; Append_List_To (New_Tree_List, Predefined_Primitive_Bodies (Tagged_Type)); return New_Tree_List; end Expand_Dispatch_Table; ------------------ -- Init_Formals -- ------------------ function Init_Formals (Typ : Entity_Id) return List_Id is Formals : List_Id; Loc : constant Source_Ptr := Sloc (Typ); begin -- First parameter is always _Init : in out typ. Note that we need -- this to be in/out because in the case of the task record value, -- there are default record fields (_Priority and _Size) that may be -- referenced in the generated initialization routine. Formals := New_List_1 ( Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uInit), In_Present => True, Out_Present => True, Parameter_Type => New_Reference_To (Typ, Loc))); -- For task record value, or type that contains tasks, add two more -- formals, _Master : Master_Id and _Chain : in out Activation_Chain -- We also add these parameters for the task record type case. if Has_Tasks (Typ) or else (Is_Record_Type (Typ) and then Is_Task_Record_Type (Typ)) then Append_To (Formals, Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uMaster), Parameter_Type => New_Reference_To (RTE (RE_Master_Id), Loc))); Append_To (Formals, Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uChain), In_Present => True, Out_Present => True, Parameter_Type => New_Reference_To (RTE (RE_Activation_Chain), Loc))); end if; return Formals; end Init_Formals; end Exp_Ch3; Make_Access_To_Object_Definition (Loc, All_Present => False, Subtype_Indication => New_Reference_To (TT_Tygnat-1.67-src/src/exp_ch4.adb 444 10015 7640 141645 5506244317 11174 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ C H 4 -- -- -- -- B o d y -- -- -- -- $Revision: 1.36 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Comperr; use Comperr; with Einfo; use Einfo; with Exp_Ch9; use Exp_Ch9; with Exp_Util; use Exp_Util; with Nmake; use Nmake; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Tbuild; use Tbuild; with Uintp; use Uintp; package body Exp_Ch4 is ------------------------ -- Local Subprograms -- ------------------------ procedure Expand_Comparison_Operator (N : Node_Id); -- This routine handles expansion of the comparison operators (N_Op_Lt, -- N_Op_Le, N_Op_Gt, N_Op_Ge). Since the code is basicallly similar with -- the addition of some outer function Make_Array_Comparison_Op (Typ : Entity_Id; Loc : Source_Ptr; Equal : Boolean) return Node_Id; -- Comparisons between arrays are expanded in line. This function -- produces the body of the implementation of (a > b), or (a >= b), when -- a and b are one-dimensional arrays of some discrete type. The original -- node is then expanded into the appropriate call to this function. function Make_Boolean_Array_Op (N : Node_Id) return Node_Id; -- Boolean operations on boolean arrays are expanded in line. This -- function produce the body for (a and b), (a or b), or (a xor b). function Tagged_Membership (N : Node_Id) return Node_Id; -- Construct the expression corresponding to the tagged membership test. -- Deals with a second operand being (or not) a class-wide type. -------------------------------- -- Expand_Comparison_Operator -- -------------------------------- -- Expansion is only required in the case of array types. The form of -- the expansion is: -- [body for greater_nn; boolean_expression] -- The body is built by Make_Array_Comparison_Op, and the form of the -- Boolean expression depends on the operator involved. procedure Expand_Comparison_Operator (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Op1 : Node_Id := Left_Opnd (N); Op2 : Node_Id := Right_Opnd (N); Typ : constant Node_Id := Etype (Op1); Result : Node_Id; Expr : Node_Id; Func_Body : Node_Id; Func_Name : Entity_Id; begin if Is_Array_Type (Typ) then -- For <= the Boolean expression is -- greater__nn (op2, op1, true) if Chars (N) = Name_Op_Le then Func_Body := Make_Array_Comparison_Op (Typ, Loc, True); Op1 := Right_Opnd (N); Op2 := Left_Opnd (N); -- For < the Boolean expression is -- greater__nn (op2, op1) elsif Chars (N) = Name_Op_Lt then Func_Body := Make_Array_Comparison_Op (Typ, Loc, False); Op1 := Right_Opnd (N); Op2 := Left_Opnd (N); -- For >= the Boolean expression is -- op1 = op2 or else greater__nn (op1, op2) elsif Chars (N) = Name_Op_Ge then Func_Body := Make_Array_Comparison_Op (Typ, Loc, True); -- For > the Boolean expression is -- greater__nn (op1, op2) elsif Chars (N) = Name_Op_Gt then Func_Body := Make_Array_Comparison_Op (Typ, Loc, False); else return; end if; Func_Name := Defining_Unit_Name (Specification (Func_Body)); Expr := Make_Function_Call (Loc, Name => New_Reference_To (Func_Name, Loc), Parameter_Associations => New_List_2 (Op1, Op2)); Result := Make_Expression_Actions (Loc, Actions => New_List_1 (Func_Body), Expression => Expr); Analyze (Result); Resolve_Subexpr (Result, Standard_Boolean); Rewrite_Substitute_Tree (N, Result); end if; end Expand_Comparison_Operator; ------------------------ -- Expand_N_Allocator -- ------------------------ -- If the allocator is for a type which requires initialization, and -- there is no initial value (i.e. the operand is a subtype indication -- rather than a qualifed expression), then we must generate a call to -- the initialization routine. This is done using an expression actions -- node: -- -- [Temp : constant ptr_T := new (T); Init (Temp.all,...); Temp] -- -- Here ptr_T is the pointer type for the allocator, and T is the -- subtype of the allocator. A special case arises if the designated -- type of the access type is a task or contains tasks. In this case -- the call to Init (Temp.all ...) is replaced by code that ensures -- that the tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block -- for details). In addition, if the type T is a task T, then the first -- argument to Init must be converted to the task record type. procedure Expand_N_Allocator (N : Node_Id) is begin -- Nothing to do if we have a qualified expression (i.e. the allocator -- has an initial value, so the initialization routine is not needed) if Nkind (Expression (N)) = N_Qualified_Expression then null; -- Else this is the case that may need an initialization routine else declare PtrT : constant Entity_Id := Etype (N); T : constant Entity_Id := Entity (Expression (N)); Init : constant Entity_Id := Base_Init_Proc (T); Loc : constant Source_Ptr := Sloc (N); Temp : Entity_Id; Arg1 : Node_Id; Args : List_Id; Discr : Elmt_Id; Node : Node_Id := N; Eact : Node_Id; begin -- Nothing to do if no initialization routine required if No (Init) then null; -- Else we have the case that definitely needs a call else Temp := Make_Defining_Identifier (Loc, New_Internal_Name ("temp")); -- Construct argument list for the initialization routine call Arg1 := Make_Explicit_Dereference (Loc, Prefix => New_Reference_To (Temp, Loc)); -- The initialization procedure expects a specific type. -- if the context is access to classwide, indicate that -- the object being allocated has the right specific type. if Is_Class_Type (Designated_Type (PtrT)) then Arg1 := Make_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (T, Loc), Expression => Arg1); end if; -- If designated type is a task type, then the first argument -- in the Init routine has to be unchecked converted to the -- corresponding record type, since that's what Init expects. if Is_Task_Type (T) then Arg1 := Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (Task_Value_Type (T), Loc), Expression => Arg1); end if; Args := New_List_1 (Arg1); -- For the task case, pass the Master_Id of the access type -- as the value of the _Master parameter, and _Chain as the -- value of the _Chain parameter (_Chain will be defined as -- part of the generated code for the allocator). if Has_Tasks (T) then Append_To (Args, New_Reference_To (Master_Id (PtrT), Loc)); Append_To (Args, Make_Identifier (Loc, Name_uChain)); end if; -- Add discriminants if discriminated type if Has_Discriminants (T) then Discr := First_Elmt (Discriminant_Constraint (T)); while Discr /= No_Elmt loop Append (New_Copy (Id_Of (Discr)), Args); Discr := Next_Elmt (Discr); end loop; end if; -- We set the allocator as analyzed so that when we analyze the -- expression actions node, we do not get an unwanted recursive -- expansion of the allocator expression. Set_Analyzed (N, True); -- Now we can rewrite the allocator. First see if it is -- already in an expression actions node, which will often -- be the case, because this is how we handle the case of -- discriminants being present. If so, we can just modify -- that expression actions node that is there, otherwise -- we must create an expression actions node. Eact := Parent (N); if Nkind (Eact) = N_Expression_Actions and then Expression (Eact) = N then null; else Rewrite_Substitute_Tree (N, Make_Expression_Actions (Loc, Actions => New_List, Expression => New_Copy (N))); Eact := N; Node := Expression (N); end if; -- Now we modify the expression actions node as follows -- input: [... ; new T] -- output: [... ; -- Temp : constant ptr_T := new (T); -- Init (Temp.all, ...); -- Temp] -- Here ptr_T is the pointer type for the allocator, and T -- is the subtype of the allocator. Append_To (Actions (Eact), Make_Object_Declaration (Loc, Defining_Identifier => Temp, Constant_Present => True, Object_Definition => New_Reference_To (PtrT, Loc), Expression => New_Copy (Node))); -- Case of designated type is task or contains task if Has_Tasks (T) then Build_Task_Allocate_Block (Actions (Eact), N, Args); else Append_To (Actions (Eact), Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (Init, Loc), Parameter_Associations => Args)); end if; Set_Expression (Eact, New_Reference_To (Temp, Loc)); Analyze (Eact); end if; end; end if; end Expand_N_Allocator; ----------------------------- -- Expand_Boolean_Operator -- ----------------------------- procedure Expand_Boolean_Operator (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Typ : constant Entity_Id := Etype (N); Result : Node_Id; Func_Body : Node_Id; Func_Name : Entity_Id; begin if Is_Array_Type (Typ) then Func_Body := Make_Boolean_Array_Op (N); Func_Name := Defining_Unit_Name (Specification (Func_Body)); Result := Make_Expression_Actions (Loc, Actions => New_List_1 (Func_Body), Expression => Make_Function_Call (Loc, Name => New_Reference_To (Func_Name, Loc), Parameter_Associations => New_List_2 (Left_Opnd (N), Right_Opnd (N)))); Analyze (Result); Resolve_Subexpr (Result, Typ); Rewrite_Substitute_Tree (N, Result); end if; end Expand_Boolean_Operator; --------------------- -- Expand_N_Op_And -- --------------------- -- This is really just a renaming of Expand_Boolean_Operator ??? procedure Expand_N_Op_And (N : Node_Id) is begin Expand_Boolean_Operator (N); end Expand_N_Op_And; -------------------- -- Expand_N_Op_Eq -- -------------------- procedure Expand_N_Op_Eq (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Lhs : constant Node_Id := Left_Opnd (N); Rhs : constant Node_Id := Right_Opnd (N); Typ : Entity_Id := Etype (Lhs); Eq_Prim : Entity_Id; begin if Ekind (Typ) = E_Private_Type then Typ := Full_Declaration (Typ); end if; if Is_Array_Type (Typ) then if Is_Scalar_Type (Component_Type (Typ)) then -- This case is left to Gigi optimization purposes null; else Rewrite_Substitute_Tree (N, Expand_Array_Equality (Loc, Typ, New_Copy (Lhs), New_Copy (Rhs))); Analyze (N); Resolve_Subexpr (N, Standard_Boolean); end if; elsif Is_Record_Type (Typ) then if Has_Discriminants (Typ) and then Present (Variant_Part (Component_List ( Type_Definition (Parent (Base_Type (Typ)))))) then -- ??? -- in this case a function has to be expanded and called using -- the same model as for initialization procedures (use of -- the case statement in the record definition). -- It has to be dealt with as a apecial case because in the -- simple case (record without variant part), we prefer to -- generate a big expression which will be optimized by the -- back-end. Unimplemented (N, "?complex equality of discriminated records"); else declare L : Node_Id := New_Copy (Lhs); R : Node_Id := New_Copy (Rhs); begin -- ??? L and R should be marked evaluate_once because the -- equality is expanded into a bunch of component equailities -- but in this case this flag seems to cause big trouble in -- the generatyed code, so it is commented out till further -- investigation. -- Set_Evaluate_Once (L, True); -- Set_Evaluate_Once (R, True); Rewrite_Substitute_Tree (N, Expand_Record_Equality (Loc, Typ, L, R)); Analyze (N); Resolve_Subexpr (N, Standard_Boolean); end; end if; end if; end Expand_N_Op_Eq; ----------------------- -- Expand_N_Op_Expon -- ----------------------- procedure Expand_N_Op_Expon (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Typ : constant Entity_Id := Etype (N); Btyp : constant Entity_Id := Root_Type (Typ); Max : constant Uint := Uint_4; Min : constant Uint := Uint_Minus_4; Base : constant Node_Id := New_Copy (Left_Opnd (N)); Exp : constant Node_Id := New_Copy (Right_Opnd (N)); Expv : Uint; Xnode : Node_Id; Temp : Node_Id; Rent : RE_Id; begin -- Evaluate our arguments, so that we can test for static case Static_Evaluation (Base); Static_Evaluation (Exp); -- Do nothing if both our operands are static. The result will be -- folded at a higher level (or at least it jolly well ought to be) if Is_Static (Base) and then Is_Static (Exp) then return; end if; -- Test for case of literal right argument if Nkind (Exp) = N_Integer_Literal then Expv := Intval (Exp); if (Ekind (Typ) in Float_Kind and then UI_Ge (Expv, Min) and then UI_Le (Expv, Max)) or else (Ekind (Typ) in Integer_Kind and then UI_Ge (Expv, Uint_0) and then UI_Le (Expv, Max)) then Expv := UI_Abs (Expv); -- X ** 0 = 1 (or 1.0) if Expv = Uint_0 then if Ekind (Typ) in Integer_Kind then Xnode := Make_Integer_Literal (Loc, Intval => Uint_1); else Xnode := Make_Real_Literal (Loc, Numerator => Uint_1, Denominator => Uint_1); end if; -- X ** 1 = X elsif Expv = Uint_1 then Xnode := Base; -- X ** 2 = X * X elsif Expv = Uint_2 then Set_Evaluate_Once (Base, True); Xnode := Make_Op_Multiply (Loc, Left_Opnd => Base, Right_Opnd => Base); -- X ** 3 = (X * X) * X elsif Expv = Uint_3 then Set_Evaluate_Once (Base, True); Xnode := Make_Op_Multiply (Loc, Left_Opnd => Make_Op_Multiply (Loc, Left_Opnd => Base, Right_Opnd => Base, Parens => True), Right_Opnd => Base); -- X ** 4 = {temp : constant base'type := base * base} temp * temp elsif Expv = Uint_4 then Set_Evaluate_Once (Base, True); Temp := Make_Defining_Identifier (Loc, New_Internal_Name ("tmp")); Xnode := Make_Expression_Actions (Loc, Actions => New_List_1 ( Make_Object_Declaration (Loc, Defining_Identifier => Temp, Constant_Present => True, Object_Definition => New_Reference_To (Typ, Loc), Expression => Make_Op_Multiply (Loc, Left_Opnd => Base, Right_Opnd => Base))), Expression => Make_Op_Multiply (Loc, Left_Opnd => New_Reference_To (Temp, Loc), Right_Opnd => New_Reference_To (Temp, Loc))); end if; -- For non-negative case, we are all set if not UI_Is_Negative (Intval (Exp)) then Rewrite_Substitute_Tree (N, Xnode); -- For negative cases, take reciprocal (base must be real) else Set_Parens (Xnode, True); Rewrite_Substitute_Tree (N, Make_Op_Divide (Loc, Left_Opnd => Make_Real_Literal (Loc, Numerator => Uint_1, Denominator => Uint_1), Right_Opnd => Xnode)); end if; Analyze (N); Resolve_Subexpr (N, Typ); return; -- Don't fold cases of large literal exponents, and also don't fold -- cases of integer bases with negative literal exponents. end if; -- Don't fold cases where exponent is not integer literal end if; -- Fall through if exponentiation must be done using a runtime routine if Btyp = Standard_Integer then Rent := RE_Xp_I; elsif Btyp = Standard_Short_Integer then Rent := RE_Xp_SI; elsif Btyp = Standard_Short_Short_Integer then Rent := RE_Xp_SSI; elsif Btyp = Standard_Long_Integer then Rent := RE_Xp_LI; elsif Btyp = Standard_Long_Long_Integer then Rent := RE_Xp_LLI; elsif Btyp = Standard_Float then Rent := RE_Xp_F; elsif Btyp = Standard_Short_Float then Rent := RE_Xp_SF; elsif Btyp = Standard_Long_Float then Rent := RE_Xp_LF; elsif Btyp = Standard_Long_Long_Float then Rent := RE_Xp_LLF; else Compiler_Error; Write_Entity_Info (Typ, "Typ ->"); Write_Entity_Info (Btyp, "Btyp ->"); Compiler_Abort; end if; -- If we are in base type, we can call runtime routine directly if Typ = Btyp then Rewrite_Substitute_Tree (N, Make_Function_Call (Loc, Name => New_Reference_To (RTE (Rent), Loc), Parameter_Associations => New_List_2 (Base, Exp))); -- Otherwise we have to introduce conversions else Rewrite_Substitute_Tree (N, Make_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (Typ, Loc), Expression => Make_Function_Call (Loc, Name => New_Reference_To (RTE (Rent), Loc), Parameter_Associations => New_List_2 ( Make_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (Btyp, Loc), Expression => Base), Exp)))); end if; Analyze (N); Resolve_Subexpr (N, Typ); return; end Expand_N_Op_Expon; -------------------- -- Expand_N_Op_Ge -- -------------------- -- This should be a body renaming if this worked ??? procedure Expand_N_Op_Ge (N : Node_Id) is begin Expand_Comparison_Operator (N); end Expand_N_Op_Ge; -------------------- -- Expand_N_Op_Gt -- -------------------- -- This should be a body renaming if this worked ??? procedure Expand_N_Op_Gt (N : Node_Id) is begin Expand_Comparison_Operator (N); end Expand_N_Op_Gt; -------------------- -- Expand_N_Op_In -- -------------------- -- Expansion is only required for the tagged case. See specification of -- Tagged_Membership function for details of required transformation. procedure Expand_N_Op_In (N : Node_Id) is Typ : constant Entity_Id := Etype (N); begin if Is_Tagged_Type (Etype (Etype (Right_Opnd (N)))) then Rewrite_Substitute_Tree (N, Tagged_Membership (N)); Analyze (N); Resolve_Subexpr (N, Typ); end if; end Expand_N_Op_In; -------------------- -- Expand_N_Op_Le -- -------------------- -- This should be a body renaming if this worked ??? procedure Expand_N_Op_Le (N : Node_Id) is begin Expand_Comparison_Operator (N); end Expand_N_Op_Le; -------------------- -- Expand_N_Op_Lt -- -------------------- -- This should be a body renaming if this worked ??? procedure Expand_N_Op_Lt (N : Node_Id) is begin Expand_Comparison_Operator (N); end Expand_N_Op_Lt; --------------------- -- Expand_N_Op_Not -- --------------------- procedure Expand_N_Op_Not (N : Node_Id) is -- If the argument of negation is a boolean array type, expand -- in line the following: -- function not_ (a: arr) is -- b : arr; -- begin -- for i in a'range loop -- b (i) := not a(i); -- end loop; -- return b; -- end not_; Loc : Source_Ptr := Sloc (N); A : Entity_Id := Make_Defining_Identifier (Loc, New_Internal_Name ("A")); B : Entity_Id := Make_Defining_Identifier (Loc, New_Internal_Name ("B")); I : Entity_Id := Make_Defining_Identifier (Loc, New_Internal_Name ("I")); A_I : Node_Id; B_I : Node_Id; Typ : constant Entity_Id := Etype (N); Func_Name : Entity_Id; Func_Body : Node_Id; Loop_Statement : Node_Id; Result : Node_Id; begin if not Is_Array_Type (Typ) then return; end if; A_I := Make_Indexed_Component (Loc, Prefix => Make_Identifier (Loc, Chars (A)), Expressions => New_List_1 ( Make_Identifier (Loc, Chars (I)))); B_I := Make_Indexed_Component (Loc, Prefix => Make_Identifier (Loc, Chars (B)), Expressions => New_List_1 ( Make_Identifier (Loc, Chars (I)))); Loop_Statement := Make_Loop_Statement (Loc, Identifier => Empty, Iteration_Scheme => Make_Iteration_Scheme (Loc, Loop_Parameter_Specification => Make_Loop_Parameter_Specification (Loc, Defining_Identifier => I, Discrete_Subtype_Definition => Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Chars (A)), Identifier => Make_Identifier (Loc, Name_Range)))), Statements => New_List_1 ( Make_Assignment_Statement (Loc, Name => B_I, Expression => Make_Op_Not (Loc, Right_Opnd => A_I)))); Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ("Not")); Func_Body := Make_Subprogram_Body (Loc, Specification => Make_Function_Specification (Loc, Defining_Unit_Name => Func_Name, Parameter_Specifications => New_List_1 ( Make_Parameter_Specification (Loc, Defining_Identifier => A, Parameter_Type => New_Reference_To (Typ, Loc))), Subtype_Mark => New_Reference_To (Typ, Loc)), Declarations => New_List_1 ( Make_Object_Declaration (Loc, Defining_Identifier => B, Object_Definition => New_Reference_To (Typ, Loc))), Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List_2 ( Loop_Statement, Make_Return_Statement (Loc, Expression => Make_Identifier (Loc, Chars (B)))))); Result := Make_Expression_Actions (Loc, Actions => New_List_1 (Func_Body), Expression => Make_Function_Call (Loc, Name => New_Reference_To (Func_Name, Loc), Parameter_Associations => New_List_1 (Right_Opnd (N)))); Analyze (Result); Resolve_Subexpr (Result, Typ); Rewrite_Substitute_Tree (N, Result); end Expand_N_Op_Not; ------------------------ -- Expand_N_Op_Not_In -- ------------------------ -- Expansion is only required for the tagged case. See specification of -- Tagged_Membership function for details of required transformation. procedure Expand_N_Op_Not_In (N : Node_Id) is Typ : constant Entity_Id := Etype (N); begin if Is_Tagged_Type (Etype (Etype (Right_Opnd (N)))) then Rewrite_Substitute_Tree (N, Make_Op_Not (Sloc (N), Tagged_Membership (N))); Analyze (N); Resolve_Subexpr (N, Typ); end if; end Expand_N_Op_Not_In; -------------------- -- Expand_N_Op_Or -- -------------------- procedure Expand_N_Op_Or (N : Node_Id) is -- renames Expand_Boolean_Operator; begin Expand_Boolean_Operator (N); end Expand_N_Op_Or; --------------------- -- Expand_N_Op_Xor -- --------------------- procedure Expand_N_Op_Xor (N : Node_Id) is -- renames Expand_Boolean_Operator; begin Expand_Boolean_Operator (N); end Expand_N_Op_Xor; --------------------------------------- -- Expand_N_Parenthesized_Expression -- --------------------------------------- -- We remove these from the tree, since they make tests higher up in -- the tree in expand more complicated, and it is easier if we just -- get rid of them, since they serve no code generation purpose. procedure Expand_N_Parenthesized_Expression (N : Node_Id) is begin Rewrite_Substitute_Tree (N, Expression (N)); end Expand_N_Parenthesized_Expression; -------------------- -- Expand_N_Slice -- -------------------- -- Build an implicit subtype declaration to represent the type delivered -- by the slice. This subtype has an Ekind of E_Slice_Subtype, which is -- a special kind of type used just for this purpose. Logically, what is -- needed is a full array subtype declaration, but that would take a lot -- of nodes. On the other hand if we don't provide any kind of subtype -- for the slice, Gigi gets really confused. The compromise of building -- a special kind of very economical subtype declaration node, and then -- putting a bit of specialized code in Gigi to deal with this special -- declaration meets the need with minimum overhead. -- The procesing consists of building this subtype and then resetting the -- Etype of the slice node to have this type. procedure Expand_N_Slice (N : Node_Id) is Impl_Subtype : Entity_Id; begin -- First we build a defining occurrence for the "slice subtype" Impl_Subtype := New_Implicit_Type (Sloc (N)); Set_Ekind (Impl_Subtype, E_Slice_Subtype); Set_Component_Type (Impl_Subtype, Component_Type (Etype (N))); Set_Slice_Range (Impl_Subtype, Discrete_Range (N)); Set_Etype (Impl_Subtype, Etype (N)); -- The Etype of the existing Slice node is reset to this anymous -- subtype. This node will be marked as Analyzed when we return and -- nothing else needs to be done to it. Set_Etype (N, Impl_Subtype); end Expand_N_Slice; ------------------------------ -- Make_Array_Comparison_Op -- ------------------------------ -- This is a hand-coded expansion of the following generic function: -- generic -- type elem is (<>); -- type index is (<>); -- type a is array (index range <>) of elem; -- -- function greater__nn (X : a; Y: a) return boolean is -- J : index :=Y'first; -- -- begin -- if X'length = 0 then -- return false; -- -- elsif Y'length = 0 then -- return true; -- -- else -- for I in X'range loop -- if X (I) = Y (J) then -- if J = Y'last then -- exit; -- else -- J := index'succ (J); -- end if; -- -- else -- return X (I) > Y (J); -- end if; -- end loop; -- -- return X'length > Y'length; -- end if; -- end greater__nn; -- If the flag Equal is true, the procedure generates the body for -- >= instead. This only affects the last return statement. -- Note that since we are essentially doing this expansion by hand, we -- do not need to generate an actual or formal generic part, just the -- instantiated function itself. function Make_Array_Comparison_Op (Typ : Entity_Id; Loc : Source_Ptr; Equal : Boolean) return Node_Id is X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_X); Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_Y); I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_I); J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_J); Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ))); Loop_Statement : Node_Id; Loop_Body : Node_Id; If_Stat : Node_Id; Inner_If : Node_Id; Final_Expr : Node_Id; Func_Body : Node_Id; Func_Name : Entity_Id; Formals : List_Id; Length1 : Node_Id; Length2 : Node_Id; begin -- if J = Y'last then -- exit; -- else -- J := index'succ (J); -- end if; Inner_If := Make_If_Statement (Loc, Condition => Make_Op_Eq (Loc, Left_Opnd => Make_Identifier (Loc, Chars (J)), Right_Opnd => Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Chars (Y)), Identifier => Make_Identifier (Loc, Name_Last))), Then_Statements => New_List_1 ( Make_Exit_Statement (Loc)), Else_Statements => New_List_1 ( Make_Assignment_Statement (Loc, Name => Make_Identifier (Loc, Chars (J)), Expression => Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Index, Loc), Identifier => Make_Identifier (Loc, Name_Succ), Expression => Make_Identifier (Loc, Chars (J)))))); -- if X (I) = Y (J) then -- if ... end if; -- else -- return X (I) > Y (J); -- end if; Loop_Body := Make_If_Statement (Loc, Condition => Make_Op_Eq (Loc, Left_Opnd => Make_Indexed_Component (Loc, Prefix => Make_Identifier (Loc, Chars (X)), Expressions => New_List_1 ( Make_Identifier (Loc, Chars (I)))), Right_Opnd => Make_Indexed_Component (Loc, Prefix => Make_Identifier (Loc, Chars (Y)), Expressions => New_List_1 ( Make_Identifier (Loc, Chars (J))))), Then_Statements => New_List_1 (Inner_If), Else_Statements => New_List_1 ( Make_Return_Statement (Loc, Expression => Make_Op_Gt (Loc, Left_Opnd => Make_Indexed_Component (Loc, Prefix => Make_Identifier (Loc, Chars (X)), Expressions => New_List_1 ( Make_Identifier (Loc, Chars (I)))), Right_Opnd => Make_Indexed_Component (Loc, Prefix => Make_Identifier (Loc, Chars (Y)), Expressions => New_List_1 ( Make_Identifier (Loc, Chars (J)))))))); -- for I in X'range loop -- if ... end if; -- end loop; Loop_Statement := Make_Loop_Statement (Loc, Identifier => Empty, Iteration_Scheme => Make_Iteration_Scheme (Loc, Loop_Parameter_Specification => Make_Loop_Parameter_Specification (Loc, Defining_Identifier => I, Discrete_Subtype_Definition => Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Chars (X)), Identifier => Make_Identifier (Loc, Name_Range)))), Statements => New_List_1 (Loop_Body)); -- if X'length = 0 then -- return false; -- elsif Y'length = 0 then -- return true; -- else -- for ... loop ... end loop; -- return X'length > Y'length; -- -- return X'length >= Y'length to implement >=. -- end if; Length1 := Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Chars (X)), Identifier => Make_Identifier (Loc, Name_Length)); Length2 := Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Chars (Y)), Identifier => Make_Identifier (Loc, Name_Length)); if Equal then Final_Expr := Make_Op_Ge (Loc, Left_Opnd => Length1, Right_Opnd => Length2); else Final_Expr := Make_Op_Gt (Loc, Left_Opnd => Length1, Right_Opnd => Length2); end if; If_Stat := Make_If_Statement (Loc, Condition => Make_Op_Eq (Loc, Left_Opnd => Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Chars (X)), Identifier => Make_Identifier (Loc, Name_Length)), Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), Then_Statements => New_List_1 ( Make_Return_Statement (Loc, Expression => New_Reference_To (Standard_False, Loc))), Elsif_Parts => New_List_1 ( Make_If_Statement (Loc, Condition => Make_Op_Eq (Loc, Left_Opnd => Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Chars (Y)), Identifier => Make_Identifier (Loc, Name_Length)), Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), Then_Statements => New_List_1 ( Make_Return_Statement (Loc, Expression => New_Reference_To (Standard_True, Loc))))), Else_Statements => New_List_2 ( Loop_Statement, Make_Return_Statement (Loc, Expression => Final_Expr))); -- (X : a; Y: a) Formals := New_List_2 ( Make_Parameter_Specification (Loc, Defining_Identifier => X, Parameter_Type => New_Reference_To (Typ, Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => Y, Parameter_Type => New_Reference_To (Typ, Loc))); -- function greater (...) return boolean is -- J : index :=Y'first; -- begin -- if ... end if; -- end greater; if Equal then Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ("Ge")); else Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ("Gt")); end if; Func_Body := Make_Subprogram_Body (Loc, Specification => Make_Function_Specification (Loc, Defining_Unit_Name => Func_Name, Parameter_Specifications => Formals, Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)), Declarations => New_List_1 ( Make_Object_Declaration (Loc, Defining_Identifier => J, Object_Definition => New_Reference_To (Index, Loc), Expression => Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Chars (Y)), Identifier => Make_Identifier (Loc, Name_First)))), Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List_1 (If_Stat))); return Func_Body; end Make_Array_Comparison_Op; --------------------------- -- Make_Boolean_Array_Op -- --------------------------- -- For logical operations on boolean arrays, expand in line the -- following, replacing 'and' with 'or' or 'xor' where needed: -- function and___nn (a : arr; b: arr) is -- c : arr; -- begin -- for i in a'range loop -- c (i) := a(i) and b(i); -- end loop; -- return c; -- end and___nn; function Make_Boolean_Array_Op (N : Node_Id) return Node_Id is Loc : Source_Ptr := Sloc (N); Typ : Entity_Id := Etype (Left_Opnd (N)); A : Entity_Id := Make_Defining_Identifier (Loc, New_Internal_Name ("A")); B : Entity_Id := Make_Defining_Identifier (Loc, New_Internal_Name ("B")); C : Entity_Id := Make_Defining_Identifier (Loc, New_Internal_Name ("C")); I : Entity_Id := Make_Defining_Identifier (Loc, New_Internal_Name ("I")); A_I : Node_Id; B_I : Node_Id; C_I : Node_Id; Op : Node_Id; Formals : List_Id; Func_Name : Entity_Id; Func_Body : Node_Id; Loop_Statement : Node_Id; begin A_I := Make_Indexed_Component (Loc, Prefix => Make_Identifier (Loc, Chars (A)), Expressions => New_List_1 ( Make_Identifier (Loc, Chars (I)))); B_I := Make_Indexed_Component (Loc, Prefix => Make_Identifier (Loc, Chars (B)), Expressions => New_List_1 ( Make_Identifier (Loc, Chars (I)))); if Nkind (N) = N_Op_And then Op := Make_Op_And (Loc, Left_Opnd => A_I, Right_Opnd => B_I); elsif Nkind (N) = N_Op_Or then Op := Make_Op_Or (Loc, Left_Opnd => A_I, Right_Opnd => B_I); else Op := Make_Op_Xor (Loc, Left_Opnd => A_I, Right_Opnd => B_I); end if; Loop_Statement := Make_Loop_Statement (Loc, Identifier => Empty, Iteration_Scheme => Make_Iteration_Scheme (Loc, Loop_Parameter_Specification => Make_Loop_Parameter_Specification (Loc, Defining_Identifier => I, Discrete_Subtype_Definition => Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Chars (A)), Identifier => Make_Identifier (Loc, Name_Range)))), Statements => New_List_1 ( Make_Assignment_Statement (Loc, Name => Make_Indexed_Component (Loc, Prefix => Make_Identifier (Loc, Chars (C)), Expressions => New_List_1 ( Make_Identifier (Loc, Chars (I)))), Expression => Op))); Formals := New_List_2 ( Make_Parameter_Specification (Loc, Defining_Identifier => A, Parameter_Type => New_Reference_To (Typ, Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => B, Parameter_Type => New_Reference_To (Typ, Loc))); if Nkind (N) = N_Op_And then Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ("And")); elsif Nkind (N) = N_Op_Or then Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ("Or")); else Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ("Xor")); end if; Func_Body := Make_Subprogram_Body (Loc, Specification => Make_Function_Specification (Loc, Defining_Unit_Name => Func_Name, Parameter_Specifications => Formals, Subtype_Mark => New_Reference_To (Typ, Loc)), Declarations => New_List_1 ( Make_Object_Declaration (Loc, Defining_Identifier => C, Object_Definition => New_Reference_To (Typ, Loc))), Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List_2 ( Loop_Statement, Make_Return_Statement (Loc, Expression => Make_Identifier (Loc, Chars (C)))))); return Func_Body; end Make_Boolean_Array_Op; ------------------------ -- Tagged_Membership -- ------------------------ -- There are two different cases to consider depending on whether -- the right operand is a class-wide type or not. If not we just -- compare the actual tag of the left expr to the target type tag: -- -- Left_Expr.Tag = Tag_Of (Right_Type); -- -- If it is a class-wide type, it is more complex. We use the table of -- ancestors accessed by the "Tags" field of the Dispatch table. We have -- to ensure that the inheritance depth of the operand if greater or equal -- than the target types's and that they are on the inheritance path : -- -- -- N : Integer := Left_Expr.Tag.all.Inheritance_Depth - -- Tag_Of (Right_Type).all.Inheritance_Depth; -- -- (N >= 0) -- and then Left_Expr.Tag.all.Tags.all (N) = Tag_Of (Right_Type) -- -- the real expressions are a bit more complicated due to type conversions function Tagged_Membership (N : Node_Id) return Node_Id is Left : constant Node_Id := Left_Opnd (N); Right : constant Node_Id := Right_Opnd (N); Sloc_N : constant Source_Ptr := Sloc (N); Left_Type : Entity_Id; Right_Type : Entity_Id; Var_N : Node_Id; begin Left_Type := Etype (Left); Right_Type := Etype (Right); if Is_Class_Type (Left_Type) then Left_Type := Etype (Left_Type); end if; if not Is_Class_Type (Right_Type) then -- Left_Type (Left)._Tag = -- System.Tag (Access_Disp_Table (Right_Type)); return Make_Op_Eq (Sloc_N, Left_Opnd => Make_Selected_Component (Sloc_N, Prefix => Make_Unchecked_Type_Conversion (Sloc_N, Subtype_Mark => New_Reference_To (Left_Type, Sloc_N), Expression => New_Copy (Left)), Selector_Name => New_Reference_To (Tag_Component (Left_Type), Sloc_N)), Right_Opnd => Make_Unchecked_Type_Conversion (Sloc_N, Subtype_Mark => New_Reference_To (RTE (RE_Tag), Sloc_N), Expression => New_Reference_To ( Access_Disp_Table (Right_Type), Sloc_N))); else -- Replace N by expression-actions -- -- -- N : Integer := -- Acc_Dt (Left_Type(Left)._Tag).all.Inheritance_Depth -- - Access_Disp_Table (Right_Type).all.Inheritance_Depth; Var_N := Make_Defining_Identifier (Sloc_N, New_Internal_Name ("n")); -- Use the root type of the class Right_Type := Etype (Right_Type); return Make_Expression_Actions (Sloc_N, Actions => New_List_1 ( Make_Object_Declaration (Sloc_N, Defining_Identifier => Var_N, Object_Definition => New_Reference_To (Standard_Integer, Sloc_N), Expression => Make_Op_Subtract (Sloc_N, Left_Opnd => Make_Selected_Component (Sloc_N, Prefix => Make_DT_Access (Sloc_N, Left, Left_Type), Selector_Name => Make_DT_Component (Sloc_N, Left_Type, 1)), Right_Opnd => Make_Selected_Component (Sloc_N, Prefix => Make_Explicit_Dereference (Sloc_N, Prefix => Make_Identifier (Sloc_N, Chars (Access_Disp_Table (Right_Type)))), Selector_Name => Make_DT_Component (Sloc_N, Right_Type, 1))))), -- (N >= 0) -- and then -- (Acc_Dt (Left_Type (Left).__Tag).all.Tags.all (N) -- = System.Tag (Access_Disp_Table (Right_Type))) Expression => Make_Op_And_Then (Sloc_N, Left_Opnd => Make_Op_Ge (Sloc_N, Left_Opnd => New_Reference_To (Var_N, Sloc_N), Right_Opnd => Make_Integer_Literal (Sloc_N, Uint_0)), Right_Opnd => Make_Op_Eq (Sloc_N, Left_Opnd => Make_Indexed_Component (Sloc_N, Prefix => Make_Explicit_Dereference (Sloc_N, Prefix => Make_Selected_Component (Sloc_N, Prefix => Make_DT_Access (Sloc_N, Left, Left_Type), Selector_Name => Make_DT_Component (Sloc_N, Left_Type, 2))), Expressions => New_List_1 (New_Reference_To (Var_N, Sloc_N))), Right_Opnd => Make_Unchecked_Type_Conversion (Sloc_N, Subtype_Mark => New_Reference_To (RTE (RE_Tag), Sloc_N), Expression => New_Reference_To ( Access_Disp_Table (Right_Type), Sloc_N))))); end if; end Tagged_Membership; end Exp_Ch4; _I); elsif Nkind (N) = N_Op_Or then Op := Make_Op_Or (Loc, Left_Opnd => A_Ignat-1.67-src/src/exp_ch5.ads 444 10015 7640 4174 5506244317 11151 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ C H 5 -- -- -- -- S p e c -- -- -- -- $Revision: 1.5 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Expand routines for chapter 5 constructs with Types; use Types; package Exp_Ch5 is procedure Expand_N_Assignment_Statement (N : Node_Id); procedure Expand_N_Block_Statement (N : Node_Id); procedure Expand_N_Case_Statement (N : Node_Id); procedure Expand_N_If_Statement (N : Node_Id); end Exp_Ch5; иñ sem_ch6.adb ä¸ò sem_ch7.ads ø¸ó sem_ch7.adb ¸ô sem_ch8.ads ¸õ sem_ch8.adb 4¸ö sem_ch9.ads H¸÷ sem_ch9.adb `¸ø sem_eval.ads€ x¸ù sem_eval.adb@ ¸ú sem_prag.ads ¨¸û sem_prag.adb À¸ü sem_util.ads Ô¸ý sem_res.adb è¸þ sem_res.ads ¸ÿ sem_util.adb  gnat-1.67-src/src/exp_ch6.adb 444 10015 7640 45732 5506244320 11150 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ C H 6 -- -- -- -- B o d y -- -- -- -- $Revision: 1.29 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Comperr; use Comperr; with Debug; use Debug; with Einfo; use Einfo; with Errout; use Errout; with Exp_Ch9; use Exp_Ch9; with Exp_Util; use Exp_Util; with Nmake; use Nmake; with Opt; use Opt; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Ch3; use Sem_Ch3; with Sem_Disp; use Sem_Disp; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Tbuild; use Tbuild; with Uintp; use Uintp; package body Exp_Ch6 is ------------------------ -- Local Subprograms -- ------------------------ procedure Expand_Call (N : Node_Id); -- This procedure contains common processing for Expand_N_Function_Call -- and Expand_N_Procedure_Statement. function Is_Unchecked_Conversion (Subp : Entity_Id) return Boolean; -- Utility to determine whether a function call is a call to an instance -- of unchecked conversion, which is transformed into a special node. ----------------- -- Expand_Call -- ----------------- -- This procedure handles expansion of function calls and procedure call -- statements (i.e. it serves as the body for Expand_N_Function_Call and -- Expand_N_Procedure_Call_Statement. Processing for calls includes: -- Supply default expressions for missing arguments -- Replace "call" to enumeration literal function by literal itself -- Rewrite call to predefined operator as operator -- Expand dispatching call (see Expand_Dispatch_Call) -- Note that the handling of traceback calls is done by the caller, since -- it is different for function calls and procedure call statemens. This -- processing is done before Expand_Call is called. procedure Expand_Call (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Subp : Entity_Id; Parent_Subp : Entity_Id; Parent_Formal : Entity_Id; Actual : Node_Id; Formal : Entity_Id; Prev : Node_Id := Empty; -- Internal procedure to insert argument corresponding to Formal. -- The value is inserted immediately after Prev, or if Prev is Empty, -- (case of empty argument list), then into a new list. In both cases -- Prev is set to the inserted default for the next call. procedure Insert_Default is Default : Node_Id; Insert, F_Name : Node_Id; begin Insert := New_Node (N_Parameter_Association, Loc); F_Name := New_Node (N_Identifier, Loc); Default := New_Copy (Default_Value (Formal)); Set_Chars (F_Name, Chars (Formal)); Set_Actual_Parameter (Insert, Default); Set_Selector_Name (Insert, F_Name); -- Case of insertion is first named actual if No (Prev) or else Nkind (Parent (Prev)) /= N_Parameter_Association then Set_Next_Named_Actual (Insert, First_Named_Actual (N)); Set_First_Named_Actual (N, Default); if No (Prev) then if not List_Present (Parameter_Associations (N)) then Set_Parameter_Associations (N, New_List); Append (Insert, Parameter_Associations (N)); end if; else Insert_After (Prev, Insert); end if; -- Case of insertion is not first named actual else Set_Next_Named_Actual (Insert, Next_Named_Actual (Parent (Prev))); Set_Next_Named_Actual (Parent (Prev), Default); Append (Insert, Parameter_Associations (N)); end if; Prev := Default; end Insert_Default; -- Start of processing for Expand_Call begin -- First step, insert default parameter values if Nkind (Name (N)) = N_Explicit_Dereference then -- Call to an access to subprogram. The type of the name node is -- a subprogram type, from which we retrieve the signature. Subp := Etype (Name (N)); Parent_Subp := Empty; else Subp := Entity (Name (N)); Parent_Subp := Alias (Subp); end if; Formal := First_Formal (Subp); Actual := First_Actual (N); while Present (Formal) loop if Present (Actual) then -- Check for named and positional parameters in proper place if Nkind (Parent (Actual)) /= N_Parameter_Association or else Chars (Selector_Name (Parent (Actual))) = Chars (Formal) then Prev := Actual; Actual := Next_Actual (Actual); else Insert_Default; end if; -- Trailing actuals are all defaults else Insert_Default; end if; Formal := Next_Formal (Formal); end loop; if Present (Parent_Subp) then while Present (Alias (Parent_Subp)) loop Parent_Subp := Alias (Parent_Subp); end loop; -- Expand an explicit conversion for parameter of the inherited type Formal := First_Formal (Subp); Parent_Formal := First_Formal (Parent_Subp); Actual := First_Actual (N); while Present (Formal) loop if (Etype (Formal) /= Etype (Parent_Formal)) then Rewrite_Substitute_Tree (Actual, Make_Unchecked_Type_Conversion (Sloc (Actual), Subtype_Mark => New_Occurrence_Of (Etype (Parent_Formal), Sloc (Actual)), Expression => New_Copy (Actual))); Set_Etype (Actual, Etype (Parent_Formal)); end if; Formal := Next_Formal (Formal); Parent_Formal := Next_Formal (Parent_Formal); Actual := Next_Actual (Actual); end loop; Set_Entity (Name (N), Parent_Subp); Subp := Parent_Subp; end if; -- Some more special cases for cases other than explicit dereference if Nkind (Name (N)) /= N_Explicit_Dereference then -- Calls to an enumeration literal are replaced by the literal if Ekind (Subp) = E_Enumeration_Literal then Copy_Node (Name (N), N); -- Calls to unchecked conversion are replaced by a conversion node elsif Is_Intrinsic (Subp) and then Is_Unchecked_Conversion (Subp) then declare Op_Node : constant Node_Id := New_Node (N_Type_Conversion, Sloc (N)); begin Set_Subtype_Mark (Op_Node, New_Occurrence_Of (Etype (Entity (Name (N))), Sloc (N))); Set_Expression (Op_Node, New_Copy (First_Actual (N))); Set_Unchecked_Conversion (Op_Node, True); Set_Etype (Op_Node, Etype (N)); Rewrite_Substitute_Tree (N, Op_Node); end; end if; end if; -- Deals with Dispatch_Call if we still have a call if (Nkind (N) = N_Function_Call or else Nkind (N) = N_Procedure_Call_Statement) and then Present (Controlling_Argument (N)) then Expand_Dispatch_Call (N); elsif Is_Abstract (Subp) then Error_Msg_N ("call to abstract subprogram must be dispatching", N); end if; end Expand_Call; -------------------------- -- Expand_Dispatch_Call -- -------------------------- -- If Suppress_Tag_Checks are not on, some tag equality tests are -- performed before the call. For example, for the call: -- F (Tagged_Arg1, Arg2, Tagged_Arg3) -- where Tagged_Arg1 is the controlling argument, and Tagged_Arg3 is an -- argument that is required to have the same tag, we first generate: -- if Tagged_Type (Tagged_Arg1)._Tag /= -- Tagged_Type (Tagged_Arg3)._Tag -- then -- raise Constraint_Error; -- end if; -- where Tagged_Type is the root type. Then the actual call is: -- Acc_Dt (Tagged_Type (Ctrl_Arg)._Tag.all).F___n.all (parameters) procedure Expand_Dispatch_Call (Call_Node : Node_Id) is Ctrl_Arg : constant Node_Id := Controlling_Argument (Call_Node); Tagged_Type : constant Entity_Id := Etype (Etype (Ctrl_Arg)); Subp : constant Entity_Id := Entity (Name (Call_Node)); Param_List : constant List_Id := Parameter_Associations (Call_Node); Prim_Ops : constant Elist_Id := Primitive_Operations (Tagged_Type); Prim_Op : Elmt_Id; Actual : Node_Id; Pos_In_Dt : Natural; Sloc_N : constant Source_Ptr := Sloc (Call_Node); Tag_Ctrl : Entity_Id; Tag_Actl : Entity_Id; Prim_Ctrl : Entity_Id; New_Actions : List_Id := New_List; New_Call_Name : Node_Id; New_Call : Node_Id; begin -- Expand_Dispatch is called directly from the semantics, so we need -- a check to see whether expansion is active before proceeding if not Expander_Active then return; end if; -- Compute the position in the dispatch table Prim_Op := First_Elmt (Prim_Ops); Pos_In_Dt := 1; while Id_Of (Prim_Op) /= Subp loop Pos_In_Dt := Pos_In_Dt + 1; Prim_Op := Next_Elmt (Prim_Op); pragma Assert (Prim_Op /= No_Elmt, Compiler_Abort (Call_Node)); end loop; -- Generate code for testing equality of tags among tagged actuals if List_Present (Param_List) then -- Get the tag component of the Etype (Ctrl_Arg) (= Tagged_Type) Tag_Ctrl := Tag_Component (Tagged_Type); pragma Assert (Present (Tag_Ctrl), Compiler_Abort (Call_Node)); Actual := First (Param_List); while Present (Actual) loop if not Tag_Checks_Suppressed (Etype (Actual)) and then Is_Tagged_Type (Etype (Actual)) and then Find_Controlling_Arg (Actual) /= Ctrl_Arg -- "=" is the only dispatching operation allowed to get -- operands with incompatible tags (it just returns false) and then Chars (Subp) /= Name_Op_Eq then -- Get the tag component of the Etype (Actual) Tag_Actl := Tag_Component (Etype (Actual)); pragma Assert (Present (Tag_Actl), Compiler_Abort (Call_Node)); -- Generate code for tag equality check Append_To (New_Actions, Make_If_Statement (Sloc_N, Condition => Make_Op_Ne (Sloc_N, Left_Opnd => Make_Selected_Component (Sloc_N, Prefix => Make_Type_Conversion (Sloc_N, Subtype_Mark => New_Occurrence_Of (Tagged_Type, Sloc_N), Expression => New_Copy (Ctrl_Arg)), Selector_Name => New_Reference_To (Tag_Ctrl, Sloc_N)), Right_Opnd => Make_Selected_Component (Sloc_N, Prefix => Make_Type_Conversion (Sloc_N, Subtype_Mark => New_Occurrence_Of (Tagged_Type, Sloc_N), Expression => New_Copy (Actual)), Selector_Name => New_Reference_To (Tag_Actl, Sloc_N))), Then_Statements => New_List_1 (New_Constraint_Error (Sloc_N)))); end if; Actual := Next (Actual); end loop; end if; -- Generate the call itself by calling the right function in the -- dispatch table: -- Acc_Dt (Tagged_Type (Ctrl_Arg)._Tag.all).Prim_{Pos_IN_Dt + 2} New_Call_Name := Make_Selected_Component (Sloc_N, Prefix => Make_DT_Access (Sloc_N, Ctrl_Arg, Tagged_Type), Selector_Name => Make_DT_Component (Sloc_N, Tagged_Type, Pos_In_Dt + 2)); if Is_Empty_List (New_Actions) then -- Replace subprogram call by the dispatching call if Nkind (Call_Node) = N_Function_Call then New_Call := Make_Function_Call (Sloc_N, Name => New_Call_Name, Parameter_Associations => New_List_Copy (Param_List)); else New_Call := Make_Procedure_Call_Statement (Sloc_N, Name => New_Call_Name, Parameter_Associations => New_List_Copy (Param_List)); end if; else -- If function call then generate expression_actions node whose -- actions are the if statements generated and expression is -- the dispatching call. if Nkind (Call_Node) = N_Function_Call then New_Call := Make_Expression_Actions (Sloc_N, Actions => New_Actions, Expression => Make_Function_Call (Sloc_N, Name => New_Call_Name, Parameter_Associations => New_List_Copy (Param_List))); -- Else procedure call then analyze the if statements created, -- insert them before the subprogram call and create the -- dispatching call with a procedure call. else Analyze_Declarations (New_Actions); Insert_List_Before (Call_Node, New_Actions); New_Call := Make_Procedure_Call_Statement (Sloc_N, Name => New_Call_Name, Parameter_Associations => New_List_Copy (Param_List)); end if; end if; -- Analyze the dispatching call and rewrite the subprogram call node. Analyze (New_Call); -- The controlling argument is reset to avoid problems with -- Rewrite_Substitute_Tree. Set_Controlling_Argument (Call_Node, Empty); Rewrite_Substitute_Tree (Call_Node, New_Call); Set_Controlling_Argument (Original_Node (Call_Node), Ctrl_Arg); end Expand_Dispatch_Call; ---------------------------- -- Expand_N_Function_Call -- ---------------------------- procedure Expand_N_Function_Call (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); begin Expand_Call (N); end Expand_N_Function_Call; --------------------------------------- -- Expand_N_Procedure_Call_Statement -- --------------------------------------- procedure Expand_N_Procedure_Call_Statement (N : Node_Id) is Call : Node_Id; begin Traceback_Store (N); Expand_Call (N); end Expand_N_Procedure_Call_Statement; ------------------------------ -- Expand_N_Subprogram_Body -- ------------------------------ -- Add return statement if last statement in body is not a return -- statement (this makes things easier on Gigi which does not want -- to have to handle a missing return). -- Add call to Activate_Tasks if body is a task activator -- Add call to Establish_Task_Master if body is a master. Note that this -- must be done before the processing that adds a return statement. -- Finally, if traceback mode is active, insert a call to the traceback -- routine at the start of the statement sequence. This is not done in -- the case of library procedures, since the version information is not -- available at the right time in these cases. procedure Expand_N_Subprogram_Body (N : Node_Id) is S : constant List_Id := Statements (Handled_Statement_Sequence (N)); Rtn : Node_Id; Body_Ent : Entity_Id; Spec_Ent : Entity_Id; Nam : Node_Id; begin -- Get entities for subprogram body and spec Nam := Defining_Unit_Name (Specification (N)); if Nkind (Nam) = N_Defining_Program_Unit_Name then Body_Ent := Name (Nam); else Body_Ent := Nam; end if; if Present (Corresponding_Spec (N)) then Spec_Ent := Corresponding_Spec (N); else Spec_Ent := Body_Ent; end if; -- Activate tasks if this is a task activator Build_Task_Activation_Call (N); -- Establish master if this is a task master if Is_Task_Master (N) then Establish_Task_Master (N); end if; -- Return processing happens for non-generic procedures which do not -- have a return as the last statement in the statement sequence.. Note -- that we don't bother to reanalyze the new body with the added return -- statement, since it would involve a lot of unnecessary work that -- would achieve precisely nothing. if Ekind (Spec_Ent) = E_Procedure and then (Is_Empty_List (S) or else Nkind (Last (S)) /= N_Return_Statement) then Rtn := Make_Return_Statement (Sloc (Last (S))); Append (Rtn, S); end if; end Expand_N_Subprogram_Body; ----------------------------- -- Is_Unchecked_Conversion -- ----------------------------- function Is_Unchecked_Conversion (Subp : Entity_Id) return Boolean is begin return Nkind (Parent (Subp)) = N_Function_Specification and then Present (Generic_Parent (Parent (Subp))) and then Chars (Generic_Parent (Parent (Subp))) = Name_Unchecked_Conversion; end Is_Unchecked_Conversion; end Exp_Ch6; end loop; -- Generate code forgnat-1.67-src/src/exp_ch9.adb 444 10015 7640 112241 5506244321 11162 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ C H 9 -- -- -- -- B o d y -- -- -- -- $Revision: 1.37 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Comperr; use Comperr; with Debug; use Debug; with Einfo; use Einfo; with Exp_Ch3; use Exp_Ch3; with Exp_Util; use Exp_Util; with Namet; use Namet; with Nmake; use Nmake; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Res; use Sem_Res; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Tbuild; use Tbuild; with Uintp; use Uintp; package body Exp_Ch9 is ----------------------- -- Local Subprograms -- ----------------------- procedure Add_Discriminal_Declarations (Decls : List_Id; Typ : Node_Id; Name : Name_Id; Loc : Source_Ptr); -- This routine is used to add discriminal declarations to task bodies -- (and protected bodies ???). The discriminants are available by normal -- selection from the concurrent object (whose name is passed as the third -- parameter). Discriminant references inside the task body have already -- been replaced by references to the corresponding discriminals. The -- declarations constructed by this procedure hook the references up with -- the objects: -- -- discriminal_name : discr_type renames name.discriminant_name; -- -- Obviously we could have expanded the discriminant references in the -- first place to be the appropriate selection, but this turns out to -- be hard to do because it would introduce difference in handling of -- discriminant references depending on their location. function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id; -- This routine constructs a specification for the procedure that we will -- build for the task body. The specification has the form -- -- procedure name___Body (_Task : access name___Val); -- -- where name is the character name taken from the task type entity that -- is passed as the argument to the procedure, and name___Val is the task -- value type that is associated with the task type. function Find_Task_Pragma (T : Node_Id; P : Name_Id) return Node_Id; -- Searches the task definition T for the first occurrence of the pragma -- whose name is given by P. The caller has ensured that the pragma is -- present in the task definition. function Task_Ref (N : Node_Id) return Node_Id; -- Given the name of a task, or the name of an access to a task, this -- function returns an expression which references the associated Task_Id. ---------------------------------- -- Add_Discriminal_Declarations -- ---------------------------------- procedure Add_Discriminal_Declarations (Decls : List_Id; Typ : Node_Id; Name : Name_Id; Loc : Source_Ptr) is D : Entity_Id; begin if Has_Discriminants (Typ) then D := First_Discriminant (Typ); while Present (D) loop Prepend_To (Decls, Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Discriminal (D), Subtype_Mark => New_Reference_To (Etype (D), Loc), Name => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name), Selector_Name => Make_Identifier (Loc, Chars (D))))); D := Next_Discriminant (D); end loop; end if; end Add_Discriminal_Declarations; ----------------------------------- -- Build_Activation_Chain_Entity -- ----------------------------------- procedure Build_Activation_Chain_Entity (N : Node_Id) is P : Node_Id; begin -- Loop to find enclosing construct containing activation chain variable -- Note??? the test for generic package declaration should be removed -- when generics are done right (because then we will never see a -- generic node in the expander). P := Parent (N); while Nkind (P) /= N_Subprogram_Body and then Nkind (P) /= N_Generic_Package_Declaration -- ??? and then Nkind (P) /= N_Package_Declaration and then Nkind (P) /= N_Package_Body and then Nkind (P) /= N_Block_Statement loop P := Parent (P); end loop; -- If we are in a package body, the activation chain variable is -- allocated in the corresponding spec if Nkind (P) = N_Package_Body then P := Parent (Corresponding_Spec (P)); pragma Assert (Nkind (P) = N_Package_Declaration, Compiler_Abort (P)); end if; -- If activation chain entity not already declared, declare it if No (Activation_Chain_Entity (P)) then Set_Activation_Chain_Entity (P, Make_Defining_Identifier (Sloc (P), Name_uChain)); Prepend ( Make_Object_Declaration (Sloc (P), Defining_Identifier => Activation_Chain_Entity (P), Object_Definition => New_Reference_To (RTE (RE_Activation_Chain), Sloc (P))), Declarations (P)); Analyze (First (Declarations (P))); end if; end Build_Activation_Chain_Entity; -------------------------- -- Build_Call_With_Task -- -------------------------- function Build_Call_With_Task (N : Node_Id; E : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (N); begin return Make_Function_Call (Loc, Name => New_Reference_To (E, Loc), Parameter_Associations => New_List_1 (Task_Ref (N))); end Build_Call_With_Task; ------------------------- -- Build_Master_Entity -- ------------------------- procedure Build_Master_Entity (E : Entity_Id) is Loc : constant Source_Ptr := Sloc (E); P : Node_Id; Decl : Node_Id; begin -- Nothing to do if we already built a master entity for this scope if Has_Master_Entity (Scope (E)) then return; end if; -- Otherwise first build the master entity -- _Master : constant Master_Id := Current_Master; -- and insert it just before the current declaration Decl := Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uMaster), Constant_Present => True, Object_Definition => New_Reference_To (RTE (RE_Master_Id), Loc), Expression => New_Reference_To (RTE (RE_Current_Master), Loc)); Analyze (Decl); P := Parent (E); Insert_Before (P, Decl); Set_Has_Master_Entity (Scope (E)); -- Now mark the containing scope as a task master loop P := Parent (P); -- If we fall off the top, we are at the outer level, and the -- environment task is our effective master, so nothing to mark. if Nkind (P) = N_Task_Body or else Nkind (P) = N_Block_Statement or else Nkind (P) = N_Subprogram_Body then Set_Is_Task_Master (P, True); return; end if; end loop; end Build_Master_Entity; -------------------------------- -- Build_Task_Activation_Call -- -------------------------------- procedure Build_Task_Activation_Call (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Chain : Entity_Id; Call : Node_Id; P : Node_Id; begin -- Get the activation chain entity. Except in the case of a package -- body, this is in the node that was passed. For a package body,we -- have to find the corresponding package declaration node. -- Note: can remove generic case when we do generics properly??? if Nkind (N) = N_Package_Body then P := Corresponding_Spec (N); loop P := Parent (P); exit when Nkind (P) = N_Package_Declaration or else Nkind (P) = N_Generic_Package_Declaration; -- ??? end loop; Chain := Activation_Chain_Entity (P); else Chain := Activation_Chain_Entity (N); end if; if Present (Chain) then Call := Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Activate_Tasks), Loc), Parameter_Associations => New_List_1 (New_Reference_To (Chain, Loc))); Analyze (Call); Resolve_Subexpr (Call, Standard_Void_Type); Prepend (Call, Statements (Handled_Statement_Sequence (N))); end if; end Build_Task_Activation_Call; ------------------------------- -- Build_Task_Allocate_Block -- ------------------------------- procedure Build_Task_Allocate_Block (Actions : List_Id; N : Node_Id; Args : List_Id) is PtrT : constant Entity_Id := Etype (N); T : constant Entity_Id := Entity (Expression (N)); Init : constant Entity_Id := Base_Init_Proc (T); Loc : constant Source_Ptr := Sloc (N); Blkent : Entity_Id; Block : Node_Id; begin Blkent := Make_Defining_Identifier (Loc, New_Internal_Name ("alloc")); Block := Make_Block_Statement (Loc, Identifier => New_Reference_To (Blkent, Loc), Declarations => New_List_2 ( -- _Chain : Activation_Chain; Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uChain), Object_Definition => New_Reference_To (RTE (RE_Activation_Chain), Loc)), -- procedure _Expunge is -- begin -- Expunge_Unactivated_Tasks (_Chain); -- end; Make_Subprogram_Body (Loc, Specification => Make_Procedure_Specification (Loc, Defining_Unit_Name => Make_Defining_Identifier (Loc, Name_uExpunge)), Declarations => Empty_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List_1 ( Make_Procedure_Call_Statement (Loc, Name => New_Reference_To ( RTE (RE_Expunge_Unactivated_Tasks), Loc), Parameter_Associations => New_List_1 ( Make_Identifier (Loc, Name_uChain)) ))))), Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List_2 ( -- Init (Args); Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (Init, Loc), Parameter_Associations => Args), -- Activate_Tasks (_Chain); Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Activate_Tasks), Loc), Parameter_Associations => New_List_1 ( Make_Identifier (Loc, Name_uChain)))), Identifier => Make_Identifier (Loc, Name_uExpunge)), Has_Created_Identifier => True); Append_To (Actions, Make_Implicit_Label_Declaration (Loc, Defining_Identifier => Blkent, Label => Block)); Append_To (Actions, Block); end Build_Task_Allocate_Block; ----------------------------------- -- Build_Task_Proc_Specification -- ----------------------------------- function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (T); Nam : constant Name_Id := Chars (T); begin return Make_Procedure_Specification (Loc, Defining_Unit_Name => Make_Defining_Identifier (Loc, Chars => New_External_Name (Nam, "body")), Parameter_Specifications => New_List_1 ( Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uTask), Parameter_Type => Make_Access_Definition (Loc, Subtype_Mark => New_Reference_To (Task_Value_Type (T), Loc))))); end Build_Task_Proc_Specification; -------------------------- -- Complete_Master_Call -- -------------------------- function Complete_Master_Call (N : Node_Id) return Node_Id is begin return Make_Procedure_Call_Statement (Sloc (N), Name => New_Reference_To (RTE (RE_Complete_Master), Sloc (N))); end Complete_Master_Call; ------------------ -- Convert_Task -- ------------------ function Convert_Task (N : Node_Id; Typ : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (N); begin if not Is_Task_Type (Typ) then return N; else return Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (Task_Value_Type (Typ), Loc), Expression => New_Copy (N)); end if; end Convert_Task; --------------------------- -- Establish_Task_Master -- --------------------------- procedure Establish_Task_Master (N : Node_Id) is begin Prepend ( Build_Call (Sloc (N), RTE (RE_Enter_Master)), Declarations (N)); Protect_Statements (N, RTE (RE_Complete_Master)); end Establish_Task_Master; -------------------------------------- -- Expand_N_Single_Task_Declaration -- -------------------------------------- -- First, we expand the single task declaration as a task type -- declaration (the field all correspond in the two node types, -- this is the reason for the dummy Discriminant_Specifications -- field in the N_Single_Task_Declaration node). Second, we treat -- the declaration as an object declaration for the task object -- and in particular we generate the appropriate initialization. procedure Expand_N_Single_Task_Declaration (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Id : constant Entity_Id := Defining_Identifier (N); begin Expand_N_Task_Type_Declaration (N); Insert_After (N, Build_Initialization_Call (Loc, New_Reference_To (Id, Loc), Etype (Id))); end Expand_N_Single_Task_Declaration; ---------------------- -- Expand_Task_Body -- ---------------------- -- Given a task body -- task body tname is -- declarations -- begin -- statements -- end x; -- This expansion routine converts it into a procedure and sets the -- elaboration flag for the procedure to true, to represent the fact -- that the task body is now elaborated: -- procedure tname___body (_Task : access tname___val) is -- discrimal : dtype renames _Task.discriminant; -- begin -- System.Task_Stages.Complete_Activation; -- statements -- at end -- System.Task_Stages.Complete_Task; -- end; -- tname___elab := True; -- In addition, if the task body is an activator, then a call to -- activate tasks is added at the start of the statements, before -- the call to Complete_Activation, and if in addition the task is -- a master then it must be established as a master. -- There is one discriminal declaration line generated for each -- discriminant that is present to provide an easy reference point -- for discriminant references inside the body (see Exp_Ch2.Expand_Name). -- Note on relationship to GNARLI definition. In the GNARLI definition, -- task body procedures have a profile (Arg : System.Address). That is -- needed because GNARLI has to use the same access-to-subprogram type -- for all task types. We depend here on knowing that in GNAT, passing -- an address argument by value is identical to passing a a record value -- by access (in either case a single pointer is passed), so even though -- this procedure has the wrong profile. In fact it's all OK, since the -- callings sequence is identical. procedure Expand_N_Task_Body (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Ttyp : constant Entity_Id := Corresponding_Spec (N); Tval : constant Entity_Id := Task_Value_Type (Ttyp); begin Add_Discriminal_Declarations (Declarations (N), Ttyp, Name_uTask, Loc); if Is_Task_Master (N) then Establish_Task_Master (N); end if; Build_Task_Activation_Call (N); Protect_Statements (N, RTE (RE_Complete_Task)); Prepend ( Build_Call (Loc, RTE (RE_Complete_Activation)), Statements (Handled_Statement_Sequence (N))); Rewrite_Substitute_Tree (N, Make_Subprogram_Body (Loc, Specification => Build_Task_Proc_Specification (Ttyp), Declarations => Declarations (N), Handled_Statement_Sequence => Handled_Statement_Sequence (N))); Analyze (N); Insert_After (N, Make_Assignment_Statement (Loc, Name => Make_Identifier (Loc, New_External_Name (Chars (Ttyp), "elab")), Expression => New_Reference_To (Standard_True, Loc))); end Expand_N_Task_Body; ------------------------------------ -- Expand_N_Task_Type_Declaration -- ------------------------------------ -- Note: this routine is also used by Expand_N_Single_Task_Declaration. -- The fields in the two nodes are similar precisely to allow this -- approach. We take care to use the task type, rather than the node -- itself, so that we get the proper type (the anonymously created type) -- in the single task case. -- We have several things to do. First we must create a Boolean flag used -- to mark if the body is elaborated yet. This variable gets set to True -- when the body of the task is elaborated (we can't rely on the normal -- ABE mechanism for the task body, since we need to pass an access to -- this elaboration boolean to the runtime routines). -- task___Elab : aliased Boolean := False; -- Next a variable is declared to hold the task stack size (either -- the default, which is the initial value given here, or a value that -- is set by a pragma Storage_Size appearing later on. -- task___Size : Size_Type := Unspecified_Size; -- Next we create a corresponding record type declaration used to represent -- values of this task. The general form of this type declaration is -- type task___Val (discriminants) is record -- _Task_Id : Task_Id; -- entry_family : array (bounds) of Void; -- _Priority : Integer := priority_expression; -- _Size : Size_Type := size_expression; -- end record; -- The discriminants are present only if the corresponding task type has -- discriminants, and they exactly mirror the task type discriminants. -- The Id field is always present. It contains the Task_Id value, as -- set by the call to Create_Task. Note that although the task is -- limited, the task value record type is not limited, so there is no -- problem in passing this field as an out parameter to Create_Task. -- One entry_family component is present for each entry family in the -- task definition. The bounds correspond to the bounds of the entry -- family (which may depend on discriminants). The element type is -- void, since we only need the bounds information for determining -- the entry index. Note that the use of an anonymous array would -- normally be illegal in this context, but this is a parser check, -- and the semantics is quite prepared to handle such a case. -- The Size field is present only if a Task_Stack_Size pragma appears in -- the task definition. The expression captures the argument that was -- present in the pragma, and is used to override the task stack size -- otherwise associated with the task type. -- The Priority field is present only if a Priority or Interrupt_Priority -- pragma appears in the task definition. The expression captures the -- argument that was present in the pragma, and is used to provide -- the Size parameter to the call to Create_Task. -- When a task is declared, an instance of the task value record is -- created. The elaboration of this declaration creates the correct -- bounds for the entry families, and also evaluates the size and -- priority expressions if needed. The initialization routine for -- the task type itself then calls Create_Task with appropriate -- parameters to initialize the value of the Task_Id field. -- Note: the address of this record is passed as the "Discriminants" -- parameter for Create_Task. Since Create_Task merely passes this onto -- the body procedure, it does not matter that it does not quite match -- the GNARLI model of what is being passed (the record contains more -- than just the discriminants, but the discriminants can be found from -- the record value). -- The Entity_Id for this created record type is placed in the -- Task_Value_Type field of the associated task type entity. -- Finally we create a procedure specification for the task body procedure: -- procedure task___Body (_Task : access task___Val); -- Note that this must come after the record type declaration, since -- the spec refers to this type. It turns out that the initialization -- procedure for the value type references the task body spec, but that's -- fine, since it won't be generated till the freeze point for the type, -- which is certainly after the task body spec declaration. procedure Expand_N_Task_Type_Declaration (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Tasktyp : constant Entity_Id := Etype (Defining_Identifier (N)); Tasknm : constant Name_Id := Chars (Tasktyp); Taskdef : constant Node_Id := Task_Definition (N); Proc_Spec : Node_Id; Rec_Ent : Entity_Id; Rec_Decl : Node_Id; Cdecls : List_Id; Dlist : List_Id; Disc : Node_Id; Efam : Entity_Id; Elab_Decl : Node_Id; Size_Decl : Node_Id; Body_Decl : Node_Id; begin -- First create the elaboration variable Elab_Decl := Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Chars => New_External_Name (Tasknm, "elab")), Aliased_Present => True, Object_Definition => New_Reference_To (Standard_Boolean, Loc), Expression => New_Reference_To (Standard_False, Loc)); Insert_After (N, Elab_Decl); -- Next create the declaration of the size variable Size_Decl := Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Chars => New_External_Name (Tasknm, "size")), Object_Definition => New_Reference_To (RTE (RE_Size_Type), Loc), Expression => New_Reference_To (RTE (RE_Unspecified_Size), Loc)); Insert_After (Elab_Decl, Size_Decl); -- Next create the record declaration for the task value type. -- This is done last, since the corresponding record initialization -- procedure will reference the previously created entities. Rec_Ent := Make_Defining_Identifier (Loc, New_External_Name (Tasknm, "val")); Set_Task_Value_Type (Tasktyp, Rec_Ent); Set_Ekind (Rec_Ent, E_Record_Type); Set_Is_Task_Record_Type (Rec_Ent, True); Set_Corresponding_Task_Type (Rec_Ent, Tasktyp); -- Initialize component list, we will fill it in later Cdecls := New_List; -- Make a copy of the discriminant specifications if List_Present (Discriminant_Specifications (N)) then Dlist := New_List; Disc := First (Discriminant_Specifications (N)); while Present (Disc) loop Append_To (Dlist, Make_Discriminant_Specification (Loc, Defining_Identifier => New_Copy (Defining_Identifier (Disc)), Discriminant_Type => New_Copy (Discriminant_Type (Disc)), Expression => New_Copy (Expression (Disc)))); Disc := Next (Disc); end loop; else Dlist := No_List; end if; -- Now we can construct the record type declaration Rec_Decl := Make_Full_Type_Declaration (Loc, Defining_Identifier => Rec_Ent, Discriminant_Specifications => Dlist, Type_Definition => Make_Record_Definition (Loc, Component_List => Make_Component_List (Loc, Component_Declarations => Cdecls))); -- Fill in the component declarations. First the _Task_Id field: Append_To (Cdecls, Make_Component_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uTask_Id), Subtype_Indication => New_Reference_To (RTE (RE_Task_ID), Loc))); -- Add components for entry families Efam := First_Entity (Tasktyp); while Present (Efam) loop if Ekind (Efam) = E_Entry_Family then Append_To (Cdecls, Make_Component_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Chars (Efam)), Subtype_Indication => Make_Constrained_Array_Definition (Loc, Discrete_Subtype_Definitions => (New_List_1 ( New_Copy (Discrete_Subtype_Definition (Parent (Efam))))), Subtype_Indication => New_Reference_To (Standard_Character, Loc)))); end if; Efam := Next_Entity (Efam); end loop; -- Add the priority component if a priority pragma is present if Present (Taskdef) and then Has_Priority_Pragma (Taskdef) then Append_To (Cdecls, Make_Component_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uPriority), Subtype_Indication => New_Reference_To (Standard_Integer, Loc), Expression => New_Copy ( Expression (First ( Pragma_Argument_Associations ( Find_Task_Pragma (Taskdef, Name_Priority))))))); end if; -- Add the task_size component if a priority pragma is present if Present (Taskdef) and then Has_Task_Stack_Size_Pragma (Taskdef) then Append_To (Cdecls, Make_Component_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uSize), Subtype_Indication => New_Reference_To (RTE (RE_Size_Type), Loc), Expression => New_Copy ( Expression (First ( Pragma_Argument_Associations ( Find_Task_Pragma (Taskdef, Name_Task_Stack_Size))))))); end if; Insert_After (Size_Decl, Rec_Decl); -- Analyze the record declaration immediately after construction, -- because the initialization procedure is needed for single task -- declarations before the next entity is analyzed. Analyze (Rec_Decl); -- Finally create the declaration of the task body procedure Proc_Spec := Build_Task_Proc_Specification (Tasktyp); Body_Decl := Make_Subprogram_Declaration (Loc, Specification => Proc_Spec); Insert_After (Rec_Decl, Body_Decl); end Expand_N_Task_Type_Declaration; ---------------------- -- Find_Task_Pragma -- ---------------------- function Find_Task_Pragma (T : Node_Id; P : Name_Id) return Node_Id is N : Node_Id; begin N := First (Visible_Declarations (T)); while Present (N) loop if Nkind (N) = N_Pragma and then Chars (Identifier (N)) = P then return N; else N := Next (N); end if; end loop; N := First (Private_Declarations (T)); while Present (N) loop if Nkind (N) = N_Pragma and then Chars (Identifier (N)) = P then return N; else N := Next (N); end if; end loop; Compiler_Abort; end Find_Task_Pragma; --------------------------- -- Make_Task_Create_Call -- --------------------------- function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Task_Rec); Tdef : Node_Id; Tdec : Node_Id; Ttyp : Node_Id; Tnam : Name_Id; Args : List_Id; Ent : Entity_Id; Eindx : Nat; Ecount : Node_Id; begin Ttyp := Corresponding_Task_Type (Task_Rec); Tnam := Chars (Ttyp); -- Get task declaration. In the case of a task type declaration, this -- is simply the parent of the task type entity. In the single task -- declaration, this parent will be the implicit type, and we can find -- the corresponding single task declaration by searching forward in -- the declaration list in the tree. Tdec := Parent (Ttyp); while Nkind (Tdec) /= N_Task_Type_Declaration and then Nkind (Tdec) /= N_Single_Task_Declaration loop Tdec := Next (Tdec); end loop; -- Now we can find the task definition from this declaration Tdef := Task_Definition (Tdec); -- Build the parameter list for the call. Note that _Init is the name -- of the formal for the object to be initialized, which is the task -- value record itself. Args := New_List; -- Size parameter. If no Task_Stack_Size pragma is present, then -- the size is taken from the task___Size variable for the type, -- which is either Unspecified_Size, or has been reset by the use -- of a Storage_Size attribute definition clause. If a pragma is -- present, then the size is taken from the _Size field of the -- task value record, which was set from the pragma value. if Present (Tdef) and then Has_Task_Stack_Size_Pragma (Tdef) then Append_To (Args, Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_uInit), Selector_Name => Make_Identifier (Loc, Name_uSize))); else Append_To (Args, Make_Identifier (Loc, New_External_Name (Tnam, "size"))); end if; -- Priority parameter. Set to Unspecified_Priority unless there is a -- priority pragma, in which case we take the value from the pragma. if Present (Tdef) and then Has_Priority_Pragma (Tdef) then Append_To (Args, Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_uInit), Selector_Name => Make_Identifier (Loc, Name_uPriority))); else Append_To (Args, New_Reference_To (RTE (RE_Unspecified_Priority), Loc)); end if; -- Number of entries. This is an expression of the form: -- -- n + _Init.a'Length + _Init.a'B'Length + ... -- -- where a,b... are the entry family names for the task definition Ent := First_Entity (Ttyp); Eindx := 0; -- Count number of non-family entries while Present (Ent) loop if Ekind (Ent) = E_Entry then Eindx := Eindx + 1; end if; Ent := Next_Entity (Ent); end loop; Ecount := Make_Integer_Literal (Loc, UI_From_Int (Eindx)); -- Loop through entry families building the addition nodes Ent := First_Entity (Ttyp); while Present (Ent) loop if Ekind (Ent) = E_Entry_Family then Ecount := Make_Op_Add (Loc, Left_Opnd => Ecount, Right_Opnd => Make_Attribute_Reference (Loc, Prefix => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_uInit), Selector_Name => Make_Identifier (Loc, Chars (Ent))), Identifier => Make_Identifier (Loc, Name_Length))); end if; Ent := Next_Entity (Ent); end loop; Append_To (Args, Ecount); -- Master parameter. This is a reference to the _Master parameter of -- the initialization procedure. Append_To (Args, Make_Identifier (Loc, Name_uMaster)); -- State parameter. This is a pointer to the task body procedure. We get -- the required value by taking the address of the task body procedure, -- and then converting it (with an unchecked conversion) to the type -- required by the task kernel. See description of Expand_Task_Body -- for further details. Append_To (Args, Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (RTE (RE_Init_State), Loc), Expression => Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, New_External_Name (Tnam, "body")), Identifier => Make_Identifier (Loc, Name_Address)))); -- Discriminants parameter. This is just the address of the task -- value record itself (which contains the discriminant values Append_To (Args, Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Name_uInit), Identifier => Make_Identifier (Loc, Name_Address))); -- Elaborated parameter. This is an access to the elaboration Boolean Append_To (Args, Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, New_External_Name (Tnam, "elab")), Identifier => Make_Identifier (Loc, Name_Access))); -- Chain parameter. This is a reference to the _Chain parameter of -- the initialization procedure. Append_To (Args, Make_Identifier (Loc, Name_uChain)); -- Created_Task parameter. This is the _Task_Id field of the task -- record value Append_To (Args, Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_uInit), Selector_Name => Make_Identifier (Loc, Name_uTask_Id))); return Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Create_Task), Loc), Parameter_Associations => Args); end Make_Task_Create_Call; -------------- -- Task_Ref -- -------------- -- The expression returned for a task has the form: -- task___Value!(name)._Task_Id -- For the case of an access to a task, there is an extra explicit -- dereference: -- task___Value!(name.all)._Task_Id -- here task___Value is the type for the associated record, which -- contains the required _Task_Id field. function Task_Ref (N : Node_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (N); Ntyp : constant Entity_Id := Etype (N); begin if Is_Access_Type (Ntyp) then return Make_Selected_Component (Loc, Prefix => Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Reference_To ( Task_Value_Type (Designated_Type (Ntyp)), Loc), Expression => Make_Explicit_Dereference (Loc, N)), Selector_Name => Make_Identifier (Loc, Name_uTask_Id)); else pragma Assert (Is_Task_Type (Ntyp), Compiler_Abort (N)); return Make_Selected_Component (Loc, Prefix => Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (Task_Value_Type (Ntyp), Loc), Expression => N), Selector_Name => Make_Identifier (Loc, Name_uTask_Id)); end if; end Task_Ref; end Exp_Ch9; irst (Visible_Declarations (T)); while Present (N) loop if Nkind (N) = N_Pragma and then Chars (Identifier (N)) = P then return N; else N := Next (N); end if; end loop; N := First (Private_Declarations (T)); while Present (N) loop if Nkind (N) = N_Pragma and then gnat-1.67-src/src/exp_ch13.adb 444 10015 7640 10167 5506244321 11221 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ C H 1 3 -- -- -- -- B o d y -- -- -- -- $Revision: 1.8 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Einfo; use Einfo; with Exp_Ch3; use Exp_Ch3; with Nmake; use Nmake; with Rtsfind; use Rtsfind; with Sinfo; use Sinfo; with Snames; use Snames; with Tbuild; use Tbuild; package body Exp_Ch13 is ------------------------------------------ -- Expand_N_Attribute_Definition_Clause -- ------------------------------------------ -- Expansion action depends on attribute involved procedure Expand_N_Attribute_Definition_Clause (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); begin case Get_Attribute_Id (Chars (Identifier (N))) is -- Storage_Size when Attribute_Storage_Size => -- If the type is a task type, then assign the value of the -- storage size to the Size variable associated with the task. -- task___Size := expression if Ekind (Etype (Name (N))) = E_Task_Type then Rewrite_Substitute_Tree (N, Make_Assignment_Statement (Loc, Name => Make_Identifier (Loc, Chars => New_External_Name ( Chars (Etype (Name (N))), "size")), Expression => Make_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (RTE (RE_Size_Type), Loc), Expression => Expression (N)))); -- Other types for Storage_Size attribute need no expansion else null; end if; -- Other attributes require no expansion when others => null; end case; end Expand_N_Attribute_Definition_Clause; ---------------------------- -- Expand_N_Freeze_Entity -- ---------------------------- procedure Expand_N_Freeze_Entity (N : Node_Id) is E : Entity_Id := Entity (N); begin -- Freeze the type if it is a record type, task type, or array type. -- Note that we explicitly check for a type, rather than use the -- Is_xxx_Type predicates, because these also include subtypes and -- there are no freeze actions for subtypes. if Ekind (E) = E_Record_Type or else Ekind (E) = E_Task_Type or else Ekind (E) = E_Array_Type then Freeze_Type (N); end if; end Expand_N_Freeze_Entity; end Exp_Ch13; ocation.adb 8¹9 unixlib.adbL¹: usage.adsSe`¹; usage.adbSet¹< a-adaint.ctˆ¹= a-gtran3.cwœ¹> a-gtran3.hs°¹?a-misc.cStaĹ@a-misc.he TعA a-namet.husì¹B a-rtree.h E¹C a-string.h-¹D a-trans3.ca(¹E a-trans3.h-<¹F a-trans4.c P¹G a-trans4.had¹H a-trans.gnat-1.67-src/src/exp_attr.adb 444 10015 7640 27030 5506244322 11433 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ A T T R -- -- -- -- B o d y -- -- -- -- $Revision: 1.16 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Einfo; use Einfo; with Exp_Ch9; use Exp_Ch9; with Nmake; use Nmake; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Res; use Sem_Res; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Tbuild; use Tbuild; with Ttypes; use Ttypes; with Uintp; use Uintp; package body Exp_Attr is ----------------------- -- Local Subprograms -- ----------------------- procedure Expand_Attribute_Callable (N : Node_Id); procedure Expand_Attribute_Image (N : Node_Id); procedure Expand_Attribute_Size (N : Node_Id); procedure Expand_Attribute_Terminated (N : Node_Id); --------------------------------- -- Expand_Attribute_Callable -- --------------------------------- -- Transforms 'Callable attribute into a call to the Callable function. procedure Expand_Attribute_Callable (N : Node_Id) is begin Rewrite_Substitute_Tree (N, Build_Call_With_Task (Prefix (N), RTE (RE_Callable))); Analyze (N); Resolve_Subexpr (N, Standard_Boolean); end Expand_Attribute_Callable; ----------------------------- -- Expand_Attribute_Image -- ----------------------------- -- For Boolean, Character, and numeric types, typ'Image (X) expands to: -- [B : string (1 .. max); -- B (1 .. System.Image.Image_styp (styp (X), B'Address)) ] -- where styp is one of the standard supported types. For user defined -- enumeration types, the transformation is to: -- Table (Enum'Pos (X)).all -- where table is the special table declared in the front end and -- constructed by special code in Gigi. procedure Expand_Attribute_Image (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Typ : constant Entity_Id := Entity (Prefix (N)); -- Prefix type of image attribute Btyp : constant Entity_Id := Base_Type (Typ); -- The base type of the prefix type Maxb : Nat; -- Maximum length required for buffer (including trailing NUL) used -- in call to function in System.Image package. Ient : Entity_Id; -- Entity for routine to call in Image package Ityp : Entity_Id := Btyp; -- Type used for first argument to image routine (styp above). -- Usually, but not always the same as the base type. B : Entity_Id; -- The entity used for the buffer in the expansion begin if Btyp = Standard_Boolean then Maxb := 6; Ient := RTE (RE_Img_B); -- In the case of Integer, we don't bother to have separate routines -- for all integer lengths, it's good enough to just handle the Integer -- and Long_Long_Integer cases, and use the smaller of these that fits. elsif Is_Integer_Type (Btyp) then if Esize (Btyp) <= Esize (Standard_Integer) then Ityp := Standard_Integer; Maxb := Standard_Integer_Width + 1; Ient := RTE (RE_Img_I); else Ityp := Standard_Long_Long_Integer; Maxb := Standard_Long_Long_Integer_Width + 1; Ient := RTE (RE_Img_LLI); end if; elsif Btyp = Standard_Short_Float then Maxb := Standard_Short_Float_Digits + 10; Ient := RTE (RE_Img_SF); elsif Btyp = Standard_Float then Maxb := Standard_Float_Digits + 10; Ient := RTE (RE_Img_F); elsif Btyp = Standard_Long_Float then Maxb := Standard_Long_Float_Digits + 10; Ient := RTE (RE_Img_LF); elsif Btyp = Standard_Long_Long_Float then Maxb := Standard_Long_Float_Digits + 10; Ient := RTE (RE_Img_LLF); elsif Btyp = Standard_Character then Maxb := 10; Ient := RTE (RE_Img_C); -- Only other possibility that is currently supported is the user -- defined enumeration type case (other unsupported cases, notably -- the real cases, should have been caught as errors earlier on) else Rewrite_Substitute_Tree (N, Make_Explicit_Dereference (Loc, Prefix => Make_Indexed_Component (Loc, Prefix => New_Reference_To (Lit_Name_Table (Entity (Prefix (N))), Loc), Expressions => New_List_1 ( Make_Attribute_Reference (Loc, Prefix => Prefix (N), Identifier => Make_Identifier (Loc, Name_Pos), Expression => Expression (N)))))); Analyze (N); Resolve_Subexpr (N, Standard_String); return; end if; -- If we fall through, we have one of the cases that is handled by -- calling one of the routines in the System.Image package B := Make_Defining_Identifier (Loc, New_Internal_Name ("temp")); Rewrite_Substitute_Tree (N, Make_Expression_Actions (Loc, Actions => New_List_1 ( Make_Object_Declaration (Loc, Defining_Identifier => B, Object_Definition => Make_Subtype_Indication (Loc, Subtype_Mark => New_Reference_To (Standard_String, Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => New_List_1 ( Make_Range (Loc, Low_Bound => Make_Integer_Literal (Loc, Uint_1), High_Bound => Make_Integer_Literal (Loc, Intval => UI_From_Int (Maxb)))))))), Expression => Make_Slice (Loc, Prefix => New_Reference_To (B, Loc), Discrete_Range => Make_Range (Loc, Low_Bound => Make_Integer_Literal (Loc, Uint_1), High_Bound => Make_Function_Call (Loc, Name => New_Reference_To (Ient, Loc), Parameter_Associations => New_List_2 ( Make_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (Ityp, Loc), Expression => Expression (N)), Make_Attribute_Reference (Loc, Prefix => New_Reference_To (B, Loc), Identifier => Make_Identifier (Loc, Name_Address)))))))); Analyze (N); Resolve_Subexpr (N, Standard_String); -- All implicit subtypes that were generated by the expression part -- should be become attached to the actions part so they will be -- processed before the expression. The implicit type for the slice -- is generated in Resolve_Subexpr and thus is not caught by the -- processing of Analyze_Expression_Actions. if Is_Non_Empty_List (Implicit_Type_List) then Append_List (Implicit_Type_List, Actions (N)); Implicit_Type_List := New_List; end if; end Expand_Attribute_Image; --------------------------- -- Expand_Attribute_Size -- --------------------------- -- Transforms X'Size into a call to the first dispatching operation -- contained in the Dispatch Table pointed by X._tag. This first operation -- happens to be the implicit _Size function giving the size of a tagged -- object. We can't just expand a call to this function, and rely on -- further expansion to transform it into a dispatch call, because _size -- may not be visible at this point. procedure Expand_Attribute_Size (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Pref : constant Node_Id := Prefix (N); Typ : constant Entity_Id := Etype (Pref); Context_Typ : constant Entity_Id := Etype (N); New_Node : Node_Id; begin if Is_Class_Type (Typ) then New_Node := Make_Indexed_Component (Loc, Prefix => Make_Selected_Component (Loc, Prefix => Make_DT_Access (Loc, Pref, Etype (Typ)), Selector_Name => Make_DT_Component (Loc, Etype (Typ), 3)), Expressions => New_List_1 (New_Copy (Pref))); if Context_Typ /= Universal_Integer then New_Node := Make_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (Context_Typ, Loc), Expression => New_Node); end if; Rewrite_Substitute_Tree (N, New_Node); Analyze (N); Resolve_Subexpr (N, Context_Typ); end if; end Expand_Attribute_Size; --------------------------------- -- Expand_Attribute_Terminated -- --------------------------------- -- Transforms 'Terminated attribute into a call to the Terminated function. procedure Expand_Attribute_Terminated (N : Node_Id) is begin Rewrite_Substitute_Tree (N, Build_Call_With_Task (Prefix (N), RTE (RE_Terminated))); Analyze (N); Resolve_Subexpr (N, Standard_Boolean); end Expand_Attribute_Terminated; ---------------------------------- -- Expand_N_Attribute_Reference -- ---------------------------------- procedure Expand_N_Attribute_Reference (N : Node_Id) is begin case Get_Attribute_Id (Chars (Identifier (N))) is -- Attributes requiring special expander action when Attribute_Callable => Expand_Attribute_Callable (N); when Attribute_Image => Expand_Attribute_Image (N); when Attribute_Size => Expand_Attribute_Size (N); when Attribute_Terminated => Expand_Attribute_Terminated (N); -- All other attributes need no expander action when others => null; end case; end Expand_N_Attribute_Reference; end Exp_Attr; c (N); Typ : constant Entity_Id := Entity (Prefix (N)); -- Prefix type of image attribute Btyp : constant Entity_Id := Base_Type (Typ); -- The base type of the prefix type Maxb : Nat; -- Maximum length required for buffer (including trailing NUL) used -- in call to function in System.Image package. Ient : Entity_Id; -- Entity for routine to call in Image package Ityp : Entity_Id := Btyp; -- Type used for firgnat-1.67-src/src/exp_attr.ads 444 10015 7640 3701 5506244322 11433 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ A T T R -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Expand routines for attribute references with Types; use Types; package Exp_Attr is procedure Expand_N_Attribute_Reference (N : Node_Id); end Exp_Attr; em_ch5.ads ¨¸ï sem_ch5.adb ¼¸ð sem_ch6.ads Ðgnat-1.67-src/src/exp_prag.ads 444 10015 7640 3643 5506244322 11417 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ P R A G -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Expand routines for pragmas with Types; use Types; package Exp_Prag is procedure Expand_N_Pragma (N : Node_Id); end Exp_Prag; sem_ch5.ads ¨¸ï sem_ch5.adb ¼¸ð sem_ch6.ads иñ sem_ch6.adb ä¸ògnat-1.67-src/src/exp_prag.adb 444 10015 7640 13630 5506244323 11414 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ P R A G -- -- -- -- B o d y -- -- -- -- $Revision: 1.10 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Comperr; use Comperr; with Exp_Util; use Exp_Util; with Nmake; use Nmake; with Opt; use Opt; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sinfo; use Sinfo; with Tbuild; use Tbuild; with Snames; use Snames; package body Exp_Prag is ----------------------- -- Local Subprograms -- ----------------------- function Arg1 (N : Node_Id) return Node_Id; function Arg2 (N : Node_Id) return Node_Id; function Arg3 (N : Node_Id) return Node_Id; -- Obtain specified Pragma_Argument_Association procedure Expand_Pragma_Abort_Defer (N : Node_Id); procedure Expand_Pragma_Interrupt_Priority (N : Node_Id); -------------- -- Arg1,2,3 -- -------------- function Arg1 (N : Node_Id) return Node_Id is begin return First (Pragma_Argument_Associations (N)); end Arg1; function Arg2 (N : Node_Id) return Node_Id is begin return Next (Arg1 (N)); end Arg2; function Arg3 (N : Node_Id) return Node_Id is begin return Next (Arg2 (N)); end Arg3; --------------------- -- Expand_N_Pragma -- --------------------- procedure Expand_N_Pragma (N : Node_Id) is begin case Get_Pragma_Id (Chars (Identifier (N))) is -- Pragmas requiring special expander action when Pragma_Abort_Defer => Expand_Pragma_Abort_Defer (N); when Pragma_Interrupt_Priority => Expand_Pragma_Interrupt_Priority (N); -- All other pragmas need no expander action when others => null; end case; end Expand_N_Pragma; ------------------------------- -- Expand_Pragma_Abort_Defer -- ------------------------------- -- An Abort_Defer pragma appears as the first statement in a handled -- statement sequence (right after the begin). It defers aborts for -- the entire statement sequence, but not for any declarations or -- handlers (if any) associated with this statement sequence. -- With the current approach of explicit calls to Abort_Defer and -- Abort_Undefer, we accomplish this by inserting a call to Abort_Defer -- at the end of the associated declarations, and a call to Abort_Undefer -- at the end of the sequence of statements. In addition, if there are -- any exception handlers, a call to Abort_Undefer is placed at the start -- of the statements of each of the handlers. procedure Expand_Pragma_Abort_Defer (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); HSS : constant Node_Id := Parent (N); -- The N_Handled_Sequence_Of_Statements node P : constant Node_Id := Parent (HSS); -- The parent of the handled sequence has the declarations EH : Node_Id; -- An exception handler begin pragma Assert (Nkind (HSS) = N_Handled_Sequence_Of_Statements, Compiler_Abort (HSS)); if Declarations (P) = No_List then Set_Declarations (P, New_List); end if; Append_To (Declarations (P), Build_Call (Loc, RTE (RE_Abort_Defer))); Append_To (Statements (HSS), Build_Call (Loc, RTE (RE_Abort_Undefer))); if List_Present (Exception_Handlers (HSS)) then EH := First (Exception_Handlers (HSS)); while Present (EH) loop Prepend_To (Statements (EH), Build_Call (Loc, RTE (RE_Abort_Undefer))); EH := Next (EH); end loop; end if; end Expand_Pragma_Abort_Defer; -------------------------------------- -- Expand_Pragma_Interrupt_Priority -- -------------------------------------- -- Supply default argument if none exists (System.Interrupt_Priority'Last) procedure Expand_Pragma_Interrupt_Priority (N : Node_Id) is begin if Pragma_Argument_Associations (N) = No_List then Set_Pragma_Argument_Associations (N, New_List_1 ( Make_Pragma_Argument_Association (Sloc (N), Expression => Make_Attribute_Reference (Sloc (N), Prefix => RTE (RE_Interrupt_Priority), Identifier => Make_Identifier (Sloc (N), Name_Last))))); end if; end Expand_Pragma_Interrupt_Priority; end Exp_Prag; ¹I a-trans.hs.Œ¹J a-tree.def. ¹K a-atree.h.d´¹L a-types.he.ȹMgnat-1.67-src/src/exp_util.ads 444 10015 7640 16344 5506244323 11466 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ U T I L -- -- -- -- S p e c -- -- -- -- $Revision: 1.12 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Package containing utility procedures used throughout the expander with Types; use Types; package Exp_Util is Expander_Active : Boolean := False; -- A flag that indicates if expansion is active (True) or deactivated -- (False). When expansion is deactivated all calls to expander routines -- have no effect. Note that the initial setting of False is merely to -- prevent saving of an undefined value for an initial call to the -- Expander_Mode_Save_And_Set procedure. function Build_Call (Loc : Source_Ptr; E : Entity_Id) return Node_Id; -- Build an N_Procedure_Call node that references the given entity -- The call has no parameters. The first argument provides the location -- information for the tree and for error messages. The call is properly -- analyzed and resolved before it is returned. procedure Expander_Mode_Save_And_Set (Status : Boolean); -- Saves the current setting of the Expander_Active flag on an internal -- stack and then sets the flag to the given value. procedure Expander_Mode_Restore; -- Restores the setting of the Expander_Active flag using the top entry -- pushed onto the stack by Expander_Mode_Save_And_Reset, popping the -- stack, except that if any errors have been detected, then the state -- of the flag is left set to False. procedure Expand_Class_Allocator (N : Node_Id; Acc_Type : Entity_Id; Class_Subtype : Entity_Id); -- Uses Expand_Class_Subtype to expand a new class subtype then -- transforms "new T'Class'(Exp)" into: -- Acc_Type (new Equiv_T'(Equiv_T (Exp))) function Expand_Class_Subtype (Loc : Source_Ptr; Typ : Entity_Id; Exp : Node_Id) return List_Id; -- When a Class_Subtype value is encountered, that is to say in such -- cases as: -- X: T'Class := Exp -- new T'Class'(Exp) -- this function generates the list of declarations defining a record -- of the following form : -- type anon is record -- _parent : Root_Type_Of (Typ) constrained with Exp discriminants; -- Extension : String (1 .. expr to match size of Exp); -- end record; -- This record is compatible with any value of T'Class thanks to the -- first field and has the same size as Exp thanks to the second field. -- This record is attached to the Subclass by its Equivalent_Type field. function Expand_Array_Equality (Loc : Source_Ptr; Typ : Entity_Id; Lhs, Rhs : Node_Id) return Node_Id; -- Expand an array equality into an expression-action containing a local -- function implementing this equality, and a call to it. Loc is the -- location for the generated nodes. Typ is the type of the array, and -- Lhs, Rhs are the array expressions to be compared. function Expand_Record_Equality (Loc : Source_Ptr; Typ : Entity_Id; Lhs, Rhs : Node_Id) return Node_Id; -- Expand a record equality into an expression that compares the fields -- individually to yield the required Boolean result. Loc is the location -- for the generated nodes. Typ is the type of the record, and Lhs, Rhs -- are the record expressions to be compared. Note that the case of -- variant records is not implemented yet ???. procedure Expand_Subtype_From_Expr (N : Node_Id; T : Entity_Id); -- Build subtype from initial value in object declarations -- where the object definition is an unconstrained type. procedure Expand_Tagged_Extension (Def : Node_Id); -- Add a field _parent at the beginning of the record. This field -- contains a value of the Parent Type. It is used to implement inheritance -- Here is an example of expansion : -- type T2 (B, C : Int) is new T1 (A => B) with record -- _Parent : T1 (A => B); <--- this is the expanded field -- D : Int; -- end; procedure Expand_Tagged_Root (Def : Node_Id); -- Add a field _Tag at the beginning of the record. This field carries the -- value of the access to the Dispatch table. It is converted to -- Ada-Tags.Tag type in order to be uniformely typed among descendants. -- It is converted back to an Access To Dispatch Table just before the -- dispatching call. This procedure is only called on the root type, -- the _Tag field being inherited by the descendent. procedure Protect_Statements (N : Node_Id; E : Entity_Id); -- This function protects the handled statement sequence of node N by -- adding a cleanup that is a call to the procedure referenced by the -- entity E. If necessary (if the handled statement sequence already has -- an exception handler, or a cleanup), an extra block is wrapped around. procedure Traceback_Store (N : Node_Id; Anal : Boolean := True); -- Constructs call node to the Store_Tb traceback store function and -- inserts the call before the node N. This construction and insertion -- happens only if Debug_Flag_B is set, otherwise the call has no effect. -- Also the insertion is suppressed if it duplicates an adjacent call, -- or if the unit containing the node N is not the main unit. Normally -- the call is analyzed before it is inserted. If Anal is set to False -- the call to Analyze is suppressed in which case the caller must -- ensure that a subsequent call to Analyze is made for the node. end Exp_Util; ht.¹C a-string.h.¹D a-trans3.cg(¹E a-trans3.h3<¹F a-trans4.c3P¹G a-trans4.h4d¹H a-trans.cs4x¹I a-trans.hs.Œ¹J a-tree.def. ¹K a-atree.h.d´¹L a-types.he.ȹMa-uint.ces.ܹNa-uignat-1.67-src/src/exp_util.adb 444 10015 7640 112543 5506244324 11464 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ U T I L -- -- -- -- B o d y -- -- -- -- $Revision: 1.24 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Debug; use Debug; with Einfo; use Einfo; with Errcount; use Errcount; with Lib; use Lib; with Namet; use Namet; with Nmake; use Nmake; with Opt; use Opt; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Ch13; use Sem_Ch13; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Sinput; use Sinput; with Snames; use Snames; with Stand; use Stand; with Table; with Tbuild; use Tbuild; with Ttypes; use Ttypes; with Uintp; use Uintp; package body Exp_Util is ----------------------- -- Local Subprograms -- ----------------------- function Expand_Composite_Equality (Loc : Source_Ptr; Typ : Entity_Id; Lhs, Rhs : Node_Id) return Node_Id; -- Local recursive function used to expand equality for nested -- composite types. Used by Expand_Record_Equality, Expand_Array_Equality. ---------------- -- Local Data -- ---------------- -- The following table is used to save values of the Expander_Active -- flag when they are saved by Expander_Mode_Save_And_Set. We use an -- extendible table (which is a bit of overkill) because it is easier -- than figuring out a maximum value or bothering with range checks! package Expander_Flags is new Table ( Component_Type => Boolean, Index_Type => Int, Low_Bound => 0, Initial => 32, Increment => 200, Table_Name => "Expander_Flags"); ---------------- -- Build_Call -- ---------------- function Build_Call (Loc : Source_Ptr; E : Entity_Id) return Node_Id is Call : Node_Id; begin Call := Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (E, Loc)); Analyze (Call); Resolve_Subexpr (Call, Standard_Void_Type); return Call; end Build_Call; -------------------------------- -- Expander_Mode_Save_And_Set -- -------------------------------- procedure Expander_Mode_Save_And_Set (Status : Boolean) is begin Expander_Flags.Increment_Last; Expander_Flags.Table (Expander_Flags.Last) := Expander_Active; Expander_Active := Status; end Expander_Mode_Save_And_Set; --------------------------- -- Expander_Mode_Restore -- --------------------------- procedure Expander_Mode_Restore is begin Expander_Active := Expander_Flags.Table (Expander_Flags.Last); Expander_Flags.Decrement_Last; if Errors_Detected /= 0 then Expander_Active := False; end if; end Expander_Mode_Restore; ---------------------------- -- Expand_Class_Allocator -- ---------------------------- -- The Node N is assumed to be a N_Allocator with a N_Qualified_Expression -- in its expression field procedure Expand_Class_Allocator (N : Node_Id; Acc_Type : Entity_Id; Class_Subtype : Entity_Id) is Exp : constant Node_Id := Expression (Expression (N)); Loc : constant Source_Ptr := Sloc (N); List_Decl : List_Id; Equiv_Type : Entity_Id; begin -- Expand_Class_Allocator is called directly from the semantics, so we -- must check to see whether expansion is active before proceeding if not Expander_Active then return; end if; List_Decl := Expand_Class_Subtype (Loc, Class_Subtype, Exp); Equiv_Type := Equivalent_Type (Class_Subtype); Rewrite_Substitute_Tree (N, Make_Expression_Actions (Loc, Actions => List_Decl, Expression => Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (Acc_Type, Loc), Expression => Make_Allocator (Loc, Expression => Make_Qualified_Expression (Loc, Subtype_Mark => New_Reference_To (Equiv_Type, Loc), Expression => Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Reference_To (Equiv_Type, Loc), Expression => New_Copy (Exp))))))); Analyze (N); end Expand_Class_Allocator; -------------------------- -- Expand_Class_Subtype -- -------------------------- -- Create a record type used as an equivalent of any member of the class -- which takes its size from exp. -- Generate the following code: -- type Equiv_T is record -- _parent : T (List of discriminant constaints taken from Exp); -- Ext__50 : String (1 .. (Exp'size - Typ'size) / Character'size); -- end Equiv_T; function Expand_Class_Subtype (Loc : Source_Ptr; Typ : Entity_Id; Exp : Node_Id) return List_Id is Root_Type : constant Entity_Id := Etype (Typ); D : Entity_Id; Equiv_Type : Entity_Id; Range_Type : Entity_Id; Str_Type : Entity_Id; List_Def : List_Id := Empty_List; Constr_Root : Entity_Id; List_Constr : List_Id; begin -- ??? Exp should be evaluate once but it causes mysterious bug in the -- code generation, sso it is commented out till further investigation -- Set_Evaluate_Once (Exp, True); -- subtype cstr__n is T (List of discriminant constaints taken from Exp) if not Has_Discriminants (Root_Type) then Constr_Root := Root_Type; else List_Constr := New_List; D := First_Discriminant (Root_Type); while (Present (D)) loop Append_To (List_Constr, Make_Selected_Component (Loc, Prefix => New_Copy (Exp), Selector_Name => New_Reference_To (D, Loc))); D := Next_Discriminant (Root_Type); end loop; Constr_Root := Make_Defining_Identifier (Loc, New_Internal_Name ("cstr")); Append_To (List_Def, Make_Full_Type_Declaration (Loc, Defining_Identifier => Constr_Root, Type_Definition => Make_Derived_Type_Definition (Loc, Subtype_Indication => Make_Subtype_Indication (Loc, Subtype_Mark => New_Reference_To (Root_Type, Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => List_Constr))))); end if; -- subtype rg__xx is Positive range -- (Exp'size - typ'size) / Character'Size Range_Type := Make_Defining_Identifier (Loc, New_Internal_Name ("rg")); Append_To (List_Def, Make_Subtype_Declaration (Loc, Defining_Identifier => Range_Type, Subtype_Indication => Make_Subtype_Indication (Loc, Subtype_Mark => New_Reference_To (Standard_Positive, Loc), Constraint => Make_Range_Constraint (Loc, Range_Expression => Make_Range (Loc, Low_Bound => Make_Integer_Literal (Loc, Uint_1), High_Bound => Make_Op_Divide (Loc, Left_Opnd => Make_Op_Subtract (Loc, Left_Opnd => Make_Attribute_Reference (Loc, Prefix => New_Copy (Exp), Identifier => Make_Identifier (Loc, Name_Size)), Right_Opnd => Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Constr_Root, Loc), Identifier => Make_Identifier (Loc, Name_Size)), Parens => True), Right_Opnd => Make_Integer_Literal (Loc, Intval => UI_From_Int (Standard_Character_Size)))))))); -- subtype str__nn is String (rg__x); Str_Type := Make_Defining_Identifier (Loc, New_Internal_Name ("str")); Append_To (List_Def, Make_Subtype_Declaration (Loc, Defining_Identifier => Str_Type, Subtype_Indication => Make_Subtype_Indication (Loc, Subtype_Mark => New_Reference_To (Standard_String, Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => New_List_1 (New_Reference_To (Range_Type, Loc)))))); -- type Equiv_T is record -- _parent : ityp__n; -- E : Str_Type; -- end Equiv_T; Equiv_Type := Make_Defining_Identifier (Loc, New_Internal_Name ("ityp")); Append_To (List_Def, Make_Full_Type_Declaration (Loc, Defining_Identifier => Equiv_Type, Type_Definition => Make_Record_Definition (Loc, Component_List => Make_Component_List (Loc, Component_Declarations => New_List_2 ( Make_Component_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uParent), Subtype_Indication => New_Reference_To (Constr_Root, Loc)), Make_Component_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Chars => New_Internal_Name ("ext")), Subtype_Indication => New_Reference_To (Str_Type, Loc))), Variant_Part => Empty)))); D := First (List_Def); -- Insert remaining implicit types before analyzing if Is_Non_Empty_List (Implicit_Type_List) then Insert_List_Before (D, Implicit_Type_List); Implicit_Type_List := New_List; end if; while (Present (D)) loop Analyze (D); D := Next (D); end loop; Set_Equivalent_Type (Typ, Equiv_Type); -- Insert the implicit node corresponding to the Class subtype -- after its equivalent type Append_To (List_Def, Make_Implicit_Type (Sloc (Typ), Typ)); Append_List_To (List_Def, Freeze_Entity (Equiv_Type)); return List_Def; end Expand_Class_Subtype; --------------------------- -- Expand_Array_Equality -- --------------------------- function Expand_Array_Equality (Loc : Source_Ptr; Typ : Entity_Id; Lhs, Rhs : Node_Id) return Node_Id is Decls : List_Id := New_List; Index_List1 : List_Id := New_List; Index_List2 : List_Id := New_List; Index : Entity_Id := First_Index (Typ); Index_Type : Entity_Id; Formals : List_Id; Result : Node_Id; Stats : Node_Id; Func_Name : Entity_Id; Func_Body : Node_Id; A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_A); B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_B); function Component_Equality (Typ : Entity_Id) return Node_Id; -- Create one statement to compare corresponding components, designated -- by a full set of indices. function Loop_One_Dimension (N : Int) return Node_Id; -- Loop over the n'th dimension of the arrays. The single statement -- in the body of the loop is a loop over the next dimension, or -- the comparison of corresponding components. ------------------------ -- Component_Equality -- ------------------------ function Component_Equality (Typ : Entity_Id) return Node_Id is Test : Node_Id; L, R : Node_Id; begin -- if a(i1...) /= b(j1...) then return false; end if; L := Make_Indexed_Component (Loc, Prefix => Make_Identifier (Loc, Chars (A)), Expressions => Index_List1); R := Make_Indexed_Component (Loc, Prefix => Make_Identifier (Loc, Chars (B)), Expressions => Index_List2); if Is_Record_Type (Component_Type (Typ)) or else Is_Array_Type (Component_Type (Typ)) then Test := Expand_Composite_Equality (Loc, Component_Type (Typ), L, R); else Test := Make_Op_Eq (Loc, Left_Opnd => L, Right_Opnd => R); end if; return Make_If_Statement (Loc, Condition => Make_Op_Not (Loc, Right_Opnd => Test), Then_Statements => New_List_1 ( Make_Return_Statement (Loc, Expression => New_Occurrence_Of (Standard_False, Loc)))); end Component_Equality; ------------------------ -- Loop_One_Dimension -- ------------------------ function Loop_One_Dimension (N : Int) return Node_Id is I : constant Entity_Id := Make_Defining_Identifier (Loc, New_Internal_Name ("i")); J : constant Entity_Id := Make_Defining_Identifier (Loc, New_Internal_Name ("j")); Stats : Node_Id; begin if N > Number_Dimensions (Typ) then return Component_Equality (Typ); else -- Generate the following: -- j: index_type := b'first (n); -- ... -- if a'length (n) /= b'length (n) then -- return false; -- else -- for i in a'range (n) loop -- -- loop over remaining dimensions. -- j := index_type'succ (j); -- end loop; -- end if; -- retrieve index type for current dimension. Index_Type := Base_Type (Etype (Index)); Append (New_Reference_To (I, Loc), Index_List1); Append (New_Reference_To (J, Loc), Index_List2); -- Declare index for j as a local variable to the function. -- Index i is a loop variable. Append (Make_Object_Declaration (Loc, Defining_Identifier => J, Object_Definition => New_Reference_To (Index_Type, Loc), Expression => Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Chars (B)), Identifier => Make_Identifier (Loc, Name_First), Expression => Make_Integer_Literal (Loc, UI_From_Int (N)))), Decls); Stats := Make_If_Statement (Loc, Condition => Make_Op_Ne (Loc, Left_Opnd => Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Chars (A)), Identifier => Make_Identifier (Loc, Name_Length), Expression => Make_Integer_Literal (Loc, UI_From_Int (N))), Right_Opnd => Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Chars (B)), Identifier => Make_Identifier (Loc, Name_Length), Expression => Make_Integer_Literal (Loc, UI_From_Int (N)))), Then_Statements => New_List_1 ( Make_Return_Statement (Loc, Expression => New_Occurrence_Of (Standard_False, Loc))), Else_Statements => New_List_1 ( Make_Loop_Statement (Loc, Identifier => Empty, Iteration_Scheme => Make_Iteration_Scheme (Loc, Loop_Parameter_Specification => Make_Loop_Parameter_Specification (Loc, Defining_Identifier => I, Discrete_Subtype_Definition => Make_Attribute_Reference (Loc, Prefix => New_Reference_To (A, Loc), Identifier => Make_Identifier (Loc, Name_Range), Expression => Make_Integer_Literal (Loc, UI_From_Int (N))))), Statements => New_List_2 ( Loop_One_Dimension (N + 1), Make_Assignment_Statement (Loc, Name => New_Reference_To (J, Loc), Expression => Make_Attribute_Reference (Loc, Prefix => New_Reference_To (Index_Type, Loc), Identifier => Make_Identifier (Loc, Name_Succ), Expression => New_Reference_To (J, Loc))))))); Index := Next_Index (Index); return Stats; end if; end Loop_One_Dimension; ------------------------------------------ -- Processing for Expand_Array_Equality -- ------------------------------------------ begin Formals := New_List_2 ( Make_Parameter_Specification (Loc, Defining_Identifier => A, Parameter_Type => New_Reference_To (Typ, Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => B, Parameter_Type => New_Reference_To (Typ, Loc))); Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ("eq")); Stats := Loop_One_Dimension (1); Func_Body := Make_Subprogram_Body (Loc, Specification => Make_Function_Specification (Loc, Defining_Unit_Name => Func_Name, Parameter_Specifications => Formals, Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)), Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List_1 (Stats))); Set_Has_Completion (Func_Name, True); Result := Make_Expression_Actions (Loc, Actions => New_List_1 (Func_Body), Expression => Make_Function_Call (Loc, Name => New_Reference_To (Func_Name, Loc), Parameter_Associations => New_List_2 (Lhs, Rhs))); return Result; end Expand_Array_Equality; ---------------------------- -- Expand_Record_Equality -- ---------------------------- -- For non-variant records Equality is expanded into: -- Lhs.Cmp1 = Rhs.Cmp1 -- and then Lhs.Cmp2 = Rhs.Cmp2 -- and then ... -- and then Lhs.Cmpn = Rhs.Cmpn -- -- The expression is folded by the back-end for adjacent fields. This -- function can be called for tagged records but only in the case of -- implemetation of predefined equality (see Predefined_Primitives_Bodies) function Expand_Record_Equality (Loc : Source_Ptr; Typ : Entity_Id; Lhs, Rhs : Node_Id) return Node_Id is function Build (Comp : Entity_Id) return Node_Id; -- Build recursively the sequence of components equalities using the -- equality (predefined or primitive) for each component type. function Build (Comp : Entity_Id) return Node_Id is Eq_Node : Node_Id; L, R : Node_Id; Next_Comp : Entity_Id := Next_Component (Comp); begin -- The inherited Components are skipped (they are part of the parent) while Present (Next_Comp) and then Next_Comp /= Original_Record_Component (Next_Comp) loop Next_Comp := Next_Component (Next_Comp); end loop; L := Make_Selected_Component (Loc, Prefix => Lhs, Selector_Name => New_Reference_To (Comp, Loc)); R := Make_Selected_Component (Loc, Prefix => Rhs, Selector_Name => New_Reference_To (Comp, Loc)); if Is_Record_Type (Etype (Comp)) or else Is_Array_Type (Etype (Comp)) then -- recursive call to deal with recursive composite types Eq_Node := Expand_Composite_Equality (Loc, Etype (Comp), L, R); else Eq_Node := Make_Op_Eq (Loc, Left_Opnd => L, Right_Opnd => R); end if; if No (Next_Comp) then return Eq_Node; else return Make_Op_And_Then (Loc, Left_Opnd => Eq_Node, Right_Opnd => Build (Next_Comp)); end if; end Build; -- Start of processing for Expand_Record_Equality begin -- Generates the following code: (assuming that component C2 is -- also a record) -- -- True -- -- Lhs.C1 = Rhs.C1 -- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn -- and then ... -- and then Lhs.Cmpn = Rhs.Cmpn if No (First_Component (Typ)) then return New_Reference_To (Standard_True, Loc); else return Build (First_Component (Typ)); end if; end Expand_Record_Equality; ------------------------------- -- Expand_Composite_Equality -- ------------------------------- -- This function is only called for comparing internal fields of composite -- types when these fields are themselves composites. This is a special -- case because it is not possible to respect normal Ada visibility rules. function Expand_Composite_Equality (Loc : Source_Ptr; Typ : Entity_Id; Lhs, Rhs : Node_Id) return Node_Id is Full_Type : Entity_Id; Prim : Elmt_Id; begin if Ekind (Typ) = E_Private_Type then Full_Type := Full_Declaration (Typ); else Full_Type := Typ; end if; Full_Type := Base_Type (Full_Type); if Is_Array_Type (Full_Type) then if Is_Scalar_Type (Component_Type (Full_Type)) then return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs); else return Expand_Array_Equality (Loc, Full_Type, Lhs, Rhs); end if; elsif Is_Tagged_Type (Full_Type) then -- Call the primitive operation "=" of this type if Is_Class_Type (Full_Type) then Full_Type := Etype (Full_Type); end if; Prim := First_Elmt (Primitive_Operations (Full_Type)); while Chars (Id_Of (Prim)) /= Name_Op_Eq loop Prim := Next_Elmt (Prim); pragma Assert (Prim /= No_Elmt); end loop; return Make_Function_Call (Loc, Name => New_Reference_To (Id_Of (Prim), Loc), Parameter_Associations => New_List_2 (Lhs, Rhs)); elsif Is_Record_Type (Full_Type) then return Expand_Record_Equality (Loc, Full_Type, Lhs, Rhs); else -- This procedure should only be called on composite types pragma Assert (False); return Empty; end if; end Expand_Composite_Equality; ------------------------------ -- Expand_Subtype_From_Expr -- ------------------------------ -- For an unconstained type T, change "Val : T := Expr;" into -- Val : T (Expr'First .. Expr'Last) := Expr; -- or if Expr is a String litteral or an array Aggregate -- Val : T (IndexTyp'first .. IndexTyp'first + Length (Expr) - 1) -- := Expr; procedure Expand_Subtype_From_Expr (N : Node_Id; T : Entity_Id) is Index_Typ : Entity_Id; New_Def : Node_Id; Loc : constant Source_Ptr := Sloc (N); begin -- Expand_Subtype_From_Expr is called directly from the semantics, so -- we must check to see whether expansion is active before proceeding. if not Expander_Active then return; end if; if Nkind (Original_Node (Expression (N))) = N_Aggregate then Unimplemented (N, "unconstrained decl. with aggregate init value"); return; elsif Is_Record_Type (T) then Unimplemented (N, "unconstrained record decl. with init value"); return; end if; Set_Evaluate_Once (Expression (N), True); if Nkind (Expression (N)) = N_String_Literal then -- the case: T (IndexTyp'first .. IndexTyp'first + Length(Expr) - 1) Index_Typ := Etype (First_Index (T)); New_Def := Make_Subtype_Indication (Loc, Subtype_Mark => New_Copy (Object_Definition (N)), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => New_List_1 ( Make_Range (Loc, Low_Bound => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Index_Typ, Loc), Identifier => Make_Identifier (Loc, Name_First)), High_Bound => Make_Op_Subtract (Loc, Left_Opnd => Make_Op_Add (Loc, Left_Opnd => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Index_Typ, Loc), Identifier => Make_Identifier (Loc, Name_First)), Right_Opnd => Make_Integer_Literal (Loc, String_Literal_Length (Etype (Expression (N))))), Right_Opnd => Make_Integer_Literal (Loc, Uint_1)))))); else -- The simple case : T (Expr'First .. Expr'Last) New_Def := Make_Subtype_Indication (Loc, Subtype_Mark => New_Copy (Object_Definition (N)), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => New_List_1 ( Make_Range (Loc, Low_Bound => Make_Attribute_Reference (Loc, Prefix => New_Copy (Expression (N)), Identifier => Make_Identifier (Loc, Name_First)), High_Bound => Make_Attribute_Reference (Loc, Prefix => New_Copy (Expression (N)), Identifier => Make_Identifier (Loc, Name_Last)))))); end if; -- Substitute the new tree Rewrite_Substitute_Tree (Object_Definition (N), New_Def); end Expand_Subtype_From_Expr; ----------------------------- -- Expand_Tagged_Extension -- ----------------------------- -- Add a field _parent at the beginning of the record. This field -- contains a value of the Parent Type. It is used to implement -- inheritance. Here is an example of expansion: -- type T2 (B, C : Int) is new T1 (A => B) with record -- _Parent : T1 (A => B); <--- this is the expanded field -- D : Int; -- end; procedure Expand_Tagged_Extension (Def : Node_Id) is Indic : constant Node_Id := Subtype_Indication (Def); Rec_Ext_Part : constant Node_Id := Record_Extension_Part (Def); Comp_List : constant Node_Id := Component_List (Rec_Ext_Part); Comp_Decl : Node_Id; Parent_N : Node_Id; Sloc_N : Source_Ptr; begin -- Expand_Tagged_Extension is called directly from the semantics, so -- we must check to see whether expansion is active before proceeding if not Expander_Active then return; end if; Sloc_N := Sloc (Comp_List); Parent_N := Make_Defining_Identifier (Sloc_N, Name_uParent); Comp_Decl := Make_Component_Declaration (Sloc_N, Defining_Identifier => Parent_N, Subtype_Indication => New_Copy (Indic)); if Null_Present (Rec_Ext_Part) then Set_Component_List ( Rec_Ext_Part, Make_Component_List (Sloc_N, Component_Declarations => New_List_1 (Comp_Decl), Variant_Part => Empty, Null_Present => False)); Set_Null_Present (Rec_Ext_Part, False); elsif Is_Empty_List (Component_Declarations (Comp_List)) then Set_Component_Declarations (Comp_List, New_List_1 (Comp_Decl)); else Insert_Before (First (Component_Declarations (Comp_List)), Comp_Decl); end if; end Expand_Tagged_Extension; ------------------------ -- Expand_Tagged_Root -- ------------------------ procedure Expand_Tagged_Root (Def : Node_Id) is Comp_List : Node_Id; Comp_Decl : Node_Id; Tag_N : Node_Id; Sloc_N : Source_Ptr; begin -- Expand_Tagged_Root is called directly from the semantics, so we -- must check to see whether expansion is active before proceeding if not Expander_Active then return; end if; if Null_Present (Def) then Set_Component_List (Def, Make_Component_List (Sloc (Def), Component_Declarations => Empty_List, Variant_Part => Empty, Null_Present => True)); end if; Comp_List := Component_List (Def); if Null_Present (Comp_List) then Sloc_N := Sloc (Comp_List); else Sloc_N := Sloc (First (Component_Declarations (Comp_List))); end if; Tag_N := Make_Defining_Identifier (Sloc_N, Name_uTag); Comp_Decl := Make_Component_Declaration (Sloc_N, Defining_Identifier => Tag_N, Subtype_Indication => New_Reference_To (RTE (RE_Tag), Sloc_N)); if Null_Present (Comp_List) then Set_Component_Declarations (Comp_List, New_List_1 (Comp_Decl)); Set_Null_Present (Comp_List, False); else Insert_Before (First (Component_Declarations (Comp_List)), Comp_Decl); end if; end Expand_Tagged_Root; ------------------------ -- Protect_Statements -- ------------------------ procedure Protect_Statements (N : Node_Id; E : Entity_Id) is Loc : constant Source_Ptr := Sloc (N); Stm : constant Node_Id := Handled_Statement_Sequence (N); begin -- If the existing statement sequence has no exception handlers, then -- all we need to do is to add the specified cleanup call. If there -- are exception handlers present, then we have to wrap an extra -- block around to hold the cleanup call because of the current rule -- that a block cannot have both a cleanup and exception handlers. if Exception_Handlers (Stm) = No_List and then No (Identifier (Stm)) then Set_Identifier (Stm, New_Occurrence_Of (E, Loc)); else Set_Handled_Statement_Sequence (N, Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List_1 ( Make_Block_Statement (Loc, Identifier => Empty, Handled_Statement_Sequence => Stm)), Identifier => New_Occurrence_Of (E, Loc))); end if; end Protect_Statements; --------------------- -- Traceback_Store -- --------------------- procedure Traceback_Store (N : Node_Id; Anal : Boolean := True) is Loc : constant Source_Ptr := Sloc (N); Call : Node_Id; Vname : Name_Id; Kind : Node_Kind; Prv : Node_Id; Unum : Unit_Number_Type; Unit_Node : Node_Id; Sparm : Node_Id; begin -- Immediate return if traceback flag is off, nothing to do if not Debug_Flag_B then return; end if; -- Immediate return if the node we are inserting before is another -- traceback store node (stops an infinite loop!) if Nkind (N) = N_Procedure_Call_Statement and then Nkind (Name (N)) = N_Identifier and then Entity (Name (N)) = RTE (RE_Store_TB) then return; end if; -- Immediate return if we are inserting immediately after another -- traceback store node (this is just to avoid unnecssary calls) Prv := Prev (N); if Present (Prv) and then Nkind (Prv) = N_Procedure_Call_Statement and then Nkind (Name (Prv)) = N_Identifier and then Entity (Name (Prv)) = RTE (RE_Store_TB) then return; end if; -- Immediate return if not main unit, or a subunit. All other units -- are being compiled for subsidiary use and do not need traceback -- calls inserted (furthermore, if they did have calls inserted, we -- get into trouble with System.Traceback itself! Unum := Get_Sloc_Unit_Number (Loc); if Unum /= Main_Unit and then Nkind (Unit (File.Table (Unum).Cunit)) /= N_Subunit then return; end if; -- Conditions for the generation of the traceback call are met. The -- call to be generated has one of the forms: -- Store_TB (linenum, Version_x'Address, _TB_Snam'Address); -- Store_TB (linenum, Version_x'Address, Null_Address); -- where Version_x is Version_B in a file that is a body, and -- Version_S in a file that is a spec. The null address form -- is used when no current subprogram name is visible. -- First decide whether to use to spec or body version, or to -- abandon generating anything (happens in generic unit case) Unit_Node := Unit (File.Table (Unum).Cunit); if Nkind (Unit_Node) = N_Subunit then Unit_Node := Proper_Body (Unit_Node); end if; if Nkind (Unit_Node) = N_Package_Declaration then Vname := Name_Version_S; elsif Nkind (Unit_Node) = N_Subprogram_Body or else Nkind (Unit_Node) = N_Package_Body then Vname := Name_Version_B; -- In some unit, probably a generic, where it makes no sense to -- generate traceback data in any case. else return; end if; -- Figure out what we need as third parameter if Present (Get_Name_Entity_Id (Name_uTB_Snam)) then Sparm := Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Name_uTB_Snam), Identifier => Make_Identifier (Loc, Name_Address)); else Sparm := New_Reference_To (RTE (RE_Null_Address), Loc); end if; -- Now build the call Call := Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (RTE (RE_Store_TB), Loc), Parameter_Associations => New_List_3 ( Make_Integer_Literal (Loc, Intval => UI_From_Int (Int (Get_Line_Number (Loc)))), Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Vname), Identifier => Make_Identifier (Loc, Name_Address)), Sparm)); if Anal then Analyze (Call); end if; Insert_Before (N, Call); end Traceback_Store; end Exp_Util; ef); Comp_List : constant Node_Id := Component_List (Rec_Ext_Part); Comp_Decl : Node_Id; Parent_N : Node_Id; Sloc_N :gnat-1.67-src/src/fname.ads 444 10015 7640 11652 5506244324 10721 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- F N A M E -- -- -- -- S p e c -- -- -- -- $Revision: 1.7 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This package defines the association between source file names and -- unit names as defined in package Uname. with Types; use Types; package Fname is -- Note: this package spec does not depend on the Uname spec in the Ada -- sense, but the comments and description of the semantics do depend on -- the conventions established by Uname, which explains the "with Uname". --------------------------- -- File Name Conventions -- --------------------------- -- GNAT requires that there be a one to one correspondence between source -- file names (as used in the Osint package interface) and unit names as -- defined by the Uname package. This correspondence is defined by the -- two subprograms defined here in the Fname package. -- The body of this package is potentially system dependent, since file -- naming conventions do differ from operating system to operating system. -- However, the code in the body of Fname does not typically require any -- operating system interface, and furthermore, we choose a convention -- that is likely to be widely implementable, and certainly is one that -- can be shared between Unix, DOS, NT, Mac OS and OS/2. -- Since we do expect this convention to be followed widely, and since -- Osint depends on the convention, it is described here in the Spec. -- However, no unit (other than Osint) in any way depends on the choices -- described here. -- Unit names are the Ada names, with all upper case letters, and a suffix -- that is either %b or %s for bodies and specs respectively. This is the -- convention described and implemented in package Uname. -- Source file names are obtained by taking the unit name, excluding the -- %b or %s, and replacing all upper case letters with lower case and -- periods with minus signs. The extension is either ads or adb for a -- spec or body respectively. -- The rules in Ada 83 mode are identical, except identical, except that in -- the case of subunit names with more than two components, the inner names -- and their associated dashes are omitted (this corresponds to the Ada/83 -- rule that subunits have to be unique in their first and last names). -- Examples of these rules are -- Unit name File name (9X) File name (83) -- PACKGE1%s packge.ads package.ads -- PACKGE1%b packge.adb packge.adb -- SCN.NLIT%b scn-nlit.adb scn-nlit.adb -- CHILD.PKG%s child-pkg.ads child-pkg.ads -- XYZ.ARG.LMS%b xyz-arg-lms.adb xyz-lms.adb -- ABC.DEF.GHI%s abc-def-ghi.ads (no child units) -- Note that the file name does *not* include the directory name. The -- management of directories is completely hidden in the Osint body. ----------------- -- Subprograms -- ----------------- function Get_File_Name (Uname : Unit_Name_Type) return File_Name_Type; -- This function returns the file name that corresponds to a given unit -- name. The caller is responsible for ensuring that the unit name meets -- the requirements given in package Uname. end Fname; ake.adb ¹v nmake.ads procedure Protect_Statements (N : Node_Id; E : Entitgnat-1.67-src/src/fname.adb 444 10015 7640 15734 5506244324 10705 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- F N A M E -- -- -- -- B o d y -- -- -- -- $Revision: 1.16 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Csets; use Csets; with Comperr; use Comperr; with Namet; use Namet; with Opt; use Opt; with Osint; use Osint; package body Fname is ------------------- -- Get_File_Name -- ------------------- function Get_File_Name (Uname : Unit_Name_Type) return File_Name_Type is Max_Namelen : Int; Uname_Ptr : Int; Fname_Ptr : Int; Unit_Char : Char; -- 's' or 'b' for spec or body begin Max_Namelen := System_Maximum_File_Name_Length; if Maximum_File_Name_Length < Max_Namelen then Max_Namelen := Maximum_File_Name_Length; end if; Get_Name_String (Uname); Uname_Ptr := 1; Fname_Ptr := 0; while Name_Buffer (Uname_Ptr) /= '%' loop pragma Assert (Uname_Ptr <= Name_Len, Compiler_Abort); -- missing % -- Special treatment for period if Name_Buffer (Uname_Ptr) = '.' then Fname_Ptr := Fname_Ptr + 1; Name_Buffer (Fname_Ptr) := '-'; -- Otherwise just copy character, folding to lower case else Fname_Ptr := Fname_Ptr + 1; Name_Buffer (Fname_Ptr) := Fold_Lower (Name_Buffer (Uname_Ptr)); end if; Uname_Ptr := Uname_Ptr + 1; end loop; Unit_Char := Name_Buffer (Uname_Ptr + 1); -- The file name (minus the extension) to be used is stored in -- Name_Buffer (1 .. Fname_Ptr). If it's too long then crunch it. if Fname_Ptr > Max_Namelen then -- First step in the crunch is to replace an initial System- by -- s- and an initial Ada- by a- to crunch runtime library file names if Fname_Ptr > 7 and then Name_Buffer (1 .. 7) = "system-" then Name_Buffer (1) := 's'; Name_Buffer (2) := '-'; for I in 8 .. Fname_Ptr loop Name_Buffer (I - 5) := Name_Buffer (I); end loop; Fname_Ptr := Fname_Ptr - 5; elsif Fname_Ptr > 4 and then Name_Buffer (1 .. 4) = "ada-" then Name_Buffer (1) := 'a'; Name_Buffer (2) := '-'; for I in 5 .. Fname_Ptr loop Name_Buffer (I - 2) := Name_Buffer (I); end loop; Fname_Ptr := Fname_Ptr - 2; end if; end if; -- If the file name is still too long, then next step is to remove -- all but the first and last components of a subunit or child name if Fname_Ptr > Max_Namelen then declare First_Minus : Int := Fname_Ptr; Last_Minus : Int := 0; begin for I in 1 .. Fname_Ptr loop if Name_Buffer (I) = '-' then First_Minus := I; exit; end if; end loop; for I in reverse 1 .. Fname_Ptr loop if Name_Buffer (I) = '-' then Last_Minus := I; exit; end if; end loop; if First_Minus < Last_Minus then Name_Buffer (First_Minus .. First_Minus + Fname_Ptr - Last_Minus) := Name_Buffer (Last_Minus .. Fname_Ptr); Fname_Ptr := Fname_Ptr - (Last_Minus - First_Minus); end if; end; end if; -- If that did not do the trick, we are still too long, so now -- is the time for the real crunching operation. The crunching -- algorithm is as follows: -- Divide the name into pieces delimited by underscores or minus signs -- Find the longest piece (leftmost if two are equally long) -- Remove last character of this piece -- Repeat until name is short enough while Fname_Ptr > Max_Namelen loop declare Long_Length : Int := 0; Long_Last : Int := 0; Piece_Start : Int; Ptr : Int; begin Ptr := 1; -- Loop through pieces to find longest piece while Ptr <= Fname_Ptr loop Piece_Start := Ptr; -- Loop through characters in one piece of name while Ptr <= Fname_Ptr and then Name_Buffer (Ptr) /= '_' and then Name_Buffer (Ptr) /= '-' loop Ptr := Ptr + 1; end loop; if Ptr - Piece_Start > Long_Length then Long_Length := Ptr - Piece_Start; Long_Last := Ptr - 1; end if; Ptr := Ptr + 1; end loop; -- Remove last character of longest piece Name_Buffer (Long_Last .. Fname_Ptr - 1) := Name_Buffer (Long_Last + 1 .. Fname_Ptr); Fname_Ptr := Fname_Ptr - 1; end; end loop; -- Here with the file name set and of OK length, add the extension Fname_Ptr := Fname_Ptr + 1; Name_Buffer (Fname_Ptr) := '.'; Fname_Ptr := Fname_Ptr + 1; Name_Buffer (Fname_Ptr) := 'a'; Fname_Ptr := Fname_Ptr + 1; Name_Buffer (Fname_Ptr) := 'd'; Fname_Ptr := Fname_Ptr + 1; Name_Buffer (Fname_Ptr) := Unit_Char; Name_Len := Fname_Ptr; return File_Name_Type (Name_Find); end Get_File_Name; end Fname; e node (this is just to avoid unnecsgnat-1.67-src/src/frontend.ads 444 10015 7640 3612 5506244325 11430 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- F R O N T E N D -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Top level of the front-end. This procedure is used by the different -- gnat drivers. procedure Frontend; sem_attr.ads p¸á sem_attr.adbd_a ˆ¸â sem_ch10.ads gn  ¸ã sem_ch10.adbgnu ¸¸ä sem_gnat-1.67-src/src/frontend.adb 444 10015 7640 10051 5506244325 11422 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- F R O N T E N D -- -- -- -- B o d y -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Errout; use Errout; with Lib; use Lib; with Namet; use Namet; with Opt; use Opt; with Output; use Output; with Par; with Rtsfind; use Rtsfind; with Sprint; use Sprint; with Scn; use Scn; with Sem; use Sem; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; with Treepr; use Treepr; with Types; use Types; with Uintp; use Uintp; with Usage; procedure Frontend is begin -- Carry out package initializations. These are initializations which -- might logically be performed at elaboration time, were it not for -- the fact that we may be doing things more than once in the big loop -- over files. Like elaboration, the order in which these calls are -- made is in some cases important. For example, Lib cannot be -- initializd until Namet, since it uses names table entries. Initialize_Uint; Initialize_Errout; Initialize_Namet; Initialize_Snames; Initialize_Rtsfind; Initialize_Stringt; Initialize_Atree; Initialize_Lib; Initialize_Scanner (Main_Unit); if Verbose_Mode or Full_List then Write_Eol; if Operating_Mode = Generate_Code then Write_String ("Compiling: "); else Write_String ("Checking: "); end if; Write_Name (File.Table (Main_Unit).File_Name); Write_Eol; end if; Create_Standard; -- Here we call the parser to parse the compilation unit Par; -- If fatal error occurred, then reset mode to syntax check only if File.Table (Main_Unit).Fatal_Error then Operating_Mode := Check_Syntax; end if; -- Do dumps requested by appropriate debug flags. Note that these -- calls are done after resetting the operating mode, so that if -- we are in the last phase now, Operaing_Mode will indicate this. Tree_Dump ('P'); Source_Dump ('P'); -- Now run the semantics unless syntax only mode. Note that we -- alread set syntax only mode if a fatal error was detected. if Operating_Mode /= Check_Syntax then Semantics (File.Table (Main_Unit).Cunit); -- Do post semantics dumps Tree_Dump ('S'); Source_Dump ('S'); end if; -- List units if option set. if List_Units then Lib.List; end if; end Frontend; x¹V bcheck.ads„Œ¹W bcheck.adbd ¹X binde.adsÙL´¹Y binde.adbÙ<ȹZ binderr.adsܹ[ binderr.adbð¹\ bindgen.ads¹] bindgen.adb¹^ bindusg.ads,¹_ bindusg.adb@¹` butil.adsØHT¹a butil.adbØ$l¹b gnatbind.adb'ô„¹c frontdrv.ads“†œ¹d frontdrv.adbÿ×È°¹exref.adsĹfxref.adbÿנܹg xref_tab.ads(˜¹h xref_tab.adbgnat-1.67-src/src/gnat1drv.ads 444 10015 7640 4026 5506244325 11337 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- G N A T 1 D R V -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Main procedure for the GNAT compiler -- This driver can only process one main unit at a time, accordingly to some -- gcc restriction. -- -- Basic cycle : -- -- file.ad[sb] ---> front-end ---> back-end ---> file.o -- -- procedure Gnat1drv; bT¸Ô rtsfind.adsh¸Õ rtsfind.adbˆ¸Ö$system-traceback.adb ¨¸×$system-traceback.adsè¼¸Ø scans.adsи٠scans.adb à¸Úscn.adsø¸Û scn-nlit.adb€ ¸Ü scn-slit.adb  ¸Ýscn.adb 0¸Þsem.ads @¸ßsem.adb X¸à sem_attr.ads`d p¸á sem_attr.adb€ ˆ¸â sem_ch10.ads&   ¸ã sem_ch10.adb&  ¸¸ä sem_ch11.ads‚?ÿ иå sem_ch11.adb‚¿ÿ è¸æ sem_gnat-1.67-src/src/gnat1drv.adb 444 10015 7640 14064 5506244326 11342 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- G N A T 1 D R V -- -- -- -- B o d y -- -- -- -- $Revision: 1.4 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Comperr; use Comperr; with Csets; use Csets; with Back_End; with Errcount; use Errcount; with Errout; use Errout; with Excep; use Excep; with Frontend; with Gnatvsn; use Gnatvsn; with Lib; use Lib; with Namet; use Namet; with Opt; use Opt; with Osint; use Osint; with Output; use Output; with Par; with Sinfo; use Sinfo; with System.Assertions; with Types; use Types; with Usage; procedure Gnat1drv is Main_Unit_Node : Node_Id; -- Compilation unit node for main unit Main_Kind : Node_Kind; -- Kind of main compilation unit node. begin Initialize_OS_Interface (Compiler); Initialize_Char_Tables; if Verbose_Mode or Full_List then Write_Eol; Write_String ("NYU GNAT Compiler Version "); Write_String (Gnat_Version_String); Write_String (" (C) Copyright NYU, 1992-1993"); Write_Eol; end if; Frontend; if Errors_Detected /= 0 then Finalize_Error_Output; Exit_Program (E_Errors); elsif Operating_Mode /= Generate_Code then Finalize_Lib; Finalize_Namet; return; end if; -- Check for unit that generates no code, and if so, generate -- warning message and suppress expander and code generation. Main_Unit_Node := File.Table (Main_Unit).Cunit; Main_Kind := Nkind (Unit (Main_Unit_Node)); -- Generate code for subprogram bodies only if they have -- a corresponding non-generic subprogram declaration. Note -- that the check for No (Library_Unit) here is a defensive -- check that should not be necessary, since the Library_Unit -- field should always be set properly. if Main_Kind = N_Subprogram_Body and then (No (Library_Unit (Main_Unit_Node)) or else Nkind (Unit (Library_Unit (Main_Unit_Node))) /= N_Generic_Subprogram_Declaration) then null; -- Generate code for package bodies only if they have -- a corresponding non-generic package declaration elsif Main_Kind = N_Package_Body and then (No (Library_Unit (Main_Unit_Node)) or else Nkind (Unit (Library_Unit (Main_Unit_Node))) /= N_Generic_Package_Declaration) then null; -- Generate code for package declarations that do not -- require a corresponding body elsif Main_Kind = N_Package_Declaration and then not Body_Required (Main_Unit_Node) then null; -- Compilation units that are renamings do not require -- bodies either. elsif Main_Kind = N_Package_Renaming_Declaration or else Main_Kind = N_Subprogram_Renaming_Declaration then null; -- In all other cases (specs which have bodies, and generics) -- we cannot generate code and we generate a warning message. -- Note that generic instantiations are gone at this stage -- since they have been replaced by their instances. else Write_String ("No code generated for this unit"); Write_Eol; return; end if; File.Table (Main_Unit).Generate_Code := True; -- If we have a corresponding spec, then we need object -- code for the spec unit as well if Nkind (Unit (Main_Unit_Node)) in N_Unit_Body and then not Acts_As_Spec (Main_Unit_Node) then File.Table (Get_Cunit_Unit_Number (Library_Unit (Main_Unit_Node))).Generate_Code := True; end if; -- Generate back end tables and library information Back_End; -- Only write the library if the backend did not generate any error -- messages. Otherwise signal errors to the driver program so that -- there will be no attempt to generate an object file. if Errors_Detected /= 0 then Finalize_Error_Output; Exit_Program (E_Errors); else Lib.Writ; Finalize_Lib; Finalize_Namet; end if; exception when Unrecoverable_Error => Finalize_Error_Output; Set_Standard_Error; Write_String ("compilation abandoned"); Write_Eol; Set_Standard_Output; Exit_Program (E_Errors); -- If we get an Assert failure, then we don't want to raise an unhandled -- exception, but rather to use the normal compilation abort mechanism when System.Assertions.Assert_Failure => Compiler_Error; Write_String ("internal error: assert failure"); Compiler_Abort; end Gnat1drv; -------------------------- -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- G N A T 1 D R V -- -- -- -- B ognat-1.67-src/src/gnatvsn.ads 444 10015 7640 5432 5506244326 11274 ----------------------------------------------------------------------------- -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- G N A T V S N -- -- -- -- S p e c -- -- -- -- $Revision: 1.59 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Gnatvsn is -- This package spec holds version information for GNAT and GBIND. It should -- be updated periodically to reflect changes and in partciular should be -- updated when bugs in the bug log are fixed. Gnat_Version_String : constant String := "1.67"; -- Version output when GNAT itself is run (in verbose mode) Gnatbind_Version_String : constant String := "1.13"; -- Version output when GNATBIND is run (in verbose mode) Gnatmake_Version_String : constant String := "1.01"; -- Version output when GNATMAKE is run Standard_Version : constant Str (1 .. 16) := "Generic V1.07 "; -- A string identifying the version of Standard. Used for library output -- and by the binder to check that all modules use the same version of -- Standard (otherwise the bind is not permitted). This is updated -- whenever a change to Standard, or any other interface or data -- structure, requires a complete recompilation of all modules. end Gnatvsn; p¹& table.adbna„¹' tbuild.ads ˜¹( tbuild.adbm¬¹) treepr.adsNÀ¹* treepr.adb:Ô¹+ treeprs.adtè¹, ttypes.adstü¹- ttypes.adts¹. types.ads $¹/ typegnat-1.67-src/src/lib-list.adb 444 10015 7640 11364 5506244326 11333 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- L I B . L I S T -- -- -- -- B o d y -- -- -- -- $Revision: 1.16 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Output; use Output; separate (Lib) procedure List is Num_Units : constant Int := Int (File.Last) - Int (File.First) + 1; -- Number of units in file table Sorted_Units : Unit_Ref_Table (1 .. Num_Units); -- Table of unit numbers that we will sort Unit_Node : Node_Id; -- Compilation unit node for current unit File_Length : constant := 26; -- Length of file name field in characters Unit_Length : constant := 22; -- Length of unit name field in characters Time_Length : constant := Time_Stamp_Length + 4; -- Length of time stamp field in characters Proc_Length : constant := 10; -- Length of processing field in characters Unit_Hed : constant Str (1 .. Unit_Length) := "Unit name "; Unit_Und : constant Str (1 .. Unit_Length) := "--------- "; Unit_Bln : constant Str (1 .. Unit_Length) := " "; File_Hed : constant Str (1 .. File_Length) := "File name "; File_Und : constant Str (1 .. File_Length) := "--------- "; File_Bln : constant Str (1 .. File_Length) := " "; Time_Hed : constant Str (1 .. Time_Length) := "Time stamp "; Time_Und : constant Str (1 .. Time_Length) := "---------- "; Proc_Hed : constant Str (1 .. Proc_Length) := "Processing"; Proc_Und : constant Str (1 .. Proc_Length) := "----------"; -- Labels for headers begin -- First step is to make a sorted table of units for I in 1 .. Num_Units loop Sorted_Units (I) := Unit_Number_Type (Int (File.First) + I - 1); end loop; Sort (Sorted_Units); -- Now we can generate the unit table listing Write_Eol; Write_Str (Unit_Hed); Write_Str (File_Hed); Write_Str (Time_Hed); Write_Str (Proc_Hed); Write_Eol; Write_Str (Unit_Und); Write_Str (File_Und); Write_Str (Time_Und); Write_Str (Proc_Und); Write_Eol; Write_Eol; for R in Sorted_Units'range loop if File.Table (Sorted_Units (R)).Source /= null then Unit_Node := File.Table (Sorted_Units (R)).Cunit; Write_Unit_Name (File.Table (Sorted_Units (R)).Unit_Name); if Name_Len > (Unit_Length - 1) then Write_Eol; Write_Str (Unit_Bln); else for I in Name_Len + 1 .. Unit_Length loop Write_Char (' '); end loop; end if; Write_Name (File.Table (Sorted_Units (R)).Full_File_Name); if Name_Len > (File_Length - 1) then Write_Eol; Write_Str (Unit_Bln); Write_Str (File_Bln); else for I in Name_Len + 1 .. File_Length loop Write_Char (' '); end loop; end if; Write_Str (File.Table (Sorted_Units (R)).Time_Stamp); if Analyzed (Unit_Node) then Write_Str (" (Par,Sem)"); else Write_Str (" (Par)"); end if; end if; Write_Eol; end loop; Write_Eol; end List; ut WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 witgnat-1.67-src/src/lib-load.adb 444 10015 7640 22623 5506244327 11300 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- L I B . L O A D -- -- -- -- B o d y -- -- -- -- $Revision: 1.19 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Debug; use Debug; with Output; use Output; with Par; with Scn; use Scn; separate (Lib) function Load (Uname : Unit_Name_Type; Required : Boolean; Enode : Node_Id) return Unit_Number_Type is Calling_Unit : Unit_Number_Type; -- Unit number of unit generating this call to Load (set only if -- Enode is present, otherwise undefined) Unum : Unit_Number_Type; -- Number of returned unit Fname : File_Name_Type := Get_File_Name (Uname); -- File name corresponding to unit name begin if Debug_Flag_L then Write_String ("*** Load request for unit: "); Write_Unit_Name (Uname); if Required then Write_String (" (Required = True)"); else Write_String (" (Required = False)"); end if; Write_Eol; end if; -- Capture error location if it is for the main unit. The idea is to post -- errors on the main unit location, not on the most recent invocation if Get_Sloc_Unit_Number (Sloc (Enode)) = Main_Unit then Load_Msg_Sloc := Sloc (Enode); end if; -- If we are generating error messages, then capture calling unit if Present (Enode) then Calling_Unit := Get_Sloc_Unit_Number (Sloc (Enode)); end if; -- See if we already have an entry for this unit Unum := File.First; while Unum <= File.Last loop exit when Uname = File.Table (Unum).Unit_Name; Unum := Unum + 1; end loop; -- Whether or not the entry was found, Unum is now the right value, since -- it is one more than File.Last (i.e. the index of the new entry we will -- create) in the not found case. -- A special check is necessary in the unit not found case. If the unit -- is not found, but the file in which it lives has already been loaded, -- then we have the problem that the file does not contain the unit that -- is needed. We simply treat this as a file not found condition. if Unum > File.Last then for I in File.First .. File.Last loop if Fname = File.Table (I).File_Name then if Present (Enode) then Error_Msg_Name_1 := Fname; Error_Msg_Unit_1 := Uname; Error_Msg ("~File{ does not contain unit$", Load_Msg_Sloc); Write_Dependency_Chain; end if; if Debug_Flag_L then Write_String ("*** File does not contain unit, Unit_Number = "); Write_Int (Int (Unum)); Write_Eol; end if; -- Build a dummy entry for this unit so that we do not keep -- repeating the message if the same unit is loaded again. File.Increment_Last; File.Table (Unum).Unit_Name := Uname; File.Table (Unum).File_Name := Fname; File.Table (Unum).Loading := False; File.Table (Unum).Source := null; end if; end loop; end if; -- If we are proceeding with load, then make load stack entry Load_Stack.Increment_Last; Load_Stack.Table (Load_Stack.Last) := Unum; -- Case of entry already in table if Unum <= File.Last then -- Here is where we check for a circular dependency, which is -- an attempt to load a unit which is currently in the process -- of being loaded. We do *not* care about a circular chain that -- leads back to a body, because this kind of circular dependence -- legitimately occurs (e.g. two package bodies that contain -- inlined subprogram referenced by the other). if File.Table (Unum).Loading and then Is_Spec_Name (File.Table (Unum).Unit_Name) then if Present (Enode) then Error_Msg ("~Circular unit dependency", Load_Msg_Sloc); Write_Dependency_Chain; end if; if Debug_Flag_L then Write_String ("*** Circular dependency encountered"); Write_Eol; end if; end if; if Debug_Flag_L then Write_String ("*** Unit already in file table, Unit_Number = "); Write_Int (Int (Unum)); Write_Eol; end if; -- Case of constructing a new entry else if Debug_Flag_L then Write_String ("*** Building new file table entry, Unit_Number = "); Write_Int (Int (Unum)); Write_Eol; end if; File.Increment_Last; File.Table (Unum).Unit_Name := Uname; File.Table (Unum).File_Name := Fname; File.Table (Unum).Loading := True; File.Table (Unum).Not_Found_Msg := False; File.Table (Unum).Body_Spec := False; File.Table (Unum).Fatal_Error := False; File.Table (Unum).Identifier_Casing := Unknown; File.Table (Unum).Generate_Code := False; File.Table (Unum).Version := " "; File.Table (Unum).Keyword_Casing := Unknown; File.Table (Unum).Last_Line := 1; File.Table (Unum).Lines_Table := new Lines_Table_Type (1 .. Alloc_Lines_Initial); -- Open file, and if it opens OK, go ahead and parse it File.Table (Unum).Source := Read_Source_File (File.Table (Unum).File_Name, False); if File.Table (Unum).Source /= null then File.Table (Unum).Lines_Table (1) := File.Table (Unum).Source'First; File.Table (Unum).Time_Stamp := Current_Source_File_Stamp; File.Table (Unum).Full_File_Name := Full_Source_Name; Initialize_Scanner (Unum); Par; File.Table (Unum).Loading := False; end if; end if; -- Case of file not found (Unum is always set, but if the Source field -- is set, it means that the file was not found and we have an error) if File.Table (Unum).Source = null then if Debug_Flag_L then Write_String ("*** File was not found, Unit_Number = "); Write_Int (Int (Unum)); Write_Eol; end if; -- Generate message if unit required and no message previously given if Required then if not File.Table (Unum).Not_Found_Msg and then Present (Enode) then Error_Msg_Name_1 := File.Table (Unum).File_Name; Error_Msg ("~file{ not found", Load_Msg_Sloc); Write_Dependency_Chain; File.Table (Unum).Not_Found_Msg := True; end if; -- In any case, if unit is required and not available, this is a -- fatal error for the caller, set flag accordingly. if Present (Enode) then File.Table (Calling_Unit).Fatal_Error := True; end if; end if; -- We mark the entry as loaded even though the load didn't succeed, -- since the meaning of .Loading being True is that the load is in -- progress, which is certainly not true in this case! File.Table (Unum).Loading := False; -- And in all cases of file not found, return No_Unit. Note that the -- entry is left in the File.Table with its Source field set to null -- to indicate that the file was not found, as per spec. Load_Stack.Decrement_Last; return No_Unit; -- Case of load completed successfully else if Debug_Flag_L then Write_String ("*** Load completed successfully, Unit_Number = "); Write_Int (Int (Unum)); Write_Eol; end if; File.Table (Unum).Loading := False; -- If loaded unit had a fatal error, then caller inherits it! if File.Table (Unum).Fatal_Error and then Present (Enode) then File.Table (Calling_Unit).Fatal_Error := True; end if; -- Return the entry in the file table Load_Stack.Decrement_Last; return Unum; end if; end Load; special check is necessary in the unit not found case. If the unit -- is not found, but the file in whichgnat-1.67-src/src/lib-sort.adb 444 10015 7640 13256 5506244327 11352 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- L I B . S O R T -- -- -- -- B o d y -- -- -- -- $Revision: 1.3 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- The algorithm used for the sort here is Floyd's Treesort3, called -- heap sort by Knuth in Art of Programming, with an optimization -- mentioned in a Knuth excercise and described and analyzed in detail -- in Dewar's Phd Thesis ("The Use of Computers to Solve the X-Ray -- Phase Problem", University of Chicago, 1968). -- Definition: a heap is a tree structure in which every node has a value -- greater than or equal to its children (or child for a node that has -- only one child). A leaf node is always considered to be a heap. -- Mapping: the array represents a binary tree, in which (assuming ones -- origin node numbering for a moment), the left son has a subscript equal -- to 2 * the parent subscript, and the right son has a subscript equal -- to the left son subscript plus one. separate (Lib) procedure Sort (Tbl : in out Unit_Ref_Table) is T : Unit_Ref_Table (1 .. Tbl'Last - Tbl'First + 1); -- Actual sort is done on this copy of the array with 1's origin -- subscripts. The addressing of the table is much neater with 1's origin, -- and it is cheaper to do an in-out copy than to fiddle with a low bound -- that is othr than 1. Num : Pos := T'Last; -- Number of elements in array. Gets reduced during second phase. Hole_Value : Unit_Number_Type; -- Value proposed for placing in Hole ------------- -- Heapify -- ------------- -- Make the subtree starting at node N into a heap by rearranging nodes -- in the subtree as needed. The input assumption is that the subtrees -- rooted at the children of the given node are already in heap form. -- The given node must have at least one child. Before the call, the -- caller moves the value of T(N) into Hole_Value. procedure Heapify (N : Pos) is Hole : Pos; -- Location in the tree of hole that needs to be filled by Heapify Son : Pos; -- Location of larger son of hole position Father : Int; -- Location of parent of hold on way back up begin Hole := N; -- This loop moves the hole down the tree, pulling up the larger of -- the two sons, and terminates at the bottom of the tree. loop Son := Hole + Hole; exit when Son > Num; if Son < Num and then Uname_Gt (File.Table (T (Son + 1)).Unit_Name, File.Table (T (Son)).Unit_Name) then Son := Son + 1; end if; T (Hole) := T (Son); Hole := Son; end loop; -- On exit from the loop, the hole is at the bottom of the tree, and -- we must check successive fathers until we find one that is large -- enough, smaller fathers get dragged back down. loop Father := Hole / 2; exit when Father < N or else Uname_Ge (File.Table (T (Father)).Unit_Name, File.Table (Hole_Value).Unit_Name); T (Hole) := T (Father); Hole := Father; end loop; -- On exit from the second loop, the Hole is ready to be filled in T (Hole) := Hole_Value; end Heapify; ---------- -- Sort -- ---------- begin for I in T'range loop T (I) := Tbl (I - 1 + Tbl'First); end loop; -- First phase of the sort converts the tree to a heap, by heapifying -- nodes Num/2, (Num/2 - 1), (Num/2 - 2) etc. in sequence for J in reverse 1 .. Num / 2 loop Hole_Value := T (J); Heapify (J); end loop; -- At this stage of sort, the root node is the largest node. Repeatedly -- exchange it with the last node in the array, reduce the size of the -- array, and re-heapify the tree from the root node. while Num > 1 loop Hole_Value := T (Num); T (Num) := T (1); Num := Num - 1; Heapify (1); end loop; -- Sort is complete, copy result back into place for I in T'range loop Tbl (I - 1 + Tbl'First) := T (I); end loop; end Sort; -- ------------------------------------------------------------------------------ -- The algorithm used for the sort here is Floyd's Treesort3, called -- heap sort by Knuth in Art of Programming, with an optimization -- mentioned in a Knuth excercise and described and analyzed in detail -- in Dewar's Phd Thegnat-1.67-src/src/lib-writ.adb 444 10015 7640 32434 5506244330 11341 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- L I B . W R I T -- -- -- -- B o d y -- -- -- -- $Revision: 1.29 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Einfo; use Einfo; with Gnatvsn; use Gnatvsn; separate (Lib) procedure Writ is Info_Buffer : Str (1 .. 2 * Max_Name_Length + 64); -- Info_Buffer used to prepare lines of library output Info_Buffer_Len : Nat; -- Number of characters stored in Info_Buffer Info_Buffer_Col : Nat; -- Column number of next character to be written (can be different from -- Info_Buffer_Len because of tab characters written by Write_Info_Tab) With_Flags : array (File.First .. File.Last) of Boolean; -- Array of flags used to show which units are with'ed Elab_Flags : array (File.First .. File.Last) of Boolean; -- Array of flags used to show which units have pragma Elaborate set Elab_All_Flags : array (File.First .. File.Last) of Boolean; -- Array of flags used to show which units have pragma Elaborate All set ----------------------- -- Local Subprograms -- ----------------------- procedure Write_Info_Initiate (Key : Char); -- Initiates write of new line to info file, the parameter is the keyword procedure Write_Info_Terminate; -- Terminate output of info line built in Info_Buffer procedure Write_Info_Char (C : Char); pragma Inline (Write_Info_Char); -- Adds one character to Info_Buffer procedure Write_Info_Name (Name : Name_Id); -- Adds characters of Name to Info_Buffer procedure Write_Info_Str (Val : Str); -- Adds characters of Val to Info_Buffer surrounded by quotes procedure Write_Info_Tab (Col : Int); -- Tab out with blanks and HT's to column Col. If already at or past Col, -- writes a single blank, so that we do get a required field separation. procedure Write_Unit_Information (Unit_Num : Unit_Number_Type); -- Write out the library information for one unit for which code is -- generated (includes unit line and with lines). procedure Collect_Withs (Cunit : Node_Id); -- Collect with lines for entries in the context clause of the -- given compilation unit, Cunit. procedure Write_With_Lines; -- Write out with lines collected by calls to Collect_Withs ------------------------- -- Write_Info_Initiate -- ------------------------- procedure Write_Info_Initiate (Key : Char) is begin Info_Buffer_Len := 0; Info_Buffer_Col := 1; Write_Info_Char (Key); Write_Info_Char (' '); end Write_Info_Initiate; -------------------------- -- Write_Info_Terminate -- -------------------------- procedure Write_Info_Terminate is begin Write_Library_Info (Info_Buffer (1 .. Info_Buffer_Len)); Info_Buffer_Len := 0; end Write_Info_Terminate; --------------------- -- Write_Info_Char -- --------------------- procedure Write_Info_Char (C : Char) is begin Info_Buffer_Len := Info_Buffer_Len + 1; Info_Buffer (Info_Buffer_Len) := C; Info_Buffer_Col := Info_Buffer_Col + 1; end Write_Info_Char; --------------------- -- Write_Info_Name -- --------------------- procedure Write_Info_Name (Name : Name_Id) is begin Get_Name_String (Name); Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Name_Len) := Name_Buffer (1 .. Name_Len); Info_Buffer_Len := Info_Buffer_Len + Name_Len; Info_Buffer_Col := Info_Buffer_Col + Name_Len; end Write_Info_Name; -------------------- -- Write_Info_Str -- -------------------- procedure Write_Info_Str (Val : Str) is begin Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Val'Length) := Val; Info_Buffer_Len := Info_Buffer_Len + Val'Length; Info_Buffer_Col := Info_Buffer_Col + Val'Length; end Write_Info_Str; -------------------- -- Write_Info_Tab -- -------------------- procedure Write_Info_Tab (Col : Int) is Next_Tab : Nat; begin if Col <= Info_Buffer_Col then Write_Info_Str (" "); else loop Next_Tab := 8 * ((Info_Buffer_Col - 1) / 8) + 8 + 1; exit when Col < Next_Tab; Write_Info_Char (HT); Info_Buffer_Col := Next_Tab; end loop; while Info_Buffer_Col < Col loop Write_Info_Char (' '); end loop; end if; end Write_Info_Tab; ---------------------------- -- Write_Unit_Information -- ---------------------------- procedure Write_Unit_Information (Unit_Num : Unit_Number_Type) is Cunit : constant Node_Id := File.Table (Unit_Num).Cunit; Pnode : Node_Id; begin Write_Info_Initiate ('U'); Write_Info_Name (File.Table (Unit_Num).Unit_Name); Write_Info_Tab (25); Write_Info_Name (File.Table (Unit_Num).File_Name); if Preelaborable (Cunit) then Write_Info_Str (" PRE"); end if; if Elaborate_Body_Present (Cunit) then Write_Info_Str (" EB"); end if; Write_Info_Terminate; -- Generate with lines, first those that are directly with'ed for I in With_Flags'range loop With_Flags (I) := False; Elab_Flags (I) := False; Elab_All_Flags (I) := False; end loop; Collect_Withs (Cunit); -- For a body, we must also check for any subunits which belong to -- us and which have context clauses of their own, since these with'ed -- units our part of our elaboration dependencies. if Nkind (Unit (Cunit)) in N_Unit_Body then for S in File.First .. File.Last loop -- We are only interested in subunits if File.Table (S).Source /= null and then Nkind (Unit (File.Table (S).Cunit)) = N_Subunit then Pnode := Library_Unit (File.Table (S).Cunit); -- Find ultimate parent of the subunit while Nkind (Unit (Pnode)) = N_Subunit loop Pnode := Library_Unit (Pnode); end loop; -- See if it belongs to us, and if so, include it's with's if Pnode = Cunit then Collect_Withs (File.Table (S).Cunit); end if; end if; end loop; end if; Write_With_Lines; end Write_Unit_Information; ------------------- -- Collect_Withs -- ------------------- procedure Collect_Withs (Cunit : Node_Id) is Item : Node_Id; Unum : Unit_Number_Type; begin Item := First (Context_Items (Cunit)); while Present (Item) loop if Nkind (Item) = N_With_Clause then Unum := Get_Cunit_Unit_Number (Library_Unit (Item)); With_Flags (Unum) := True; if Elaborate_Present (Item) then Elab_Flags (Unum) := True; end if; if Elaborate_All_Present (Item) then Elab_All_Flags (Unum) := True; end if; end if; Item := Next (Item); end loop; end Collect_Withs; ---------------------- -- Write_With_Lines -- ---------------------- procedure Write_With_Lines is With_Table : Unit_Ref_Table (1 .. Pos (File.Last - File.First + 1)); Num_Withs : Int := 0; Cunit : Node_Id; Uname : Unit_Name_Type; Fname : File_Name_Type; begin -- Loop to build the with table for I in File.First .. File.Last loop if With_Flags (I) then Num_Withs := Num_Withs + 1; With_Table (Num_Withs) := I; end if; end loop; -- Sort and output the table Sort (With_Table (1 .. Num_Withs)); for I in 1 .. Num_Withs loop Cunit := File.Table (With_Table (I)).Cunit; Uname := File.Table (With_Table (I)).Unit_Name; Fname := File.Table (With_Table (I)).File_Name; Write_Info_Initiate ('W'); Write_Info_Name (Uname); -- Now we need to figure out the names of the files that contain the -- with'ed unit. These will usually be the files for the body, except -- except in the case of a package that has no body, as indicated by -- the Body_Required flag in the compilation unit node not being set. -- No names are output for a generic unit. if Nkind (Unit (Cunit)) not in N_Generic_Declaration then Write_Info_Tab (25); if Body_Required (Cunit) or else Nkind (Unit (Cunit)) = N_Subprogram_Declaration then Write_Info_Name (Get_File_Name (Get_Body_Name (Uname))); Write_Info_Tab (49); Write_Info_Name (Lib_File_Name (Get_File_Name (Get_Body_Name (Uname)))); else Write_Info_Name (Fname); Write_Info_Tab (49); Write_Info_Name (Lib_File_Name (Fname)); end if; if Elab_Flags (With_Table (I)) then Write_Info_Str (" E"); end if; if Elab_All_Flags (With_Table (I)) then Write_Info_Str (" EA"); end if; end if; Write_Info_Terminate; end loop; end Write_With_Lines; ---------- -- Writ -- ---------- begin Create_Output_Library_Info; -- Output version line Write_Info_Initiate ('V'); Write_Info_Char ('"'); Write_Info_Str (Library_Version); Write_Info_Char ('"'); Write_Info_Terminate; -- Output standard version line Write_Info_Initiate ('S'); Write_Info_Char ('"'); Write_Info_Str (Standard_Version); Write_Info_Char ('"'); Write_Info_Terminate; -- Output main program line if this is acceptable main program declare U : constant Node_Id := Unit (File.Table (Main_Unit).Cunit); S : Node_Id; begin if Nkind (U) = N_Subprogram_Body then S := Specification (U); if not List_Present (Parameter_Specifications (S)) then if Nkind (S) = N_Procedure_Specification then Write_Info_Initiate ('M'); Write_Info_Char ('P'); Write_Info_Terminate; elsif Is_Integer_Type (Etype (Defining_Unit_Name (S))) then Write_Info_Initiate ('M'); Write_Info_Char ('F'); Write_Info_Terminate; end if; end if; end if; end; -- Loop through file table to output information for all units for which -- we have generated code, as marked by the Generate_Code flag. for Unit in File.First .. File.Last loop if File.Table (Unit).Generate_Code then Write_Info_Terminate; -- blank line Write_Unit_Information (Unit); end if; end loop; Write_Info_Terminate; -- blank line -- Prepare to output the source dependency lines declare Sdep_Table : Unit_Ref_Table (1 .. Pos (File.Last - File.First + 1)); -- Keeps track of sdep entries Num_Sdep : Int := 0; -- Number of active entries in Sdep_Table begin for Unit in File.First .. File.Last loop if File.Table (Unit).Source /= null then Num_Sdep := Num_Sdep + 1; Sdep_Table (Num_Sdep) := Unit; end if; end loop; Lib.Sort (Sdep_Table (1 .. Num_Sdep)); for I in 1 .. Num_Sdep loop Write_Info_Initiate ('D'); Write_Info_Name (File.Table (Sdep_Table (I)).File_Name); Write_Info_Tab (25); Write_Info_Str (File.Table (Sdep_Table (I)).Time_Stamp); if File.Table (Sdep_Table (I)).Version (1) /= ' ' then Write_Info_Char (' '); Write_Info_Str (File.Table (Sdep_Table (I)).Version); end if; Write_Info_Terminate; end loop; end; Close_Output_Library_Info; end Writ; re met. The -- call to be generated has one of the forms: -- Store_TB (linenum, Version_x'Address, _TB_Snam'Address); -- Store_TB (linenum, Version_x'Address, Null_Address); -- where Version_x ignat-1.67-src/src/lib.adb 444 10015 7640 20420 5506244330 10346 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- L I B -- -- -- -- B o d y -- -- -- -- $Revision: 1.25 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Alloc; use Alloc; with Errout; use Errout; with Fname; use Fname; with Libfmt; use Libfmt; with Limits; use Limits; with Namet; use Namet; with Namet; use Namet; with Osint; use Osint; with Sinfo; use Sinfo; with Uname; use Uname; package body Lib is Lib_Version : constant Str (1 .. 16) := "GNAT Lib v 1.0 "; -- Library version. This value must be updated whenever any change to the -- compiler affects the library formats in such a way as to obsolete -- previously compiled library modules. ---------------- -- Local Data -- ---------------- Load_Msg_Sloc : Source_Ptr; -- Location for placing error messages (a token in the main source text) -- This is set from Sloc (Enode) by Load only in the case where this Sloc -- is in the main source file. This ensures that not found messages and -- circular dependency messages reference the original with in this source. package Load_Stack is new Table ( Component_Type => Unit_Number_Type, Index_Type => Nat, Low_Bound => 0, Initial => 10, Increment => 100, Table_Name => "Lib.Load_Stack"); -- The Load_Stack table contains a list of unit numbers (indexes into the -- File.Table) of units being loaded on a single dependency chain. The -- First entry is the main unit. The second entry, if present is a unit -- on which the first unit depends, etc. This stack is used to generate -- error messages showing the dependency chain if a file is not found. -- The Load function makes an entry in this table when it is called, and -- removes the entry just before it returns. type Unit_Ref_Table is array (Pos range <>) of Unit_Number_Type; -- Type to hold list of indirect references to unit number table ----------------------- -- Local Subprograms -- ----------------------- procedure Sort (Tbl : in out Unit_Ref_Table); -- This procedure sorts the given unit reference table in order of -- ascending unit names, where the ordering relation is as described -- by the comparison routines provided by package Uname. procedure Write_Dependency_Chain; -- This procedure is used to generate error message info lines that -- trace the current dependency chain when a load error occurs. -------------------------- -- Get_Sloc_Unit_Number -- -------------------------- function Get_Sloc_Unit_Number (S : Source_Ptr) return Unit_Number_Type is begin for U in File.First .. File.Last loop if File.Table (U).Source /= null and then S in File.Table (U).Source'range then return U; end if; end loop; -- If not in the table, must be the main source unit, and we just -- have not got it put into the table yet. return Main_Unit; end Get_Sloc_Unit_Number; --------------------------- -- Get_Cunit_Unit_Number -- --------------------------- function Get_Cunit_Unit_Number (N : Node_Id) return Unit_Number_Type is begin for U in File.First .. File.Last loop if File.Table (U).Cunit = N then return U; end if; end loop; -- If not in the table, must be the main source unit, and we just -- have not got it put into the table yet. return Main_Unit; end Get_Cunit_Unit_Number; -------------------- -- Initialize_Lib -- -------------------- procedure Initialize_Lib is begin File.Init; Load_Stack.Init; Load_Stack.Increment_Last; Load_Stack.Table (Load_Stack.Last) := Main_Unit; -- Initialize File.Table entry for Main_Unit. Note that we don't know -- the unit name yet, that gets filled in when the parser parses the -- main unit, at which time a check is made that it matches the main -- file name, and then the Unit_Name field is set. File.Increment_Last; File.Table (Main_Unit).File_Name := Next_Main_Source; if File.Table (Main_Unit).File_Name /= No_File then File.Table (Main_Unit).Source := Read_Source_File (File.Table (Main_Unit).File_Name, True); File.Table (Main_Unit).Full_File_Name := Full_Source_Name; File.Table (Main_Unit).Time_Stamp := Current_Source_File_Stamp; File.Table (Main_Unit).Loading := True; File.Table (Main_Unit).Fatal_Error := False; File.Table (Main_Unit).Generate_Code := False; File.Table (Main_Unit).Identifier_Casing := Unknown; File.Table (Main_Unit).Keyword_Casing := Unknown; File.Table (Main_Unit).Not_Found_Msg := False; File.Table (Main_Unit).Body_Spec := False; File.Table (Main_Unit).Version := " "; File.Table (Main_Unit).Last_Line := 1; File.Table (Main_Unit).Lines_Table := new Lines_Table_Type (1 .. Alloc_Lines_Initial); File.Table (Main_Unit).Lines_Table (1) := File.Table (Main_Unit).Source'First; end if; end Initialize_Lib; ------------------ -- Finalize_Lib -- ------------------ procedure Finalize_Lib is begin for I in File.First .. File.Last loop Free (File.Table (I).Source); Free_Lines (File.Table (I).Lines_Table); end loop; end Finalize_Lib; ---------- -- List -- ---------- procedure List is separate; --------------- -- Is_Loaded -- --------------- function Is_Loaded (Uname : Unit_Name_Type) return Boolean is begin for Unum in File.First .. File.Last loop if Uname = File.Table (Unum).Unit_Name then return True; end if; end loop; return False; end Is_Loaded; ---------- -- Load -- ---------- function Load (Uname : Unit_Name_Type; Required : Boolean; Enode : Node_Id) return Unit_Number_Type is separate; ---------- -- Sort -- ---------- procedure Sort (Tbl : in out Unit_Ref_Table) is separate; ---------- -- Writ -- ---------- procedure Writ is separate; ---------------------------- -- Write_Dependency_Chain -- ---------------------------- procedure Write_Dependency_Chain is begin for U in Load_Stack.First .. Load_Stack.Last - 1 loop Error_Msg_Unit_1 := File.Table (Load_Stack.Table (U)).Unit_Name; Error_Msg_Unit_2 := File.Table (Load_Stack.Table (U + 1)).Unit_Name; Error_Msg ("unit$ depends on unit$!", Load_Msg_Sloc); end loop; end Write_Dependency_Chain; end Lib; -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under gnat-1.67-src/src/libfmt.ads 444 10015 7640 20577 5506244331 11114 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- L I B F M T -- -- -- -- S p e c -- -- -- -- $Revision: 1.21 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This package describes the format of the library information that is -- associated with compiled source files. The method of this association -- is potentially implementation dependent and is described and implemented -- in package Osint. From the point of view of the description here, all -- we need to know is that the information is represented as a string of -- characters that is somehow associated with a compiled source file, and -- can be retrieved when the source file is opened. If no library information -- exists for a given source file, then we take this to mean that the given -- source file has not been previously compiled. with Types; use Types; package Libfmt is Library_Version : constant Str (1 .. 16) := "GNAT Lib v 1.0 "; -- Library version. This value must be updated whenever any change to the -- compiler affects the library formats in such a way as to obsolete -- previously compiled library modules. ----------------------------------- -- Representation of Time Stamps -- ----------------------------------- -- All compiled units are marked with a time stamp which is derived from -- the source file (we assume that the host system has the concept of a -- file time stamp which is modified when a file is modified). These -- time stamps are used to ensure consistency of the set of units that -- constitutes a library. Time stamps are 12 character strings with -- with the following format: -- YYMMDDHHMMSS -- YY year (2 low order digits) -- MM month (2 digits 01-12) -- DD day (2 digits 01-31) -- HH hour (2 digits 00-23) -- MM minutes (2 digits 00-59) -- SS seconds (2 digits 00-59) -- Time stamps may be compared lexicographically (i.e. Ada comparison -- operations on strings) to determine which is later or earlier. However, -- in normal mode, only equality comparisons have any effect on the -- semantics of the library (later/earlier comparisons are used only for -- determining the most informative error messages to be given). ----------------------------------- -- Format of Library Information -- ----------------------------------- -- The library information is written as a series of lines of the form: -- Key_Character parameter parameter ... -- The first two lines in the file identify the library output version -- and standard version (these are required to be consistent across the -- entire set of compilation units). -- V "xxxxxxxxxxxxxxxx" [MP] -- -- This line indicates the library output version, as defined in this -- package spec. It ensures that separate object modules of a program -- are consistent. It has to be changed if anything changes which would -- affect successful binding of separately compiled modules. Examples -- of such changes are modifications in the format of the library info -- described in this package, or modifications to calling sequences, -- or to the way that data is represented. -- S "xxxxxxxxxxxxxxxx" -- -- This line identifies the version of the Standard package that was -- used in the previous compilation (see Standard_Version in the -- specification of package Stand). -- The next line is present only for a unit that can be a main program -- It has the form: -- M type -- The type parameter is either P for a parameterless procedure, -- or F for a function returning a value of integral type (the -- latter is for writing a main program that returns an exit status) -- Following these header lines, a set of information lines appears for -- each compilation unit that appears in the corresponding object file. In -- particular, when a package body or subprogram body is compiled, there -- will be two sets of information, one for the spec and one for the body. -- with the entry for the body appearing first. This is the only case in -- which a single ALI file contains more than one unit (in particular note -- that subunits do *not* count as compilation units for this purpose, and -- generate no library information, since they are inlined). -- The lines for each compilation unit have the following form. -- U unit-name source-name [PRE] [EB] -- -- This line identifies the unit to which this section of the library -- information file applies. The first three parameters are the unit -- name in internal format, as described in package Uname, and the name -- of the source file containing the unit. The PRE parameter is present -- if the package is preelaborated, i.e. no runtime elaboration is -- required. The EB parameter is present if the pragma Elaborate_Body -- applies to this unit. -- W unit-name [source-name lib-name [E] [EA]] -- -- One of these lines is present for each unit that is mentioned in -- an explicit with clause by the current unit. The first parameter -- is the unit name in internal format. The second parameter is the -- file name of the file that must be compiled to compile this unit -- (which is usually the file for the body, except for packages which -- have no body). The third parameter is the file name of the library -- is the file name of the library information file that contains the -- results of compiling this unit. The E and EA are present if the -- this case). The E and EA parameters are present if the pragmas -- pragmas Elaborate and Elaborate_All respectively apply to this -- unit. In the case of generic units, only the first parameter is -- present, since generic units do not need to be compiled, and -- generate no library information. Note that the elaborate pragmas -- can be given for generic units, but they are ignored. -- Following the unit information, is a series of lines that indicates -- the source files on which the compiled units depend. This is used by -- the binder for consistency checking. -- D source-name time-stamp optional-comments -- The optional comments, if present, must be separated from the time -- stamp by at least one blank. Currently the optional-comments field is -- used by the compiler for the RCS version number if the -dv flag is set. -- Note: blank lines are ignored when the library information is read, -- and separate sections of the file are separated by blank lines to -- ease readability. Blanks between fields are also ignored. end Libfmt; source files. The method of this association -- is potentially implementation dependent and is described and implemented -- ingnat-1.67-src/src/limits.ads 444 10015 7640 4215 5506244331 11107 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- L I M I T S -- -- -- -- S p e c -- -- -- -- $Revision: 1.7 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ package Limits is -- This package defines various capacity limits and other limits in the system Max_Line_Length : constant := 512; -- Maximum source line length Max_Name_Length : constant := 1024; -- Maximum length of unit name (including all dots, and " (spec)") and -- of file names in the library, must be at least Max_Line_Length. end Limits; t.ads) è¹  sinput.adb ü¹  snames.adsb ¹  snames.adb $¹  sprint.ads 8¹  sprint.adbi L¹ stand.ads `¹ stand.adbs t¹ stringt.ads ˆ¹ stringt.adb œ¹ switch.ads °¹ switch.adb й$system_environment.ads ð¹ $system_environment.adb¹!a-ada.h¹"gnat-1.67-src/src/namet-ch.adb 444 10015 7640 16540 5506244331 11305 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- N A M E T . C H -- -- -- -- B o d y -- -- -- -- $Revision: 1.3 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ separate (Namet) function CH return Hash_Index_Type is subtype Int_1_12 is Int range 1 .. 12; -- Used to avoid when others on case jump below Even_Name_Len : Int; -- Last even numbered position (used for >12 case) begin -- Special test for 12 (rather than counting on a when others for the -- case statement below) avoids some Ada compilers converting the case -- statement into successive jumps. -- The case of a name longer than 12 characters is handled by taking the -- first 6 odd numbered characters and the last 6 even numbered characters if Name_Len > 12 then Even_Name_Len := (Name_Len) / 2 * 2; return (((((((((((( Char'Pos (Name_Buffer (01))) * 2 + Char'Pos (Name_Buffer (Even_Name_Len - 10))) * 2 + Char'Pos (Name_Buffer (03))) * 2 + Char'Pos (Name_Buffer (Even_Name_Len - 08))) * 2 + Char'Pos (Name_Buffer (05))) * 2 + Char'Pos (Name_Buffer (Even_Name_Len - 06))) * 2 + Char'Pos (Name_Buffer (07))) * 2 + Char'Pos (Name_Buffer (Even_Name_Len - 04))) * 2 + Char'Pos (Name_Buffer (09))) * 2 + Char'Pos (Name_Buffer (Even_Name_Len - 02))) * 2 + Char'Pos (Name_Buffer (11))) * 2 + Char'Pos (Name_Buffer (Even_Name_Len))) mod Hash_Num; end if; -- For the cases of 1-12 characters, all characters participate in the -- hash. The positioning is randomized, with the bias that characters -- later on participate fully (i.e. are added towards the right side). case (Int_1_12 (Name_Len)) is when 1 => return Char'Pos (Name_Buffer (1)); when 2 => return (( Char'Pos (Name_Buffer (1))) * 64 + Char'Pos (Name_Buffer (2))) mod Hash_Num; when 3 => return ((( Char'Pos (Name_Buffer (1))) * 16 + Char'Pos (Name_Buffer (3))) * 16 + Char'Pos (Name_Buffer (2))) mod Hash_Num; when 4 => return (((( Char'Pos (Name_Buffer (1))) * 8 + Char'Pos (Name_Buffer (2))) * 8 + Char'Pos (Name_Buffer (3))) * 8 + Char'Pos (Name_Buffer (4))) mod Hash_Num; when 5 => return ((((( Char'Pos (Name_Buffer (4))) * 8 + Char'Pos (Name_Buffer (1))) * 4 + Char'Pos (Name_Buffer (3))) * 4 + Char'Pos (Name_Buffer (5))) * 8 + Char'Pos (Name_Buffer (2))) mod Hash_Num; when 6 => return (((((( Char'Pos (Name_Buffer (5))) * 4 + Char'Pos (Name_Buffer (1))) * 4 + Char'Pos (Name_Buffer (4))) * 4 + Char'Pos (Name_Buffer (2))) * 4 + Char'Pos (Name_Buffer (6))) * 4 + Char'Pos (Name_Buffer (3))) mod Hash_Num; when 7 => return ((((((( Char'Pos (Name_Buffer (4))) * 4 + Char'Pos (Name_Buffer (3))) * 4 + Char'Pos (Name_Buffer (1))) * 4 + Char'Pos (Name_Buffer (2))) * 2 + Char'Pos (Name_Buffer (5))) * 2 + Char'Pos (Name_Buffer (7))) * 2 + Char'Pos (Name_Buffer (6))) mod Hash_Num; when 8 => return (((((((( Char'Pos (Name_Buffer (2))) * 4 + Char'Pos (Name_Buffer (1))) * 4 + Char'Pos (Name_Buffer (3))) * 2 + Char'Pos (Name_Buffer (5))) * 2 + Char'Pos (Name_Buffer (7))) * 2 + Char'Pos (Name_Buffer (6))) * 2 + Char'Pos (Name_Buffer (4))) * 2 + Char'Pos (Name_Buffer (8))) mod Hash_Num; when 9 => return ((((((((( Char'Pos (Name_Buffer (2))) * 4 + Char'Pos (Name_Buffer (1))) * 4 + Char'Pos (Name_Buffer (3))) * 4 + Char'Pos (Name_Buffer (4))) * 2 + Char'Pos (Name_Buffer (8))) * 2 + Char'Pos (Name_Buffer (7))) * 2 + Char'Pos (Name_Buffer (5))) * 2 + Char'Pos (Name_Buffer (6))) * 2 + Char'Pos (Name_Buffer (9))) mod Hash_Num; when 10 => return (((((((((( Char'Pos (Name_Buffer (01))) * 2 + Char'Pos (Name_Buffer (02))) * 2 + Char'Pos (Name_Buffer (08))) * 2 + Char'Pos (Name_Buffer (03))) * 2 + Char'Pos (Name_Buffer (04))) * 2 + Char'Pos (Name_Buffer (09))) * 2 + Char'Pos (Name_Buffer (06))) * 2 + Char'Pos (Name_Buffer (05))) * 2 + Char'Pos (Name_Buffer (07))) * 2 + Char'Pos (Name_Buffer (10))) mod Hash_Num; when 11 => return ((((((((((( Char'Pos (Name_Buffer (05))) * 2 + Char'Pos (Name_Buffer (01))) * 2 + Char'Pos (Name_Buffer (06))) * 2 + Char'Pos (Name_Buffer (09))) * 2 + Char'Pos (Name_Buffer (07))) * 2 + Char'Pos (Name_Buffer (03))) * 2 + Char'Pos (Name_Buffer (08))) * 2 + Char'Pos (Name_Buffer (02))) * 2 + Char'Pos (Name_Buffer (10))) * 2 + Char'Pos (Name_Buffer (04))) * 2 + Char'Pos (Name_Buffer (11))) mod Hash_Num; when 12 => return (((((((((((( Char'Pos (Name_Buffer (03))) * 2 + Char'Pos (Name_Buffer (02))) * 2 + Char'Pos (Name_Buffer (05))) * 2 + Char'Pos (Name_Buffer (01))) * 2 + Char'Pos (Name_Buffer (06))) * 2 + Char'Pos (Name_Buffer (04))) * 2 + Char'Pos (Name_Buffer (08))) * 2 + Char'Pos (Name_Buffer (11))) * 2 + Char'Pos (Name_Buffer (07))) * 2 + Char'Pos (Name_Buffer (09))) * 2 + Char'Pos (Name_Buffer (10))) * 2 + Char'Pos (Name_Buffer (12))) mod Hash_Num; end case; end CH; - S "xxxxxxxxxxxxxxxx" -- -- This line identifies the version of the Standard package that was -- used in the previous compilation (see Sgnat-1.67-src/src/namet.ads 444 10015 7640 24100 5506244332 10726 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- N A M E T -- -- -- -- S p e c -- -- -- -- $Revision: 1.33 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Alloc; use Alloc; with Limits; use Limits; with Types; use Types; with Table; package Namet is -- WARNING: There is a C version of this package. Any changes to this -- source file must be properly reflected in the C header file namet.h -- which is created manually from namet.ads and namet.adb. -- This package contains routines for handling the names table. The table -- is used to store character strings for identifiers and operator symbols, -- as well as other string values such as unit names and file names. -- The forms of the entries are as follows: -- Identifiers Upper case letters folded to lower case. -- Character set encoding and folding conventions -- are the same as the source program. -- Operator symbols Stored with surrounding quotes. All letters are -- lower case. -- Unit names Stored with upper case letters folded to lower case. -- See package Uname for further details. -- File names Stored exactly as provided by Fname.Get_File_Name, -- including casing of letters. -- The names are hashed so that a given name appears only once in the table. -- The first 26 entries in the names table (with Name_Id values in the range -- First_Name_Id .. First_Name_Id + 25) represent names which are the one -- character lower case letters in the range a-z, and these names are created -- and initialized by the Initialize_Namet routine. -- Note: character literals are not hashed into this table, since they can be -- represented directly using the appropriate Char_Code value. -- Two values, one of type Int and one of type Byte, are stored with each -- names table entry and subprograms are provided for setting and retrieving -- these associated values. The usage of these values is up to the client. -- In the compiler, the Int field is used to point to a chain of potentially -- visible entities (see Sem.Ch8 for details), and the Byte field is used -- to hold the Token_Type value for reserved words (see Sem for details). -- In the binder, the Byte field is unused, and the Int field is used in -- various ways depending on the name involved (see binder documentation). Name_Buffer : Str (1 .. Max_Name_Length); -- This buffer is used to set the name to be stored in the table for the -- Name_Find call, and to retrieve the name for the Get_Name_String call. Name_Len : Nat; -- Length of name stored in Name_Buffer. Used as an input parameter for -- Name_Find, and as an output value by Get_Name_String, or Write_Name. ----------------- -- Subprograms -- ----------------- procedure Initialize_Namet; -- Initializes the names table, including initializing the first 26 -- entries in the table (for the 1-character lower case names a-z) procedure Finalize_Namet; -- Called at the end of a use of the Namet package (before a subsequent -- call to Initialize_Namet). Currently this routine is only used to -- generate debugging output. function Last_Name_Id return Name_Id; pragma Inline (Last_Name_Id); -- Name_Id of last currently allocated name function Name_Find return Name_Id; -- Name_Find is called with a string stored in Name_Buffer whose length -- is in Name_Len (i.e. the characters of the name are in subscript -- positions 1 to Name_Len in Name_Buffer). It searches the names -- table to see if the string has already been stored. If so the Id of -- the existing entry is returned. Otherwise a new entry is created with -- its Name_Table_Info field set to zero. function Name_Enter return Name_Id; -- Name_Enter has the same calling interface as Name_Find. The difference -- is that it does not search the table for an existing match, and also -- subsequent Name_Find calls using the same name will not locate the -- entry created by this call. Thus multiple calls to Name_Enter with the -- same name will create multiple entries in the name table with different -- Name_Id values. This is useful in the case of created names, which are -- never expected to be looked up. function Length_Of_Name (Id : Name_Id) return Nat; pragma Inline (Length_Of_Name); -- Returns length of given name in characters procedure Get_Name_String (Id : Name_Id); -- Get_Name_String is used to retrieve the string associated with an entry -- in the names table. The resulting string is stored in Name_Buffer -- and Name_Len is set. It is an error to call Get_Name_String with one -- of the special name Id values (No_Name, Error_Name, or Child_Name). procedure Write_Name (Id : Name_Id); -- Write_Name writes the characters of the specified name using the -- standard output procedures in package Output. No end of line is -- written, just the characters of the name. On return Name_Buffer and -- Name_Len are set as for a call to Get_Name_String. function Get_Name_Table_Info (Id : Name_Id) return Int; pragma Inline (Get_Name_Table_Info); -- Fetches the Int value associated with the given name function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id; pragma Inline (Get_Name_Entity_Id); -- Fetches the Entity_Id value associated with the given name. -- Identical to previous one, but reinterprets the contents of the -- field as an Entity. This routine is the basic link between lexemes -- (identifiers) and semantic entities. procedure Set_Name_Table_Info (Id : Name_Id; Val : Int); pragma Inline (Set_Name_Table_Info); -- Sets the Int value associated with the given name procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id); pragma Inline (Set_Name_Entity_Id); -- Sets the Entity_Id value associated with the given name. function Get_Name_Table_Byte (Id : Name_Id) return Byte; pragma Inline (Get_Name_Table_Byte); -- Fetches the Byte value associated with the given name procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte); pragma Inline (Set_Name_Table_Byte); -- Sets the Byte value associated with the given name ----------------------------- -- Private Part Subpackage -- ----------------------------- -- The following package contains the definition of the data structure -- used by the implementation of the Namet package. Logically it really -- corresponds to the private part, hence the name. The reason that it -- is defined as a sub-package is to allow special access from clients -- that need to see the internals of the data structures. package Namet_Private_Part is -- This table stores the actual string names. Although logically there -- is no need for a terminating character (since the length is stored -- in the name entry table), we still store a NUL character at the end -- of every name (for convenience in interfacing to the C world). package Name_Chars is new Table ( Component_Type => Char, Index_Type => Int, Low_Bound => 0, Initial => Alloc_Name_Chars_Initial, Increment => Alloc_Name_Chars_Increment, Table_Name => "Name_Chars"); type Name_Entry is record Name_Chars_Index : Int; -- Starting location of characters in the Name_Chars table minus -- one (i.e. pointer to character just before first character). The -- reason for the bias of one is that indexes in Name_Buffer are -- one's origin, so this avoids unnecessary adds and subtracts of 1. Name_Len : Short; -- Length of this name in characters Byte_Info : Byte; -- Byte value associated with this name Hash_Link : Name_Id; -- Link to next entry in names table for same hash code Int_Info : Int; -- Int Value associated with this name end record; -- This is the table that is referenced by Name_Id entries. -- It contains one entry for each unique name in the table. package Name_Entries is new Table ( Component_Type => Name_Entry, Index_Type => Name_Id, Low_Bound => First_Name_Id, Initial => Alloc_Names_Initial, Increment => Alloc_Names_Increment, Table_Name => "Name_Entries"); end Namet_Private_Part; end Namet; then Write_Info_Char (' '); Write_Info_Str (File.Table (Sdep_Table (I)).Version); end if; Write_Info_Terminate; end loop; end; Close_Output_Library_Info; end Writ; re met. The -- call to be generated has one of the forms: -- Store_TB (linenum, Version_x'Address, _TB_Snam'Address); -- Store_TB (linenum, Version_x'Address, Null_Address); -- where Version_x ignat-1.67-src/src/opt.ads 444 10015 7640 17721 5506244332 10437 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- O P T -- -- -- -- S p e c -- -- -- -- $Revision: 1.31 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This package contains global switches set by the initialization -- routine from the command line and referenced throughout the compiler -- or binder. The comments indicate which options are used by the compiler -- which are used by the binder, and which are common to both programs. with Types; use Types; package Opt is -------------------------------------------- -- Switches Common to Compiler and Binder -- -------------------------------------------- Brief_Output : Boolean := False; -- Force brief error messages to standard error, even if verbose mode is -- set (so that main error messages go to standard output). Identifier_Character_Set : Char := '1'; -- This variable indicates the character set to be used for identifiers. -- The possible settings are: -- '1' Latin-1 -- '2' Latin-2 -- '3' Latin-3 -- '4' Latin-4 -- 'p' PC -- 'f' Full upper set (all distinct) -- 'n' No upper characters (Ada/83 rules) -- The setting affects the set of letters allowed in identifiers and the -- upper/lower case equivalences. It does not affect the interpretation of -- character and string literals, which are always stored using the actual -- coding in the source program. Maximum_Errors : Int := 9999; -- Maximum number of errors before compilation is terminated Maximum_File_Name_Length : Int := Int'Last; -- Maximum number of characters allowed in a file name, not counting the -- extension, as set by the appropriate switch. A value of Int'Last means -- that the switch was not present (in which case the maximum file name -- length will be taken from Osint.System_Maximum_File_Name_Length). Suppress_Options : Suppress_Record; -- Flags set True to globally suppress the corresponding checks (i.e. to -- cause the compiler to act as though the corresponding Suppress pragma -- is always in effect). These are initialized from command line options. Verbose_Mode : Boolean := False; -- Set to True to get verbose mode (full error message text and location -- information sent to standard output, also header, copyright and summary type Warning_Mode_Type is (Suppress, Normal, Treat_As_Error); Warning_Mode : Warning_Mode_Type := Normal; -- Controls treatment of warning messages. If set to Suppress, warning -- messages are not generated at all. In Normal mode, they are generated -- but do not count as errors. In Treat_As_Error mode, warning messages -- are generated and are treated as errors. ---------------------------------------- -- Switches Used Only By The Compiler -- ---------------------------------------- Ada_83_Switch : Boolean := False; -- This is the value of the command line switch for Ada 83 mode. At the -- start of compiling a unit, Ada_9X and Ada_83 are set from this value -- but then they can be subsequently modified by pragmas Ada_83, Ada_9X. Ada_9X : Boolean := True; -- Set True if operating in Ada/9X mode -- Set False if operating in Ada/83 mode Ada_83 : Boolean := False; -- Set True if operating in Ada/83 mode -- Set False if operating in Ada/9X mode All_Errors_Mode : Boolean := False; -- Flag set to force display of multiple errors on a single line Assertions_Enabled : Boolean := False; -- Enable assertions made using pragma Assert Full_List : Boolean := False; -- Set True to generate full source listing with embedded errors GNAT_Style_Check : Boolean := False; -- Set True to perform GNAT style checks. Note that if this is set, then -- RM_Column_Check is also set (i.e. GNAT style checking always includes -- the RM column checks as well). Immediate_Errors : Boolean := False; -- If set to True, then error messages are output as soon as they are -- detected (useful for navigating around compiler error situations) Inline_Active : Boolean := True; -- Set False to deactive pragma Inline processing across modules. Default -- to inline across module boundaries, as specified in the RM. List_Units : Boolean := False; -- List units in the active lbrary type Mode_Type is (Check_Syntax, Check_Semantics, Generate_Code); Operating_Mode : Mode_Type := Generate_Code; -- Indicates the operating mode of the compiler. The default is generate -- code, which runs the parser, semantics and backend. Switches can be -- used to set syntax checking only mode, or syntax and semantics checking -- only mode. Operating_Mode can also be modified as a result of detecting -- errors during the compilation process. In particular if any error is -- detected then Operating_Mode is reset from Generate_Code to -- to Check_Semantics after generating an error message. Try_Semantics : Boolean := False; -- Flag set to force attempt at semantic analysis, even if parser errors -- occur. This will probably cause blowups at this stage in the game! RM_Column_Check : Boolean := False; -- Flag set to cause column alignment to be taken into account in -- determining legality of various constructs. Note that this is -- always set True if GNAT_Style_Check is set True. -------------------------------------- -- Switches Used Only By The Binder -- -------------------------------------- All_Sources : Boolean := False; -- Set to True to require all source files to be present Bind_Main_Program : Boolean := True; -- Set to False if not binding main Ada program Check_Only : Boolean := False; -- Set to True to do checks only, no output of binder file Check_Source_Files : Boolean := False; -- Set to True to enable consistency checking for any source files that -- are present (i.e. date must match the date in the library info file). Elab_Dependency_Output : Boolean := False; -- Set to True to output complete list of elaboration constraints Elab_Order_Output : Boolean := False; -- Set to True to output chosen elaboration order Ignore_Time_Stamp_Errors : Boolean := False; -- Ignore time stamp mismatch errors (treat as warnings only) Output_Filename_Present : Boolean := False; -- Set to True when the output C filename is given with option -o end Opt; -- -- S pgnat-1.67-src/src/namet.adb 444 10015 7640 33206 5506244332 10714 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- N A M E T -- -- -- -- B o d y -- -- -- -- $Revision: 1.35 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Debug; use Debug; with Output; use Output; package body Namet is -- WARNING: There is a C version of this package. Any changes to this -- source file must be properly reflected in the C header file namet.h -- which is created manually from namet.ads and namet.adb. use Namet_Private_Part; -- We are allowed to see our own private data! Hash_Num : constant Int := 2**12; -- Number of headers in the hash table. Current hash algorithm is closely -- tailored to this choice, so it can only be changed if a corresponding -- change is made to the hash alogorithm. Hash_Max : constant Int := Hash_Num - 1; -- Indexes in the hash header table run from 0 to Hash_Num - 1 subtype Hash_Index_Type is Int range 0 .. Hash_Max; -- Range of hash index values Hash_Table : array (Hash_Index_Type) of Name_Id; -- The hash table is used to locate existing entries in the names table. -- The entries point to the first names table entry whose hash value -- matches the hash code. Then subsequent names table entries with the -- same hash code value are linked through the Hash_Link fields. One_Char_Id_Base : constant := Name_Id'Pos (First_Name_Id) - Char'Pos ('a'); -- Bias to get Name_Id of one characte identifier name ----------------------- -- Local Subprograms -- ----------------------- function CH return Hash_Index_Type; pragma Inline (CH); -- Compute hash code for name stored in Name_Buffer (length in Name_Len) function CH return Hash_Index_Type is separate; ---------------------- -- Initialize_Namet -- ---------------------- procedure Initialize_Namet is begin Name_Chars.Init; Name_Entries.Init; -- Initialize entries for a-z for C in Char range 'a' .. 'z' loop Name_Entries.Increment_Last; Name_Entries.Table (Name_Entries.Last).Name_Chars_Index := Name_Chars.Last; Name_Entries.Table (Name_Entries.Last).Name_Len := 1; Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name; Name_Entries.Table (Name_Entries.Last).Int_Info := 0; Name_Entries.Table (Name_Entries.Last).Byte_Info := 0; Name_Chars.Increment_Last; Name_Chars.Table (Name_Chars.Last) := C; Name_Chars.Increment_Last; Name_Chars.Table (Name_Chars.Last) := NUL; end loop; -- Clear hash table for I in Hash_Index_Type loop Hash_Table (I) := No_Name; end loop; end Initialize_Namet; -------------------- -- Finalize_Namet -- -------------------- procedure Finalize_Namet is Max_Chain_Length : constant := 50; -- Max length of chains for which specific information is output F : array (Int range 0 .. Max_Chain_Length) of Int; -- N'th entry is number of chains of length N Probes : Int := 0; -- Used to compute average number of probes Nsyms : Int := 0; -- Number of symbols in table begin if Debug_Flag_H then for I in F'range loop F (I) := 0; end loop; for I in Hash_Index_Type loop if Hash_Table (I) = No_Name then F (0) := F (0) + 1; else Write_String ("Hash_Table ("); Write_Int (Int (I)); Write_String (") has "); declare C : Int := 1; N : Name_Id; S : Int; begin C := 0; N := Hash_Table (I); while N /= No_Name loop N := Name_Entries.Table (N).Hash_Link; C := C + 1; end loop; Write_Int (C); Write_String (" entries"); Write_Eol; if C < Max_Chain_Length then F (C) := F (C) + 1; else F (Max_Chain_Length) := F (Max_Chain_Length) + 1; end if; N := Hash_Table (I); while N /= No_Name loop S := Name_Entries.Table (N).Name_Chars_Index; Write_String (" "); for J in 1 .. Name_Entries.Table (N).Name_Len loop Write_Char (Name_Chars.Table (S + Int (J))); end loop; Write_Eol; N := Name_Entries.Table (N).Hash_Link; end loop; end; end if; end loop; Write_Eol; for I in Int range 0 .. Max_Chain_Length loop if F (I) /= 0 then Write_Str ("Number of hash chains of length "); if I < 10 then Write_Char (' '); end if; Write_Int (I); if I = Max_Chain_Length then Write_Str (" or greater"); end if; Write_Str (" = "); Write_Int (F (I)); Write_Eol; if I /= 0 then Nsyms := Nsyms + F (I); Probes := Probes + F (I) * (1 + I) * 100; end if; end if; end loop; Write_Eol; Write_String ("Average number of probes for lookup = "); Probes := Probes / Nsyms; Write_Int (Probes / 200); Write_Char ('.'); Probes := (Probes mod 200) / 2; Write_Char (Char'Val (48 + Probes / 10)); Write_Char (Char'Val (48 + Probes mod 10)); Write_Eol; Write_Eol; end if; end Finalize_Namet; ------------------ -- Last_Name_Id -- ------------------ function Last_Name_Id return Name_Id is begin return Name_Entries.Last; end Last_Name_Id; --------------- -- Name_Find -- --------------- function Name_Find return Name_Id is New_Id : Name_Id; -- Id of entry in hash search, and value to be returned S : Int; -- Pointer into string table Hash_Index : Hash_Index_Type; -- Computed hash index begin -- Quick handling for one character identifiers if Name_Len = 1 and then Name_Buffer (1) in 'a' .. 'z' then return Name_Id (One_Char_Id_Base + Char'Pos (Name_Buffer (1))); -- Otherwise search hash table for existing matching entry else Hash_Index := Namet.CH; New_Id := Hash_Table (Hash_Index); if New_Id = No_Name then Hash_Table (Hash_Index) := Name_Entries.Last + 1; else Search : loop if Name_Len /= Int (Name_Entries.Table (New_Id).Name_Len) then goto No_Match; end if; S := Name_Entries.Table (New_Id).Name_Chars_Index; for I in 1 .. Name_Len loop if Name_Chars.Table (S + I) /= Name_Buffer (I) then goto No_Match; end if; end loop; return New_Id; -- Current entry in hash chain does not match <> if Name_Entries.Table (New_Id).Hash_Link /= No_Name then New_Id := Name_Entries.Table (New_Id).Hash_Link; else Name_Entries.Table (New_Id).Hash_Link := Name_Entries.Last + 1; exit Search; end if; end loop Search; end if; -- We fall through here only if a matching entry was not found in the -- hash table. We now create a new entry in the names table. The hash -- link pointing to the new entry (Name_Entries.Last+1) has been set. Name_Entries.Increment_Last; Name_Entries.Table (Name_Entries.Last).Name_Chars_Index := Name_Chars.Last; Name_Entries.Table (Name_Entries.Last).Name_Len := Short (Name_Len); Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name; Name_Entries.Table (Name_Entries.Last).Int_Info := 0; Name_Entries.Table (Name_Entries.Last).Byte_Info := 0; -- Set corresponding string entry in the Name_Chars table for I in 1 .. Name_Len loop Name_Chars.Increment_Last; Name_Chars.Table (Name_Chars.Last) := Name_Buffer (I); end loop; Name_Chars.Increment_Last; Name_Chars.Table (Name_Chars.Last) := NUL; return Name_Entries.Last; end if; end Name_Find; ---------------- -- Name_Enter -- ---------------- function Name_Enter return Name_Id is begin Name_Entries.Increment_Last; Name_Entries.Table (Name_Entries.Last).Name_Chars_Index := Name_Chars.Last; Name_Entries.Table (Name_Entries.Last).Name_Len := Short (Name_Len); Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name; Name_Entries.Table (Name_Entries.Last).Int_Info := 0; Name_Entries.Table (Name_Entries.Last).Byte_Info := 0; -- Set corresponding string entry in the Name_Chars table for I in 1 .. Name_Len loop Name_Chars.Increment_Last; Name_Chars.Table (Name_Chars.Last) := Name_Buffer (I); end loop; Name_Chars.Increment_Last; Name_Chars.Table (Name_Chars.Last) := NUL; return Name_Entries.Last; end Name_Enter; -------------------- -- Length_Of_Name -- -------------------- function Length_Of_Name (Id : Name_Id) return Nat is begin return Int (Name_Entries.Table (Id).Name_Len); end Length_Of_Name; --------------------- -- Get_Name_String -- --------------------- procedure Get_Name_String (Id : Name_Id) is S : Int; begin pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); S := Name_Entries.Table (Id).Name_Chars_Index; Name_Len := Int (Name_Entries.Table (Id).Name_Len); for I in 1 .. Name_Len loop Name_Buffer (I) := Name_Chars.Table (S + I); end loop; end Get_Name_String; ------------------------- -- Get_Name_Table_Info -- ------------------------- function Get_Name_Table_Info (Id : Name_Id) return Int is begin pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); return Name_Entries.Table (Id).Int_Info; end Get_Name_Table_Info; ------------------------ -- Get_Name_Entity_Id -- ------------------------ function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is begin return Entity_Id (Get_Name_Table_Info (Id)); end Get_Name_Entity_Id; ------------------------- -- Set_Name_Table_Info -- ------------------------- procedure Set_Name_Table_Info (Id : Name_Id; Val : Int) is begin pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); Name_Entries.Table (Id).Int_Info := Val; end Set_Name_Table_Info; ------------------------ -- Set_Name_Entity_Id -- ------------------------ procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is begin Set_Name_Table_Info (Id, Int (Val)); end Set_Name_Entity_Id; ------------------------- -- Get_Name_Table_Byte -- ------------------------- function Get_Name_Table_Byte (Id : Name_Id) return Byte is begin pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); return Name_Entries.Table (Id).Byte_Info; end Get_Name_Table_Byte; ------------------------- -- Set_Name_Table_Byte -- ------------------------- procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte) is begin pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); Name_Entries.Table (Id).Byte_Info := Val; end Set_Name_Table_Byte; ----------------- -- Write_Name -- ----------------- procedure Write_Name (Id : Name_Id) is begin if Id >= First_Name_Id then Get_Name_String (Id); Write_Str (Name_Buffer (1 .. Name_Len)); end if; end Write_Name; end Namet; Write_Str (" or greater"); end if; Write_Str (" = "); Write_Int (F (I)); Write_Eol; if I /= 0 then Nsyms := Nsyms + F (I); Probes := Probes + F (I) * (1 + I) * 100; end if; end if; end loop; Write_Eol; Write_Sgnat-1.67-src/src/nmake.adt 444 10015 7640 6276 5506244333 10715 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- N M A K E -- -- -- -- T e m p l a t e -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This file is a template used as input to the utility program xnmake.spt -- which reads this template, and the spec of Sinfo (sinfo.ads) and generates -- the body and spec for the Nmake package (files nmake.ads and nmake.adb) with Atree; use Atree; with Sinfo; use Sinfo; with Snames; use Snames; with Types; use Types; package Nmake is -- This package contains a set of routines used to construct tree nodes -- using a functional style. There is one routine for each node type defined -- in Sinfo with the general interface: -- function Make_xxx (Sloc : Source_Ptr, -- Field_Name_1 : Field_Name_1_Type [:= default] -- Field_Name_2 : Field_Name_2_Type [:= default] -- ...) -- return Node_Id -- Only syntactic fields are included (i.e. fields marked as "-Sem" or "-Lib" -- in the Sinfo spec are excluded). -- Default values are provided only for flag fields (where the default is -- False), and for optional fields. An optional field is one where the -- comment line describing the field contains the string "(set to xxx if". -- For such fields, a default value of xxx is provided." -- Warning: since calls to Make_xxx routines are normal function calls, the -- arguments can be evaluated in any order. This means that at most one such -- argument can have side effects (e.g. be a call to a parse routine). !!TEMPLATE INSERTION POINT end Nmake; adsB$¹/ types.adb 8¹0 uintp.adsffL¹1 uintp.adb `¹2 uname.adsr t¹3 uname.adb C˜¹4(unchecked_conversion.adsnch¼¹5(unchecked_conversion.adbnchà¹6(unchecked_deallocation.adsh¹7 unixlib.ads$¹8(unchecked_deallocation.adbh8¹9 gnat-1.67-src/src/osint.ads 444 10015 7640 40337 5506244333 10771 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- O S I N T -- -- -- -- S p e c -- -- -- -- $Revision: 1.21 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Osint is -- This package contains the low level, operating system routines used in -- the GNAT compiler and binder for command line processing and file -- input output. The specification is suitable for use with MS/DOS or -- Unix of similar systems. Separate bodies are provided for different -- operating systems environments. type Program_Type is (Compiler, Binder, Make); Program : Program_Type; -- Program currently running (set by Initialize_OS_Interface) procedure Initialize_OS_Interface (P : Program_Type); -- This routine scans parameters and initializes for the first call to -- Open_Next_File. It also resets any of the variables in Options in -- response to command switch settings. Init may terminate execution -- if the parameters are invalid or some other fatal error is encountered. -- The interface is set up to accomodate scanning a series of files (e.g. -- as the result of wild card references in DOS, or an expanded list of -- source files in Unix). Of course it is perfectly possible to ignore -- this in the implementation and provide for opening only one file. -- The parameter is the program that is running. procedure Write_Program_Name; -- Writes name of program as invoked to standard output file function System_Maximum_File_Name_Length return Pos; -- Returns the maximum number of characters allowed in a file name, not -- counting the extension. If there is no limit, then Int'Last is returned. ----------------------- -- Source File Input -- ----------------------- -- Source file input routines are used by the compiler to read the main -- source files and the subsidiary source files (e.g. with'ed units), and -- also by the binder and make to check presence/time stamps of sources. function More_Source_Files return Boolean; -- Indicates whether more source file remain to be processed. Returns -- False right away if no source files, or if all source files have -- been processed. function Next_Main_Source return File_Name_Type; -- This function returns the name of the next main source file specified -- on the command line. It is an error to call Next_Main_Source if no more -- source files exist (i.e. Next_Main_Source may be called only if a -- previous call to More_Source_Files returned True). This name is the -- simple file name (without any directory information). function Read_Source_File (Name : File_Name_Type; Fatal_Err : Boolean) return Source_Buffer_Ptr; -- Allocates a Text_Buffer of appropriate length and then reads the entire -- contents of the source file Name into the buffer. The text is terminated -- by an EOF character which is not necessarily the last text character. -- The lower bound of the text buffer for the first file opened after a -- call to Next_Main_Source is zero. The lower bound for buffers returned -- by subsequent calls are one greater than the previous high bound. If -- the given file cannot be opened, then the action depends on Fatal_Err. -- If Fatal_Err is True, an error message is given, otherwise if Fatal_Err -- is False, then null is returned. Note that the Name passed to this -- function is the simple file name, without any directory information. -- The implementation of Read_Source_File is responsible for searching for -- the file in appropriate directories. function Current_Source_File_Stamp return Time_Stamp_Type; -- Returns the time stamp of the source file most recently read by a -- call to Read_Source_File. function Full_Source_Name return Name_Id; -- This function returns the full name of the source file most recently -- read using Read_Source_File. This name includes the appropriate -- directory information (typically a relative directory name in a -- Unix like system). This name is only used for the purpose of error -- message construction and need not be accessible by Name_Find (i.e. -- it may be created by Name_Enter). function Source_File_Stamp (Name : File_Name_Type) return Time_Stamp_Type; -- Returns the time stamp of the specified source file. If the source -- file cannot be opened, an all blank time stamp is returned (this is -- not an error situation). ------------------------------------------- -- Representation of Library Information -- ------------------------------------------- -- Associated with each compiled source file is library information, -- a string of bytes whose exact format is described in packag Libfmt. -- Compiling a source file generates this library information for the -- compiled unit, and access the library information for units that -- were compiled previously on which the unit being compiled depends. -- How this information is stored is up to the implementation of this -- package. At the interface level, this information is simply associated -- with its corresponding source. -- Several different implementations are possible: -- 1. The information could be directly associated with the source file, -- e.g. placed in a resource fork of this file on the Mac, or on -- MS-DOS, written to the source file after the end of file mark. -- 2. The information could be written into the generated object module -- if the system supports the inclusion of arbitrary informational -- byte streams into object files. In this case there must be a naming -- convention that allows object files to be located given the name of -- the corresponding source file. -- 3. The information could be written to a separate file, whose name is -- related to the name of the source file by a fixed convention. -- Which of these three methods is chosen depends on the contraints of the -- host operating system. The interface described here is independent of -- which of these approaches is used. ------------------------------- -- Library Information Input -- ------------------------------- -- These subprograms are used by the binder to read library information -- files, see section above for representation of these files. function More_Lib_Files return Boolean; -- Indicates whether more library information files remain to be processed. -- Returns False right away if no source files, or if all source files -- have been processed. function Next_Main_Lib_File return File_Name_Type; -- This function returns the name of the next library info file specified -- on the command line. It is an error to call Next_Main_Lib_File if no -- more library information files exist (i.e. Next_Main_Lib_File may be -- called only if a previous call to More_Lib_Files returned True). This -- name is the simple name, excluding any directory information. function Read_Library_Info (Lib_File : File_Name_Type; Fatal_Err : Boolean) return Text_Buffer_Ptr; -- Allocates a Text_Buffer of appropriate length and reads in the entire -- source of the library information from the library information file -- whose name (obtained by a previous call to Lib_File_Name) is given by -- the parameter Name. An EOF character terminates the text (but is not -- necessarily the last character of the text). The lower bound of the -- Text_Buffer is always zero. If the library information for the given -- file cannot be located, then null is returned. If the given file cannot -- be opened, then the action depends on Fatal_Err. If Fatal_Err is True, -- an error message is given, otherwise if Fatal_Err is False, then null -- is returned. Note that the Lib_File is a simple name which does not -- include any directory information. The implementation is responsible -- for searching for the file in appropriate directories. function Full_Library_Info_Name return Name_Id; -- This function returns the full name of the library information file -- most recently read using Read_Library_Info, including appropriate -- directory information (typically a relative directory name in a -- Unix like system). This name is only used for the purpose of error -- message construction and need not be accessible by Name_Find (i.e. -- it may be created by Name_Enter). -------------------------------- -- Library Information Output -- -------------------------------- -- These routines are used by the compiler to generate the library -- information file for the main source file being compiled. See section -- above for a discussion of how library information files are stored. -- The Lib_File_Name routine is also used by Make. procedure Create_Output_Library_Info; -- Creates the output library information file for the source file which -- is currently being compiled (i.e. the file which was most recently -- returned by Next_Main_Source). procedure Write_Library_Info (Info : Str); -- Writes the contents of the referenced string to the library information -- file for the main source file currently being compiled (i.e. the file -- which was most recently opened with a call to Read_Next_File). Info -- represents a single line in the file, but does not contain any line -- termination characters. The implementation of Write_Library_Info is -- responsible for adding necessary end of line and end of file control -- characters to the generated file. procedure Close_Output_Library_Info; -- Closes the file created by Create_Output_Library_Info, flushing any -- buffers etc from writes by Write_Library_Info. function Lib_File_Name (Source_File : File_Name_Type) return File_Name_Type; -- Given the name of a source file, returns the name of the corresponding -- library information file. This may be the name of the object file, or -- of a separate file used to store the library information. In either case -- the returned result is suitable for use in a call to Read_Library_Info. -- Note: this subprogram is in this section because it is used by the -- compiler to determine the proper library information names to be placed -- in the generated library information file. ------------------- -- Binder Output -- ------------------- -- These routines are used by the binder to generate the C source file -- containing the binder output. The format of this file is described -- in the package Bindfmt. procedure Create_Binder_Output; -- Creates the binder output file corresponding to the library information -- file for the main program (i.e. for the file returned by the previous -- call to Next_Main_Lib_File). procedure Write_Binder_Info (Info : Str); -- Writes the contents of the referenced string to the binder output file -- created by a previous call to Create_Binder_Output. Info represents a -- single line in the file, but does not contain any line termination -- characters. The implementation of Write_Library_Info is responsible -- for adding necessary end of line and end of file control characters as -- required by the operating system. procedure Close_Binder_Output; -- Closes the file created by Create_Binder_Output, flushing any -- buffers etc from writes by Write_Binder_Info. ----------------- -- Xref Output -- ----------------- -- These routines are used by the xref tool to generate the .ref files -- containing the xref output. function Number_Of_Files return Int; -- gives the total number of filenames found on command line. procedure Create_Req_Output; -- Create the output file for the required interface of the unit I. The -- file name must be in Buffer_name befor calling this procedure. procedure Create_Xref_Output; -- Creates the xref output file. If there is only one file to be analysed -- it will create 'file.ref' otherwise 'X.ref' procedure Write_Xref_Info (Info : Str; Eol : Boolean := True); -- Writes the contents of the referenced string to the Xref output file -- created by a previous call to Create_Xref_Output. Info represents a -- single line in the file, but does not contain any line termination -- characters. The implementation of Write_Xref_Info is responsible -- for adding necessary end of line and end of file control characters as -- required by the operating system. procedure Close_Xref_Output; -- Closes the file created by Create_Xref_Output, flushing any -- buffers etc from writes by Write_Xref_Info. ----------------- -- Termination -- ----------------- type Exit_Code_Type is (E_Success, E_Warnings, E_Errors, E_Fatal, E_Abort); -- This type defines the possible exit statuses for the Exit_Program -- call. Success is used for normal termination. Warnings indicates that -- warning messages were posted, but no errors. Errors indicates that -- at least one error message was generated. Fatal indicates that a fatal -- error condition was detected such as source file not found. The status -- code E_Abort is only used for an internally detected compiler error. -- If possible, a traceback or other appropriate debugging information -- should be generated in this case. procedure Exit_Program (Exit_Code : Exit_Code_Type); -- A call to Exit_Program terminates execution with the given status. -- A status of zero indicates normal completion, a non-zero status -- indicates abnormal termination. ----------------------- -- Program Execution -- ----------------------- -- These routines are used by Make to call the compiler and binder. The -- options are supplied by Osint from the original command line, using -- an appropriate convention to separate Make options, Compile options -- and Make options. function Do_Compile (Source_File : File_Name_Type) return Exit_Code_Type; -- Perform a compilation of the given source file. The returned value -- indicates whether or not the compilation succeeded. If the return -- type is E_Success, then a matching ALI file has been created. function Do_Bind (Lib_File : File_Name_Type) return Exit_Code_Type; -- Perform a bind of the given library file. The exit code will be -- returned as the exit code of Make itself. Note that Do_Bind is -- called only if all Do_Compile steps succeeded (returned E_Success). -- Otherwise the exit code from Make is the highest exit code returned -- by any Do_Compile step. end Osint; -- This function returns the name of the next library info file specified -- on the command line. It is an error to call Next_Main_Lib_File if no -- more library information files exist (i.e. Next_Main_Lib_File may be -- called only if a previous call to More_Lib_Files retgnat-1.67-src/src/osint.adb 444 10015 7640 52754 5506244334 10757 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- O S I N T -- -- -- -- B o d y -- -- -- -- $Revision: 1.41 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Namet; use Namet; with Output; use Output; with Switch; use Switch; with Unixlib; use Unixlib; with Sysid; use Sysid; with Opt; use Opt; with System_Environment; use System_Environment; package body Osint is File_Names : array (Int range 1 .. Int (Arg_Count)) of Str_Ptr; -- As arguments are scanned in OS_Interface_Init, filenames are stored -- in this array. The string does not contain a terminating NUL. Number_File_Names : Int := 0; -- The total number of filenames found on command line and placed in -- File_Names Current_File_Name_Index : Int := 0; -- The index in File_Names of the last file opened by Open_Next_File. -- The value 0 indicates that no files have been opened yet. In_Binder : Boolean; In_Compiler : Boolean; In_Make : Boolean; -- Exactly one of these flags is set True to indicate which program -- is bound and executing with Osint, which is used by all these programs. Source_Time_Stamp : Time_Stamp_Type; -- Time stamp for current source file Output_FD : Unix_FD; -- The file descriptor for the current library info or binder output Next_Source_Low_Bound : Source_Ptr := 0; -- Value for low bound of next text buffer EOL : constant Character := Ascii.LF; -- End of line character Output_Filename : Str_Ptr := null; -- The name after the -o option Save_Full_Source_Name : Name_Id; -- Set to full name of source file read by the most recent call to -- Read_Source_File (result returned by Full_Source_Name) Save_Full_Library_Info_Name : Name_Id; -- Set to full name of library information file read by the most recent -- call to Read_Library_Info (result returned by Full_Library_Info_Name) ----------------------------- -- Initialize_OS_Interface -- ----------------------------- procedure Initialize_OS_Interface (P : Program_Type) is Already_Seen : Boolean := False; begin Program := P; case Program is when Binder => In_Binder := True; when Compiler => In_Compiler := True; when Make => In_Make := True; end case; -- Set PC character set as default if operating system is MS/DOS style if MS_DOS then Identifier_Character_Set := 'p'; end if; -- Loop through command line arguments, storing them for later access for Next_Arg in 1 .. Arg_Count - 1 loop declare Next_Argv : constant String := Arg_Value (Next_Arg).all; Current_Arg : Str (1 .. Nat (Next_Argv'Last)); begin if Next_Argv'Length /= 0 and then Next_Argv (1) = '-' then Scan_Switches (Next_Argv); -- Not a switch, so must be a filename (if non-empty) elsif Next_Argv'Length /= 0 then -- Ignore empty arguments for I in Next_Argv'range loop Current_Arg (Nat (I)) := Char'Val (Character'Pos (Next_Argv (I))); end loop; if Output_Filename_Present and not Already_Seen then Already_Seen := True; Output_Filename := new Str'(Current_Arg); else Number_File_Names := Number_File_Names + 1; File_Names (Number_File_Names) := new Str'(Current_Arg); end if; end if; end; end loop; end Initialize_OS_Interface; ------------------------ -- Write_Program_Name -- ------------------------ procedure Write_Program_Name is begin Write_String (Arg_Value (0).all); end Write_Program_Name; ------------------------------------- -- System_Maximum_File_Name_Length -- ------------------------------------- function System_Maximum_File_Name_Length return Pos is begin return Int'Last; end System_Maximum_File_Name_Length; ----------------------- -- More_Source_Files -- ----------------------- function More_Source_Files return Boolean is begin pragma Assert (In_Compiler or In_Make); return (Current_File_Name_Index < Number_File_Names); end More_Source_Files; ---------------------- -- Next_Main_Source -- ---------------------- function Next_Main_Source return File_Name_Type is File_Name : Str_Ptr; Fptr : Int; begin pragma Assert (In_Compiler or In_Make); Current_File_Name_Index := Current_File_Name_Index + 1; -- Fatal error if no more files (should call More_Source_Files) pragma Assert (Current_File_Name_Index <= Number_File_Names); -- Otherwise return name of the file File_Name := File_Names (Current_File_Name_Index); Fptr := File_Name'First; for I in reverse File_Name'range loop if File_Name (I) = '/' then Fptr := I + 1; end if; end loop; Name_Len := File_Name'Last - Fptr + 1; Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last); Next_Source_Low_Bound := 0; return File_Name_Type (Name_Find); end Next_Main_Source; ---------------------- -- Read_Source_File -- ---------------------- function Read_Source_File (Name : File_Name_Type; Fatal_Err : Boolean) return Source_Buffer_Ptr is Source_File_FD : Unix_FD; -- The file descriptor for the current source file. A negative value -- indicates failure to open the specified source file. Text : Source_Buffer_Ptr; -- Allocated text buffer begin -- Set full source name -- TBD??? Get_Name_String (Name); Save_Full_Source_Name := Name_Enter; -- Set file name (we use supplied file name with the original -- directory path from the main source file name) Get_Name_String (Name); declare File_Name : constant Str_Ptr := File_Names (Current_File_Name_Index); Given_Name : Str (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); begin Name_Buffer (1 .. File_Name'Last) := File_Name.all; Name_Len := File_Name'Length; for I in reverse 1 .. Name_Len loop exit when Name_Buffer (I) = '/'; Name_Len := Name_Len - 1; end loop; Name_Buffer (Name_Len + 1 .. Name_Len + Given_Name'Length) := Given_Name; Name_Len := Name_Len + Given_Name'Length; -- Now open the file Name_Buffer (Name_Len + 1) := NUL; Source_File_FD := Unix_Open_Read (Name_Buffer'Address); if Source_File_FD < 0 then if Fatal_Err then Write_String ("Cannot open: "); Write_Str (File_Name.all); Write_Eol; Exit_Program (E_Fatal); else return null; end if; end if; end; -- Read data from the file declare Len : Int := Unix_File_Length (Source_File_FD); -- Length of source file text Lo : Source_Ptr := Next_Source_Low_Bound; -- Low bound for allocated text buffer Hi : Source_Ptr := Lo + Source_Ptr (Len); -- High bound for allocated text buffer. Note length is Len + 1 -- which allows for extra EOF character at the end of the buffer. Block_Size : constant := 2**14; -- Block size for read Ptr : Source_Ptr := Lo; -- Next location in text buffer to fill Count : Int; -- Count of characters read begin Text := new Source_Buffer (Lo .. Hi); -- Note extra charater at end for EOF character loop Count := Unix_Read (Source_File_FD, Text (Ptr)'Address, Block_Size); exit when Count < Block_Size; Ptr := Ptr + Block_Size; end loop; Text (Hi) := EOF; Next_Source_Low_Bound := Hi + 1; end; -- Read is complete, get time stamp, close file and we are done Source_Time_Stamp := Unix_File_Time_Stamp (Source_File_FD); Unixlib.Unix_Close (Source_File_FD); return Text; end Read_Source_File; ------------------------------- -- Current_Source_File_Stamp -- ------------------------------- function Current_Source_File_Stamp return Time_Stamp_Type is begin return Source_Time_Stamp; end Current_Source_File_Stamp; ---------------------- -- Full_Source_Name -- ---------------------- function Full_Source_Name return Name_Id is begin return Save_Full_Source_Name; end Full_Source_Name; ----------------------- -- Source_File_Stamp -- ----------------------- function Source_File_Stamp (Name : File_Name_Type) return Time_Stamp_Type is Text : Source_Buffer_Ptr; begin Text := Read_Source_File (Name, False); if Text = null then return " "; else Free (Text); return Source_Time_Stamp; end if; end Source_File_Stamp; -------------------- -- More_Lib_Files -- -------------------- function More_Lib_Files return Boolean is begin pragma Assert (In_Binder); return (Current_File_Name_Index < Number_File_Names); end More_Lib_Files; ------------------------ -- Next_Main_Lib_File -- ------------------------ function Next_Main_Lib_File return File_Name_Type is File_Name : Str_Ptr; Fptr : Int; begin pragma Assert (In_Binder); Current_File_Name_Index := Current_File_Name_Index + 1; -- Fatal error if no more files (should call More_Lib_Files) pragma Assert (Current_File_Name_Index <= Number_File_Names); -- Otherwise return name of the file File_Name := File_Names (Current_File_Name_Index); Fptr := File_Name'First; for I in reverse File_Name'range loop if File_Name (I) = '/' then Fptr := I + 1; end if; end loop; Name_Len := File_Name'Last - Fptr + 1; Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last); Next_Source_Low_Bound := 0; return File_Name_Type (Name_Find); end Next_Main_Lib_File; ----------------------- -- Read_Library_Info -- ----------------------- function Read_Library_Info (Lib_File : File_Name_Type; Fatal_Err : Boolean) return Text_Buffer_Ptr is Lib_FD : Unix_FD; -- The file descriptor for the current library file. A negative value -- indicates failure to open the specified source file. Text : Source_Buffer_Ptr; -- Allocated text buffer. begin -- Set full name -- TBD??? Get_Name_String (Lib_File); Save_Full_Library_Info_Name := Name_Enter; -- Set file name (we use supplied file name with the original -- directory path from the main source file name) Get_Name_String (Lib_File); declare File_Name : Str_Ptr; Given_Name : Str (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); begin File_Name := File_Names (Current_File_Name_Index); Name_Buffer (1 .. File_Name'Last) := File_Name.all; Name_Len := File_Name'Length; for I in reverse 1 .. Name_Len loop exit when Name_Buffer (I) = '/'; Name_Len := Name_Len - 1; end loop; Name_Buffer (Name_Len + 1 .. Name_Len + Given_Name'Length) := Given_Name; Name_Len := Name_Len + Given_Name'Length; -- Now open the file Name_Buffer (Name_Len + 1) := NUL; Lib_FD := Unix_Open_Read (Name_Buffer'Address); if Lib_FD < 0 then if Fatal_Err then Write_String ("Cannot open: "); Write_Str (File_Name.all); Write_Eol; Exit_Program (E_Fatal); else return null; end if; end if; end; -- Read data from the file declare Len : Int := Unix_File_Length (Lib_FD); -- Length of source file text Lo : Source_Ptr := 0; -- Low bound for allocated text buffer Hi : Source_Ptr := Source_Ptr (Len); -- High bound for allocated text buffer. Note length is Len + 1 -- which allows for extra EOF character at the end of the buffer. Block_Size : constant := 2**14; -- Block size for read Ptr : Source_Ptr := Lo; -- Next location in text buffer to fill Count : Int; -- Count of characters read begin Text := new Source_Buffer (Lo .. Hi); -- Note extra charater at end for EOF character loop Count := Unix_Read (Lib_FD, Text (Ptr)'Address, Block_Size); exit when Count < Block_Size; Ptr := Ptr + Block_Size; end loop; Text (Hi) := EOF; Next_Source_Low_Bound := Hi + 1; end; -- Read is complete, close file and we are done Unixlib.Unix_Close (Lib_FD); return Text; end Read_Library_Info; ---------------------------- -- Full_Library_Info_Name -- ---------------------------- function Full_Library_Info_Name return Name_Id is begin return Save_Full_Library_Info_Name; end Full_Library_Info_Name; -------------------------------- -- Create_Output_Library_Info -- -------------------------------- procedure Create_Output_Library_Info is File_Name : constant Str_Ptr := File_Names (Current_File_Name_Index); Name_Buf : Str (File_Name'First .. File_Name'Last + 5); -- Buffer for name (with extra room for .ali and NUL) begin pragma Assert (In_Compiler); Name_Buf (File_Name'range) := File_Name.all; for I in reverse File_Name'range loop if Name_Buf (I) = '.' then Name_Buf (I + 1 .. I + 3) := "ali"; Name_Buf (I + 4) := NUL; Output_FD := Unix_Create_File (Name_Buf'Address); if Output_FD < 0 then Write_String ("Cannot create: "); Write_Str (Name_Buf); Write_Eol; Exit_Program (E_Fatal); end if; return; end if; end loop; -- Should be impossible not to have an extension pragma Assert (False); end Create_Output_Library_Info; ------------------------ -- Write_Library_Info -- ------------------------ procedure Write_Library_Info (Info : Str) is begin pragma Assert (In_Compiler); Unix_Write (Output_FD, Info'Address, Info'Length); Unix_Write (Output_FD, EOL'Address, 1); end Write_Library_Info; ------------------------------- -- Close_Output_Library_Info -- ------------------------------- procedure Close_Output_Library_Info is begin pragma Assert (In_Compiler); Unix_Close (Output_FD); end Close_Output_Library_Info; ------------------- -- Lib_File_Name -- ------------------- function Lib_File_Name (Source_File : File_Name_Type) return File_Name_Type is Fptr : Int; -- Pointer to location to set extension in place begin Get_Name_String (Source_File); Fptr := Name_Len + 1; for I in reverse 1 .. Name_Len loop if Name_Buffer (I) = '.' then Fptr := I; exit; end if; end loop; Name_Buffer (Fptr .. Fptr + 3) := ".ali"; Name_Buffer (Fptr + 4) := NUL; Name_Len := Fptr + 3; return Name_Find; end Lib_File_Name; -------------------------- -- Create_Binder_Output -- -------------------------- procedure Create_Binder_Output is File_Name : Str_Ptr; Name_Buf : Str (1 .. 200); I : Nat; begin pragma Assert (In_Binder); if (Output_Filename_Present) then if Output_Filename /= null then Name_Buf (Output_Filename'range) := Output_Filename.all; Name_Buf (Output_Filename'Last + 1) := NUL; else Write_String ("Output filename missing after -o"); Write_Eol; Exit_Program (E_Fatal); end if; else File_Name := File_Names (Current_File_Name_Index); Name_Buf (1 .. 5) := "bind_"; Name_Buf (6 .. File_Name'Length + 5) := File_Name.all; Name_Buf (File_Name'Length + 6) := '.'; I := 6; while Name_Buf (I) /= '.' loop I := I + 1; end loop; Name_Buf (I + 1) := 'c'; Name_Buf (I + 2) := NUL; end if; Output_FD := Unix_Create_File (Name_Buf'Address); if Output_FD < 0 then Write_String ("Cannot create: "); Write_Str (Name_Buf); Write_Eol; Exit_Program (E_Fatal); end if; end Create_Binder_Output; ------------------------ -- Write_Binder_Info -- ------------------------ procedure Write_Binder_Info (Info : Str) is begin pragma Assert (In_Binder); Unix_Write (Output_FD, Info'Address, Info'Length); Unix_Write (Output_FD, EOL'Address, 1); end Write_Binder_Info; ------------------------- -- Close_Binder_Output -- ------------------------- procedure Close_Binder_Output is begin pragma Assert (In_Binder); Unix_Close (Output_FD); end Close_Binder_Output; --------------------- -- Number_Of_Files -- --------------------- function Number_Of_Files return Int is begin return Number_File_Names; end Number_Of_Files; ------------------------ -- Create_Req_Output -- ------------------------ procedure Create_Req_Output is begin pragma Assert (In_Compiler or In_Make); Output_FD := Unix_Create_File (Name_Buffer'Address); if Output_FD < 0 then Write_String ("Cannot create REQ File :"); Write_Str (Name_Buffer); Output.Write_Eol; Exit_Program (E_Fatal); end if; end Create_Req_Output; ------------------------- -- Create_Xref_Output -- ------------------------- procedure Create_Xref_Output is Multi_File_Xref : constant Str (1 .. 5) := "X.ref"; begin pragma Assert (In_Compiler); -- For now, always use X.ref, since cannot reference Lib Name_Buffer (1 .. Multi_File_Xref'Last) := Multi_File_Xref; Name_Len := Multi_File_Xref'Last; Name_Buffer (Name_Len + 1) := NUL; Output_FD := Unix_Create_File (Name_Buffer'Address); if Output_FD < 0 then Write_String ("Cannot create Xref-File !!!"); Write_Eol; Exit_Program (E_Fatal); end if; end Create_Xref_Output; ------------------------- -- Write_Xref_Output -- ------------------------- procedure Write_Xref_Info (Info : Str; Eol : Boolean := True) is begin pragma Assert (In_Compiler); Unix_Write (Output_FD, Info'Address, Info'Length); if Eol then Unix_Write (Output_FD, Osint.EOL'Address, 1); end if; end Write_Xref_Info; ------------------------- -- Close_Xref_Output -- ------------------------- procedure Close_Xref_Output is begin pragma Assert (In_Compiler); Unix_Close (Output_FD); end Close_Xref_Output; ------------------ -- Exit_Program -- ------------------ procedure Exit_Program (Exit_Code : Exit_Code_Type) is begin case Exit_Code is when E_Success => Unix_Exit (0); when E_Warnings => Unix_Exit (0); when E_Errors => Unix_Exit (1); when E_Fatal => Unix_Exit (2); when E_Abort => Unix_Abort; end case; end Exit_program; ---------------- -- Do_Compile -- ---------------- function Do_Compile (Source_File : File_Name_Type) return Exit_Code_Type is begin return E_Success; end Do_Compile; ------------- -- Do_Bind -- ------------- function Do_Bind (Lib_File : File_Name_Type) return Exit_Code_Type is begin return E_Success; end Do_Bind; end Osint; ; end; gnat-1.67-src/src/output.ads 444 10015 7640 11253 5506244334 11171 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- O U T P U T -- -- -- -- S p e c -- -- -- -- $Revision: 1.9 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Output is -- This package contains low level output routines used by the compiler function Column return Int; -- Returns column number about to be written (start of line = column 1) -- If a tab is output, this column count reflects the result of outputting -- an equivalent number of blanks (with standard positions 1,9,17..) procedure Set_Standard_Error; -- Sets subsequent output to appear on the standard error file (whatever -- that might mean for the host operating system, if anything). procedure Set_Standard_Output; -- Sets subsequent output to appear on the standard output file (whatever -- that might mean for the host operating system, if anything). This is -- the default mode before any call to either of the Set procedures. procedure Write_Char (C : Char); -- Write one character to the standard output file. Note that the -- character should not be LF or CR (use Write_Eol for end of line) procedure Write_Eol; -- Write an end of line (whatever is required by the system in use, -- e.g. CR/LF for DOS, or LF for Unix) to the standard output file. procedure Write_Int (I : Int); -- Write an unsigned integer value with no leading blanks or zeroes procedure Write_Str (S : Str); -- Write a string of characters to the standard output file. Note that -- end of line is handled separately using WRITE_EOL, so the string -- should not contain either of the characters LF or CR, but it may -- contain horizontal tab characters. procedure Write_String (S : String); -- Like Write_Str, but the argument is of type Standard.String and can -- contain only valid characters for this type. In particular, it cannot -- contain horizontal tab, or any other format effector characters. -------------------------- -- Debugging Procedures -- -------------------------- -- The following procedures are intended only for debugging purposes, -- for temporary insertion into the text in environments where a debugger -- is not available. They all have non-standard very short lower case -- names, precisely to make sure that they are only used for debugging! procedure ws (S : String); -- Dump string followed by line return procedure w (S : Str); -- Dump string followed by line return procedure w (I : Int); -- Dump integer followed by line return procedure w (B : Boolean); -- Dump Boolean followed by line return procedure ws (L : Str; S : String); -- Dump two strings separated by blanks, followed by line return procedure w (L : Str; S : Str); -- Dump two strings separated by blanks, followed by line return procedure w (L : Str; I : Int); -- Dump contents of string followed by blank, integer, line return procedure w (L : Str; B : Boolean); -- Dump contents of string followd by blank, Boolean, line return end Output; dress, 1); end Write_Library_Info; ------------------------------- -- Close_Output_Library_Info -- ------------------------------- procedure Close_Output_Library_Info is begin pragma Assert (In_Compiler); Unix_Close (Output_FD); end Close_Output_Library_Info; ------------------- -- Lib_File_Name --gnat-1.67-src/src/output.adb 444 10015 7640 11425 5506244334 11151 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- O U T P U T -- -- -- -- B o d y -- -- (UNIX Version) -- -- -- -- $Revision: 1.14 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Unixlib; use Unixlib; package body Output is -- This version of the package written for operation under UNIX, using -- the Alsys System_Environment package for OS interface functions. Current_Column : Int := 1; -- Current column number FD : Unix_FD := Unix_Standout; -- File descriptor for current output ------------- -- Column -- ------------- function Column return Int is begin return Current_Column; end Column; ------------------------ -- Set_Standard_Error -- ------------------------ procedure Set_Standard_Error is begin FD := Unix_Standerr; end Set_Standard_Error; ------------------------- -- Set_Standard_Output -- ------------------------- procedure Set_Standard_Output is begin FD := Unix_Standout; end Set_Standard_Output; ---------------- -- Write_Char -- ---------------- procedure Write_Char (C : Char) is begin Unix_Write (FD, C'Address, 1); Current_Column := Current_Column + 1; end Write_Char; --------------- -- Write_Eol -- --------------- procedure Write_Eol is begin Write_Char (LF); Current_Column := 1; end Write_Eol; --------------- -- Write_Int -- --------------- procedure Write_Int (I : Int) is begin if I < 0 then Write_Char ('-'); Write_Int ( -I); else if I > 9 then Write_Int (I / 10); end if; Write_Char (Char'VAL ((I mod 10) + 48)); end if; end Write_Int; --------------- -- Write_Str -- --------------- procedure Write_Str (S : Str) is begin Unix_Write (FD, S'Address, S'length); Current_Column := Current_Column + S'Length; end Write_Str; ------------------ -- Write_String -- ------------------ procedure Write_String (S : String) is begin Unix_Write (FD, S'Address, S'length); Current_Column := Current_Column + S'Length; end Write_String; -------------------------- -- Debugging Procedures -- -------------------------- procedure ws (S : String) is begin Write_String (S); Write_Eol; end ws; procedure w (S : Str) is begin Write_Str (S); Write_Eol; end w; procedure w (I : Int) is begin Write_Int (I); Write_Eol; end w; procedure w (B : Boolean) is begin if B then ws ("True"); else ws ("False"); end if; end w; procedure ws (L : Str; S : String) is begin Write_Str (L); Write_Char (' '); ws (S); end ws; procedure w (L : Str; S : Str) is begin Write_Str (L); Write_Char (' '); w (S); end w; procedure w (L : Str; I : Int) is begin Write_Str (L); Write_Char (' '); w (I); end w; procedure w (L : Str; B : Boolean) is begin Write_Str (L); Write_Char (' '); w (B); end w; end Output; -- ------------------------------- procedure Close_Output_Library_Info is begin pragma Assert (In_Compiler); Unix_Close (Output_FD); end Close_Output_Library_Info; ------------------- -- Lib_File_Name --gnat-1.67-src/src/par.ads 444 10015 7640 4523 5506244335 10376 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P A R -- -- -- -- S p e c -- -- -- -- $Revision: 1.9 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- The Par procedure and its subunits contains all the parsing routines -- for the top down recursive descent parser that constructs the parse tree procedure Par; -- Parse the compilation unit contained in the current source file and -- enter its N_Compilation_Unit node into the appropriate entry of the -- File.Table (i.e. File.Table (Current_Unit).Cunit). It also sets the -- File.Table (Current_Unit).Entity field to point to the corresponding -- defining entity. The tree on return is parsed, and decorated with any -- needed implicit label declarations. ns.adsc€\¹% table.adsc€p¹& table.adb>@„¹' tbuild.ads@˜¹( tbuild.adb¬¹) treepr.ads€À¹* treepr.adbHÔ¹+ treeprs.gnat-1.67-src/src/par-ch10.adb 444 10015 7640 44110 5506244335 11122 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P A R . C H 1 0 -- -- -- -- B o d y -- -- -- -- $Revision: 1.39 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Uname; use Uname; separate (Par) package body Ch10 is -- Local functions, used only in this chapter function P_Context_Clause return List_Id; function P_Subunit return Node_Id; ------------------------- -- 10.1.1 Compilation -- ------------------------- -- COMPILATION ::= {COMPILATION_UNIT} -- There is no specific parsing routine for a compilation, since we only -- permit a single compilation in a source file, so there is no explicit -- occurrence of compilations as such (our representation of a compilation -- is a series of separate source files). ------------------------------ -- 10.1.1 Compilation unit -- ------------------------------ -- COMPILATION_UNIT ::= -- CONTEXT_CLAUSE LIBRARY_ITEM -- | CONTEXT_CLAUSE SUBUNIT -- LIBRARY_ITEM ::= -- private LIBRARY_UNIT_DECLARATION | LIBRARY_UNIT_BODY -- LIBRARY_UNIT_DECLARATION ::= -- SUBPROGRAM_DECLARATION | PACKAGE_DECLARATION -- | GENERIC_DECLARATION | GENERIC_INSTANTIATION -- LIBRARY_UNIT_RENAMING_DECLARATION ::= -- PACKAGE_RENAMING_DECLARATION | SUBPROGRAM_RENAMING_DECLARATION -- LIBRARY_UNIT_BODY ::= SUBPROGRAM_BODY | PACKAGE_BODY -- Error recovery: cannot raise Error_Resync. If an error occurs, tokens -- are skipped up to the next possible beginning of a compilation unit. function P_Compilation_Unit return Node_Id is Scan_State : Saved_Scan_State; Context_Item_List : List_Id; Body_Node : Node_Id; Spec_Node : Node_Id; Specification_Node : Node_Id; Unit_Node : Node_Id; Comp_Unit_Node : Node_Id; Name_Node : Node_Id; File_Name : Name_Id; Cunit_Error_Flag : Boolean := False; -- This flag is set True if we have to scan for a compilation unit -- token. It is used to ensure clean termination in such cases by -- not insisting on being at the end of file, and, in the sytax only -- case by not scanning for additional compilation units. begin Comp_Unit_Node := New_Node (N_Compilation_Unit, No_Location); File.Table (Scan_Unit).Cunit := Comp_Unit_Node; Set_Context_Items (Comp_Unit_Node, P_Context_Clause); -- Allow PRIVATE in 9X mode if Token = Tok_Private then File.Table (Scan_Unit).Keyword_Casing := Determine_Token_Casing; if GNAT_Style_Check then GNAT_Column_Check (Token_Ptr); end if; if Ada_83 then Error_Msg_SC ("private units not allowed in Ada 83!"); end if; Save_Scan_State (Scan_State); -- at PRIVATE Scan; -- past PRIVATE if Token = Tok_Separate then Error_Msg_SP ("cannot have private subunits!"); elsif Token = Tok_Package then Scan; -- past PACKAGE if Token = Tok_Body then Restore_Scan_State (Scan_State); -- to PRIVATE Error_Msg_SC ("cannot have private package body!"); Scan; -- ignore PRIVATE else Restore_Scan_State (Scan_State); -- to PRIVATE Scan; -- past PRIVATE Set_Private_Present (Comp_Unit_Node, True); end if; end if; end if; -- Loop to find our way to a compilation unit token loop exit when Token in Token_Class_Cunit and then Token /= Tok_With; exit when Bad_Spelling_Of (Tok_Procedure) or else Bad_Spelling_Of (Tok_Package) or else Bad_Spelling_Of (Tok_Function) or else Bad_Spelling_Of (Tok_Generic); if Token = Tok_With then Error_Msg_SC ("misplaced WITH"); Append_List (P_Context_Clause, Context_Items (Comp_Unit_Node)); elsif Bad_Spelling_Of (Tok_With) then Append_List (P_Context_Clause, Context_Items (Comp_Unit_Node)); else Error_Msg_SC ("~compilation unit expected"); Cunit_Error_Flag := True; Resync_Cunit; -- If we are at an end of file, then just quit, the above error -- message was complaint enough. if Token = Tok_EOF then return Error; end if; end if; end loop; -- We have a compilation unit token, so that's a reasonable choice for -- determining the standard casing convention used for keywords in case -- it hasn't already been done on seeing a WITH or PRIVATE. File.Table (Scan_Unit).Keyword_Casing := Determine_Token_Casing; if GNAT_Style_Check then GNAT_Column_Check (Token_Ptr); end if; -- Remaining processing depends on particular type of compilation unit if Token = Tok_Package then Set_Unit (Comp_Unit_Node, P_Package (Pf_Decl_Gins_Pbod_Rnam)); elsif Token = Tok_Generic then Set_Unit (Comp_Unit_Node, P_Generic); elsif Token = Tok_Separate then Set_Unit (Comp_Unit_Node, P_Subunit); elsif Token = Tok_Procedure or else Token = Tok_Function then Set_Unit (Comp_Unit_Node, P_Subprogram (Pf_Decl_Gins_Pbod_Rnam)); -- A little bit of an error recovery check here. If we just scanned -- a subprogram declaration (as indicated by an SIS entry being -- active), then if the following token is BEGIN or an identifier, -- or a token which can reasonably start a declaration but cannot -- start a compilation unit, then we assume that the semicolon in -- the declaration should have been IS. if SIS_Entry_Active then if Token = Tok_Begin or else Token = Tok_Identifier or else Token in Token_Class_Deckn then Push_Scope_Stack; Scope.Table (Scope.Last).Etyp := E_Name; Scope.Table (Scope.Last).Sloc := SIS_Sloc; Scope.Table (Scope.Last).Ecol := SIS_Ecol; Scope.Table (Scope.Last).Lreq := False; SIS_Entry_Active := False; Error_Msg_SP ("semicolon should be IS!"); Body_Node := Unit (Comp_Unit_Node); Specification_Node := Specification (Body_Node); Change_Node (Body_Node, N_Subprogram_Body); Set_Specification (Body_Node, Specification_Node); P_Decls_Begin_End (Body_Node); Set_Unit (Comp_Unit_Node, Body_Node); end if; end if; -- Shouldn't be any other possibilities for compilation units else Error_Msg_SC ("Internal error: expected compilation unit token here"); Compiler_Abort; end if; -- Here is where we set the Sloc field of the N_Compilation_Unit node, -- which must point to the name of the unit, which is a bit hard to -- find in some cases (which is why we set it in the node!) Unit_Node := Unit (Comp_Unit_Node); -- Only try this if we got an OK unit! if Unit_Node /= Error then if Nkind (Unit_Node) = N_Subunit then Unit_Node := Proper_Body (Unit_Node); end if; if Nkind (Unit_Node) in N_Generic_Declaration then Unit_Node := Specification (Unit_Node); end if; if Nkind (Unit_Node) = N_Package_Declaration or else Nkind (Unit_Node) = N_Subprogram_Declaration or else Nkind (Unit_Node) = N_Subprogram_Body or else Nkind (Unit_Node) = N_Subprogram_Renaming_Declaration then Unit_Node := Specification (Unit_Node); end if; if Nkind (Unit_Node) = N_Task_Body or else Nkind (Unit_Node) = N_Protected_Body then Name_Node := Defining_Identifier (Unit_Node); else Name_Node := Defining_Unit_Name (Unit_Node); end if; Set_Sloc (Comp_Unit_Node, Sloc (Name_Node)); -- Set Entity field in file table. Easier now that we have name! -- Note that this is also skipped if we had a bad unit if Nkind (Name_Node) = N_Defining_Program_Unit_Name then File.Table (Scan_Unit).Entity := Defining_Identifier (Name_Node); else File.Table (Scan_Unit).Entity := Name_Node; end if; -- Set unit name File.Table (Scan_Unit).Unit_Name := Get_Unit_Name (Unit (Comp_Unit_Node)); -- If we had a bad unit, make sure the fatal flag is set in the file -- table entry, since this is surely a fatal error and also set our -- flag to inhibit the requirement that we be at end of file. else Cunit_Error_Flag := True; File.Table (Scan_Unit).Fatal_Error := True; end if; -- Clear away any missing semicolon indication, we are done with that -- unit, so what's done is done, and we don't want anything hanging -- around from the attempt to parse it! SIS_Entry_Active := False; -- Any final pragmas get appended to the context clause if Token = Tok_Pragma then Set_Following_Pragmas (Comp_Unit_Node, New_List); P_Pragmas_Opt (Following_Pragmas (Comp_Unit_Node)); end if; -- If -db debug switch is set, then add a "with System" to the context -- clause to allow references by the declarations of _V used to address -- version strings in traceback information. Don't do this in System -- itself, or we get a circular with dependency! Note that we put the -- with of System at the start of the context clause, because it can't -- go after a pragma Elaborate. if Debug_Flag_B and then Unit_Node /= Error and then Present (File.Table (Scan_Unit).Entity) and then Chars (File.Table (Scan_Unit).Entity) /= Name_System then Prepend_To (Context_Items (Comp_Unit_Node), Make_With_Clause (Sloc (Name_Node), Name => Make_Identifier (Sloc (Name_Node), Name_System))); end if; -- And now we should be at the end of file, except that if we had to -- scan for a compilation unit, then we don't check this, since it -- seems in practice to often make things worse, and we already gave -- a serious error message. if Token /= Tok_EOF and then not Cunit_Error_Flag then -- If we are not at end of file, then fatal error unless we are -- syntax checking only mode, where we do allow additional units -- by making a recursive call to this routine. Skip this message -- if we already had some fatal error. if Operating_Mode = Check_Syntax then return P_Compilation_Unit; else if not File.Table (Scan_Unit).Fatal_Error then if Token in Token_Class_Cunit then Error_Msg_SC ("~end of file expected, " & "file can have only one compilation unit"); else Error_Msg_SC ("~end of file expected"); end if; end if; return Error; end if; -- This is the normal return else return Comp_Unit_Node; end if; exception -- An error resync is a serious bomb, so indicate result unit no good when Error_Resync => File.Table (Scan_Unit).Fatal_Error := True; return Error; end P_Compilation_Unit; -------------------------- -- 10.1.1 Library Item -- -------------------------- -- Parsed by P_Compilation_Unit (10.1.1) -------------------------------------- -- 10.1.1 Library Unit Declaration -- -------------------------------------- -- Parsed by P_Compilation_Unit (10.1.1) ----------------------------------------------- -- 10.1.1 Library Unit Renaming Declaration -- ----------------------------------------------- -- Parsed by P_Compilation_Unit (10.1.1) ------------------------------- -- 10.1.1 Library Unit Body -- ------------------------------- -- Parsed by P_Compilation_Unit (10.1.1) ---------------------------- -- 10.1.2 Context Clause -- ---------------------------- -- CONTEXT_CLAUSE ::= {CONTEXT_ITEM} -- CONTEXT_ITEM ::= WITH_CLAUSE | USE_CLAUSE -- WITH_CLAUSE ::= -- with library_unit_NAME {,library_unit_NAME}; -- Error recovery: Cannot raise Error_Resync function P_Context_Clause return List_Id is Item_List : List_Id; Scan_State : Saved_Scan_State; With_Node : Node_Id; Id_Node : Node_Id; First_Flag : Boolean; begin Item_List := New_List; -- Get keyword casing from WITH keyword in case not set yet if Token = Tok_With then File.Table (Scan_Unit).Keyword_Casing := Determine_Token_Casing; end if; -- Loop through context items loop if GNAT_Style_Check then GNAT_Column_Check (Token_Ptr); end if; -- Gather any pragmas appearing in the context clause P_Pragmas_Opt (Item_List); -- Processing for WITH clause if Token = Tok_With then Scan; -- past WITH First_Flag := True; -- Loop through names in one with clause, generating a separate -- N_With_Clause node for each nam encountered. loop With_Node := New_Node (N_With_Clause, Token_Ptr); Append (With_Node, Item_List); if Ada_9X then Set_Name (With_Node, P_Qualified_Simple_Name); else -- Ada-83 Save_Scan_State (Scan_State); -- at Id Id_Node := P_Identifier; if Token = Tok_Dot then Restore_Scan_State (Scan_State); -- to Id Error_Msg_SC ("child units not allowed in Ada 83!"); Set_Name (With_Node, P_Qualified_Simple_Name); else Set_Name (With_Node, Id_Node); end if; end if; Set_First_Name (With_Node, First_Flag); First_Flag := False; exit when Token /= Tok_Comma; Scan; -- past comma end loop; Set_Last_Name (With_Node, True); TF_Semicolon; -- Processing for USE clause elsif Token = Tok_Use then Append (P_Use_Clause, Item_List); -- Anything else is end of context clause else exit; end if; end loop; return Item_List; end P_Context_Clause; ------------------------- -- 10.1.2 With Clause -- ------------------------- -- Parsed by P_Context_Clause (10.1.1) ----------------------- -- 10.1.3 Body Stub -- ----------------------- -- Function stub parsed by P_Subprogram (6.1) -- Procedure stub parsed by P_Subprogram (6.1) -- Task stub parsed by P_Task (9.1) -- Protected stub parsed by P_Protected (9.4) --------------------- -- 10.1.3 Subunit -- --------------------- -- SUBUNIT ::= -- separate (parent_unit_NAME) PROPER_BODY -- The caller has checked that the initial token is SEPARATE -- Error recovery: cannot raise Error_Resync function P_Subunit return Node_Id is Subunit_Node : Node_Id; Body_Node : Node_Id; begin Subunit_Node := New_Node (N_Subunit, Token_Ptr); Body_Node := Error; -- in case no good body found Scan; -- past SEPARATE; T_Left_Paren; Set_Name (Subunit_Node, P_Qualified_Simple_Name); T_Right_Paren; if Token = Tok_Function or else Token = Tok_Procedure then Body_Node := P_Subprogram (Pf_Pbod); elsif Token = Tok_Package then Body_Node := P_Package (Pf_Pbod); elsif Token = Tok_Protected then Scan; -- past PROTECTED if Token = Tok_Body then Body_Node := P_Protected; else Error_Msg_AP ("~BODY expected"); return Error; end if; elsif Token = Tok_Task then Scan; -- past TASK if Token = Tok_Body then Body_Node := P_Task; else Error_Msg_AP ("~BODY expected"); return Error; end if; else Error_Msg_SC ("~proper body expected"); return Error; end if; Set_Proper_Body (Subunit_Node, Body_Node); return Subunit_Node; end P_Subunit; end Ch10; it (Comp_Unit_Node)); -- If we had a bad unit, make sure the fatal flag is set in the file -- table entry, since this is surely a fatal error and also set our -- flag to inhibit the requirement that we be at end of file. else Cunit_Error_Flag := True; File.Table (Scan_Unit).Fatal_Error := True; end if; -- Clear away any missing semicolon indication, we are done with that gnat-1.67-src/src/par-ch11.adb 444 10015 7640 16413 5506244336 11131 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P A R . C H 1 1 -- -- -- -- B o d y -- -- -- -- $Revision: 1.10 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ separate (Par) package body Ch11 is -- Local functions, used only in this chapter function P_Exception_Handler return Node_Id; function P_Exception_Choice return Node_Id; --------------------------------- -- 11.1 Exception Declaration -- --------------------------------- -- Parsed by P_Identifier_Declaration (3.2) ------------------------------------------ -- 11.2 Handled Sequence Of Statements -- ------------------------------------------ -- HANDLED_SEQUENCE_OF_STATEMENTS ::= -- SEQUENCE_OF_STATEMENTS -- [exception -- EXCEPTION_HANDLER -- {EXCEPTION_HANDLER}] -- Error_Recovery : Cannot raise Error_Resync function P_Handled_Sequence_Of_Statements return Node_Id is Handled_Stmt_Seq_Node : Node_Id; begin Handled_Stmt_Seq_Node := New_Node (N_Handled_Sequence_Of_Statements, Token_Ptr); Set_Statements (Handled_Stmt_Seq_Node, P_Sequence_Of_Statements (SS_Extm_Sreq)); if Token = Tok_Exception then Set_Exception_Handlers (Handled_Stmt_Seq_Node, P_Exception_Handler_Part); end if; return Handled_Stmt_Seq_Node; end P_Handled_Sequence_Of_Statements; ----------------------------- -- 11.2 Exception Handler -- ----------------------------- -- EXCEPTION_HANDLER ::= -- when [CHOICE_PARAMETER_SPECIFICATION :] -- EXCEPTION_CHOICE {| EXCEPTION_CHOICE} => -- SEQUENCE_OF_STATEMENTS -- CHOICE_PARAMETER_SPECIFICATION ::= DEFINING_IDENTIFIER -- Error recovery: cannot raise Error_Resync function P_Exception_Handler return Node_Id is Scan_State : Saved_Scan_State; Handler_Node : Node_Id; Choice_Param_Node : Node_Id; begin Handler_Node := New_Node (N_Exception_Handler, Token_Ptr); T_When; -- Test for possible choice parameter present if Token = Tok_Identifier then Choice_Param_Node := Token_Node; Save_Scan_State (Scan_State); -- at identifier Scan; -- past identifier if Token = Tok_Colon then if Ada_83 then Error_Msg_SP ("choice parameter not allowed in Ada 83!"); end if; Scan; -- past : Set_Choice_Parameter (Handler_Node, Choice_Param_Node); else Restore_Scan_State (Scan_State); -- to identifier end if; end if; -- Loop through exception choices Set_Exception_Choices (Handler_Node, New_List); loop Append (P_Exception_Choice, Exception_Choices (Handler_Node)); exit when Token /= Tok_Vertical_Bar; Scan; -- past vertical bar end loop; TF_Arrow; Set_Statements (Handler_Node, P_Sequence_Of_Statements (SS_Sreq_Whtm)); return Handler_Node; end P_Exception_Handler; ---------------------------------- -- 11.2 Exception Handler Part -- ---------------------------------- -- EXCEPTION_HANDLER_PART ::= -- exception EXCEPTION_HANDLER {EXCEPTION_HANDLER} -- Note that this is an added rule which does not appear in the official -- grammar, which includes it as part of Handled_Sequence_Of_Statements. -- The value returned is a list of exception handlers (possibly intermixed -- with pragmas). -- Control returns after scanning the last exception handler, presumably -- at the keyword END, but this is not checked in this routine. -- The caller has checked that the initial token is EXCEPTION -- Error recovery: cannot raise Error_Resync function P_Exception_Handler_Part return List_Id is Handlers_List : List_Id; begin Scan; -- past EXCEPTION Handlers_List := New_List; P_Pragmas_Opt (Handlers_List); if Token = Tok_End then Error_Msg_SC ("must have at least one exception handler!"); else loop Append (P_Exception_Handler, Handlers_List); P_Pragmas_Opt (Handlers_List); exit when Token /= Tok_When; end loop; end if; return Handlers_List; end P_Exception_Handler_Part; ---------------------------- -- 11.2 Exception Choice -- ---------------------------- -- EXCEPTION_CHOICE ::= exception_NAME | others -- Error recovery: cannot raise Error_Resync. If an error occurs, then the -- scan pointer is advanced to the next arrow or vertical bar or semicolon. function P_Exception_Choice return Node_Id is begin if Token = Tok_Others then Scan; -- past OTHERS return New_Node (N_Others_Choice, Prev_Token_Ptr); else return P_Qualified_Simple_Name_Resync; -- exception name end if; exception when Error_Resync => Resync_Choice; return Error; end P_Exception_Choice; ---------------------------- -- 11.2 Choice Parameter -- ---------------------------- -- Parsed by P_Exception_Handler --------------------------- -- 11.3 Raise Statement -- --------------------------- -- RAISE_STATEMENT ::= raise [exception_NAME]; -- The caller has verified that the initial token is RAISE -- Error recovery: can raise Error_Resync function P_Raise_Statement return Node_Id is Raise_Node : Node_Id; begin Raise_Node := New_Node (N_Raise_Statement, Token_Ptr); Scan; -- past RAISE if Token /= Tok_Semicolon then Set_Name (Raise_Node, P_Qualified_Simple_Name_Resync); end if; TF_Semicolon; return Raise_Node; end P_Raise_Statement; end Ch11; oken = Tok_Exception then Set_Exception_Handlers (Handled_Stmt_Seq_Node, P_Exception_Handler_Part); end if; return Handled_Stmt_Seq_Node; end P_Handled_Sequence_Of_Statements; -----------------------------gnat-1.67-src/src/par-ch12.adb 444 10015 7640 65710 5506244336 11136 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P A R . C H 1 2 -- -- -- -- B o d y -- -- -- -- $Revision: 1.28 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ separate (Par) package body Ch12 is -- Local functions, used only in this chapter function P_Formal_Derived_Type_Definition return Node_Id; function P_Formal_Discrete_Type_Definition return Node_Id; function P_Formal_Fixed_Point_Definition return Node_Id; function P_Formal_Floating_Point_Definition return Node_Id; function P_Formal_Function_Declaration return Node_Id; function P_Formal_Modular_Type_Definition return Node_Id; function P_Formal_Package_Declaration return Node_Id; function P_Formal_Private_Type_Definition return Node_Id; function P_Formal_Procedure_Declaration return Node_Id; function P_Formal_Signed_Integer_Type_Definition return Node_Id; function P_Formal_Type_Declaration return Node_Id; function P_Formal_Type_Definition return Node_Id; function P_Generic_Association return Node_Id; procedure P_Formal_Object_Declarations (Decls : List_Id); -- Scans one or more formal object declarations and appends them to -- Decls. Scans more than one declaration only in the case where the -- source has a declaration with multiple defining identifiers. -------------------------------- -- 12.1 Generic (also 8.5.5) -- -------------------------------- -- This routine parses either one of the forms of a generic declaration -- or a generic renaming declaration. -- GENERIC_DECLARATION ::= -- GENERIC_SUBPROGRAM_DECLARATION | GENERIC_PACKAGE_DECLARATION -- GENERIC_SUBPROGRAM_DECLARATION ::= -- GENERIC_FORMAL_PART SUBPROGRAM_SPECIFICATION; -- GENERIC_PACKAGE_DECLARATION ::= -- GENERIC_FORMAL_PART PACKAGE_SPECIFICATION; -- GENERIC_FORMAL_PART ::= -- generic {GENERIC_FORMAL_PARAMETER_DECLARATION | USE_CLAUSE} -- GENERIC_RENAMING_DECLARATION ::= -- generic package DEFINING_PROGRAM_UNIT_NAME -- renames generic_package_NAME -- | generic procedure DEFINING_PROGRAM_UNIT_NAME -- renames generic_procedure_NAME -- | generic function DEFINING_PROGRAM_UNIT_NAME -- renames generic_function_NAME -- GENERIC_FORMAL_PARAMETER_DECLARATION ::= -- FORMAL_OBJECT_DECLARATION -- | FORMAL_TYPE_DECLARATION -- | FORMAL_SUBPROGRAM_DECLARATION -- | FORMAL_PACKAGE_DECLARATION -- The caller has checked that the initial token is GENERIC -- Error recovery: can raise Error_Resync function P_Generic return Node_Id is Gen_Sloc : constant Source_Ptr := Token_Ptr; Gen_Decl : Node_Id; Decl_Node : Node_Id; Decls : List_Id; Def_Unit : Node_Id; Ren_Token : Token_Type; Scan_State : Saved_Scan_State; begin Scan; -- past GENERIC Save_Scan_State (Scan_State); -- at token past GENERIC -- Check for generic renaming declaration case if Token = Tok_Package or else Token = Tok_Function or else Token = Tok_Procedure then Ren_Token := Token; Scan; -- scan past PACKAGE, FUNCTION or PROCEDURE if Token = Tok_Identifier then Def_Unit := P_Defining_Program_Unit_Name; if Token = Tok_Renames then if Ren_Token = Tok_Package then Decl_Node := New_Node (N_Generic_Package_Renaming_Declaration, Gen_Sloc); elsif Ren_Token = Tok_Procedure then Decl_Node := New_Node (N_Generic_Procedure_Renaming_Declaration, Gen_Sloc); else -- Ren_Token = Tok_Function then Decl_Node := New_Node (N_Generic_Function_Renaming_Declaration, Gen_Sloc); end if; Scan; -- past RENAMES Set_Defining_Unit_Name (Decl_Node, Def_Unit); Set_Name (Decl_Node, P_Name); TF_Semicolon; return Decl_Node; end if; end if; end if; -- Fall through if this is *not* a generic renaming declaration Restore_Scan_State (Scan_State); Decls := New_List; -- Loop through generic parameter declarations and use clauses Decl_Loop : loop if Token = Tok_Use then Append (P_Use_Clause, Decls); else -- Parse a generic parameter declaration if Token = Tok_Identifier then P_Formal_Object_Declarations (Decls); elsif Token = Tok_Type then Append (P_Formal_Type_Declaration, Decls); elsif Token = Tok_With then Scan; -- past WITH if Token = Tok_Package then Append (P_Formal_Package_Declaration, Decls); elsif Token = Tok_Procedure then Append (P_Formal_Procedure_Declaration, Decls); elsif Token = Tok_Function then Append (P_Formal_Function_Declaration, Decls); else Error_Msg_BC ("FUNCTION, PROCEDURE or PACKAGE expected here"); Resync_Past_Semicolon; end if; elsif Token = Tok_Subtype then Error_Msg_SC ("subtype declaration not allowed " & "as generic parameter declaration!"); Resync_Past_Semicolon; else exit Decl_Loop; end if; end if; end loop Decl_Loop; -- Generic formal part is scanned, scan out subprogram or package spec if Token = Tok_Package then Gen_Decl := New_Node (N_Generic_Package_Declaration, Gen_Sloc); Set_Specification (Gen_Decl, P_Package (Pf_Spcn)); else Gen_Decl := New_Node (N_Generic_Subprogram_Declaration, Gen_Sloc); Set_Specification (Gen_Decl, P_Subprogram_Specification); TF_Semicolon; end if; Set_Generic_Formal_Declarations (Gen_Decl, Decls); return Gen_Decl; end P_Generic; ------------------------------------------ -- 12.1 Generic Subprogram Declaration -- ------------------------------------------ -- Parsed by P_Generic_Declaration (12.1) --------------------------------------- -- 12.1 Generic Package Declaration -- --------------------------------------- -- Parsed by P_Generic_Declaration (12.1) ------------------------------------------------- -- 12.1 Generic Formal Parameter Declaration -- ------------------------------------------------- -- Parsed by P_Generic (12.1) --------------------------------- -- 12.3 Generic Instantiation -- --------------------------------- -- Generic procedure instantiation parsed by P_Subprogram (6.1) -- Generic function instantiation parsed by P_Subprogram (6.1) -- Generic package instantiation parsed by P_Package (7.1) ------------------------------- -- 12.3 Generic Actual Part -- ------------------------------- -- GENERIC_ACTUAL_PART ::= -- (GENERIC_ASSOCIATION {, GENERIC_ASSOCIATION}) -- Returns a list of generic associations, or Empty if none are present -- Error recovery: cannot raise Error_Resync function P_Generic_Actual_Part_Opt return List_Id is Association_List : List_Id; begin -- Figure out if a generic actual part operation is present. Clearly -- there is no generic actual part if the current token is semicolon if Token = Tok_Semicolon then return No_List; -- If we don't have a left paren, then we have an error, and the job -- is to figure out whether a left paren or semicolon was intended. -- We assume a missing left paren (and hence a generic actual part -- present) if the current token is not on a new line, or if it is -- indented from the subprogram token. Otherwise assume missing -- semicolon (which will be diagnosed by caller) and no generic part elsif Token /= Tok_Left_Paren and then Token_Is_At_Start_Of_Line and then Start_Column <= Scope.Table (Scope.Last).Ecol then return No_List; -- Otherwise we have a generic actual part (either a left paren is -- present, or we have decided that there must be a missing left paren) else Association_List := New_List; T_Left_Paren; loop Append (P_Generic_Association, Association_List); exit when not Comma_Present; end loop; T_Right_Paren; return Association_List; end if; end P_Generic_Actual_Part_Opt; ------------------------------- -- 12.3 Generic Association -- ------------------------------- -- GENERIC_ASSOCIATION ::= -- [generic_formal_parameter_SELECTOR_NAME =>] -- EXPLICIT_GENERIC_ACTUAL_PARAMETER -- EXPLICIT_GENERIC_ACTUAL_PARAMETER ::= -- EXPRESSION | variable_NAME | subprogram_NAME -- | entry_NAME | SUBTYPE_MARK | package_instance_NAME -- Error recovery: cannot raise Error_Resync function P_Generic_Association return Node_Id is Scan_State : Saved_Scan_State; Param_Name_Node : Node_Id; Generic_Assoc_Node : Node_Id; begin Generic_Assoc_Node := New_Node (N_Generic_Association, Token_Ptr); if Token in Token_Class_Desig then Param_Name_Node := Token_Node; Save_Scan_State (Scan_State); -- at designator Scan; -- past simple name or operator symbol if Token = Tok_Arrow then Scan; -- past arrow Set_Selector_Name (Generic_Assoc_Node, Param_Name_Node); else Restore_Scan_State (Scan_State); -- to designator end if; end if; Set_Explicit_Generic_Actual_Parameter (Generic_Assoc_Node, P_Expression); return Generic_Assoc_Node; end P_Generic_Association; ------------------------------------ -- 12.3 Generic Actual Parameter -- ------------------------------------ -- Parsed by P_Generic_Association (12.3) -------------------------------------- -- 12.4 Formal Object Declarations -- -------------------------------------- -- FORMAL_OBJECT_DECLARATION ::= -- DEFINING_IDENTIFIER_LIST : -- MODE SUBTYPE_MARK [:= DEFAULT_EXPRESSION]; -- The caller has checked that the initial token is an identifier -- Error recovery: cannot raise Error_Resync procedure P_Formal_Object_Declarations (Decls : List_Id) is Decl_Node : Node_Id; Scan_State : Saved_Scan_State; Num_Idents : Nat; Ident : Nat; Idents : array (Int range 1 .. 4096) of Entity_Id; -- This array holds the list of defining identifiers. The upper bound -- of 4096 is intended to be essentially infinite, and we do not even -- bother to check for it being exceeded. begin Idents (1) := P_Defining_Identifier; Num_Idents := 1; while Comma_Present loop Num_Idents := Num_Idents + 1; Idents (Num_Idents) := P_Defining_Identifier; end loop; T_Colon; -- If there are multiple identifiers, we repeatedly scan the -- type and initialization expression information by resetting -- the scan pointer (so that we get completely separate trees -- for each occurrence). if Num_Idents > 1 then Save_Scan_State (Scan_State); end if; -- Loop through defining identifiers in list Ident := 1; Ident_Loop : loop Decl_Node := New_Node (N_Formal_Object_Declaration, Token_Ptr); Set_Defining_Identifier (Decl_Node, Idents (Ident)); P_Mode (Decl_Node); Set_Subtype_Mark (Decl_Node, P_Subtype_Mark_Resync); No_Constraint; if Token = Tok_Colon_Equal then Scan; -- past := Set_Expression (Decl_Node, P_Expression_No_Right_Paren); end if; if Ident > 1 then Set_Prev_Ids (Decl_Node, True); end if; if Ident < Num_Idents then Set_More_Ids (Decl_Node, True); end if; Append (Decl_Node, Decls); exit Ident_Loop when Ident = Num_Idents; Ident := Ident + 1; Restore_Scan_State (Scan_State); end loop Ident_Loop; TF_Semicolon; end P_Formal_Object_Declarations; ----------------------------------- -- 12.5 Formal Type Declaration -- ----------------------------------- -- FORMAL_TYPE_DECLARATION ::= -- type DEFINING_IDENTIFIER [FORMAL_DISCRIMINANT_PART] -- is FORMAL_TYPE_DEFINITION; -- The caller has checked that the initial token is TYPE -- Error recovery: cannot raise Error_Resync function P_Formal_Type_Declaration return Node_Id is Decl_Node : Node_Id; Discr_Part : Node_Id; begin Decl_Node := New_Node (N_Formal_Type_Declaration, Token_Ptr); Scan; -- past TYPE Set_Defining_Identifier (Decl_Node, P_Defining_Identifier); if P_Unknown_Discriminant_Part_Opt then Set_Has_Unknown_Discriminants (Decl_Node, True); else Set_Discriminant_Specifications (Decl_Node, P_Known_Discriminant_Part_Opt); end if; T_Is; Set_Formal_Type_Definition (Decl_Node, P_Formal_Type_Definition); TF_Semicolon; return Decl_Node; end P_Formal_Type_Declaration; ---------------------------------- -- 12.5 Formal Type Definition -- ---------------------------------- -- FORMAL_TYPE_DEFINITION ::= -- FORMAL_PRIVATE_TYPE_DEFINITION -- | FORMAL_DERIVED_TYPE_DEFINITION -- | FORMAL_DISCRETE_TYPE_DEFINITION -- | FORMAL_INTEGER_TYPE_DEFINITION -- | FORMAL_REAL_TYPE_DEFINITION -- | FORMAL_FIXED_POINT_TYPE_DEFINITION -- | FORMAL_ARRAY_TYPE_DEFINITION -- | FORMAL_ACCESS_TYPE_DEFINITION -- FORMAL_REAL_TYPE_DEFINITION ::= -- FORMAL_FLOATING_POINT_DEFINITION | FORMAL_FIXED_POINT_DEFINITION -- FORMAL_ARRAY_TYPE_DEFINITION ::= ARRAY_TYPE_DEFINITION -- FORMAL_ACCESS_TYPE_DEFINITION ::= ACCESS_TYPE_DEFINITION function P_Formal_Type_Definition return Node_Id is begin if Token_Name = Name_Abstract then Check_9X_Keyword (Tok_Abstract, Tok_Tagged); end if; if Token_Name = Name_Tagged then Check_9X_Keyword (Tok_Tagged, Tok_Private); Check_9X_Keyword (Tok_Tagged, Tok_Limited); end if; case Token is when Tok_Private | Tok_Abstract | Tok_Limited | Tok_Tagged => return P_Formal_Private_Type_Definition; when Tok_New => return P_Formal_Derived_Type_Definition; when Tok_Left_Paren => return P_Formal_Discrete_Type_Definition; when Tok_Range => return P_Formal_Signed_Integer_Type_Definition; when Tok_Mod => return P_Formal_Modular_Type_Definition; when Tok_Digits => return P_Formal_Floating_Point_Definition; when Tok_Delta => return P_Formal_Fixed_Point_Definition; when Tok_Array => return P_Array_Type_Definition; when Tok_Access => return P_Access_Type_Definition; when Tok_Record => Error_Msg_SC ("record not allowed in generic type definition!"); Discard_Junk_Node (P_Record_Definition); return Error; when others => Error_Msg_BC ("expecting generic type definition here"); Resync_Past_Semicolon; return Error; end case; end P_Formal_Type_Definition; -------------------------------------------- -- 12.5.1 Formal Private Type Definition -- -------------------------------------------- -- FORMAL_PRIVATE_TYPE_DEFINITION ::= -- [abstract] [tagged] [limited] private -- The caller has checked the initial token is PRIVATE, ABSTRACT, -- TAGGED or LIMITED -- Error recovery: cannot raise Error_Resync function P_Formal_Private_Type_Definition return Node_Id is Def_Node : Node_Id; begin Def_Node := New_Node (N_Formal_Private_Type_Definition, Token_Ptr); if Token = Tok_Abstract then Scan; -- past ABSTRACT if Token_Name = Name_Tagged then Check_9X_Keyword (Tok_Tagged, Tok_Private); Check_9X_Keyword (Tok_Tagged, Tok_Limited); end if; if Token /= Tok_Tagged then Error_Msg_SP ("ABSTRACT must be followed by TAGGED"); else Set_Abstract_Present (Def_Node, True); end if; end if; if Token = Tok_Tagged then Set_Tagged_Present (Def_Node, True); Scan; -- past TAGGED end if; if Token = Tok_Limited then Set_Limited_Present (Def_Node, True); Scan; -- past LIMITED end if; Set_Sloc (Def_Node, Token_Ptr); T_Private; return Def_Node; end P_Formal_Private_Type_Definition; -------------------------------------------- -- 12.5.1 Formal Derived Type Definition -- -------------------------------------------- -- FORMAL_DERIVED_TYPE_DEFINITION ::= new SUBTYPE_MARK [with private] -- The caller has checked the initial token is NEW -- Error recovery: cannot raise Error_Resync function P_Formal_Derived_Type_Definition return Node_Id is Def_Node : Node_Id; begin Def_Node := New_Node (N_Formal_Derived_Type_Definition, Token_Ptr); Scan; -- past NEW; Set_Subtype_Mark (Def_Node, P_Subtype_Mark); No_Constraint; if Token = Tok_With then Scan; -- past WITH Set_Private_Present (Def_Node, True); T_Private; end if; return Def_Node; end P_Formal_Derived_Type_Definition; --------------------------------------------- -- 12.5.2 Formal Discrete Type Definition -- --------------------------------------------- -- FORMAL_DISCRETE_TYPE_DEFINITION ::= (<>) -- The caller has checked the initial token is left paren -- Error recovery: cannot raise Error_Resync function P_Formal_Discrete_Type_Definition return Node_Id is Def_Node : Node_Id; begin Def_Node := New_Node (N_Formal_Discrete_Type_Definition, Token_Ptr); Scan; -- past left paren T_Box; T_Right_Paren; return Def_Node; end P_Formal_Discrete_Type_Definition; --------------------------------------------------- -- 12.5.2 Formal Signed Integer Type Definition -- --------------------------------------------------- -- FORMAL_SIGNED_INTEGER_TYPE_DEFINITION ::= range <> -- The caller has checked the initial token is RANGE -- Error recovery: cannot raise Error_Resync function P_Formal_Signed_Integer_Type_Definition return Node_Id is Def_Node : Node_Id; begin Def_Node := New_Node (N_Formal_Signed_Integer_Type_Definition, Token_Ptr); Scan; -- past RANGE T_Box; return Def_Node; end P_Formal_Signed_Integer_Type_Definition; -------------------------------------------- -- 12.5.2 Formal Modular Type Definition -- -------------------------------------------- -- FORMAL_MODULAR_TYPE_DEFINITION ::= mod <> -- The caller has checked the initial token is MOD -- Error recovery: cannot raise Error_Resync function P_Formal_Modular_Type_Definition return Node_Id is Def_Node : Node_Id; begin Def_Node := New_Node (N_Formal_Modular_Type_Definition, Token_Ptr); Scan; -- past MOD T_Box; return Def_Node; end P_Formal_Modular_Type_Definition; ---------------------------------------------- -- 12.5.2 Formal Floating Point Definition -- ---------------------------------------------- -- FORMAL_FLOATING_POINT_DEFINITION ::= digits <> -- The caller has checked the initial token is DIGITS -- Error recovery: cannot raise Error_Resync function P_Formal_Floating_Point_Definition return Node_Id is Def_Node : Node_Id; begin Def_Node := New_Node (N_Formal_Floating_Point_Definition, Token_Ptr); Scan; -- past DIGITS T_Box; return Def_Node; end P_Formal_Floating_Point_Definition; ------------------------------------------- -- 12.5.2 Formal Fixed Point Definition -- ------------------------------------------- -- FORMAL_FIXED_POINT_DEFINITION ::= -- FORMAL_ORDINARY_FIXED_POINT_DEFINITION -- | FORMAL_DECIMAL_FIXED_POINT_DEFINITION -- FORMAL_ORDINARY_FIXED_POINT_DEFINITION ::= delta <> -- FORMAL_DECIMAL_FIXED_POINT_DEFINITION ::= delta <> digits <> -- The caller has checked the initial token is DELTA -- Error recovery: cannot raise Error_Resync function P_Formal_Fixed_Point_Definition return Node_Id is Def_Node : Node_Id; Delta_Sloc : Source_Ptr; begin Delta_Sloc := Token_Ptr; Scan; -- past DELTA T_Box; if Token = Tok_Digits then Def_Node := New_Node (N_Formal_Decimal_Fixed_Point_Definition, Delta_Sloc); Scan; -- past DIGITS T_Box; else Def_Node := New_Node (N_Formal_Ordinary_Fixed_Point_Definition, Delta_Sloc); end if; return Def_Node; end P_Formal_Fixed_Point_Definition; ---------------------------------------------------- -- 12.5.2 Formal Ordinary Fixed Point Definition -- ---------------------------------------------------- -- Parsed by P_Formal_Fixed_Point_Definition (12.5.2) --------------------------------------------------- -- 12.5.2 Formal Decimal Fixed Point Definition -- --------------------------------------------------- -- Parsed by P_Formal_Fixed_Point_Definition (12.5.2) ------------------------------------------- -- 12.5.3 Generic Array Type Definition -- ------------------------------------------- -- Parsed by P_Formal_Type_Definition (12.5) -------------------------------------------- -- 12.5.4 Generic Access Type Definition -- -------------------------------------------- -- Parsed by P_Formal_Type_Definition (12.5) ----------------------------------------- -- 12.6 Formal Subprogram Declaration -- ----------------------------------------- -- FORMAL_SUBPROGRAM_DECLARATION ::= -- with SUBPROGRAM_SPECIFICATION [is SUBPROGRAM_DEFAULT]; -- SUBPROGRAM_DEFAULT ::= DEFAULT_NAME | <> -- DEFAULT_NAME ::= NAME -- The caller has checked that the initial tokens are WITH FUNCTION or -- WITH PROCEDURE, and the initial WITH has been scanned out. -- Note: we separate this into two procedures because the name is allowed -- to be an operator symbol for a function, but not for a procedure. -- Error recovery: cannot raise Error_Resync function P_Formal_Function_Declaration return Node_Id is Def_Node : Node_Id; begin Def_Node := New_Node (N_Formal_Subprogram_Declaration, Prev_Token_Ptr); Set_Specification (Def_Node, P_Subprogram_Specification); if Token = Tok_Is then Scan; -- past IS if Token = Tok_Box then Set_Box_Present (Def_Node, True); Scan; -- past <> else Set_Default_Name (Def_Node, P_Name); end if; end if; T_Semicolon; return Def_Node; end P_Formal_Function_Declaration; function P_Formal_Procedure_Declaration return Node_Id is Def_Node : Node_Id; begin Def_Node := New_Node (N_Formal_Subprogram_Declaration, Prev_Token_Ptr); Set_Specification (Def_Node, P_Subprogram_Specification); if Token = Tok_Is then Scan; -- past IS if Token = Tok_Box then Set_Box_Present (Def_Node, True); Scan; -- past <> else Set_Name (Def_Node, P_Qualified_Simple_Name); end if; end if; T_Semicolon; return Def_Node; end P_Formal_Procedure_Declaration; -------------------------------------- -- 12.7 Formal Package Declaration -- -------------------------------------- -- FORMAL_PACKAGE_DECLARATION ::= -- with package DEFINING_IDENTIFIER -- is new generic_package_NAME FORMAL_PACKAGE_ACTUAL_PART; -- FORMAL_PACKAGE_ACTUAL_PART ::= -- (<>) | [GENERIC_ACTUAL_PART] -- The caller has checked that the initial tokens are WITH PACKAGE, -- and the initial WITH has been scanned out (so Token = Tok_Package). -- Error recovery: cannot raise Error_Resync function P_Formal_Package_Declaration return Node_Id is Def_Node : Node_Id; Scan_State : Saved_Scan_State; begin Scan; -- past PACKAGE Def_Node := New_Node (N_Formal_Package_Declaration, Prev_Token_Ptr); Set_Defining_Identifier (Def_Node, P_Defining_Identifier); T_Is; T_New; Set_Name (Def_Node, P_Qualified_Simple_Name); if Token = Tok_Left_Paren then Save_Scan_State (Scan_State); -- at the left paren Scan; -- past the left paren if Token = Tok_Box then Set_Box_Present (Def_Node, True); Scan; -- past box T_Right_Paren; else Restore_Scan_State (Scan_State); -- to the left paren Set_Generic_Associations (Def_Node, P_Generic_Actual_Part_Opt); end if; end if; T_Semicolon; return Def_Node; end P_Formal_Package_Declaration; -------------------------------------- -- 12.7 Formal Package Actual Part -- -------------------------------------- -- Parsed by P_Formal_Package_Declaration (12.7) end Ch12; e_Definition, Token_Ptr); Scan; -- past NEW; gnat-1.67-src/src/par-ch13.adb 444 10015 7640 26126 5506244337 11136 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P A R . C H 1 3 -- -- -- -- B o d y -- -- -- -- $Revision: 1.21 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ separate (Par) package body Ch13 is -- Local functions, used only in this chapter function P_Component_Clause return Node_Id; function P_Mod_Clause return Node_Id; --------------------------------- -- 13.1 Representation Clause -- --------------------------------- -- REPRESENTATION_CLAUSE ::= -- ATTRIBUTE_DEFINITION_CLAUSE -- | ENUMERATION_REPRESENTATION_CLAUSE -- | RECORD_REPRESENTATION_CLAUSE -- | AT_CLAUSE -- ATTRIBUTE_DEFINITION_CLAUSE ::= -- for DIRECT_NAME'ATTRIBUTE_DESIGNATOR use EXPRESSION; -- | for DIRECT_NAME'ATTRIBUTE_DESIGNATOR use NAME; -- Note: in Ada 83, the expression must be a simple expression -- AT_CLAUSE ::= for DIRECT_NAME use at EXPRESSION; -- Note: in Ada 83, the expression must be a simple expression -- ENUMERATION_REPRESENTATION_CLAUSE ::= -- for first_subtype_DIRECT_NAME use ENUMERATION_AGGREGATE; -- ENUMERATION_AGGREGATE ::= ARRAY_AGGREGATE -- RECORD_REPRESENTATION_CLAUSE ::= -- for first_subtype_DIRECT_NAME use -- record [MOD_CLAUSE] -- {COMPONENT_CLAUSE} -- end record; -- The caller has checked that the initial token is FOR -- Error recovery: cannot raise Error_Resync, if an error occurs, -- the scan is repositioned past the next semicolon. function P_Representation_Clause return Node_Id is For_Loc : Source_Ptr; Identifier_Node : Node_Id; Rep_Clause_Node : Node_Id; Expr_Node : Node_Id; begin For_Loc := Token_Ptr; Scan; -- past FOR -- Note that the name in a representation clause is always a simple -- name, even in the attribute case, see AI-300 which made this so! Identifier_Node := P_Identifier; -- Check case of qualified name to give good error message if Token = Tok_Dot then Error_Msg_SC ("representation clause requires simple name!"); loop exit when Token /= Tok_Dot; Scan; -- past dot Discard_Junk_Node (P_Identifier); end loop; end if; -- Attribute Definition Clause if Token = Tok_Apostrophe then Rep_Clause_Node := New_Node (N_Attribute_Definition_Clause, For_Loc); Set_Name (Rep_Clause_Node, Identifier_Node); Scan; -- past apostrophe Set_Identifier (Rep_Clause_Node, P_Identifier); T_Use; Expr_Node := P_Expression_No_Right_Paren; Check_Simple_Expression_In_Ada_83 (Expr_Node); Set_Expression (Rep_Clause_Node, Expr_Node); else TF_Use; -- AT follows USE (At Clause) if Token = Tok_At then if Ada_9X then Error_Msg_SC ("obsolescent feature: at clause?"); end if; Scan; -- past AT Rep_Clause_Node := New_Node (N_At_Clause, For_Loc); Set_Identifier (Rep_Clause_Node, Identifier_Node); Expr_Node := P_Expression_No_Right_Paren; Check_Simple_Expression_In_Ada_83 (Expr_Node); Set_Expression (Rep_Clause_Node, Expr_Node); -- RECORD follows USE (Record Representation Clause) elsif Token = Tok_Record then Rep_Clause_Node := New_Node (N_Record_Representation_Clause, For_Loc); Set_Identifier (Rep_Clause_Node, Identifier_Node); Push_Scope_Stack; Scope.Table (Scope.Last).Etyp := E_Record; Scope.Table (Scope.Last).Ecol := Start_Column; Scope.Table (Scope.Last).Sloc := Token_Ptr; Scan; -- past RECORD -- Possible Mod Clause if Token = Tok_At then Set_Mod_Clause (Rep_Clause_Node, P_Mod_Clause); end if; Set_Component_Clauses (Rep_Clause_Node, New_List); -- Loop through component clauses loop if Token not in Token_Class_Name then exit when Check_End; end if; Append (P_Component_Clause, Component_Clauses (Rep_Clause_Node)); end loop; -- Left paren follows USE (Enumeration Representation Clause) elsif Token = Tok_Left_Paren then Rep_Clause_Node := New_Node (N_Enumeration_Representation_Clause, For_Loc); Set_Identifier (Rep_Clause_Node, Identifier_Node); Set_Array_Aggregate (Rep_Clause_Node, P_Aggregate); -- Some other token follows FOR (invalid representation clause) else Error_Msg_SC ("invalid representation clause"); raise Error_Resync; end if; end if; TF_Semicolon; return Rep_Clause_Node; exception when Error_Resync => Resync_Past_Semicolon; return Error; end P_Representation_Clause; -------------------------------------- -- 13.1 Type Representation Clause -- -------------------------------------- -- Parsed by P_Representation_Clause (13.1) --------------------------------------- -- 13.2 Attribute Definition Clause -- --------------------------------------- -- Parsed by P_Representation_Clause (13.1) --------------------------------------------- -- 13.3 Enumeration Representation Clause -- --------------------------------------------- -- Parsed by P_Representation_Clause (13.1) ---------------------------------------- -- 13.4 Record Representation Clause -- ---------------------------------------- -- Parsed by P_Representation_Clause (13.1) ---------------------- -- 13.4 Mod Clause -- ---------------------- -- MOD_CLAUSE ::= at mod static_EXPRESSION; -- Note: in Ada 83, the expression must be a simple expression -- The caller has checked that the initial Token is AT -- Error recovery: cannot raise Error_Resync function P_Mod_Clause return Node_Id is Mod_Node : Node_Id; Expr_Node : Node_Id; begin if Ada_9X then Error_Msg_SC ("obsolescent feature: mod clause?"); end if; Mod_Node := New_Node (N_Mod_Clause, Token_Ptr); Scan; -- past AT T_Mod; Expr_Node := P_Expression_No_Right_Paren; Check_Simple_Expression_In_Ada_83 (Expr_Node); Set_Expression (Mod_Node, Expr_Node); TF_Semicolon; return Mod_Node; end P_Mod_Clause; ----------------------------- -- 13.4 Component Clauses -- ----------------------------- -- COMPONENT_CLAUSE ::= -- COMPONENT_CLAUSE_COMPONENT_NAME at POSITION -- range FIRST_BIT .. LAST_BIT; -- COMPONENT_CLAUSE_COMPONENT_NAME ::= -- component_DIRECT_NAME -- | component_DIRECT_NAME'ATTRIBUTE_DESIGNATOR -- | FIRST_SUBTYPE_DIRECT_NAME'ATTRIBUTE_DESIGNATOR -- POSITION ::= static_EXPRESSION -- Note: in Ada 83, the expression must be a simple expression -- FIRST_BIT ::= static_SIMPLE_EXPRESSION -- LAST_BIT ::= static_SIMPLE_EXPRESSION -- Note: the AARM V2.0 grammar has an error at this point, it uses -- EXPRESSION instead of SIMPLE_EXPRESSION for FIRST_BIT and LAST_BIT -- Error recovery: cannot raise Error_Resync function P_Component_Clause return Node_Id is Component_Node : Node_Id; Comp_Name : Node_Id; Expr_Node : Node_Id; begin Component_Node := New_Node (N_Component_Clause, Token_Ptr); Comp_Name := P_Name; if Nkind (Comp_Name) = N_Identifier or else Nkind (Comp_Name) = N_Attribute_Reference then Set_Component_Name (Component_Node, Comp_Name); else Error_Msg_N ("component name must be direct name or attribute", Comp_Name); Set_Component_Name (Component_Node, Error); end if; Set_Sloc (Component_Node, Token_Ptr); T_At; Expr_Node := P_Expression_No_Right_Paren; Check_Simple_Expression_In_Ada_83 (Expr_Node); Set_Position (Component_Node, Expr_Node); T_Range; Expr_Node := P_Expression_No_Right_Paren; Check_Simple_Expression_In_Ada_83 (Expr_Node); Set_First_Bit (Component_Node, Expr_Node); T_Dot_Dot; Expr_Node := P_Expression_No_Right_Paren; Check_Simple_Expression_In_Ada_83 (Expr_Node); Set_Last_Bit (Component_Node, Expr_Node); TF_Semicolon; return Component_Node; end P_Component_Clause; -------------------------- -- 13.8 Code Statement -- -------------------------- -- CODE_STATEMENT ::= SUBTYPE_MARK'RECORD_AGGREGATE; -- On entry the caller has scanned the SUBTYPE_MARK (passed in as the -- single argument, and the scan points to the apostrophe. -- Error recovery: can raise Error_Resync function P_Code_Statement (Subtype_Mark : Node_Id) return Node_Id is Node1 : Node_Id; begin Scan; -- past apostrophe -- If left paren, then we have a possible code statement if Token = Tok_Left_Paren then Node1 := New_Node (N_Code_Statement, Sloc (Subtype_Mark)); Set_Expression (Node1, P_Qualified_Expression (Subtype_Mark)); TF_Semicolon; return Node1; -- Otherwise we have an illegal range attribute. Note that P_Call_Name -- ensures that Token = Tok_Range is the only possibility left here. else -- Token = Tok_Range Error_Msg_SC ("RANGE attribute illegal here!"); raise Error_Resync; end if; end P_Code_Statement; end Ch13; ion P_Representation_Clause return Node_Id is For_Loc : Source_Ptr; Identifier_Node : Node_Id; Rep_Clause_Node : Node_Id; Expr_Node : Node_Id; begin For_Loc := Token_Ptr; Scan; -- past FOR -- Note that the name in a representation clause is always a simple -- name, even in the attribute case, see AI-300 which made this so! Identifier_Node := P_Idengnat-1.67-src/src/par-ch2.adb 444 10015 7640 22526 5506244337 11054 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P A R . C H 2 -- -- -- -- B o d y -- -- -- -- $Revision: 1.20 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ separate (Par) package body Ch2 is -- Local functions, used only in this chapter function P_Pragma_Argument_Association return Node_Id; --------------------- -- 2.3 Identifier -- --------------------- -- IDENTIFIER ::= LETTER {LETTER | DIGIT | UNDERLINE} -- An IDENTIFIER shall not contain two underlines in a row -- An IDENTIFIER shall not be a reserved word -- Error recovery: can raise Error_Resync (cannot return Error) function P_Identifier return Node_Id is Ident_Node : Node_Id; begin -- All set if we do indeed have an identifier if Token = Tok_Identifier then Ident_Node := Token_Node; Scan; -- past Identifier return Ident_Node; -- If we have a reserved identifier, manufacture an identifier with -- a corresponding name after posting an appropriate error message elsif Is_Reserved_Identifier then Scan_Reserved_Identifier (Force_Msg => False); Ident_Node := Token_Node; Scan; -- past the node return Ident_Node; -- Otherwise we have junk that cannot be interpreted as an identifier else T_Identifier; -- to give message raise Error_Resync; end if; end P_Identifier; -------------------------- -- 2.4 Numeric Literal -- -------------------------- -- Numeric literal is returned by the scanner as either -- Tok_Integer_Literal or Tok_Real_Literal ---------------------------- -- 2.4.1 Decimal Literal -- ---------------------------- -- Decimal literal is returned by the scanner as either -- Tok_Integer_Literal or Tok_Real_Literal -------------------------- -- 2.4.1 Based Literal -- -------------------------- -- Based literal is returned by the scanner as either -- Tok_Integer_Literal or Tok_Real_Literal ---------------------------- -- 2.5 Character Literal -- ---------------------------- -- Handled by the scanner and returned as Tok_Character_Literal ------------------------- -- 2.6 String Literal -- ------------------------- -- Handled by the scanner and returned as Tok_Character_Literal -- or if the string looks like an operator as Tok_Operator_Symbol. ------------------ -- 2.7 Comment -- ------------------ -- Handled by the scanner which simply skips past encountered comments ----------------- -- 2.8 Pragma -- ----------------- -- PRAGMA ::= pragma IDENTIFIER -- [(PRAGMA_ARGUMENT_ASSOCIATION {, PRAGMA_ARGUMENT_ASSOCIATION})]; -- The caller has checked that the initial token is PRAGMA -- Error recovery: cannot raise Error_Resync -- One special piece of processing is needed in this routine. As described -- in the section on "Handling semicolon used in place of IS" in module -- Parse, the parser detects the case of missing subprogram bodies to -- allow recovery from this syntactic error. Pragma INTERFACE (and, for -- Ada 9X, pragma IMPORT) can appear in place of the body. The parser must -- recognize the use of these two pragmas in this context, otherwise it -- will think there are missing bodies, and try to change ; to IS, when -- in fact the bodies ARE present, supplied by these pragmas. function P_Pragma return Node_Id is Interface_Check_Required : Boolean := False; -- Set True if check of pragma INTERFACE is required Import_Check_Required : Boolean := False; -- Set True if check of pragma IMPORT is required Arg_Count : Int := 0; -- Number of argument associations processed Pragma_Node : Node_Id; Pragma_Name : Name_Id; Semicolon_Loc : Source_Ptr; begin Pragma_Node := New_Node (N_Pragma, Token_Ptr); Scan; -- past PRAGMA Pragma_Name := Token_Name; Set_Identifier (Pragma_Node, P_Identifier); -- See if special INTERFACE/IMPORT check is required if SIS_Entry_Active then Interface_Check_Required := (Pragma_Name = Name_Interface); Import_Check_Required := (Pragma_Name = Name_Import); else Interface_Check_Required := False; Import_Check_Required := False; end if; if Token = Tok_Left_Paren then Set_Pragma_Argument_Associations (Pragma_Node, New_List); Scan; -- past ( loop Arg_Count := Arg_Count + 1; if Arg_Count = 2 and then (Interface_Check_Required or else Import_Check_Required) then -- Here is where we cancel the SIS active status if this pragma -- supplies a body for the currently active subprogram spec. if Token in Token_Class_Desig then if Token_Name = Chars (SIS_Labl) then SIS_Entry_Active := False; end if; end if; end if; Append (P_Pragma_Argument_Association, Pragma_Argument_Associations (Pragma_Node)); exit when Token /= Tok_Comma; Scan; -- past comma end loop; T_Right_Paren; end if; Semicolon_Loc := Token_Ptr; if Token /= Tok_Semicolon then T_Semicolon; Resync_Past_Semicolon; else Scan; -- past semicolon end if; if Is_Pragma_Name (Chars (Identifier (Pragma_Node))) then return Par.Prag (Pragma_Node, Semicolon_Loc); else Error_Msg_Node_1 := Identifier (Pragma_Node); Error_Msg ("unrecognized pragma&?!", Sloc (Identifier (Pragma_Node))); return Error; end if; exception when Error_Resync => Resync_Past_Semicolon; return Error; end P_Pragma; -- This routine is called if a pragma is encountered in an inappropriate -- position, the pragma is scanned out and control returns to continue. -- The caller has checked that the initial token is pragma -- Error recovery: cannot raise Error_Resync procedure P_Pragmas_Misplaced is begin while Token = Tok_Pragma loop Error_Msg_SC ("pragma not allowed here"); Discard_Junk_Node (P_Pragma); end loop; end P_Pragmas_Misplaced; -- This procedure is called to scan out an optional sequence of pragmas. -- Any pragmas found are appended to the list provided as an argument. -- Error recovery: Cannot raise Error_Resync procedure P_Pragmas_Opt (List : List_Id) is begin while Token = Tok_Pragma loop Append (P_Pragma, List); end loop; end P_Pragmas_Opt; -------------------------------------- -- 2.8 Pragma_Argument Association -- -------------------------------------- -- PRAGMA_ARGUMENT_ASSOCIATION ::= -- [argument_IDENTIFIER =>] NAME -- | [argument_IDENTIFIER =>] EXPRESSION -- Error recovery: cannot raise Error_Resync function P_Pragma_Argument_Association return Node_Id is Scan_State : Saved_Scan_State; Pragma_Arg_Node : Node_Id; Identifier_Node : Node_Id; begin Pragma_Arg_Node := New_Node (N_Pragma_Argument_Association, Token_Ptr); if Token = Tok_Identifier then Identifier_Node := Token_Node; Save_Scan_State (Scan_State); -- at Identifier Scan; -- past Identifier if Token = Tok_Arrow then Scan; -- past arrow Set_Identifier (Pragma_Arg_Node, Identifier_Node); else Restore_Scan_State (Scan_State); -- to Identifier end if; end if; Set_Expression (Pragma_Arg_Node, P_Expression); return Pragma_Arg_Node; end P_Pragma_Argument_Association; end Ch2; the initial token is PRAGMA -- Error recovery: cannot raise Error_Resync -- One special piece of processing is needed in this routine. As described -- in thgnat-1.67-src/src/par-ch3.adb 444 10015 7640 302520 5506244342 11064 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P A R . C H 3 -- -- -- -- B o d y -- -- -- -- $Revision: 1.65 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Sinfo.Change; use Sinfo.Change; separate (Par) package body Ch3 is -- Local subprograms, used only in this chapter function P_Component_List return Node_Id; function P_Delta_Constraint return Node_Id; function P_Derived_Type_Def_Or_Private_Ext_Decl return Node_Id; function P_Digits_Constraint return Node_Id; function P_Discriminant_Association return Node_Id; function P_Enumeration_Literal_Specification return Node_Id; function P_Enumeration_Type_Definition return Node_Id; function P_Fixed_Point_Definition return Node_Id; function P_Floating_Point_Definition return Node_Id; function P_Index_Or_Discriminant_Constraint return Node_Id; function P_Real_Range_Specification_Opt return Node_Id; function P_Subtype_Declaration return Node_Id; function P_Type_Declaration return Node_Id; function P_Constrained_Array_Definition return Node_Id; function P_Modular_Type_Definition return Node_Id; function P_Variant return Node_Id; function P_Variant_Part return Node_Id; procedure P_Declarative_Items (Decls : List_Id; Done : out Boolean); -- Scans out a single declarative item, or, in the case of a declaration -- with a list of identifiers, a list of declarations, one for each of -- the identifiers in the list. The declaration or declarations scanned -- are appended to the given list. Done indicates whether or not there -- may be additional declarative items to scan. If Done is True, then -- a decision has been made that there are no more items to scan. If -- Done is False, then there may be additional declarations to scan. procedure P_Identifier_Declarations (Decls : List_Id; Done : out Boolean); -- Scans out a set of declarations for an identifier or list of -- identifiers, and appends them to the given list. Done indicates -- whether or not there may be additional declarative items to scan. -- If Done is True, then a decision has been made that there are no -- more items to scan. If Done is False, then there may be additional -- declarations to scan. procedure P_Begin_For_Missing_Body; -- Scans out a begin for the case of a missing subprogram body ---------------------------- -- 3.1 Basic Declaration -- ---------------------------- -- Parsed by P_Basic_Declarative_Items (3.9) ------------------------------ -- 3.1 Defining Identifier -- ------------------------------ -- DEFINING_IDENTIFIER ::= IDENTIFIER -- Error recovery: can raise Error_Resync function P_Defining_Identifier return Node_Id is Ident_Node : Node_Id; begin -- Scan out the identifier. Note that this code is essentially identical -- to P_Identifier, except that in the call to Scan_Reserved_Identifier -- we set Force_Msg to True, since we want at least one message for each -- separate declaration (but not use) of a reserved identifier. if Token = Tok_Identifier then null; -- If we have a reserved identifier, manufacture an identifier with -- a corresponding name after posting an appropriate error message elsif Is_Reserved_Identifier then Scan_Reserved_Identifier (Force_Msg => True); -- Otherwise we have junk that cannot be interpreted as an identifier else T_Identifier; -- to give message raise Error_Resync; end if; Ident_Node := Token_Node; Scan; -- past the reserved identifier if Ident_Node /= Error then Change_Identifier_To_Defining_Identifier (Ident_Node); end if; return Ident_Node; end P_Defining_Identifier; ----------------------------- -- 3.2.1 Type Declaration -- ----------------------------- -- TYPE_DECLARATION ::= -- FULL_TYPE_DECLARATION -- | INCOMPLETE_TYPE_DECLARATION -- | PRIVATE_TYPE_DECLARATION -- FULL_TYPE_DECLARATION ::= -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] is TYPE_DEFINITION; -- | CONCURRENT_TYPE_DECLARATION -- INCOMPLETE_TYPE_DECLARATION ::= -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART]; -- PRIVATE_TYPE_DECLARATION ::= -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] -- is [abstract] [tagged] [limited] private; -- TYPE_DEFINITION ::= -- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION -- | REAL_TYPE_DEFINITION | ARRAY_TYPE_DEFINITION -- | RECORD_TYPE_DEFINITION | ACCESS_TYPE_DEFINITION -- | DERIVED_TYPE_DEFINITION -- INTEGER_TYPE_DEFINITION ::= -- SIGNED_INTEGER_TYPE_DEFINITION -- UNSIGNED_RANGE_SPECIFICATION -- Error recovery: can raise Error_Resync -- Note: The processing for full type declaration, *incomplete type -- declaration, private type declaration and type definition is -- included in this function. The processing for concurrent type -- declarations is NOT here, but rather in chapter 9 (i.e. this -- function handles only declarations starting with TYPE). function P_Type_Declaration return Node_Id is Type_Loc : Source_Ptr; Type_Start_Col : Column_Number_Type; Ident_Node : Node_Id; Decl_Node : Node_Id; Discr_List : List_Id; Unknown_Dis : Boolean; Discr_Sloc : Source_Ptr; Abstract_Present : Boolean := False; Abstract_Loc : Source_Ptr; Typedef_Node : Node_Id; -- Normally holds type definition, except in the case of a private -- extension declaration, in which case it holds the declaration itself begin Type_Loc := Token_Ptr; Type_Start_Col := Start_Column; T_Type; Ident_Node := P_Defining_Identifier; Discr_Sloc := Token_Ptr; if P_Unknown_Discriminant_Part_Opt then Unknown_Dis := True; Discr_List := No_List; else Unknown_Dis := False; Discr_List := P_Known_Discriminant_Part_Opt; end if; -- Incomplete type declaration. We complete the processing for this -- case here and return the resulting incomplete type declaration node if Token = Tok_Semicolon then Scan; -- past ; Decl_Node := New_Node (N_Incomplete_Type_Declaration, Type_Loc); Set_Defining_Identifier (Decl_Node, Ident_Node); Set_Has_Unknown_Discriminants (Decl_Node, Unknown_Dis); Set_Discriminant_Specifications (Decl_Node, Discr_List); return Decl_Node; end if; -- Full type declaration or private type declaration, must have IS if Token = Tok_Equal then TF_Is; Scan; -- past = used in place of IS else TF_Is; end if; if Token_Name = Name_Abstract then Check_9X_Keyword (Tok_Abstract, Tok_Tagged); Check_9X_Keyword (Tok_Abstract, Tok_New); end if; if Token = Tok_Abstract then Abstract_Present := True; Abstract_Loc := Token_Ptr; Scan; -- past ABSTRACT end if; if Token_Name = Name_Tagged then Check_9X_Keyword (Tok_Tagged, Tok_Private); Check_9X_Keyword (Tok_Tagged, Tok_Limited); Check_9X_Keyword (Tok_Tagged, Tok_Record); end if; -- The following procesing deals with either a private type declaration -- or a full type declaration. In the private type case, we build the -- N_Private_Type_Declaration node, setting its Tagged_Present and -- Limited_Present flags, on encountering the Private keyword, and -- leave Typedef_Node set to Empty. For the full type declaration -- case, Typedef_Node gets set to the type definition. Typedef_Node := Empty; -- Switch on token following the IS case Token is when Tok_Range => Typedef_Node := P_Signed_Integer_Type_Definition; TF_Semicolon; when Tok_Mod => Typedef_Node := P_Modular_Type_Definition; TF_Semicolon; when Tok_New => Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl; TF_Semicolon; when Tok_Array => Typedef_Node := P_Array_Type_Definition; TF_Semicolon; when Tok_Access => Typedef_Node := P_Access_Type_Definition; TF_Semicolon; when Tok_Left_Paren => Typedef_Node := P_Enumeration_Type_Definition; TF_Semicolon; when Tok_Digits => Typedef_Node := P_Floating_Point_Definition; TF_Semicolon; when Tok_Delta => Typedef_Node := P_Fixed_Point_Definition; TF_Semicolon; when Tok_Record => Typedef_Node := P_Record_Definition; TF_Semicolon; when Tok_Null => Typedef_Node := P_Record_Definition; TF_Semicolon; when Tok_Tagged => Scan; -- past TAGGED if Token = Tok_Limited then Scan; -- past LIMITED -- TAGGED LIMITED PRIVATE case if Token = Tok_Private then Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc); Set_Tagged_Present (Decl_Node, True); Set_Limited_Present (Decl_Node, True); Scan; -- past PRIVATE -- TAGGED LIMITED RECORD else Typedef_Node := P_Record_Definition; Set_Tagged_Present (Typedef_Node, True); Set_Limited_Present (Typedef_Node, True); end if; else -- TAGGED PRIVATE if Token = Tok_Private then Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc); Set_Tagged_Present (Decl_Node, True); Scan; -- past PRIVATE -- TAGGED RECORD else Typedef_Node := P_Record_Definition; Set_Tagged_Present (Typedef_Node, True); end if; end if; TF_Semicolon; -- PRIVATE when Tok_Private => Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc); Scan; -- past PRIVATE TF_Semicolon; when Tok_Limited => Scan; -- past LIMITED -- LIMITED RECORD or LIMITED NULL RECORD if Token = Tok_Record or else Token = Tok_Null then if Ada_83 then Error_Msg_SP ("limited record declaration not allowed in Ada 83!"); end if; Typedef_Node := P_Record_Definition; Set_Limited_Present (Typedef_Node, True); -- LIMITED PRIVATE is the only remaining possibility here else Decl_Node := New_Node (N_Private_Type_Declaration, Type_Loc); Set_Limited_Present (Decl_Node, True); T_Private; -- past PRIVATE (or complain if not there!) end if; TF_Semicolon; -- Here we have an identifier after the IS, which is certainly wrong -- and which might be one of several different mistakes. when Tok_Identifier => -- First case, if identifier is on same line, then probably we -- have something like "type X is Integer .." and the best -- diagnosis is a missing NEW. Note that the missing new message -- will be posted by P_Derived_Type_Def_Or_Private_Ext_Decl. if not Token_Is_At_Start_Of_Line then Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl; TF_Semicolon; -- If the identifier is at the start of the line, and is in the -- same column as the type declaration itself then we consider -- that we had a missing type definition on the previous line elsif Start_Column <= Type_Start_Col then Error_Msg_AP ("type definition expected"); Typedef_Node := Error; -- If the identifier is at the start of the line, and is in -- a column to the right of the type declaration line, then we -- may have something like: -- type x is -- r : integer -- and the best diagnosis is a missing record keyword else Typedef_Node := P_Record_Definition; TF_Semicolon; end if; -- Anything else is an error when others => Error_Msg_AP ("type definition expected"); raise Error_Resync; end case; -- For the private type declaration case, the private type declaration -- node has been built, with the Tagged_Present and Limited_Present -- flags set as needed, and Typedef_Node is left set to Empty. if No (Typedef_Node) then Set_Has_Unknown_Discriminants (Decl_Node, Unknown_Dis); Set_Abstract_Present (Decl_Node, Abstract_Present); -- For a private extension declaration, Typedef_Node contains the -- N_Private_Extension_Declaration node, which we now complete. Note -- that the private extension declaration, unlike a full type -- declaration, does permit unknown discriminants. elsif Nkind (Typedef_Node) = N_Private_Extension_Declaration then Decl_Node := Typedef_Node; Set_Sloc (Decl_Node, Type_Loc); Set_Has_Unknown_Discriminants (Decl_Node, Unknown_Dis); Set_Abstract_Present (Typedef_Node, Abstract_Present); -- In the full type declaration case, Typedef_Node has the type -- definition and here is where we build the full type declaration -- node. This is also where we check for improper use of an unknown -- discriminant part (not allowed for full type declaration). else if Nkind (Typedef_Node) = N_Record_Definition or else (Nkind (Typedef_Node) = N_Derived_Type_Definition and then Present (Record_Extension_Part (Typedef_Node))) then Set_Abstract_Present (Typedef_Node, Abstract_Present); elsif Abstract_Present then Error_Msg ("ABSTRACT not allowed here, ignored", Abstract_Loc); end if; Decl_Node := New_Node (N_Full_Type_Declaration, Type_Loc); Set_Type_Definition (Decl_Node, Typedef_Node); if Unknown_Dis then Error_Msg ("Full type declaration cannot have unknown discriminants", Discr_Sloc); end if; end if; -- Remaining processing is common for all three cases Set_Defining_Identifier (Decl_Node, Ident_Node); Set_Discriminant_Specifications (Decl_Node, Discr_List); return Decl_Node; end P_Type_Declaration; ---------------------------------- -- 3.2.1 Full Type Declaration -- ---------------------------------- -- Parsed by P_Type_Declaration (3.3.1) ---------------------------- -- 3.2.1 Type Definition -- ---------------------------- -- Parsed by P_Type_Declaration (3.3.1) -------------------------------- -- 3.2.2 Subtype Declaration -- -------------------------------- -- SUBTYPE_DECLARATION ::= -- subtype DEFINING_IDENTIFIER is SUBTYPE_INDICATION; -- The caller has checked that the initial token is SUBTYPE -- Error recovery: can raise Error_Resync function P_Subtype_Declaration return Node_Id is Decl_Node : Node_Id; begin Decl_Node := New_Node (N_Subtype_Declaration, Token_Ptr); Scan; -- past SUBTYPE Set_Defining_Identifier (Decl_Node, P_Defining_Identifier); TF_Is; if Token = Tok_New then Error_Msg_SC ("NEW ignored (only allowed in type declaration)"); Scan; -- past NEW end if; Set_Subtype_Indication (Decl_Node, P_Subtype_Indication); TF_Semicolon; return Decl_Node; end P_Subtype_Declaration; ------------------------------- -- 3.2.2 Subtype Indication -- ------------------------------- -- SUBTYPE_INDICATION ::= SUBTYPE_MARK [CONSTRAINT] -- Error recovery: can raise Error_Resync function P_Subtype_Indication return Node_Id is Type_Node : Node_Id; begin if Token = Tok_Identifier or else Token = Tok_Operator_Symbol then Type_Node := P_Subtype_Mark; else -- Check for error of using record definition and treat it nicely, -- otherwise things are really messed up, so resynchronize. if Token = Tok_Record then Error_Msg_SC ("anonymous record definitions are not permitted"); Discard_Junk_Node (P_Record_Definition); return Error; else Error_Msg_AP ("subtype indication expected"); raise Error_Resync; end if; end if; return P_Subtype_Indication (Type_Node); end P_Subtype_Indication; -- The following function is identical except that it is called with -- the subtype mark already scanned out, and it scans out the constraint -- Error recovery: can raise Error_Resync function P_Subtype_Indication (Subtype_Mark : Node_Id) return Node_Id is Indic_Node : Node_Id; Constr_Node : Node_Id; begin Constr_Node := P_Constraint_Opt; if No (Constr_Node) then return Subtype_Mark; else Indic_Node := New_Node (N_Subtype_Indication, Token_Ptr); Set_Subtype_Mark (Indic_Node, Check_Subtype_Mark (Subtype_Mark)); Set_Constraint (Indic_Node, Constr_Node); return Indic_Node; end if; end P_Subtype_Indication; ------------------------- -- 3.2.2 Subtype Mark -- ------------------------- -- SUBTYPE_MARK ::= subtype_NAME; -- Note: The subtype mark which appears after an IN or NOT IN -- operator is parsed by P_Range_Or_Subtype_Mark (4.4) -- Error recovery: cannot raise Error_Resync function P_Subtype_Mark return Node_Id is begin return P_Subtype_Mark_Resync; exception when Error_Resync => return Error; end P_Subtype_Mark; -- This routine differs from P_Subtype_Mark in that it insists that an -- identifier be present, and if it is not, it raises Error_Resync. -- Error recovery: can raise Error_Resync function P_Subtype_Mark_Resync return Node_Id is Type_Node : Node_Id; Attr_Node : Node_Id; begin if Token = Tok_Array then Error_Msg_SC ("anonymous array definition not allowed here"); Discard_Junk_Node (P_Array_Type_Definition); return Empty; else Type_Node := P_Qualified_Simple_Name_Resync; -- Check for a subtype mark attribute. The only valid possibilities -- are 'CLASS and 'BASE and 'STANDARD_ACCESS. Anything else is an -- error which we may as well diagnose here. if Token = Tok_Apostrophe then return P_Subtype_Mark_Attribute (Type_Node); else return Type_Node; end if; end if; end P_Subtype_Mark_Resync; -- The following function is called to scan out a subtype mark attribute. -- The caller has already scanned out the subtype mark, which is passed in -- as the argument, and has checked that the current token is apostrophe. -- Only a special subclass of attributes, called type attributes -- (see Snames package) are allowed in this syntactic position. -- Note: if the apostrophe is followed by other than an identifier, then -- the input expression is returned unchanged, and the scan pointer is -- left pointing to the apostrophe. -- Error recovery: can raise Error_Resync function P_Subtype_Mark_Attribute (Type_Node : Node_Id) return Node_Id is Attr_Node : Node_Id; Scan_State : Saved_Scan_State; Prefix : Node_Id; begin Prefix := Check_Subtype_Mark (Type_Node); if Prefix = Error then raise Error_Resync; end if; -- Loop through attributes appearing (more than one can appear as for -- for example in X'Base'Class). We are at an apostrophe on entry to -- this loop, and it runs once for each attribute parsed, with -- Prefix being the current possible prefix if it is an attribute. loop Save_Scan_State (Scan_State); -- at Apostrophe Scan; -- past apostrophe if Token /= Tok_Identifier then Restore_Scan_State (Scan_State); -- to apostrophe return Prefix; -- no attribute after all elsif not Is_Type_Attribute_Name (Token_Name) then Error_Msg_N ("attribute & may not be used in a subtype mark", Token_Node); raise Error_Resync; else Attr_Node := Make_Attribute_Reference (Prev_Token_Ptr, Prefix => Prefix, Identifier => Token_Node); Scan; -- past type attribute identifier end if; exit when Token /= Tok_Apostrophe; Prefix := Attr_Node; end loop; -- Fall through here after scanning type attribute return Attr_Node; end P_Subtype_Mark_Attribute; ----------------------- -- 3.2.2 Constraint -- ----------------------- -- CONSTRAINT ::= SCALAR_CONSTRAINT | COMPOSITE_CONSTRAINT -- SCALAR_CONSTRAINT ::= -- RANGE_CONSTRAINT | DIGITS_CONSTRAINT | DELTA_CONSTRAINT -- COMPOSITE_CONSTRAINT ::= -- INDEX_CONSTRAINT | DISCRIMINANT_CONSTRAINT -- If no constraint is present, this function returns Empty -- Error recovery: can raise Error_Resync function P_Constraint_Opt return Node_Id is begin if Token = Tok_Range then return P_Range_Constraint; elsif Token = Tok_Digits then return P_Digits_Constraint; elsif Token = Tok_Delta then return P_Delta_Constraint; elsif Token = Tok_Left_Paren then return P_Index_Or_Discriminant_Constraint; else return Empty; end if; end P_Constraint_Opt; ------------------------------- -- 3.3.1 Object Declaration -- ------------------------------- -- OBJECT DECLARATION ::= -- DEFINING_IDENTIFIER_LIST : [constant] [aliased] -- SUBTYPE_INDICATION [:= EXPRESSION]; -- | DEFINING_IDENTIFIER_LIST : [constant] [aliased] -- ARRAY_TYPE_DEFINITION [:= EXPRESSION]; -- | SINGLE_TASK_DECLARATION -- | SINGLE_PROTECTED_DECLARATION -- Cases starting with identifiers are parsed by P_Identifier_Declarations. -- The concurrent cases are parsed by either P_Task or P_Protected. -------------------------------------------------------- -- 3.2 Identifier Declarations (Also 7.4, 8.5, 11.1) -- -------------------------------------------------------- -- This routine scans out a declaration starting with an identifier: -- OBJECT_DECLARATION ::= -- DEFINING_IDENTIFIER_LIST : [constant] [aliased] -- SUBTYPE_INDICATION [:= EXPRESSION]; -- | DEFINING_IDENTIFIER_LIST : [constant] [aliased] -- ARRAY_TYPE_DEFINITION [:= EXPRESSION]; -- NUMBER_DECLARATION ::= -- DEFINING_IDENTIFIER_LIST : constant ::= static_EXPRESSION; -- OBJECT_RENAMING_DECLARATION ::= -- DEFINING_IDENTIFIER : SUBTYPE_MARK renames object_NAME; -- EXCEPTION_RENAMING_DECLARATION ::= -- DEFINING_IDENTIFIER : exception renames exception_NAME; -- EXCEPTION_DECLARATION ::= -- DEFINING_IDENTIFIER_LIST : exception; -- Note that the ALIASED indication in an object declaration is -- marked by a flag in the parent node. -- The caller has checked that the initial token is an identifier -- The value returned is a list of declarations, one for each identifier -- in the list (as described in Sinfo, we always split up multiple -- declarations into the equivalent sequence of single declarations -- using the More_Ids and Prev_Ids flags to preserve the source). -- If the identifier turns out to be a probable statement rather than -- an identifier, then the scan is left pointing to the identifier and -- No_List is returned. -- Error recovery: can raise Error_Resync procedure P_Identifier_Declarations (Decls : List_Id; Done : out Boolean) is Decl_Node : Node_Id; Type_Node : Node_Id; Ident_Sloc : Source_Ptr; Scan_State : Saved_Scan_State; List_OK : Boolean := True; Ident : Nat; Idents : array (Int range 1 .. 4096) of Entity_Id; -- Used to save identifiers in the identifier list. The upper bound -- of 4096 is expected to be infinite in practice, and we do not even -- bother to check if this upper bound is exceeded. Num_Idents : Nat := 1; -- Number of identifiers stored in Idents procedure No_List; -- This procedure is called in renames cases to make sure that we do -- not have more than one identifier. If we do have more than one -- then an error message is issued (and the declaration is split into -- multiple declarations) procedure No_List is begin if Num_Idents > 1 then Error_Msg ("identifier list not allowed for RENAMES", Sloc (Idents (2))); end if; List_OK := False; end No_List; -- Start of processing for P_Identifier_Declarations begin Ident_Sloc := Token_Ptr; Save_Scan_State (Scan_State); -- at first identifier Idents (1) := P_Defining_Identifier; -- If we have a colon after the identifier, then we can assume that -- this is in fact a valid identifier declaration and can steam ahead. if Token = Tok_Colon then Scan; -- past colon -- If we have a comma, then scan out the list of identifiers elsif Token = Tok_Comma then while Comma_Present loop Num_Idents := Num_Idents + 1; Idents (Num_Idents) := P_Defining_Identifier; end loop; T_Colon; -- If we have identifier followed by := then we assume that what is -- really meant is an assignment statement, and that the declarations -- are complete (i.e. there was a missing BEGIN). In this case we reset -- the scan pointer to the identifier and indicate that there are no -- more declarations. elsif Token = Tok_Colon_Equal then Restore_Scan_State (Scan_State); Done := True; return; -- Otherwise we have an error situation else Restore_Scan_State (Scan_State); -- First case is possible misuse of PROTECTED in Ada 83 mode. If -- so, fix the keyword and return to scan the protected declaration. if Token_Name = Name_Protected then Check_9X_Keyword (Tok_Protected, Tok_Identifier); Check_9X_Keyword (Tok_Protected, Tok_Type); Check_9X_Keyword (Tok_Protected, Tok_Body); if Token = Tok_Protected then Done := False; return; end if; -- Check misspelling possibilities. If so, correct the misspelling -- and return to scan out the resulting declaration. elsif Bad_Spelling_Of (Tok_Function) or else Bad_Spelling_Of (Tok_Procedure) or else Bad_Spelling_Of (Tok_Package) or else Bad_Spelling_Of (Tok_Pragma) or else Bad_Spelling_Of (Tok_Protected) or else Bad_Spelling_Of (Tok_Generic) or else Bad_Spelling_Of (Tok_Subtype) or else Bad_Spelling_Of (Tok_Type) or else Bad_Spelling_Of (Tok_Task) or else Bad_Spelling_Of (Tok_Use) or else Bad_Spelling_Of (Tok_For) then Done := False; return; -- Otherwise we definitely have an ordinary identifier with a junk -- token after it. Just complain that we need a colon and plough on. else Scan; -- past identifier T_Colon; end if; end if; -- Come here with an identifier list and colon scanned out. We now build -- the nodes for the declarative items. One node is built for each -- identifier in the list, with the type information being repeated by -- rescanning the appropriate section of source. if Num_Idents > 1 then Save_Scan_State (Scan_State); end if; -- Loop through identifiers Ident := 1; Ident_Loop : loop if Token_Name = Name_Aliased then Check_9X_Keyword (Tok_Aliased, Tok_Array); Check_9X_Keyword (Tok_Aliased, Tok_Identifier); Check_9X_Keyword (Tok_Constant, Tok_Identifier); end if; -- Constant cases if Token = Tok_Constant then Scan; -- past CONSTANT -- Number declaration, initialization required if Token = Tok_Colon_Equal then Decl_Node := New_Node (N_Number_Declaration, Ident_Sloc); Scan; -- past := Set_Expression (Decl_Node, P_Expression_No_Right_Paren); -- Constant object declaration else Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); Set_Constant_Present (Decl_Node, True); if Token_Name = Name_Aliased then Check_9X_Keyword (Tok_Aliased, Tok_Array); Check_9X_Keyword (Tok_Aliased, Tok_Identifier); end if; if Token = Tok_Aliased then Error_Msg_SC ("ALIASED should be before CONSTANT"); Scan; -- past ALIASED Set_Aliased_Present (Decl_Node, True); end if; if Token = Tok_Array then Set_Object_Definition (Decl_Node, P_Constrained_Array_Definition); else Set_Object_Definition (Decl_Node, P_Subtype_Indication); end if; end if; -- Exception cases elsif Token = Tok_Exception then Scan; -- past EXCEPTION if Token = Tok_Renames then Scan; -- past RENAMES No_List; Decl_Node := New_Node (N_Exception_Renaming_Declaration, Ident_Sloc); Set_Name (Decl_Node, P_Qualified_Simple_Name_Resync); No_Constraint; else Decl_Node := New_Node (N_Exception_Declaration, Prev_Token_Ptr); end if; -- Aliased case (note that an object definition is required) elsif Token = Tok_Aliased then Scan; -- past ALIASED Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); Set_Aliased_Present (Decl_Node, True); if Token = Tok_Constant then Scan; -- past CONSTANT Set_Constant_Present (Decl_Node, True); end if; if Token = Tok_Array then Set_Object_Definition (Decl_Node, P_Constrained_Array_Definition); else Set_Object_Definition (Decl_Node, P_Subtype_Indication); end if; -- Array case elsif Token = Tok_Array then Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); Set_Object_Definition (Decl_Node, P_Constrained_Array_Definition); -- Subtype indication case else Type_Node := P_Subtype_Mark; -- Object renaming declaration if Token = Tok_Renames then Scan; -- past RENAMES No_List; Decl_Node := New_Node (N_Object_Renaming_Declaration, Ident_Sloc); Set_Subtype_Mark (Decl_Node, Type_Node); Set_Name (Decl_Node, P_Name); -- Object declaration else Decl_Node := New_Node (N_Object_Declaration, Ident_Sloc); Set_Object_Definition (Decl_Node, P_Subtype_Indication (Type_Node)); -- RENAMES at this point means that we had the combination of -- a constraint on the Type_Node and renames, which is illegal if Token = Tok_Renames then Error_Msg_N ("constraint not allowed in object renaming declaration", Constraint (Object_Definition (Decl_Node))); raise Error_Resync; end if; end if; end if; -- Scan out initialization, allowed only for object declaration if Token = Tok_Colon_Equal then Scan; -- past := if Nkind (Decl_Node) = N_Object_Declaration then Set_Expression (Decl_Node, P_Expression_No_Right_Paren); else Error_Msg_SP ("initialization not allowed here"); Discard_Junk_Node (P_Expression_No_Right_Paren); end if; end if; TF_Semicolon; Set_Defining_Identifier (Decl_Node, Idents (Ident)); if List_OK then if Ident < Num_Idents then Set_More_Ids (Decl_Node, True); end if; if Ident > 1 then Set_Prev_Ids (Decl_Node, True); end if; end if; Append (Decl_Node, Decls); exit Ident_Loop when Ident = Num_Idents; Restore_Scan_State (Scan_State); Ident := Ident + 1; end loop Ident_Loop; Done := False; end P_Identifier_Declarations; ------------------------------------- -- 3.3.1 Defining Identifier List -- ------------------------------------- -- DEFINING_IDENTIFIER_LIST ::= {DEFINING_IDENTIFIER} -- Always parsed by the construct in which it appears. See special -- section on "Handling of Defining Identifier Lists" in this unit. ----------------------------- -- 3.2 Number Declaration -- ----------------------------- -- Parsed by P_Identifier_Declarations(3.2) ------------------------------------------------------------------------ -- 3.4, 7.3 Derived Type Definition or Private Extension Declaration -- ------------------------------------------------------------------------ -- DERIVED_TYPE_DEFINITION ::= -- new [abstract] parent_SUBTYPE_INDICATION [TYPE_EXTENSION_PART] -- PRIVATE_EXTENSION_DECLARATION ::= -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] is -- new [abstract] ancestor_SUBTYPE_INDICATION with PRIVATE; -- The caller has already scanned out the part up to the NEW, and Token -- either contains Tok_New (or ought to, if it doesn't this procedure -- will post an appropriate "NEW expected" message). -- Note: the caller is responsible for filling in the Sloc field of -- the returned node in the private extension declaration case as -- well as the stuff relating to the discriminant part. -- Error recovery: can raise Error_Resync; function P_Derived_Type_Def_Or_Private_Ext_Decl return Node_Id is Typedef_Node : Node_Id; Typedecl_Node : Node_Id; begin Typedef_Node := New_Node (N_Derived_Type_Definition, Token_Ptr); T_New; if Token_Name = Name_Abstract then Check_9X_Keyword (Tok_Abstract, Tok_Identifier); end if; if Token = Tok_Abstract then Set_Abstract_Present (Typedef_Node, True); Scan; -- past ABSTRACT end if; Set_Subtype_Indication (Typedef_Node, P_Subtype_Indication); if Token = Tok_With then Scan; -- past WITH -- Private extension declaration if Token = Tok_Private then Scan; -- past PRIVATE -- Throw away the type definition node and build the type -- declaration node. Note the caller must set the Sloc, -- Discriminant_Specifications, Has_Unknown_Discriminants, -- and Defined_Identifier fields in the returned node. Typedecl_Node := Make_Private_Extension_Declaration (No_Location, Defining_Identifier => Empty, Subtype_Indication => Subtype_Indication (Typedef_Node), Abstract_Present => Abstract_Present (Typedef_Node)); Delete_Node (Typedef_Node); return Typedecl_Node; -- Derived type definition with record extension part else Set_Record_Extension_Part (Typedef_Node, P_Record_Definition); return Typedef_Node; end if; -- Derived type definition with no record extension part else return Typedef_Node; end if; end P_Derived_Type_Def_Or_Private_Ext_Decl; --------------------------- -- 3.5 Range Constraint -- --------------------------- -- RANGE_CONSTRAINT ::= range RANGE -- The caller has checked that the initial token is RANGE -- Error recovery: cannot raise Error_Resync function P_Range_Constraint return Node_Id is Range_Node : Node_Id; begin Range_Node := New_Node (N_Range_Constraint, Token_Ptr); Scan; -- past RANGE Set_Range_Expression (Range_Node, P_Range); return Range_Node; end P_Range_Constraint; ---------------- -- 3.5 Range -- ---------------- -- RANGE ::= -- RANGE_ATTRIBUTE_REFERENCE | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION -- Note: the range that appears in a membership test is parsed by -- P_Range_Or_Subtype_Mark. -- Error recovery: cannot raise Error_Resync function P_Range return Node_Id is Expr_Node : Node_Id; Range_Node : Node_Id; begin Expr_Node := P_Expression; Check_Simple_Expression (Expr_Node); if Token = Tok_Dot_Dot then Range_Node := New_Node (N_Range, Token_Ptr); Set_Low_Bound (Range_Node, Expr_Node); Scan; -- past .. Expr_Node := P_Expression; Check_Simple_Expression (Expr_Node); Set_High_Bound (Range_Node, Expr_Node); return Range_Node; -- If no double dot, must be range attribute elsif Token = Tok_Apostrophe then return P_Range_Attribute (Expr_Node); -- Anything else is an error else T_Dot_Dot; -- force missing .. message return Error; end if; end P_Range; ---------------------------------------- -- 3.5.1 Enumeration Type Definition -- ---------------------------------------- -- ENUMERATION_TYPE_DEFINITION ::= -- (ENUMERATION_LITERAL_SPECIFICATION -- {, ENUMERATION_LITERAL_SPECIFICATION}) -- The caller has already scanned out the TYPE keyword -- Error recovery: can raise Error_Resync; function P_Enumeration_Type_Definition return Node_Id is Typedef_Node : Node_Id; begin Typedef_Node := New_Node (N_Enumeration_Type_Definition, Token_Ptr); Set_Literals (Typedef_Node, New_List); T_Left_Paren; loop Append (P_Enumeration_Literal_Specification, Literals (Typedef_Node)); exit when not Comma_Present; end loop; T_Right_Paren; return Typedef_Node; end P_Enumeration_Type_Definition; ---------------------------------------------- -- 3.5.1 Enumeration Literal Specification -- ---------------------------------------------- -- ENUMERATION_LITERAL_SPECIFICATION ::= -- DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL -- Error recovery: can raise Error_Resync function P_Enumeration_Literal_Specification return Node_Id is Literal_Node : Node_Id; begin if Token = Tok_Char_Literal then Literal_Node := Token_Node; Change_Character_Literal_To_Defining_Character_Literal (Literal_Node); elsif Token = Tok_Identifier then Literal_Node := Token_Node; Change_Identifier_To_Defining_Identifier (Literal_Node); else Error_Msg_SC ("enumeration literal expected"); raise Error_Resync; end if; Scan; -- past character literal or identifier return Literal_Node; end P_Enumeration_Literal_Specification; --------------------------------------- -- 3.5.1 Defining Character Literal -- --------------------------------------- -- Parsed by P_Enumeration_Literal_Specification (3.5.1) ------------------------------------ -- 3.5.4 Integer Type Definition -- ------------------------------------ -- Parsed by P_Type_Declaration (3.2.1) ------------------------------------ -- 3.5.4 Integer Type Definition -- ------------------------------------ -- Parsed by P_Type_Declaration (3.2.1) ------------------------------------------- -- 3.5.4 Signed Integer Type Definition -- ------------------------------------------- -- SIGNED_INTEGER_TYPE_DEFINITION ::= -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION -- The caller has checked that the initial token is RANGE -- Error recovery: cannot raise Error_Resync function P_Signed_Integer_Type_Definition return Node_Id is Typedef_Node : Node_Id; Expr_Node : Node_Id; begin Typedef_Node := New_Node (N_Signed_Integer_Type_Definition, Token_Ptr); Scan; -- past RANGE Expr_Node := P_Expression; Check_Simple_Expression (Expr_Node); Set_Low_Bound (Typedef_Node, Expr_Node); T_Dot_Dot; Expr_Node := P_Expression; Check_Simple_Expression (Expr_Node); Set_High_Bound (Typedef_Node, Expr_Node); return Typedef_Node; end P_Signed_Integer_Type_Definition; ------------------------------------ -- 3.5.4 Modular Type Definition -- ------------------------------------ -- MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION -- The caller has checked that the initial token is MOD -- Error recovery: cannot raise Error_Resync function P_Modular_Type_Definition return Node_Id is Typedef_Node : Node_Id; begin Typedef_Node := New_Node (N_Modular_Type_Definition, Token_Ptr); Scan; -- past MOD Set_Expression (Typedef_Node, P_Expression_No_Right_Paren); return Typedef_Node; end P_Modular_Type_Definition; --------------------------------- -- 3.5.6 Real Type Definition -- --------------------------------- -- Parsed by P_Type_Declaration (3.2.1) -------------------------------------- -- 3.5.7 Floating Point Definition -- -------------------------------------- -- FLOATING_POINT_DEFINITION ::= -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION] -- Note: In Ada-83, the EXPRESSION must be a SIMPLE_EXPRESSION -- The caller has checked that the initial token is DIGITS -- Error recovery: cannot raise Error_Resync function P_Floating_Point_Definition return Node_Id is Definition_Node : Node_Id; Expr_Node : Node_Id; begin Definition_Node := New_Node (N_Floating_Point_Definition, Token_Ptr); Scan; -- past DIGITS Expr_Node := P_Expression_No_Right_Paren; Check_Simple_Expression_In_Ada_83 (Expr_Node); Set_Digits_Expression (Definition_Node, Expr_Node); Set_Real_Range_Specification (Definition_Node, P_Real_Range_Specification_Opt); return Definition_Node; end P_Floating_Point_Definition; ------------------------------------- -- 3.5.7 Real Range Specification -- ------------------------------------- -- REAL_RANGE_SPECIFICATION ::= -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION -- Error recovery: cannot raise Error_Resync function P_Real_Range_Specification_Opt return Node_Id is Specification_Node : Node_Id; Expr_Node : Node_Id; begin if Token = Tok_Range then Specification_Node := New_Node (N_Real_Range_Specification, Token_Ptr); Scan; -- past RANGE Expr_Node := P_Expression_No_Right_Paren; Check_Simple_Expression (Expr_Node); Set_Low_Bound (Specification_Node, Expr_Node); T_Dot_Dot; Expr_Node := P_Expression_No_Right_Paren; Check_Simple_Expression (Expr_Node); Set_High_Bound (Specification_Node, Expr_Node); return Specification_Node; else return Empty; end if; end P_Real_Range_Specification_Opt; ----------------------------------- -- 3.5.9 Fixed Point Definition -- ----------------------------------- -- FIXED_POINT_DEFINITION ::= -- ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION -- ORDINARY_FIXED_POINT_DEFINITION ::= -- delta static_EXPRESSION REAL_RANGE_SPECIFICATION -- | DECIMAL_FIXED_POINT_DEFINITION -- DECIMAL_FIXED_POINT_DEFINITION ::= -- delta static_EXPRESSION -- digits static_EXPRESSION [REAL_RANGE_SPECIFICATION] -- The caller has checked that the initial token is DELTA -- Error recovery: cannot raise Error_Resync function P_Fixed_Point_Definition return Node_Id is Delta_Node : Node_Id; Delta_Loc : Source_Ptr; Def_Node : Node_Id; Expr_Node : Node_Id; begin Delta_Loc := Token_Ptr; Scan; -- past DELTA Delta_Node := P_Expression_No_Right_Paren; Check_Simple_Expression_In_Ada_83 (Delta_Node); if Token = Tok_Digits then if Ada_83 then Error_Msg_SC ("decimal fixed types not allowed in Ada 83!"); end if; Def_Node := New_Node (N_Decimal_Fixed_Point_Definition, Delta_Loc); Scan; -- past DIGITS Expr_Node := P_Expression_No_Right_Paren; Check_Simple_Expression_In_Ada_83 (Expr_Node); Set_Digits_Expression (Def_Node, Expr_Node); else Def_Node := New_Node (N_Ordinary_Fixed_Point_Definition, Delta_Loc); end if; Set_Delta_Expression (Def_Node, Delta_Node); if Token = Tok_Range then Set_Real_Range_Specification (Def_Node, P_Real_Range_Specification_Opt); end if; return Def_Node; end P_Fixed_Point_Definition; -------------------------------------------- -- 3.5.9 Ordinary Fixed Point Definition -- -------------------------------------------- -- Parsed by P_Fixed_Point_Definition (3.5.9) ------------------------------------------- -- 3.5.9 Decimal Fixed Point Definition -- ------------------------------------------- -- Parsed by P_Fixed_Point_Definition (3.5.9) ------------------------------ -- 3.5.9 Digits Constraint -- ------------------------------ -- DIGITS_CONSTRAINT ::= -- digits static_EXPRESSION [RANGE_CONSTRAINT] -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION -- The caller has checked that the initial token is DIGITS function P_Digits_Constraint return Node_Id is Constraint_Node : Node_Id; Expr_Node : Node_Id; begin Constraint_Node := New_Node (N_Digits_Constraint, Token_Ptr); Scan; -- past DIGITS Expr_Node := P_Expression_No_Right_Paren; Check_Simple_Expression_In_Ada_83 (Expr_Node); Set_Digits_Expression (Constraint_Node, Expr_Node); if Token = Tok_Range then Set_Range_Constraint (Constraint_Node, P_Range_Constraint); end if; return Constraint_Node; end P_Digits_Constraint; ----------------------------- -- 3.5.9 Delta Constraint -- ----------------------------- -- DELTA CONSTRAINT ::= DELTA STATIC_EXPRESSION [RANGE_CONSTRAINT] -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION -- The caller has checked that the initial token is DELTA -- Error recovery: cannot raise Error_Resync function P_Delta_Constraint return Node_Id is Constraint_Node : Node_Id; Expr_Node : Node_Id; begin Constraint_Node := New_Node (N_Delta_Constraint, Token_Ptr); Scan; -- past DELTA Expr_Node := P_Expression_No_Right_Paren; Check_Simple_Expression_In_Ada_83 (Expr_Node); Set_Delta_Expression (Constraint_Node, Expr_Node); if Token = Tok_Range then Set_Range_Constraint (Constraint_Node, P_Range_Constraint); end if; return Constraint_Node; end P_Delta_Constraint; -------------------------------- -- 3.6 Array Type Definition -- -------------------------------- -- ARRAY_TYPE_DEFINITION ::= -- UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION -- UNCONSTRAINED_ARRAY_DEFINITION ::= -- array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of -- COMPONENT_DEFINITION -- INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <> -- CONSTRAINED_ARRAY_DEFINITION ::= -- ARRAY (DISCRETE_SUBTYPE_DEFINITION -- {, DISCRETE_SUBTYPE_DEFINITION}) OF COMPONENT_DEFINITION -- DISCRETE_SUBTYPE_DEFINITION ::= -- DISCRETE_SUBTYPE_INDICATION | RANGE -- COMPONENT_DEFINITION ::= [aliased] SUBTYPE_INDICATION -- The caller has checked that the initial token is ARRAY -- Error recovery: can raise Error_Resync function P_Array_Type_Definition return Node_Id is Array_Loc : Source_Ptr; Def_Node : Node_Id; Subs_List : List_Id; Scan_State : Saved_Scan_State; begin Array_Loc := Token_Ptr; Scan; -- past ARRAY Subs_List := New_List; T_Left_Paren; -- It's quite tricky to disentangle these two possibilities, so we do -- a prescan to determine which case we have and then reset the scan. -- The prescan skips past possible subtype mark tokens. Save_Scan_State (Scan_State); -- just after paren while Token in Token_Class_Desig or else Token = Tok_Dot or else Token = Tok_Apostrophe -- because of 'BASE, 'CLASS loop Scan; end loop; -- If we end up on RANGE <> then we have the unconstrained case. We -- will also allow the RANGE to be omitted, just to improve error -- handling for a case like array (integer <>) of integer; Scan; -- past possible RANGE or <> if (Prev_Token = Tok_Range and then Token = Tok_Box) or else Prev_Token = Tok_Box then Def_Node := New_Node (N_Unconstrained_Array_Definition, Array_Loc); Restore_Scan_State (Scan_State); -- to first subtype mark loop Append (P_Subtype_Mark_Resync, Subs_List); T_Range; T_Box; exit when Token = Tok_Right_Paren or else Token = Tok_Of; T_Comma; end loop; Set_Subtype_Marks (Def_Node, Subs_List); else Def_Node := New_Node (N_Constrained_Array_Definition, Array_Loc); Restore_Scan_State (Scan_State); -- to first discrete range loop Append (P_Discrete_Subtype_Definition, Subs_List); exit when not Comma_Present; end loop; Set_Discrete_Subtype_Definitions (Def_Node, Subs_List); end if; T_Right_Paren; T_Of; if Token = Tok_Aliased then Set_Aliased_Present (Def_Node, True); Scan; -- past ALIASED end if; Set_Subtype_Indication (Def_Node, P_Subtype_Indication); return Def_Node; end P_Array_Type_Definition; ----------------------------------------- -- 3.6 Unconstrained Array Definition -- ----------------------------------------- -- Parsed by P_Array_Type_Definition (3.6) ----------------------------------- -- 3.6 Index Subtype Definition -- ----------------------------------- -- Parsed by P_Array_Type_Definition (3.6) --------------------------------------- -- 3.6 Constrained Array Definition -- --------------------------------------- -- CONSTRAINED_ARRAY_DEFINITION ::= -- ARRAY (DISCRETE_SUBTYPE_DEFINITION -- {, DISCRETE_SUBTYPE_DEFINITION}) OF COMPONENT_DEFINITION -- DISCRETE_SUBTYPE_DEFINITION ::= -- DISCRETE_SUBTYPE_INDICATION | RANGE -- COMPONENT_DEFINITION ::= [aliased] SUBTYPE_INDICATION -- This is normally parsed by P_Array_Type_Definition (3.6). The function -- here is used in situations where only a constrained array definition -- is acceptable (i.e. in constant and variable declarations). -- The caller has checked that the initial token is ARRAY -- Error recovery: can raise Error_Resync function P_Constrained_Array_Definition return Node_Id is Def_Node : Node_Id; begin Def_Node := P_Array_Type_Definition; if Nkind (Def_Node) = N_Unconstrained_Array_Definition then Error_Msg ("cannot declare objects of unconstrained array types", Sloc (Def_Node)); return Error; else return Def_Node; end if; end P_Constrained_Array_Definition; -------------------------------------- -- 3.6 Discrete Subtype Definition -- -------------------------------------- -- DISCRETE_SUBTYPE_DEFINITION ::= -- discrete_SUBTYPE_INDICATION | RANGE -- Error recovery: cannot raise Error_Resync function P_Discrete_Subtype_Definition return Node_Id is begin -- The syntax of a discrete subtype definition is identical to that -- of a discrete range, so we simply share the same parsing code. return P_Discrete_Range; end P_Discrete_Subtype_Definition; --------------------------- -- 3.6.1 Discrete Range -- --------------------------- -- DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE -- RANGE ::= range_ATTRIBUTE | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION -- SUBTYPE_INDICATION ::= SUBTYPE_MARK [CONSTRAINT] -- The possible forms for a discrete range are: -- Subtype_Mark (SUBTYPE_INDICATION, 3.2.2) -- Subtype_Mark range Range (SUBTYPE_INDICATION, 3.2.2) -- Range_Attribute (RANGE, 3.5) -- Simple_Expression .. Simple_Expression (RANGE, 3.5) -- Error recovery: cannot raise Error_Resync function P_Discrete_Range return Node_Id is Expr_Node : Node_Id; Range_Node : Node_Id; begin Expr_Node := P_Expression; Check_Simple_Expression (Expr_Node); if Token = Tok_Range then if Expr_Form /= EF_Simple_Name then Error_Msg_SC ("range must be preceded by subtype mark"); end if; return P_Subtype_Indication (Expr_Node); -- All set if range attribute scanned elsif Token = Tok_Apostrophe then return P_Range_Attribute (Expr_Node); -- Check Expression .. Expression case elsif Token = Tok_Dot_Dot then Range_Node := New_Node (N_Range, Token_Ptr); Set_Low_Bound (Range_Node, Expr_Node); Scan; -- past .. Expr_Node := P_Expression; Check_Simple_Expression (Expr_Node); Set_High_Bound (Range_Node, Expr_Node); return Range_Node; -- Otherwise we must have a subtype mark elsif Expr_Form = EF_Simple_Name then return Expr_Node; -- If incorrect, complain that we expect .. else T_Dot_Dot; return Expr_Node; end if; end P_Discrete_Range; ------------------------------- -- 3.6 Component Definition -- ------------------------------- -- COMPONENT_DEFINITION ::= [aliased] SUBTYPE_INDICATION -- No tree node is constructed for a component definition. Instead, the -- Subtype_Indication and Aliased_Present fields of the parent node (which -- is an array definition or component declaration node) are set. The -- processing for setting these fields is in the parent node function. ------------------------------------ -- 3.7 Unknown Discriminant Part -- ------------------------------------ -- UNKNOWN_DISCRIMINANT_PART ::= (<>) -- If no unknown discriminant part is present, then False is returned, -- otherwise the unknown discriminant is scanned out and True is returned. -- Error recovery: cannot raise Error_Resync function P_Unknown_Discriminant_Part_Opt return Boolean is Scan_State : Saved_Scan_State; begin if Token /= Tok_Left_Paren then return False; else Save_Scan_State (Scan_State); Scan; -- past the left paren if Token = Tok_Box then if Ada_83 then Error_Msg_SC ("Unknown discriminants not allowed in Ada 83"); end if; Scan; -- past the box T_Right_Paren; -- must be followed by right paren return True; else Restore_Scan_State (Scan_State); return False; end if; end if; end P_Unknown_Discriminant_Part_Opt; ---------------------------------- -- 3.7 Known Discriminant Part -- ---------------------------------- -- KNOWN_DISCRIMINANT_PART ::= -- (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION}) -- DISCRIMINANT_SPECIFICATION ::= -- DEFINING_IDENTIFIER_LIST : SUBTYPE_MARK -- [:= DEFAULT_EXPRESSION] -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION -- [:= DEFAULT_EXPRESSION] -- If no known discriminant part is present, then No_List is returned -- Error recovery: cannot raise Error_Resync function P_Known_Discriminant_Part_Opt return List_Id is Specification_Node : Node_Id; Specification_List : List_Id; Scan_State : Saved_Scan_State; Num_Idents : Nat; Ident : Nat; Idents : array (Int range 1 .. 4096) of Entity_Id; -- This array holds the list of defining identifiers. The upper bound -- of 4096 is intended to be essentially infinite, and we do not even -- bother to check for it being exceeded. begin if Token = Tok_Left_Paren then Specification_List := New_List; Scan; -- past ( P_Pragmas_Misplaced; Specification_Loop : loop Idents (1) := P_Defining_Identifier; Num_Idents := 1; while Comma_Present loop Num_Idents := Num_Idents + 1; Idents (Num_Idents) := P_Defining_Identifier; end loop; T_Colon; -- If there are multiple identifiers, we repeatedly scan the -- type and initialization expression information by resetting -- the scan pointer (so that we get completely separate trees -- for each occurrence). if Num_Idents > 1 then Save_Scan_State (Scan_State); end if; -- Loop through defining identifiers in list Ident := 1; Ident_Loop : loop Specification_Node := New_Node (N_Discriminant_Specification, Token_Ptr); Set_Defining_Identifier (Specification_Node, Idents (Ident)); if Token = Tok_Access then if Ada_83 then Error_Msg_SC ("access discriminants not allowed in Ada 83!"); end if; Set_Discriminant_Type (Specification_Node, P_Access_Definition); else Set_Discriminant_Type (Specification_Node, P_Subtype_Mark); No_Constraint; end if; if Token = Tok_Colon_Equal then Scan; -- past := Set_Expression (Specification_Node, P_Expression); end if; if Ident > 1 then Set_Prev_Ids (Specification_Node, True); end if; if Ident < Num_Idents then Set_More_Ids (Specification_Node, True); end if; Append (Specification_Node, Specification_List); exit Ident_Loop when Ident = Num_Idents; Ident := Ident + 1; Restore_Scan_State (Scan_State); end loop Ident_Loop; exit Specification_Loop when Token /= Tok_Semicolon; Scan; -- past ; P_Pragmas_Misplaced; end loop Specification_Loop; T_Right_Paren; return Specification_List; else return No_List; end if; end P_Known_Discriminant_Part_Opt; ------------------------------------- -- 3.7 Discriminant Specification -- ------------------------------------- -- Parsed by P_Known_Discriminant_Part_Opt (3.7) -- Error recovery: cannot raise Error_Resync ------------------------------------ -- 3.7.1 Discriminant Constraint -- ------------------------------------ -- Parsed by P_Index_Or_Discriminant_Constraint (3.7.1) ------------------------------------- -- 3.7.1 Discriminant Association -- ------------------------------------- -- Parsed by P_Index_Or_Discriminant_Constraint (3.6.2) -------------------------------------------------------- -- 3.7.1 Index or Discriminant Constraint (also 3.6) -- -------------------------------------------------------- -- DISCRIMINANT_CONSTRAINT ::= -- (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION}) -- DISCRIMINANT_ASSOCIATION ::= -- [discriminant_SELECTOR_NAME {| discriminant_SELECTOR_NAME} =>] -- EXPRESSION -- INDEX_CONSTRAINT ::= (DISCRETE_RANGE {, DISCRETE_RANGE}) -- DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE -- This routine parses either an index or a discriminant constraint. As -- is clear from the above grammar, it is often possible to clearly -- determine which of the two possibilities we have, but there are -- cases (those in which we have a series of expressions of the same -- syntactic form as subtype indications), where we cannot tell. Since -- this means that in any case the semantic phase has to distinguish -- between the two, there is not much point in the parser trying to -- distinguish even those cases where the difference is clear. In any -- case, if we have a situation like: -- (A => 123, 235 .. 500) -- it is not clear which of the two items is the wrong one, better to -- let the semantic phase give a clear message. Consequently, this -- routine in general returns a list of items which can be either -- discrete ranges or discriminant associations. -- The caller has checked that the initial token is a left paren -- Error recovery: can raise Error_Resync function P_Index_Or_Discriminant_Constraint return Node_Id is Scan_State : Saved_Scan_State; Constr_Node : Node_Id; Constr_List : List_Id; Expr_Node : Node_Id; Result_Node : Node_Id; begin Result_Node := New_Node (N_Index_Or_Discriminant_Constraint, Token_Ptr); Scan; -- past ( Constr_List := New_List; Set_Constraints (Result_Node, Constr_List); -- The two syntactic forms are a little mixed up, so what we are doing -- here is looking at the first entry to determine which case we have -- A discriminant constraint is a list of discriminant associations, -- which have one of the following possible forms: -- Expression -- Id => Expression -- Id | Id | .. | Id => Expression -- An index constraint is a list of discrete ranges which have one -- of the following possible forms: -- Subtype_Mark -- Subtype_Mark range Range -- Range_Attribute -- Simple_Expression .. Simple_Expression -- Loop through discriminants in list loop -- Check cases of Id => Expression or Id | Id => Expression if Token = Tok_Identifier then Save_Scan_State (Scan_State); -- at Id Scan; -- past Id if Token = Tok_Arrow or else Token = Tok_Vertical_Bar then Restore_Scan_State (Scan_State); -- to Id Append (P_Discriminant_Association, Constr_List); goto Loop_Continue; else Restore_Scan_State (Scan_State); -- to Id end if; end if; -- Otherwise scan out an expression and see what we have got Expr_Node := P_Expression; -- Check range constraint if Token = Tok_Range then if Expr_Form /= EF_Simple_Name then Error_Msg_SC ("subtype mark required before RANGE"); end if; Append (P_Subtype_Indication (Expr_Node), Constr_List); goto Loop_Continue; -- Check range attribute elsif Token = Tok_Apostrophe then Append (P_Range_Attribute (Expr_Node), Constr_List); goto Loop_Continue; -- Check Simple_Expression .. Simple_Expression case elsif Token = Tok_Dot_Dot then Check_Simple_Expression (Expr_Node); Constr_Node := New_Node (N_Range, Token_Ptr); Set_Low_Bound (Constr_Node, Expr_Node); Scan; -- past .. Expr_Node := P_Expression; Check_Simple_Expression (Expr_Node); Set_High_Bound (Constr_Node, Expr_Node); Append (Constr_Node, Constr_List); goto Loop_Continue; -- Case of an expression which could be either form else Append (Expr_Node, Constr_List); goto Loop_Continue; end if; -- Here with a single entry scanned <> exit when not Comma_Present; end loop; Scan; -- past right paren return Result_Node; end P_Index_Or_Discriminant_Constraint; ------------------------------------- -- 3.7.1 Discriminant Association -- ------------------------------------- -- DISCRIMINANT_ASSOCIATION ::= -- [discriminant_SELECTOR_NAME -- {| discriminant_SELECTOR_NAME} =>] EXPRESSION -- This routine is used only when the name list is present and the caller -- has already checked this (by scanning ahead and repositioning the -- scan). -- Error_Recovery: cannot raise Error_Resync; function P_Discriminant_Association return Node_Id is Discr_Node : Node_Id; Names_List : List_Id; Ident_Sloc : Source_Ptr; begin Ident_Sloc := Token_Ptr; Names_List := New_List; loop Append (P_Identifier, Names_List); exit when Token /= Tok_Vertical_Bar; Scan; -- past | end loop; Discr_Node := New_Node (N_Discriminant_Association, Ident_Sloc); Set_Selector_Names (Discr_Node, Names_List); TF_Arrow; Set_Expression (Discr_Node, P_Expression); return Discr_Node; end P_Discriminant_Association; --------------------------------- -- 3.8 Record Type Definition -- --------------------------------- -- RECORD_TYPE_DEFINITION ::= [tagged] [limited] RECORD_DEFINITION -- There is no node in the tree for a record type definition. Instead -- a record definition node appears, with possible Tagged_Present and -- Limited_Present flags set. ---------------------------- -- 3.8 Record Definition -- ---------------------------- -- RECORD_DEFINITION ::= -- record -- COMPONENT_LIST -- end record -- | null record -- Note: in the case where a record definition node is used to represent -- a record type definition, the caller sets the Tagged_Present and -- Limited_Present flags in the resulting N_Record_Definition node as -- required. -- Note that the RECORD token at the start may be missing in certain -- error situations, so this function is expected to post the error -- Error recovery: can raise Error_Resync function P_Record_Definition return Node_Id is Rec_Node : Node_Id; begin Rec_Node := New_Node (N_Record_Definition, Token_Ptr); -- Null record case if Token = Tok_Null then Scan; -- past NULL T_Record; Set_Null_Present (Rec_Node, True); -- Case starting with RECORD keyword. Build scope stack entry. For the -- column, we use the first non-blank character on the line, to deal -- with situations such as: -- type X is record -- ... -- end record; -- which is not official RM indentation, but is not uncommon usage else Push_Scope_Stack; Scope.Table (Scope.Last).Etyp := E_Record; Scope.Table (Scope.Last).Ecol := Start_Column; Scope.Table (Scope.Last).Sloc := Token_Ptr; Scope.Table (Scope.Last).Labl := Error; T_Record; Set_Component_List (Rec_Node, P_Component_List); loop exit when Check_End; Discard_Junk_Node (P_Component_List); end loop; end if; return Rec_Node; end P_Record_Definition; ------------------------- -- 3.8 Component List -- ------------------------- -- COMPONENT_LIST ::= -- COMPONENT_DECLARATION {COMPONENT_DECLARATION} -- | {COMPONENT_DECLARATION} VARIANT_PART -- | null; -- Error recovery: cannot raise Error_Resync function P_Component_List return Node_Id is Component_List_Node : Node_Id; Decls_List : List_Id; Scan_State : Saved_Scan_State; begin Component_List_Node := New_Node (N_Component_List, Token_Ptr); if Token = Tok_Null then Scan; -- past NULL Set_Null_Present (Component_List_Node, True); TF_Semicolon; return Component_List_Node; else Decls_List := New_List; P_Pragmas_Opt (Decls_List); if Token /= Tok_Case then Component_Scan_Loop : loop P_Component_Declarations (Decls_List); P_Pragmas_Opt (Decls_List); exit when Token = Tok_End or else Token = Tok_Case or else Token = Tok_When; -- We are done if we do not have an identifier. However, if -- we have a misspelled reserved identifier that is in a column -- to the right of the record definition, we will treat it as -- an identifier. It turns out to be too dangerous in practice -- to accept such a mis-spelled identifier which does not have -- this additional clue that confirms the incorrect spelling. if Token /= Tok_Identifier then if Start_Column > Scope.Table (Scope.Last).Ecol and then Is_Reserved_Identifier then Save_Scan_State (Scan_State); -- at reserved id Scan; -- possible reserved id if Token = Tok_Comma or else Token = Tok_Colon then Restore_Scan_State (Scan_State); Scan_Reserved_Identifier (Force_Msg => True); -- Note reserved identifier used as field name after -- all because not followed by colon or comma else Restore_Scan_State (Scan_State); exit Component_Scan_Loop; end if; -- Non-identifier that definitely was not reserved id else exit Component_Scan_Loop; end if; end if; end loop Component_Scan_Loop; end if; if Token = Tok_Case then Set_Variant_Part (Component_List_Node, P_Variant_Part); end if; Set_Component_Declarations (Component_List_Node, Decls_List); return Component_List_Node; end if; end P_Component_List; --------------------------------- -- 3.8 Component Declarations -- --------------------------------- -- COMPONENT_DECLARATION ::= -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION [:= EXPRESSION]; -- COMPONENT_DEFINITION ::= [aliased] SUBTYPE_INDICATION -- Error recovery: cannot raise Error_Resync, if an error occurs, -- the scan is positioned past the following semicolon. procedure P_Component_Declarations (Decls : List_Id) is Decl_Node : Node_Id; Scan_State : Saved_Scan_State; Num_Idents : Nat; Ident : Nat; Idents : array (Int range 1 .. 4096) of Entity_Id; -- This array holds the list of defining identifiers. The upper bound -- of 4096 is intended to be essentially infinite, and we do not even -- bother to check for it being exceeded. begin if Token /= Tok_Identifier then Error_Msg_SC ("component declaration expected"); Resync_Past_Semicolon; return; end if; Idents (1) := P_Defining_Identifier; Num_Idents := 1; while Comma_Present loop Num_Idents := Num_Idents + 1; Idents (Num_Idents) := P_Defining_Identifier; end loop; T_Colon; -- If there are multiple identifiers, we repeatedly scan the -- type and initialization expression information by resetting -- the scan pointer (so that we get completely separate trees -- for each occurrence). if Num_Idents > 1 then Save_Scan_State (Scan_State); end if; -- Loop through defining identifiers in list Ident := 1; Ident_Loop : loop begin Decl_Node := New_Node (N_Component_Declaration, Token_Ptr); Set_Defining_Identifier (Decl_Node, Idents (Ident)); if Token = Tok_Constant then Error_Msg_SC ("constant components are not permitted"); Scan; end if; if Token_Name = Name_Aliased then Check_9X_Keyword (Tok_Aliased, Tok_Identifier); end if; if Token = Tok_Aliased then Scan; -- past ALIASED Set_Aliased_Present (Decl_Node, True); end if; Set_Subtype_Indication (Decl_Node, P_Subtype_Indication); if Token = Tok_Colon_Equal then Scan; -- past := Set_Expression (Decl_Node, P_Expression_No_Right_Paren); end if; if Ident > 1 then Set_Prev_Ids (Decl_Node, True); end if; if Ident < Num_Idents then Set_More_Ids (Decl_Node, True); end if; Append (Decl_Node, Decls); exit Ident_Loop when Ident = Num_Idents; Ident := Ident + 1; Restore_Scan_State (Scan_State); exception when Error_Resync => if Token /= Tok_End then Resync_Past_Semicolon; end if; end; end loop Ident_Loop; TF_Semicolon; end P_Component_Declarations; ------------------------- -- 3.8.1 Variant Part -- ------------------------- -- VARIANT_PART ::= -- case discriminant_DIRECT_NAME is -- VARIANT -- {VARIANT} -- end case; -- The caller has checked that the initial token is CASE -- Error recovery: cannot raise Error_Resync function P_Variant_Part return Node_Id is Variant_Part_Node : Node_Id; Variants_List : List_Id; Case_Node : Node_Id; Case_Sloc : Source_Ptr; begin Variant_Part_Node := New_Node (N_Variant_Part, Token_Ptr); Push_Scope_Stack; Scope.Table (Scope.Last).Etyp := E_Case; Scope.Table (Scope.Last).Sloc := Token_Ptr; Scope.Table (Scope.Last).Ecol := Start_Column; Scan; -- past CASE Case_Node := P_Expression; Case_Sloc := Token_Ptr; Set_Name (Variant_Part_Node, Case_Node); if Nkind (Case_Node) /= N_Identifier then Set_Name (Variant_Part_Node, Error); Error_Msg ("discriminant name expected", Sloc (Case_Node)); end if; TF_Is; Variants_List := New_List; P_Pragmas_Opt (Variants_List); -- Test missing variant if Token = Tok_End then Error_Msg_BC ("WHEN expected (must have at least one variant)"); else Append (P_Variant, Variants_List); end if; -- Loop through variants, note that we allow if in place of when, -- this error will be detected and handled in P_Variant. loop P_Pragmas_Opt (Variants_List); if Token /= Tok_When and then Token /= Tok_If and then Token /= Tok_Others then exit when Check_End; end if; Append (P_Variant, Variants_List); end loop; Set_Variants (Variant_Part_Node, Variants_List); return Variant_Part_Node; end P_Variant_Part; -------------------- -- 3.8.1 Variant -- -------------------- -- VARIANT ::= when DISCRETE_CHOICE_LIST => COMPONENT_LIST -- Error recovery: cannot raise Error_Resync -- The initial token on entry is either WHEN, IF or OTHERS function P_Variant return Node_Id is Variant_Node : Node_Id; begin -- Special check to recover nicely from use of IF in place of WHEN if Token = Tok_If then T_When; Scan; -- past IF else T_When; end if; Variant_Node := New_Node (N_Variant, Prev_Token_Ptr); Set_Discrete_Choices (Variant_Node, P_Discrete_Choice_List); TF_Arrow; Set_Component_List (Variant_Node, P_Component_List); return Variant_Node; end P_Variant; --------------------------------- -- 3.8.1 Discrete Choice List -- --------------------------------- -- DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE} -- DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others -- Note: in Ada 83, the expression must be a simple expression -- Error recovery: cannot raise Error_Resync function P_Discrete_Choice_List return List_Id is Choices : List_Id; Expr_Node : Node_Id; Choice_Node : Node_Id; Range_Node : Node_Id; begin Choices := New_List; loop if Token = Tok_Others then Append (New_Node (N_Others_Choice, Token_Ptr), Choices); Scan; -- past OTHERS else begin Expr_Node := P_Expression_No_Right_Paren; if Token = Tok_Dot_Dot then Choice_Node := New_Node (N_Range, Token_Ptr); Check_Simple_Expression (Expr_Node); Set_Low_Bound (Choice_Node, Expr_Node); Scan; -- past .. Expr_Node := P_Expression_No_Right_Paren; Check_Simple_Expression (Expr_Node); Set_High_Bound (Choice_Node, Expr_Node); Append (Choice_Node, Choices); elsif Token = Tok_Apostrophe then Append (P_Range_Attribute (Expr_Node), Choices); elsif Expr_Form = EF_Simple_Name then if Token = Tok_Range then Append (P_Subtype_Indication (Expr_Node), Choices); elsif Token in Token_Class_Consk then Error_Msg_SC ("the only constraint allowed here " & "is a range constraint"); Discard_Junk_Node (P_Constraint_Opt); Append (Expr_Node, Choices); else Append (Expr_Node, Choices); end if; else Check_Simple_Expression_In_Ada_83 (Expr_Node); Append (Expr_Node, Choices); end if; exception when Error_Resync => Resync_Choice; return Error_List; end; end if; exit when Token /= Tok_Vertical_Bar; Scan; -- past | end loop; return Choices; end P_Discrete_Choice_List; ---------------------------------- -- 3.9.1 Record Extension Part -- ---------------------------------- -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION ---------------------------------- -- 3.10 Access Type Definition -- ---------------------------------- -- ACCESS_TYPE_DEFINITION ::= -- ACCESS_TO_OBJECT_DEFINITION | ACCESS_TO_SUBPROGRAM_DEFINITION -- ACCESS_TO_OBJECT_DEFINITION ::= -- access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION -- GENERAL_ACCESS_MODIFIER ::= all | constant -- ACCESS_TO_SUBPROGRAM_DEFINITION -- access [protected] procedure PARAMETER_PROFILE -- | access [protected] function PARAMETER_AND_RESULT_PROFILE -- The caller has checked that the initial token is ACCESS -- Error recovery: can raise Error_Resync function P_Access_Type_Definition return Node_Id is Prot_Flag : Boolean; Access_Loc : Source_Ptr; Type_Def_Node : Node_Id; begin Access_Loc := Token_Ptr; Scan; -- past ACCESS if Token_Name = Name_Protected then Check_9X_Keyword (Tok_Protected, Tok_Procedure); Check_9X_Keyword (Tok_Protected, Tok_Function); end if; Prot_Flag := (Token = Tok_Protected); if Prot_Flag then Scan; -- past PROTECTED if Token /= Tok_Procedure and then Token /= Tok_Function then Error_Msg_SC ("FUNCTION or PROCEDURE expected"); end if; end if; if Token = Tok_Procedure then if Ada_83 then Error_Msg_SC ("access to procedure not allowed in Ada 83!"); end if; Type_Def_Node := New_Node (N_Access_Procedure_Definition, Access_Loc); Scan; -- past PROCEDURE Set_Parameter_Specifications (Type_Def_Node, P_Formal_Part_Opt); Set_Protected_Present (Type_Def_Node, Prot_Flag); elsif Token = Tok_Function then if Ada_83 then Error_Msg_SC ("access to function not allowed in Ada 83!"); end if; Type_Def_Node := New_Node (N_Access_Function_Definition, Access_Loc); Scan; -- past FUNCTION Set_Parameter_Specifications (Type_Def_Node, P_Formal_Part_Opt); Set_Protected_Present (Type_Def_Node, Prot_Flag); TF_Return; Set_Subtype_Mark (Type_Def_Node, P_Subtype_Mark); No_Constraint; else Type_Def_Node := New_Node (N_Access_To_Object_Definition, Access_Loc); if Token = Tok_All or else Token = Tok_Constant then if Ada_83 then Error_Msg_SC ("access modifiers not allowed in Ada 83!"); end if; if Token = Tok_All then Set_All_Present (Type_Def_Node, True); else Set_Constant_Present (Type_Def_Node, True); end if; Scan; -- past ALL or CONSTANT end if; Set_Subtype_Indication (Type_Def_Node, P_Subtype_Indication); end if; return Type_Def_Node; end P_Access_Type_Definition; --------------------------------------- -- 3.10 Access To Object Definition -- --------------------------------------- -- Parsed by P_Access_Type_Definition (3.10) ----------------------------------- -- 3.10 General Access Modifier -- ----------------------------------- -- Parsed by P_Access_Type_Definition (3.10) ------------------------------------------- -- 3.10 Access To Subprogram Definition -- ------------------------------------------- -- Parsed by P_Access_Type_Definition (3.10) ----------------------------- -- 3.10 Access Definition -- ----------------------------- -- ACCESS_DEFINITION ::= access SUBTYPE_MARK -- The caller has checked that the initial token is ACCESS -- Error recovery: cannot raise Error_Resync function P_Access_Definition return Node_Id is Def_Node : Node_Id; begin Def_Node := New_Node (N_Access_Definition, Token_Ptr); Scan; -- past ACCESS Set_Subtype_Mark (Def_Node, P_Subtype_Mark); No_Constraint; return Def_Node; end P_Access_Definition; ----------------------------------------- -- 3.10.1 Incomplete Type Declaration -- ----------------------------------------- -- Parsed by P_Type_Declaration (3.3.1) ---------------------------- -- 3.11 Declarative Part -- ---------------------------- -- DECLARATIVE_PART ::= {DECLARATIVE_ITEM} -- Error recovery: cannot raise Error_Resync (because P_Declarative_Items -- handles errors, and returns cleanly after an error has occurred) function P_Declarative_Part return List_Id is Decls : List_Id; Done : Boolean; begin -- Get rid of active SIS entry from outer scope. This means we will -- miss some nested cases, but it doesn't seem worth the effort. See -- discussion in Par for further details SIS_Entry_Active := False; Decls := New_List; -- Loop to scan out the declarations loop P_Declarative_Items (Decls, Done); exit when Done; end loop; -- Get rid of active SIS entry which is left set only if we scanned a -- procedure declaration and have not found the body. We could give -- an error message, but that really would be usurping the role of -- semantic analysis (this really is a missing body case). SIS_Entry_Active := False; return Decls; end P_Declarative_Part; ---------------------------- -- 3.11 Declarative Item -- ---------------------------- -- DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY -- Can return Error if a junk declaration is found, or Empty if no -- declaration is found (i.e. a token ending declarations, such as -- BEGIN or END is encountered). -- Error recovery: cannot raise Error_Resync. If an error resync occurs, -- then the scan is set past the next semicolon and Error is returned. procedure P_Declarative_Items (Decls : List_Id; Done : out Boolean) is Scan_State : Saved_Scan_State; begin if GNAT_Style_Check then GNAT_Column_Check (Token_Ptr); end if; case Token is when Tok_Function => Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls); Done := False; when Tok_For => Append (P_Representation_Clause, Decls); Done := False; when Tok_Generic => Append (P_Generic, Decls); Done := False; when Tok_Identifier => P_Identifier_Declarations (Decls, Done); when Tok_Package => Append (P_Package (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls); Done := False; when Tok_Pragma => Append (P_Pragma, Decls); Done := False; when Tok_Procedure => Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub), Decls); Done := False; when Tok_Protected => Scan; -- past PROTECTED Append (P_Protected, Decls); Done := False; when Tok_Subtype => Append (P_Subtype_Declaration, Decls); Done := False; when Tok_Task => Scan; -- past TASK Append (P_Task, Decls); Done := False; when Tok_Type => Append (P_Type_Declaration, Decls); Done := False; when Tok_Use => Append (P_Use_Clause, Decls); Done := False; -- BEGIN terminates the scan of a sequence of declarations unless -- there is a missing subprogram body, see section on handling -- semicolon in place of IS. We only treat the begin as satisfying -- the subprogram declaration if it falls in the expected column -- or to its right. when Tok_Begin => if SIS_Entry_Active and then Start_Column >= SIS_Ecol then P_Begin_For_Missing_Body; Done := False; else Done := True; end if; -- Normally an END terminates the scan for basic declarative -- items. The one exception is END RECORD, which is probably -- left over from some other junk. when Tok_End => Save_Scan_State (Scan_State); -- at END Scan; -- past END if Token = Tok_Record then Error_Msg_SP ("no RECORD for this `end record`!"); Scan; -- past RECORD TF_Semicolon; else Restore_Scan_State (Scan_State); -- to END Done := True; end if; -- The following tokens which can only be the start of a statement -- are considered to end a declarative part (i.e. we have a missing -- BEGIN situation). We are fairly conservative in making this -- judgment, because it is a real mess to go into statement mode -- prematurely in reponse to a junk declaration. when Tok_Abort | Tok_Accept | Tok_Declare | Tok_Delay | Tok_Exit | Tok_Goto | Tok_If | Tok_Loop | Tok_Return | Tok_Requeue | Tok_Select | Tok_While => -- But before we decide that it's a statement, let's check for -- a reserved word misused as an identifier. if Is_Reserved_Identifier then Save_Scan_State (Scan_State); Scan; -- past the token if Token /= Tok_Colon and then Token /= Tok_Comma then Restore_Scan_State (Scan_State); Done := True; else Restore_Scan_State (Scan_State); Scan_Reserved_Identifier (Force_Msg => True); P_Identifier_Declarations (Decls, Done); end if; else Done := True; end if; -- PRIVATE definitely terminates the declarations, and we don't -- check for a misuse of a reserved keyword in this case. when Tok_Private => Done := True; -- An end of file definitely terminates the declarations! when Tok_EOF => Done := True; -- The remaining tokens do not end the scan, but cannot start a -- valid declaration, so we signal an error and resynchronize. -- But first check for misuse of a reserved identifier. when others => -- Here to we check for a reserved identifier if Is_Reserved_Identifier then Save_Scan_State (Scan_State); Scan; -- past the token if Token /= Tok_Colon and then Token /= Tok_Comma then Restore_Scan_State (Scan_State); Error_Msg_SC ("declaration expected"); Resync_Past_Semicolon; Done := True; else Restore_Scan_State (Scan_State); Scan_Reserved_Identifier (Force_Msg => True); P_Identifier_Declarations (Decls, Done); end if; else Error_Msg_SC ("declaration expected"); Resync_Past_Semicolon; Done := True; end if; end case; -- To resynchronize after an error, we scan to the next semicolon and -- return with Done = False, indicating that there may still be more -- valid declarations to come. exception when Error_Resync => Resync_Past_Semicolon; Done := False; end P_Declarative_Items; ----------------------------------- -- 3.11 Basic Declarative Items -- ----------------------------------- -- BASIC_DECLARATIVE_ITEM ::= -- BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE -- Scan zero or more basic declarative items -- Error recovery: cannot raise Error_Resync. If an error is detected, then -- the scan pointer is repositioned past the next semicolon, and the scan -- for declarative items continues. function P_Basic_Declarative_Items return List_Id is Decl : Node_Id; Decls : List_Id; Kind : Node_Kind; Done : Boolean; begin -- Get rid of active SIS entry from outer scope. This means we will -- miss some nested cases, but it doesn't seem worth the effort. See -- discussion in Par for further details SIS_Entry_Active := False; -- Loop to scan out declarations Decls := New_List; loop P_Declarative_Items (Decls, Done); exit when Done; end loop; -- Get rid of active SIS entry. This is set only if we have scanned a -- procedure declaration and have not found the body. We could give -- an error message, but that really would be usurping the role of -- semantic analysis (this really is a case of a missing body). SIS_Entry_Active := False; -- Test for body scanned, not acceptable as basic declarative item Decl := First (Decls); while Present (Decl) loop Kind := Nkind (Decl); -- Test for body scanned, not acceptable as basic decl item if Kind = N_Subprogram_Body or else Kind = N_Package_Body or else Kind = N_Task_Body or else Kind = N_Protected_Body then Error_Msg ("proper body not allowed in package spec", Sloc (Decl)); -- Test for body stub scanned, not acceptable as basic decl item elsif Kind in N_Body_Stub then Error_Msg ("body stub not allowed in package spec", Sloc (Decl)); end if; Decl := Next (Decl); end loop; return Decls; end P_Basic_Declarative_Items; ---------------- -- 3.11 Body -- ---------------- -- Body is parsed by P_Declarative_Item_Opt (3.11) ----------------------- -- 3.11 Proper Body -- ----------------------- -- Proper body is parsed by P_Declarative_Item_Opt (3.11) ---------------------------------- -- 3.11 BEGIN for Missing Body -- ---------------------------------- -- This procedure is called if a BEGIN is encountered during the scan of -- declarations in a declarative part, or at the outer level, and there -- is a subprogram declaration outstanding for which no body has been -- supplied. This is the case where we assume that the semicolon in the -- subprogram declaration should really have been is. The active SIS -- entry describes the subprogram declaration. On return the declaration -- has been modified to become a body. -- Error recovery: cannot raise Error_Resync procedure P_Begin_For_Missing_Body is Specification_Node : Node_Id; Outer_Decls : List_Id; Decl_Node : Node_Id; Body_Node : Node_Id; begin -- First issue the error message. If we had a missing semicolon in the -- declaration, then change the message to if SIS_Missing_Semicolon_Message /= No_Error_Msg then Change_Error_Text -- Replace: "missing semicolon" (SIS_Missing_Semicolon_Message, "missing ""is"" "); -- Otherwise we saved the semicolon position, so complain about it else Error_Msg ("semicolon should be IS", SIS_Semicolon_Sloc); end if; -- The next job is to fix up any declarations that occurred between -- the procedure header and the BEGIN. These got chained to the outer -- declarative region (immediately after the procedure declaration) -- and they should be chained to the subprogram itself, which is a body -- rather than a spec. Specification_Node := Specification (SIS_Declaration_Node); Change_Node (SIS_Declaration_Node, N_Subprogram_Body); Body_Node := SIS_Declaration_Node; Set_Specification (Body_Node, Specification_Node); Set_Declarations (Body_Node, New_List); loop Decl_Node := Remove_Next (Body_Node); exit when Decl_Node = Empty; Append (Decl_Node, Declarations (Body_Node)); end loop; -- Now make the scope table entry for the Begin-End and scan it out Push_Scope_Stack; Scope.Table (Scope.Last).Sloc := SIS_Sloc; Scope.Table (Scope.Last).Etyp := E_Name; Scope.Table (Scope.Last).Ecol := SIS_Ecol; Scope.Table (Scope.Last).Labl := SIS_Labl; Scope.Table (Scope.Last).Lreq := False; SIS_Entry_Active := False; Scan; -- past BEGIN Set_Handled_Statement_Sequence (Body_Node, P_Handled_Sequence_Of_Statements); End_Statements; return; end P_Begin_For_Missing_Body; end Ch3; red to end a declarative part (i.e. we have a missing -- BEGIN situation). We are fairly conservative in making this -- judgment, because it is a real mess gnat-1.67-src/src/par-ch4.adb 444 10015 7640 216171 5506244343 11074 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P A R . C H 4 -- -- -- -- B o d y -- -- -- -- $Revision: 1.41 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ separate (Par) package body Ch4 is -- Local functions, used only in this chapter function P_Aggregate_Or_Paren_Expr return Node_Id; function P_Allocator return Node_Id; function P_Component_Association return Node_Id; function P_Factor return Node_Id; function P_Primary return Node_Id; function P_Range_Or_Subtype_Mark return Node_Id; function P_Relation return Node_Id; function P_Simple_Expression return Node_Id; function P_Term return Node_Id; function P_Binary_Adding_Operator return Node_Kind; function P_Logical_Operator return Node_Kind; function P_Multiplying_Operator return Node_Kind; function P_Relational_Operator return Node_Kind; function P_Unary_Adding_Operator return Node_Kind; function No_Right_Paren (Expr : Node_Id) return Node_Id; -- Function to check for no right paren at end of expression, returns -- its argument if no right paren, else flags the paren and returns Error. procedure Set_Op_Name (Node : Node_Id); -- Procedure to set name field (Chars) in operator node -------------------- -- No_Right_Paren -- -------------------- function No_Right_Paren (Expr : Node_Id) return Node_Id is begin if Token = Tok_Right_Paren then Error_Msg_SC ("unexpected right parenthesis"); Resync_Expression; return Error; else return Expr; end if; end No_Right_Paren; ------------------ -- Set_Op_Name -- ------------------ procedure Set_Op_Name (Node : Node_Id) is subtype Op_Node is Node_Kind range N_Op_And .. N_Op_Not; type Name_Of_Type is array (Op_Node) of Name_Id; Name_Of : Name_Of_Type := Name_Of_Type'( N_Op_And => Name_Op_And, N_Op_And_Then => Name_Op_And_Then, N_Op_Or => Name_Op_Or, N_Op_Or_Else => Name_Op_Or_Else, N_Op_Xor => Name_Op_Xor, N_Op_In => Name_Op_In, N_Op_Not_In => Name_Op_Not_In, N_Op_Eq => Name_Op_Eq, N_Op_Ne => Name_Op_Ne, N_Op_Lt => Name_Op_Lt, N_Op_Le => Name_Op_Le, N_Op_Gt => Name_Op_Gt, N_Op_Ge => Name_Op_Ge, N_Op_Add => Name_Op_Add, N_Op_Subtract => Name_Op_Subtract, N_Op_Concat => Name_Op_Concat, N_Op_Multiply => Name_Op_Multiply, N_Op_Divide => Name_Op_Divide, N_Op_Mod => Name_Op_Mod, N_Op_Rem => Name_Op_Rem, N_Op_Expon => Name_Op_Expon, N_Op_Plus => Name_Op_Add, N_Op_Minus => Name_Op_Subtract, N_Op_Abs => Name_Op_Abs, N_Op_Not => Name_Op_Not); begin Set_Chars (Node, Name_Of (Nkind (Node))); end Set_Op_Name; -------------------------- -- Name (4.1, also 6.4) -- -------------------------- -- NAME ::= -- DIRECT_NAME | EXPLICIT_DEREFERENCE -- | INDEXED_COMPONENT | SLICE -- | SELECTED_COMPONENT | ATTRIBUTE -- | TYPE_CONVERSION | FUNCTION_CALL -- | CHARACTER_LITERAL -- DIRECT_NAME ::= IDENTIFIER | OPERATOR_SYMBOL -- PREFIX ::= NAME | IMPLICIT_DEREFERENCE -- EXPLICIT_DEREFERENCE ::= NAME . all -- IMPLICIT_DEREFERENCE ::= NAME -- INDEXED_COMPONENT ::= PREFIX (EXPRESSION {, EXPRESSION}) -- SLICE ::= PREFIX (DISCRETE_RANGE) -- SELECTED_COMPONENT ::= PREFIX . SELECTOR_NAME -- SELECTOR_NAME ::= IDENTIFIER | CHARACTER_LITERAL | OPERATOR_SYMBOL -- ATTRIBUTE_REFERENCE ::= PREFIX ' ATTRIBUTE_DESIGNATOR -- ATTRIBUTE_DESIGNATOR ::= -- IDENTIFIER [(static_EXPRESSION)] -- | access | delta | digits -- RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR -- RANGE_ATTRIBUTE_DESIGNATOR ::= PREFIX [(static_EXPRESSION)] -- FUNCTION_CALL ::= -- function_NAME | function_PREFIX [ACTUAL_PARAMETER_PART] -- ACTUAL_PARAMETER_PART ::= -- (PARAMETER_ASSOCIATION {,PARAMETER_ASSOCIATION}) -- PARAMETER_ASSOCIATION ::= [FORMAL_PARAMETER =>] ACTUAL_PARAMETER -- FORMAL_PARAMETER ::= parameter_SELECTOR_NAME -- ACTUAL_PARAMETER ::= EXPRESSION | variable_NAME -- This routine scans a name. Note that we do not consider the attributes -- Range, Base (unless followed by another attribute), or Class to be -- Names in this parser (they can only be used in subtype mark contexts). -- Note: syntactically a procedure call looks just like a function call, -- so this routine is in practice used to scan out procedure calls as well. -- On return, Expr_Form is set to either EF_Name or EF_Simple_Name -- Error recovery: can raise Error_Resync function P_Name return Node_Id is Scan_State : Saved_Scan_State; Name_Node : Node_Id; begin Name_Node := P_Call_Name; -- Complain if we didn't get a name if Expr_Form = EF_Call then Error_Msg ("function call cannot be used as name", Sloc (Name (Name_Node))); Expr_Form := EF_Simple_Name; return Error; -- Complain about bad apostrophe cases elsif Token = Tok_Apostrophe then Save_Scan_State (Scan_State); -- at apostrophe Scan; -- past apostrophe if Token = Tok_Range then Error_Msg_SP ("range attribute cannot be used as a name"); Restore_Scan_State (Scan_State); -- to apostrophe raise Error_Resync; else -- Token = Tok_Left_Paren Error_Msg_SP ("qualified expression cannot be used as a name"); raise Error_Resync; end if; end if; return Name_Node; end P_Name; -- This routine scans either a call or a name. These constructs have -- overlapping syntax, so the approach is to use this general routine to -- scan out any of these cases. On return, the global variable Expr_Form -- is set to one of the following -- EF_Name For a name that could not be a call (array slice or -- character literal) -- -- EF_Call For a call that could be a name (one or more named -- parameters present) -- -- EF_Call_Name For all other cases, which could be either calls or -- names, and the parser cannot tell the difference. -- Note: if on return Token = Tok_Apostrophe, then the apostrophe must be -- followed by either a left paren (qualified expression case), or by -- range (range attribute case). All other uses of apostrophe (i.e. all -- other attributes) are handled in this routine. In the case of the left -- paren, P_Call_Name checks that the preceding name is simple, and issues -- an error message if this is not the case. -- Error recovery: can raise Error_Resync function P_Call_Name return Node_Id is Scan_State : Saved_Scan_State; Call_Name_Node : Node_Id; Prefix_Node : Node_Id; Ident_Node : Node_Id; Expr_Node : Node_Id; Range_Node : Node_Id; Arg_Node : Node_Id; Arg_List : List_Id; Attr_Follows : Boolean; Attr_Id : Attribute_Id; begin if Token not in Token_Class_Name then Error_Msg_AP ("name expected"); raise Error_Resync; end if; -- Loop through designators in qualified name Call_Name_Node := Token_Node; loop Scan; -- past designator exit when Token /= Tok_Dot; Scan; -- past dot -- If we do not have another designator after the dot, then join -- the normal circuit to handle a dot extension (may be .all or -- character literal case). Otherwise loop back to scan the next -- designator. if Token not in Token_Class_Desig then goto Scan_Name_Extension_Dot; else Prefix_Node := Call_Name_Node; Call_Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr); Set_Prefix (Call_Name_Node, Prefix_Node); Set_Selector_Name (Call_Name_Node, Token_Node); end if; end loop; -- We have now scanned out a qualified designator. If the last token is -- an operator symbol, then we certainly do not have the Snam case, so -- we can just use the normal name extension check circuit if Prev_Token = Tok_Operator_Symbol then goto Scan_Name_Extension; end if; -- We have scanned out a qualified simple name, check for name extension -- Note that we know there is no dot here at this stage, so the only -- possible cases of name extension are apostrophe and left paren. if Token = Tok_Apostrophe then Save_Scan_State (Scan_State); -- at apostrophe Scan; -- past apostrophe -- If left paren, then this might be a qualified expression, but we -- are only in the business of scanning out names, so return with -- Token backed up to point to the apostrophe. The treatment for -- the range attribute is similar (we do not consider x'range to -- be a name in this grammar). if Token = Tok_Left_Paren or else Token = Tok_Range then Restore_Scan_State (Scan_State); -- to apostrophe Expr_Form := EF_Simple_Name; return Call_Name_Node; -- Otherwise we have the case of a name extended by an attribute else goto Scan_Name_Extension_Apostrophe; end if; -- Check case of qualified simple name extended by a left parenthesis elsif Token = Tok_Left_Paren then Scan; -- past left paren goto Scan_Name_Extension_Left_Paren; -- Otherwise the qualified simple name is not extended, so return else Expr_Form := EF_Simple_Name; return Call_Name_Node; end if; -- Loop scanning past name extensions. A label is used for control -- transfer for this loop for ease of interfacing with the finite state -- machine in the parenthesis scanning circuit, and also to allow for -- passing in control to the appropriate point from the above code. <> -- Character literal used as name cannot be extended. Also this -- cannot be a call, since the name for a call must be a designator. if Prev_Token = Tok_Char_Literal then Expr_Form := EF_Name; return Call_Name_Node; -- Immediate exit if no name extension (left paren, dot, apostrophe) elsif Token not in Token_Class_Namext then Expr_Form := EF_Call_Name; return Call_Name_Node; end if; -- Merge here when we know there is a name extension <> if Token = Tok_Left_Paren then Scan; -- past left paren goto Scan_Name_Extension_Left_Paren; elsif Token = Tok_Apostrophe then Save_Scan_State (Scan_State); -- at apostrophe Scan; -- past apostrophe goto Scan_Name_Extension_Apostrophe; else -- Token = Tok_Dot Scan; -- past dot goto Scan_Name_Extension_Dot; end if; -- Case of name extended by dot (selection), dot is already skipped <> -- Explicit dereference case if Token = Tok_All then Prefix_Node := Call_Name_Node; Call_Name_Node := New_Node (N_Explicit_Dereference, Token_Ptr); Set_Prefix (Call_Name_Node, Prefix_Node); Scan; -- past ALL goto Scan_Name_Extension; -- Selected component case elsif Token in Token_Class_Name then Prefix_Node := Call_Name_Node; Call_Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr); Set_Prefix (Call_Name_Node, Prefix_Node); Set_Selector_Name (Call_Name_Node, Token_Node); Scan; -- past selector goto Scan_Name_Extension; -- Reserved identifier as selector elsif Is_Reserved_Identifier then Scan_Reserved_Identifier (Force_Msg => False); Prefix_Node := Call_Name_Node; Call_Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr); Set_Prefix (Call_Name_Node, Prefix_Node); Set_Selector_Name (Call_Name_Node, Token_Node); Scan; -- past identifier used as selector goto Scan_Name_Extension; -- Here if nothing legal after the dot else Error_Msg_AP ("selector expected"); raise Error_Resync; end if; -- Here for an apostrophe as name extension. The scan position at the -- apostrophe has already been saved, and the apostrophe scanned out. <> -- If range attribute after apostrophe, then return with Token -- pointing to the apostrophe. Note that in this case the prefix -- need not be a simple name (cases like A.all'range). Similarly -- if there is a left paren after the apostrophe, then we also -- return with Token pointing to the apostrophe (this is the -- qualified expression case). if Token = Tok_Range or else Token = Tok_Left_Paren then Restore_Scan_State (Scan_State); -- to apostrophe Expr_Form := EF_Call_Name; return Call_Name_Node; -- Here for cases where attribute designator is an identifier elsif Token = Tok_Identifier then if Is_Attribute_Name (Token_Name) then Ident_Node := Token_Node; else Error_Msg_N ("Unrecognized attribute&", Token_Node); end if; -- Here for case of attribute designator is not an identifier else Ident_Node := New_Node (N_Identifier, Token_Ptr); if Token = Tok_Delta then Set_Chars (Ident_Node, Name_Delta); elsif Token = Tok_Digits then Set_Chars (Ident_Node, Name_Digits); elsif Token = Tok_Access then Set_Chars (Ident_Node, Name_Access); if Ada_83 then Error_Msg_N ("`Access` attribute not allowed in Ada 83!", Token_Node); end if; else Error_Msg_AP ("attribute designator expected"); raise Error_Resync; end if; end if; -- We come here with an OK attribute scanned, and the corresponding -- Attribute identifier node stored in Ident_Node. Prefix_Node := Call_Name_Node; Call_Name_Node := New_Node (N_Attribute_Reference, Prev_Token_Ptr); Scan; -- past attribute designator Set_Prefix (Call_Name_Node, Prefix_Node); Set_Identifier (Call_Name_Node, Ident_Node); Attr_Id := Get_Attribute_Id (Chars (Ident_Node)); -- The syntax of Array attributes (FIRST, LAST, LENGTH and RANGE) -- includes an optional static expression that denotes a dimension. -- Attributes that are functions (IMAGE, POS, PRED, SUCC, VAL -- and VALUE) must be semantically followed by a single argument. -- It is simplest to regard a parenthesized expression that follows -- and attribute designator as being part of the designator. -- Subsequent semantic checks determine whether the presence of -- the argument is legal for that attribute. -- An exception occurs with attributes that return functions of two -- parameters ('Min, 'Max, 'Read, 'Write, 'Output). For these cases -- we do *not* swallow the parenthesized expressions which follow -- the attribute reference. -- The attribute ACCESS is also treated specially, because it may -- be followed by an argument list, in the admidedly pathological -- usage: some_function'access(x, y, z), which is equivalent to -- calling some_function(x, y, z) directly. if Token = Tok_Left_Paren and then Attr_Id /= Attribute_Access and then Attr_Id /= Attribute_Max and then Attr_Id /= Attribute_Min and then Attr_Id /= Attribute_Output and then Attr_Id /= Attribute_Read and then Attr_Id /= Attribute_Write then Scan; -- past left paren Set_Expression (Call_Name_Node, P_Expression); T_Right_Paren; end if; goto Scan_Name_Extension; -- Here for left parenthesis extending name (left paren skipped) <> -- We now have to scan through a list of items, terminated by a -- right parenthesis. The scan is handled by a finite state -- machine. The possibilities are: -- (discrete_range) -- This is a slice. This case is handled in LP_State_Init. -- (expression, expression, ..) -- This is interpreted as an indexed component, i.e. as a -- case of a name which can be extended in the normal manner. -- This case is handled by LP_State_Name or LP_State_Expr. -- (..., identifier => expression , ...) -- If there is at least one occurence of identifier => (but -- none of the other cases apply), then we have a call. -- LP_State_Init handles the scan of the initial argument <> -- Test for Id => case if Token = Tok_Identifier then Save_Scan_State (Scan_State); -- at Id Scan; -- past Id if Token = Tok_Arrow then Restore_Scan_State (Scan_State); -- to Id Arg_List := New_List; goto LP_State_Call; else Restore_Scan_State (Scan_State); -- to Id end if; end if; -- Here we have an expression after all Expr_Node := P_Expression; -- Check cases of discrete range for a slice -- First possibility: Simple_expression .. Simple_expression if Token = Tok_Dot_Dot then Check_Simple_Expression (Expr_Node); Range_Node := New_Node (N_Range, Token_Ptr); Set_Low_Bound (Range_Node, Expr_Node); Scan; -- past .. Expr_Node := P_Expression; Check_Simple_Expression (Expr_Node); Set_High_Bound (Range_Node, Expr_Node); -- Second possibility: Range attribute elsif Token = Tok_Apostrophe then Range_Node := P_Range_Attribute (Expr_Node); -- Third possibility: Type_name range Range elsif Token = Tok_Range then if Expr_Form /= EF_Simple_Name then Error_Msg_SC ("subtype mark must precede RANGE"); raise Error_Resync; end if; Range_Node := P_Subtype_Indication (Expr_Node); -- Otherwise we just have an expression. It is true that we might -- have a subtype mark without a range constraint but this case -- is syntactically indistinguishable from the expression case. else Arg_List := New_List; goto LP_State_Expr; end if; -- Fall through here with unmistakable Discrete range scanned, -- which means that we definitely have the case of a slice. The -- Discrete range is in Range_Node. if Token = Tok_Comma then Error_Msg_SC ("slice cannot have more than one dimension"); raise Error_Resync; elsif Token /= Tok_Right_Paren then T_Right_Paren; raise Error_Resync; else Scan; -- past right paren Prefix_Node := Call_Name_Node; Call_Name_Node := New_Node (N_Slice, Sloc (Prefix_Node)); Set_Prefix (Call_Name_Node, Prefix_Node); Set_Discrete_Range (Call_Name_Node, Range_Node); -- If we have a name extension, go scan it if Token in Token_Class_Namext then goto Scan_Name_Extension_OK; -- Otherwise return (a slice is a name, but is not a call) else Expr_Form := EF_Name; return Call_Name_Node; end if; end if; -- In LP_State_Expr, we have scanned one or more expressions, and -- so we have a call or an indexed component which is a name. On -- entry we have the expression just scanned in Expr_Node and -- Arg_List contains the list of expressions encountered so far <> Append (Expr_Node, Arg_List); if not Comma_Present then T_Right_Paren; Prefix_Node := Call_Name_Node; Call_Name_Node := New_Node (N_Indexed_Component, Sloc (Prefix_Node)); Set_Prefix (Call_Name_Node, Prefix_Node); Set_Expressions (Call_Name_Node, Arg_List); goto Scan_Name_Extension; end if; -- Comma present (and scanned out), test for identifier => case -- Test for identifer => case if Token = Tok_Identifier then Save_Scan_State (Scan_State); -- at Id Scan; -- past Id if Token = Tok_Arrow then Restore_Scan_State (Scan_State); -- to Id goto LP_State_Call; -- Otherwise it's just an expression after all, so backup else Restore_Scan_State (Scan_State); -- to Id end if; end if; -- Here we have an expression after all, so stay in this state Expr_Node := P_Expression; goto LP_State_Expr; -- LP_State_Call corresponds to the situation in which at least -- one instance of Id => Expression has been encountered, so we -- know that we do not have a name, but rather a call. We enter -- it with the scan pointer pointing to the next argument to scan, -- and Arg_List containing the list of arguments scanned so far. <> -- Test for case of Id => Expression (named parameter) if Token = Tok_Identifier then Save_Scan_State (Scan_State); -- at Id Ident_Node := Token_Node; Scan; -- past Id if Token = Tok_Arrow then Arg_Node := New_Node (N_Parameter_Association, Prev_Token_Ptr); Set_Selector_Name (Arg_Node, Ident_Node); Scan; -- past arrow Set_Actual_Parameter (Arg_Node, P_Expression); Append (Arg_Node, Arg_List); -- If a comma follows, go back and scan next entry if Comma_Present then goto LP_State_Call; -- Otherwise we have the end of a call else Prefix_Node := Call_Name_Node; Call_Name_Node := New_Node (N_Function_Call, Sloc (Prefix_Node)); Set_Name (Call_Name_Node, Prefix_Node); Set_Parameter_Associations (Call_Name_Node, Arg_List); T_Right_Paren; if Token in Token_Class_Namext then goto Scan_Name_Extension_OK; -- This is a case of a call which cannot be a name else Expr_Form := EF_Call; return Call_Name_Node; end if; end if; -- Not named parameter: Id started an expression after all else Restore_Scan_State (Scan_State); -- to Id end if; end if; -- Here if entry did not start with Id => which means that it -- is a positional parameter, which is not allowed, since we -- have seen at least one named parameter already. Error_Msg_SC ("positional parameter association " & "not allowed after named one"); Expr_Node := P_Expression; -- We go back to scanning out expressions, so that we do not get -- multiple error messages when several positional parameters -- follow a named parameter. goto LP_State_Expr; -- End of treatment for name extensions starting with left paren -- End of loop through name extensions end P_Call_Name; -- This function parses a restricted form of Names which are either -- designators, or designators preceded by a sequence of prefixes -- that are direct names. -- Error recovery: cannot raise Error_Resync function P_Function_Name return Node_Id is Designator_Node : Node_Id; Prefix_Node : Node_Id; Selector_Node : Node_Id; Dot_Sloc : Source_Ptr; begin -- Prefix node is set to the gathered prefix so far, Empty means that -- no prefix has been scanned. This allows us to build up the result -- in the required right recursive manner. Prefix_Node := Empty; -- Loop through prefixes loop Designator_Node := Token_Node; if Token not in Token_Class_Desig then return P_Identifier; -- let P_Identifier issue the error message else -- Token in Token_Class_Desig Scan; -- past designator exit when Token /= Tok_Dot; end if; -- Here at a dot, with token just before it in Designator_Node if No (Prefix_Node) then Prefix_Node := Designator_Node; else Selector_Node := New_Node (N_Selected_Component, Dot_Sloc); Set_Prefix (Selector_Node, Prefix_Node); Set_Selector_Name (Selector_Node, Designator_Node); Prefix_Node := Selector_Node; end if; Dot_Sloc := Token_Ptr; Scan; -- past dot end loop; -- Fall out of the loop having just scanned a designator if No (Prefix_Node) then return Designator_Node; else Selector_Node := New_Node (N_Selected_Component, Dot_Sloc); Set_Prefix (Selector_Node, Prefix_Node); Set_Selector_Name (Selector_Node, Designator_Node); return Selector_Node; end if; exception when Error_Resync => return Error; end P_Function_Name; -- This function parses a restricted form of Names which are either -- identifiers, or identifiers preceded by a sequence of prefixes -- that are direct names. -- Error recovery: cannot raise Error_Resync function P_Qualified_Simple_Name return Node_Id is Designator_Node : Node_Id; Prefix_Node : Node_Id; Selector_Node : Node_Id; Dot_Sloc : Source_Ptr; begin -- Prefix node is set to the gathered prefix so far, Empty means that -- no prefix has been scanned. This allows us to build up the result -- in the required right recursive manner. Prefix_Node := Empty; -- Loop through prefixes loop Designator_Node := Token_Node; if Token = Tok_Identifier then Scan; -- past identifier exit when Token /= Tok_Dot; elsif Token not in Token_Class_Desig then return P_Identifier; -- let P_Identifier issue the error message else Scan; -- past designator if Token /= Tok_Dot then Error_Msg_SP ("identifier expected"); return Error; end if; end if; -- Here at a dot, with token just before it in Designator_Node if No (Prefix_Node) then Prefix_Node := Designator_Node; else Selector_Node := New_Node (N_Selected_Component, Dot_Sloc); Set_Prefix (Selector_Node, Prefix_Node); Set_Selector_Name (Selector_Node, Designator_Node); Prefix_Node := Selector_Node; end if; Dot_Sloc := Token_Ptr; Scan; -- past dot end loop; -- Fall out of the loop having just scanned an identifier if No (Prefix_Node) then return Designator_Node; else Selector_Node := New_Node (N_Selected_Component, Dot_Sloc); Set_Prefix (Selector_Node, Prefix_Node); Set_Selector_Name (Selector_Node, Designator_Node); return Selector_Node; end if; exception when Error_Resync => return Error; end P_Qualified_Simple_Name; -- This procedure differs from P_Qualified_Simple_Name only in that it -- raises Error_Resync if any error is encountered. It only returns after -- scanning a valid qualified simple name. -- Error recovery: can raise Error_Resync function P_Qualified_Simple_Name_Resync return Node_Id is Designator_Node : Node_Id; Prefix_Node : Node_Id; Selector_Node : Node_Id; Dot_Sloc : Source_Ptr; begin Prefix_Node := Empty; -- Loop through prefixes loop Designator_Node := Token_Node; if Token = Tok_Identifier then Scan; -- past identifier exit when Token /= Tok_Dot; elsif Token not in Token_Class_Desig then Discard_Junk_Node (P_Identifier); -- to issue the error message raise Error_Resync; else Scan; -- past designator if Token /= Tok_Dot then Error_Msg_SP ("identifier expected"); raise Error_Resync; end if; end if; -- Here at a dot, with token just before it in Designator_Node if No (Prefix_Node) then Prefix_Node := Designator_Node; else Selector_Node := New_Node (N_Selected_Component, Dot_Sloc); Set_Prefix (Selector_Node, Prefix_Node); Set_Selector_Name (Selector_Node, Designator_Node); Prefix_Node := Selector_Node; end if; Dot_Sloc := Token_Ptr; Scan; -- past period end loop; -- Fall out of the loop having just scanned an identifier if No (Prefix_Node) then return Designator_Node; else Selector_Node := New_Node (N_Selected_Component, Dot_Sloc); Set_Prefix (Selector_Node, Prefix_Node); Set_Selector_Name (Selector_Node, Designator_Node); return Selector_Node; end if; end P_Qualified_Simple_Name_Resync; ---------------------- -- 4.1 Direct Name -- ---------------------- -- Parsed by P_Call_Name (4.1) ----------------- -- 4.1 Prefix -- ----------------- -- Parsed by P_Call_Name (4.1) ------------------------------- -- 4.1 Explicit Dereference -- ------------------------------- -- Parsed by P_Call_Name (4.1) ------------------------------- -- 4.1 Implicit Dereference -- ------------------------------- -- Parsed by P_Call_Name (4.1) ------------------------------ -- 4.1.1 Indexed Component -- ------------------------------ -- Parsed by P_Call_Name (4.1) ------------------ -- 4.1.2 Slice -- ------------------ -- Parsed by P_Call_Name (4.1) ------------------------------- -- 4.1.3 Selected Component -- ------------------------------- -- Parsed by P_Call_Name (4.1) -------------------------- -- 4.1.3 Selector Name -- -------------------------- -- Parsed by P_Call_Name (4.1) -------------------------------- -- 4.1.4 Attribute Reference -- -------------------------------- -- Parsed by P_Call_Name (4.1) --------------------------------- -- 4.1.4 Attribute Designator -- --------------------------------- -- Parsed by P_Call_Name (4.1) or P_Range_Attribute (4.1.4) -------------------------------------- -- 4.1.4 Range Attribute Reference -- -------------------------------------- -- RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR -- RANGE_ATTRIBUTE_DESIGNATOR ::= PREFIX [(static_EXPRESSION)] -- In the grammar, a RANGE attribute is simply a name, but its use is -- highly restricted, so in the parser, we do not regard it as a name. -- Instead, P_Call_Name returns without scanning the 'RANGE part of -- the attribute, and the caller uses the following function to construct -- a range attribute in places where it is appropriate. -- Note that RANGE here is treated essentially as an identifier, -- rather than a reserved word. -- The caller has parsed the prefix, i.e. a name, and Token points to -- the apostrophe. The token after the apostrophe is known to be RANGE -- at this point. The prefix node becomes the prefix of the attribute. -- Error_Recovery: Cannot raise Error_Resync function P_Range_Attribute (Prefix_Node : Node_Id) return Node_Id is Attr_Node : Node_Id; Range_Node : Node_Id; begin Attr_Node := New_Node (N_Attribute_Reference, Token_Ptr); Set_Prefix (Attr_Node, Prefix_Node); Scan; -- past apostrophe Range_Node := New_Node (N_Identifier, Token_Ptr); Set_Chars (Range_Node, Name_Range); Set_Identifier (Attr_Node, Range_Node); Scan; -- past RANGE if Token = Tok_Left_Paren then Scan; -- past left paren Set_Expression (Attr_Node, P_Expression); T_Right_Paren; end if; return Attr_Node; end P_Range_Attribute; --------------------------------------- -- 4.1.4 Range Attribute Designator -- --------------------------------------- -- Parsed by P_Range_Attribute (4.1.4) -------------------- -- 4.3 Aggregate -- -------------------- -- Parsed by P_Aggregate_Or_Paren_Expr (4.3), except in the case where -- an aggregate is known to be required (code statement, extension -- aggregate), in which cases this routine performs the necessary check. -- Error recovery: can raise Error_Resync function P_Aggregate return Node_Id is Aggregate_Node : Node_Id; Aggregate_Sloc : Source_Ptr; Expr_Node : Node_Id; begin Aggregate_Sloc := Token_Ptr; Aggregate_Node := P_Aggregate_Or_Paren_Expr; if Nkind (Aggregate_Node) /= N_Aggregate and then Nkind (Aggregate_Node) /= N_Extension_Aggregate then Error_Msg ("aggregate may not have single positional component", Aggregate_Sloc); Expr_Node := Aggregate_Node; Aggregate_Node := New_Node (N_Aggregate, Aggregate_Sloc); Set_Expressions (Aggregate_Node, New_List); Append (Expr_Node, Expressions (Aggregate_Node)); end if; return Aggregate_Node; end P_Aggregate; ------------------------------------------------------------ -- 4.3 Aggregate or Parenthesized Expresssion (also 4.4) -- ------------------------------------------------------------ -- This procedure parses out either an aggregate or a parenthesized -- expression (these two constructs are closely related, since a -- parenthesized expression looks like an aggregate with a single -- positional component). -- AGGREGATE ::= -- RECORD_AGGREGATE | EXTENSION_AGGREGATE | ARRAY_AGGREGATE -- RECORD_AGGREGATE ::= (RECORD_COMPONENT_ASSOCIATION_LIST) -- RECORD_COMPONENT_ASSOCIATION_LIST ::= -- RECORD_COMPONENT_ASSOCIATION {, RECORD_COMPONENT_ASSOCIATION} -- | NULL RECORD -- EXTENSION_AGGREGATE ::= -- (EXPRESSION with RECORD_COMPONENT_ASSOCIATION_LIST) -- ARRAY_AGGREGATE ::= -- POSITIONAL_ARRAY_AGGREGATE | NAMED_ARRAY_AGGREGATE -- POSITIONAL_ARRAY_AGGREGATE ::= -- (EXPRESSION, EXPRESSION {, EXPRESSION}) -- | (EXPRESSION {, EXPRESSION}, OTHERS => EXPRESSION) -- NAMED_ARRAY_AGGREGATE ::= -- (ARRAY_COMPONENT_ASSOCIATION {, ARRAY_COMPONENT_ASSOCIATION}) -- PRIMARY ::= (EXPRESSION); -- Error recovery: can raise Error_Resync function P_Aggregate_Or_Paren_Expr return Node_Id is Aggregate_Node : Node_Id; Expr_List : List_Id; Assoc_List : List_Id; Expr_Node : Node_Id; Pexpr_Node : Node_Id; Assoc_Node : Node_Id; Lparen_Sloc : Source_Ptr; Scan_State : Saved_Scan_State; begin Lparen_Sloc := Token_Ptr; T_Left_Paren; -- Note: the mechanism used here of rescanning the initial expression -- is distinctly unpleasant, but it saves a lot of fiddling in scanning -- out the discrete choice list. Perhaps we should fix things later? -- Deal with expression and extension aggregate cases first if Token /= Tok_Others then Save_Scan_State (Scan_State); -- at start of expression -- Deal with (NULL RECORD) case if Token = Tok_Null then Scan; -- past NULL if Token = Tok_Record then Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc); Set_Null_Record_Present (Aggregate_Node, True); Scan; -- past RECORD T_Right_Paren; return Aggregate_Node; else Restore_Scan_State (Scan_State); -- to NULL that must be expr end if; end if; Expr_Node := P_Expression; -- Extension aggregate case if Token = Tok_With then Aggregate_Node := New_Node (N_Extension_Aggregate, Lparen_Sloc); Set_Expression (Aggregate_Node, Expr_Node); Scan; -- past WITH -- Deal with WITH NULL RECORD case if Token = Tok_Null then Save_Scan_State (Scan_State); -- at NULL Scan; -- past NULL if Token = Tok_Record then Scan; -- past RECORD Set_Null_Record_Present (Aggregate_Node, True); T_Right_Paren; return Aggregate_Node; else Restore_Scan_State (Scan_State); -- to NULL that must be expr end if; end if; -- Otherwise we have a component association list Assoc_List := New_List_1 (P_Component_Association); while Comma_Present loop Append (P_Component_Association, Assoc_List); end loop; Set_Component_Associations (Aggregate_Node, Assoc_List); T_Right_Paren; return Aggregate_Node; -- Expression case elsif Token = Tok_Right_Paren or else Token in Token_Class_Eterm then if Expr_Node /= Error then if Parens (Expr_Node) then Pexpr_Node := New_Node (N_Parenthesized_Expression, Lparen_Sloc); Set_Expression (Pexpr_Node, Expr_Node); Expr_Node := Pexpr_Node; else Set_Parens (Expr_Node, True); end if; end if; T_Right_Paren; -- past right paren (error message if none) return Expr_Node; end if; end if; -- Come here if the only possibility left is a record/array aggregate Expr_List := No_List; -- don't set yet, maybe all named entries Assoc_List := No_List; -- don't set yet, maybe all positional entries Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc); -- This loop scans through component associations. On entry to the -- loop, an expression has been scanned at the start of the current -- association unless the current token is OTHERS. loop -- Deal with others association first. This is a named association if Token = Tok_Others then if Assoc_List = No_List then Assoc_List := New_List; end if; Append (P_Component_Association, Assoc_List); -- Here an expression has been scanned out, deal with positional case elsif Token = Tok_Comma or else Token = Tok_Right_Paren then if Assoc_List /= No_List then Error_Msg_BC ("""=>"" expected (positional association cannot follow " & "named association"); end if; if Expr_List = No_List then Expr_List := New_List; end if; Append (Expr_Node, Expr_List); -- Improper use of WITH elsif Token = Tok_With then Error_Msg_SC ("WITH must be preceded by single expression in " & "extension aggregate"); raise Error_Resync; -- Here we definitely have a named association else Restore_Scan_State (Scan_State); -- to start of expression if Assoc_List = No_List then Assoc_List := New_List; end if; Append (P_Component_Association, Assoc_List); end if; exit when not Comma_Present; if Token /= Tok_Others then Save_Scan_State (Scan_State); -- at start of expression Expr_Node := P_Expression; end if; end loop; -- All component associations (positional and named) have been scanned T_Right_Paren; Set_Expressions (Aggregate_Node, Expr_List); Set_Component_Associations (Aggregate_Node, Assoc_List); return Aggregate_Node; end P_Aggregate_Or_Paren_Expr; -------------------------------- -- 4.3 Component Association -- -------------------------------- -- RECORD_COMPONENT_ASSOCIATION ::= -- component_SELECTOR_NAME {| component_SELECTOR_NAME} => EXPRESSION -- | others => EXPRESSION -- ARRAY_COMPONENT_ASSOCIATION ::= -- DISCRETE_CHOICE_LIST => EXPRESSION -- Note: An others choice can also be handled by this routine -- Error recovery: can raise Error_Resync function P_Component_Association return Node_Id is Assoc_Node : Node_Id; begin Assoc_Node := New_Node (N_Component_Association, Token_Ptr); Set_Choices (Assoc_Node, P_Discrete_Choice_List); Set_Sloc (Assoc_Node, Token_Ptr); TF_Arrow; Set_Expression (Assoc_Node, P_Expression); return Assoc_Node; end P_Component_Association; ----------------------------- -- 4.3.1 Record Aggregate -- ----------------------------- -- Parsed by P_Aggregate_Or_Paren_Expr (4.3) ----------------------------------------- -- 4.3.1 Record Component Association -- ----------------------------------------- -- Parsed by P_Component_Association (4.3) -------------------------------- -- 4.3.2 Extension Aggregate -- -------------------------------- -- Parsed by P_Aggregate_Or_Paren_Expr (4.3) ---------------------------------------- -- 4.3.2 Extension_Part_Subaggregate -- ---------------------------------------- -- Parsed by P_Aggregate_Or_Paren_Expr (4.3) ---------------------------- -- 4.3.3 Array Aggregate -- ---------------------------- -- Parsed by P_Aggregate_Or_Paren_Expr (4.3) --------------------------------------- -- 4.3.3 Positional Array Aggregate -- --------------------------------------- -- Parsed by P_Aggregate_Or_Paren_Expr (4.3) ---------------------------------- -- 4.3.3 Named Array Aggregate -- ---------------------------------- -- Parsed by P_Aggregate_Or_Paren_Expr (4.3) ---------------------------------------- -- 4.3.3 Array Component Association -- ---------------------------------------- -- Parsed by P_Component_Association (4.3) --------------------- -- 4.4 Expression -- --------------------- -- EXPRESSION ::= -- RELATION {and RELATION} | RELATION {and then RELATION} -- | RELATION {or RELATION} | RELATION {or else RELATION} -- | RELATION {xor RELATION} -- On return, Expr_Form indicates the categorization of the expression -- Note: if Token = Tok_Apostrophe on return, then Expr_Form is set to -- EF_Simple_Name and the following token is RANGE (range attribute case). -- Error recovery: cannot raise Error_Resync function P_Expression return Node_Id is Logical_Op : Node_Kind; Prev_Logical_Op : Node_Kind; Op_Location : Source_Ptr; Node1 : Node_Id; Node2 : Node_Id; begin Node1 := P_Relation; if Token in Token_Class_Logop then Prev_Logical_Op := N_Empty; loop Op_Location := Token_Ptr; Logical_Op := P_Logical_Operator; if Prev_Logical_Op /= N_Empty and then Logical_Op /= Prev_Logical_Op then Error_Msg ("mixed logical operators in expression", Op_Location); Prev_Logical_Op := N_Empty; else Prev_Logical_Op := Logical_Op; end if; Node2 := Node1; Node1 := New_Node (Logical_Op, Op_Location); Set_Left_Opnd (Node1, Node2); Set_Right_Opnd (Node1, P_Relation); Set_Op_Name (Node1); exit when Token not in Token_Class_Logop; end loop; Expr_Form := EF_Non_Simple; end if; return Node1; end P_Expression; --------------------------------------------------- -- 4.4 Expression with no Right Paren Following -- --------------------------------------------------- -- This function is identical to the normal P_Expression, except that it -- checks that the expression scan did not stop on a right paren. It is -- called in all contexts where a right parenthesis cannot legitimately -- follow an expression. function P_Expression_No_Right_Paren return Node_Id is begin return No_Right_Paren (P_Expression); end P_Expression_No_Right_Paren; ------------------- -- 4.4 Relation -- ------------------- -- RELATION ::= -- SIMPLE_EXPRESSION [RELATIONAL_OPERATOR SIMPLE_EXPRESSION] -- | SIMPLE_EXPRESSION [not] in RANGE -- | SIMPLE_EXPRESSION [not] in SUBTYPE_MARK -- On return, Expr_Form indicates the categorization of the expression -- Note: if Token = Tok_Apostrophe on return, then Expr_Form is set to -- EF_Simple_Name and the following token is RANGE (range attribute case). -- Error recovery: cannot raise Error_Resync. If an error occurs within an -- expression, then tokens are scanned until either a non-expression token, -- a right paren (not matched by a left paren) or a comma, is encountered. function P_Relation return Node_Id is Node1, Node2 : Node_Id; begin Node1 := P_Simple_Expression; if Token not in Token_Class_Relop then return Node1; else -- Here we have a relational operator following. If so then scan it -- out. Note that the assignment symbol := is treated as a relational -- operator to improve the error recovery when it is misused for =. Node2 := New_Node (P_Relational_Operator, Token_Ptr); Set_Left_Opnd (Node2, Node1); Set_Op_Name (Node2); if Prev_Token = Tok_In then Set_Right_Opnd (Node2, P_Range_Or_Subtype_Mark); else Set_Right_Opnd (Node2, P_Simple_Expression); end if; Expr_Form := EF_Non_Simple; if Token in Token_Class_Relop then Error_Msg_SC ("unexpected relational operator"); raise Error_Resync; end if; return Node2; end if; -- If any error occurs, then scan to the next expression terminator symbol -- or comma or right paren at the outer (i.e. current) parentheses level. -- The flags are set to indicate a normal simple expression. exception when Error_Resync => Resync_Expression; Expr_Form := EF_Simple; return Error; end P_Relation; ----------------------------------- -- P_Range_Or_Subtype_Mark (4.4) -- ----------------------------------- -- This routine scans out the range or subtype mark that forms the right -- operand of a membership test. The reason that we include this code in -- chapter 4 is that it is only called from Ch4, and also we need to be -- able to call the Simple_Expression routine in this context. function P_Range_Or_Subtype_Mark return Node_Id is Expr_Node : Node_Id; Range_Node : Node_Id; begin Expr_Node := P_Simple_Expression; -- Simple_Expression .. Simple_Expression as range if Token = Tok_Dot_Dot then Range_Node := New_Node (N_Range, Token_Ptr); Set_Low_Bound (Range_Node, Expr_Node); Scan; -- past .. Set_High_Bound (Range_Node, P_Simple_Expression); return Range_Node; -- If no double dot, could be range attribute elsif Token = Tok_Apostrophe then return P_Range_Attribute (Expr_Node); -- Case of subtype mark (optionally qualified simple name or an -- attribute whose prefix is an optionally qualifed simple name) elsif Expr_Form = EF_Simple_Name or else Nkind (Expr_Node) = N_Attribute_Reference then -- Check for error of range constraint after a subtype mark if Token = Tok_Range then Error_Msg_SC ("range constraint not allowed in membership test"); Scan; -- past RANGE raise Error_Resync; -- Check for error of DIGITS or DELTA after a subtype mark elsif Token = Tok_Digits or else Token = Tok_Delta then Error_Msg_SC ("accuracy definition not allowed in membership test"); Scan; -- past DIGITS or DELTA raise Error_Resync; elsif Token = Tok_Apostrophe then return P_Subtype_Mark_Attribute (Expr_Node); else return Expr_Node; end if; -- For other cases (call, non-simple name, qualified expression), we -- assume that we have a missing .. (as reasonable an error as any!) else T_Dot_Dot; -- give .. expected message raise Error_Resync; end if; end P_Range_Or_Subtype_Mark; ---------------------------- -- 4.4 Simple Expression -- ---------------------------- -- SIMPLE_EXPRESSION ::= -- [UNARY_ADDING_OPERATOR] TERM {BINARY_ADDING_OPERATOR TERM} -- On return, Expr_Form indicates the categorization of the expression -- Note: if Token = Tok_Apostrophe on return, then Expr_Form is set to -- EF_Simple_Name and the following token is RANGE (range attribute case). -- Error recovery: cannot raise Error_Resync. If an error occurs within an -- expression, then tokens are scanned until either a non-expression token, -- a right paren (not matched by a left paren) or a comma, is encountered. -- Note: P_Simple_Expression is called only internally by higher level -- expression routines. In cases in the grammar where a simple expression -- is required, the approach is to scan an expression, and then post an -- appropriate error message if the expression obtained is not simple. This -- gives better error recovery and treatment. function P_Simple_Expression return Node_Id is Scan_State : Saved_Scan_State; Node1, Node2 : Node_Id; begin -- Check for cases starting with a name. There are two reasons for -- special casing. First speed things up by catching a common case -- without going through several routine layers. Second the caller must -- be informed via Expr_Form when the simple expression is a name. if Token in Token_Class_Name then Node1 := P_Call_Name; -- Deal with apostrophe cases if Token = Tok_Apostrophe then Save_Scan_State (Scan_State); -- at apostrophe Scan; -- past apostrophe -- If qualified expression, scan it out and fall through if Token = Tok_Left_Paren then Node1 := P_Qualified_Expression (Node1); Expr_Form := EF_Simple; -- If range attribute, then we return with Token pointing to the -- apostrophe. Note: avoid the normal error check on exit. We -- know that the expression really is complete in this case! else -- Token = Tok_Range then Restore_Scan_State (Scan_State); -- to apostrophe Expr_Form := EF_Simple_Name; return Node1; end if; end if; -- If an expression terminator follows, the previous processing -- completely scanned out the expression (a common case), and -- left Expr_Form set appropriately for returning to our caller. if Token in Token_Class_Sterm then null; -- If we do not have an expression terminator, then complete the -- scan of a simple expression. This code duplicates the code -- found in P_Term and P_Factor. else if Token = Tok_Double_Asterisk then Node2 := New_Node (N_Op_Expon, Token_Ptr); Scan; -- past ** Set_Left_Opnd (Node2, Node1); Set_Right_Opnd (Node2, P_Primary); Set_Op_Name (Node2); Node1 := Node2; end if; loop exit when Token not in Token_Class_Mulop; Node2 := New_Node (P_Multiplying_Operator, Token_Ptr); Scan; -- past operator Set_Left_Opnd (Node2, Node1); Set_Right_Opnd (Node2, P_Factor); Set_Op_Name (Node2); Node1 := Node2; end loop; loop exit when Token not in Token_Class_Binary_Addop; Node2 := New_Node (P_Binary_Adding_Operator, Token_Ptr); Scan; -- past operator Set_Left_Opnd (Node2, Node1); Set_Right_Opnd (Node2, P_Term); Set_Op_Name (Node2); Node1 := Node2; end loop; Expr_Form := EF_Simple; end if; -- Cases where simple expression does not start with a name else -- Scan initial sign and initial Term if Token in Token_Class_Unary_Addop then Node1 := New_Node (P_Unary_Adding_Operator, Token_Ptr); Scan; -- past operator Set_Right_Opnd (Node1, P_Term); Set_Op_Name (Node1); else Node1 := P_Term; end if; -- Scan out sequence of terms separated by binary adding operators loop exit when Token not in Token_Class_Binary_Addop; Node2 := New_Node (P_Binary_Adding_Operator, Token_Ptr); Scan; -- past operator Set_Left_Opnd (Node2, Node1); Set_Right_Opnd (Node2, P_Term); Set_Op_Name (Node2); Node1 := Node2; end loop; -- All done, we clearly do not have name or numeric literal so this -- is a case of a simple expression which is some other possibility. Expr_Form := EF_Simple; end if; -- Special test to improve error recovery: If the current token is not -- the first token on a line (as determined by checking the previous -- token position with the start of the current line), then we insist -- that we have an appropriate terminating token. Consider the -- following two examples: -- 1) if A nad B then ... -- 2) A := B -- C := D -- In the first example, we would like to issue a binary operator -- expected message and resynchronize to the then. In the second -- example, we do not want to issue a binary operator message, so -- that instead we will get the missing semicolon message. This -- distinction is of course a heuristic which does not always work, -- but in practice it is quite effective. -- Note: the one case in which we do not go through this circuit is -- when we have scanned a range attribute and want to return with -- Token pointing to the apostrophe. The apostrophe is not normally -- an expression terminator, and is not in Token_Class_Sterm, but -- in this special case we know that the expression is complete. <> if not Token_Is_At_Start_Of_Line and then Token not in Token_Class_Sterm then Error_Msg_AP ("binary operator expected"); raise Error_Resync; else return Node1; end if; -- If any error occurs, then scan to next expression terminator symbol -- or comma, right paren or vertical bar at the outer (i.e. current) paren -- level. Expr_Form is set to indicate a normal simple expression. exception when Error_Resync => Resync_Expression; Expr_Form := EF_Simple; return Error; end P_Simple_Expression; --------------- -- 4.4 Term -- --------------- -- TERM ::= FACTOR {MULTIPLYING_OPERATOR FACTOR} -- Error recovery: can raise Error_Resync function P_Term return Node_Id is Node1, Node2 : Node_Id; begin Node1 := P_Factor; loop exit when Token not in Token_Class_Mulop; Node2 := New_Node (P_Multiplying_Operator, Token_Ptr); Scan; -- past operator Set_Left_Opnd (Node2, Node1); Set_Right_Opnd (Node2, P_Factor); Set_Op_Name (Node2); Node1 := Node2; end loop; return Node1; end P_Term; ----------------- -- 4.4 Factor -- ----------------- -- FACTOR ::= PRIMARY [** PRIMARY] | abs PRIMARY | not PRIMARY -- Error recovery: can raise Error_Resync function P_Factor return Node_Id is Node1 : Node_Id; Node2 : Node_Id; begin if Token = Tok_Abs then Node1 := New_Node (N_Op_Abs, Token_Ptr); Scan; -- past ABS Set_Right_Opnd (Node1, P_Primary); Set_Op_Name (Node1); return Node1; elsif Token = Tok_Not then Node1 := New_Node (N_Op_Not, Token_Ptr); Scan; -- past NOT Set_Right_Opnd (Node1, P_Primary); Set_Op_Name (Node1); return Node1; else Node1 := P_Primary; if Token = Tok_Double_Asterisk then Node2 := New_Node (N_Op_Expon, Token_Ptr); Scan; -- past ** Set_Left_Opnd (Node2, Node1); Set_Right_Opnd (Node2, P_Primary); Set_Op_Name (Node2); return Node2; else return Node1; end if; end if; end P_Factor; ------------------ -- 4.4 Primary -- ------------------ -- PRIMARY ::= -- NUMERIC_LITERAL | null -- | STRING_LITERAL | AGGREGATE -- | NAME | QUALIFIED_EXPRESSION -- | ALLOCATOR | (EXPRESSION) -- Error recovery: can raise Error_Resync function P_Primary return Node_Id is Scan_State : Saved_Scan_State; Node1, Node2 : Node_Id; begin -- The loop runs more than once only if misplaced pragmas are found loop case Token is -- Name token can start a name, call or qualified expression, all -- of which are acceptable possibilities for primary. Note also -- that string literal is included in name (as operator symbol) -- and type conversion is included in name (as indexed component). when Tok_Char_Literal | Tok_Operator_Symbol | Tok_Identifier => Node1 := P_Call_Name; -- All done unless apostrophe follows if Token /= Tok_Apostrophe then return Node1; -- Apostrophe following means that we have either just parsed -- the subtype mark of a qualified expression, or the prefix -- or a range attribute. else -- Token = Tok_Apostrophe Save_Scan_State (Scan_State); -- at apostrophe Scan; -- past apostrophe -- If range attribute, then we have a case where this cannot -- appear, since the only legitimate case (where the scanned -- expression is a qualified simple name) is handled at the -- Simple_Expression level. This case corresponds to a usage -- such as 3 + A'Range, which is always illegal. if Token = Tok_Range then Error_Msg_SP ("range attribute not allowed here"); Restore_Scan_State (Scan_State); -- to apostrophe Node1 := P_Range_Attribute (Node1); return Error; -- If left paren, then we have a qualified expression. Note -- that P_Call_Name guarantees that in this case, where -- Token = Tok_Apostrophe on return, the only two possible -- tokens following the apostrophe are left paren and -- RANGE, so we know we have a left paren here. else -- Token = Tok_Left_Paren return P_Qualified_Expression (Node1); end if; end if; -- Numeric or string literal when Tok_Integer_Literal | Tok_Real_Literal | Tok_String_Literal => Node1 := Token_Node; Scan; -- past number return Node1; -- Left paren, starts aggregate or parenthesized expression when Tok_Left_Paren => return P_Aggregate_Or_Paren_Expr; -- Allocator when Tok_New => return P_Allocator; -- Null when Tok_Null => Scan; -- past NULL return New_Node (N_Null, Prev_Token_Ptr); -- Pragma, not allowed here, so just skip past it when Tok_Pragma => P_Pragmas_Misplaced; -- Anything else is illegal as the first token of a primary, but -- we test for a reserved identifier so that it is treated nicely when others => if Is_Reserved_Identifier then return P_Identifier; else Error_Msg_AP ("missing operand"); raise Error_Resync; end if; end case; end loop; end P_Primary; --------------------------- -- 4.5 Logical Operator -- --------------------------- -- LOGICAL_OPERATOR ::= AND | OR | XOR -- Note: AND THEN and OR ELSE are also treated as logical operators -- by the parser (even though they are not operators semantically) -- The value returned is the appropriate Node_Kind code for the operator -- On return, Token points to the token following the scanned operator. -- The caller has checked that the first token is a legitimate logical -- operator token (i.e. is either XOR, AND, OR). -- Error recovery: cannot raise Error_Resync function P_Logical_Operator return Node_Kind is begin if Token = Tok_And then Scan; -- past AND if Token = Tok_Then then Scan; -- past THEN return N_Op_And_Then; else return N_Op_And; end if; elsif Token = Tok_Or then Scan; -- past OR if Token = Tok_Else then Scan; -- past ELSE return N_Op_Or_Else; else return N_Op_Or; end if; else -- Token = Tok_Xor Scan; -- past XOR return N_Op_Xor; end if; end P_Logical_Operator; ------------------------------ -- 4.5 Relational Operator -- ------------------------------ -- RELATIONAL_OPERATOR ::= = | /= | < | <= | > | >= -- The value returned is the appropriate Node_Kind code for the operator. -- On return, Token points to the operator token, NOT past it. -- The caller has checked that the first token is a legitimate relational -- operator token (i.e. is one of the operator tokens listed above). -- Error recovery: cannot raise Error_Resync function P_Relational_Operator return Node_Kind is Op_Kind : Node_Kind; Relop_Node : constant array (Token_Class_Relop) of Node_Kind := (Tok_Less => N_Op_Lt, Tok_Equal => N_Op_Eq, Tok_Greater => N_Op_Gt, Tok_Not_Equal => N_Op_Ne, Tok_Greater_Equal => N_Op_Ge, Tok_Less_Equal => N_Op_Le, Tok_In => N_Op_In, Tok_Not => N_Op_Not_In, Tok_Box => N_Op_Ne); begin if Token = Tok_Box then Error_Msg_SC ("<> should be /="); end if; Op_Kind := Relop_Node (Token); Scan; -- past operator token if Prev_Token = Tok_Not then T_In; end if; return Op_Kind; end P_Relational_Operator; --------------------------------- -- 4.5 Binary Adding Operator -- --------------------------------- -- BINARY_ADDING_OPERATOR ::= + | - | & -- The value returned is the appropriate Node_Kind code for the operator. -- On return, Token points to the operator token (NOT past it). -- The caller has checked that the first token is a legitimate adding -- operator token (i.e. is one of the operator tokens listed above). -- Error recovery: cannot raise Error_Resync function P_Binary_Adding_Operator return Node_Kind is Addop_Node : constant array (Token_Class_Binary_Addop) of Node_Kind := (Tok_Ampersand => N_Op_Concat, Tok_Minus => N_Op_Subtract, Tok_Plus => N_Op_Add); begin -- This is where we make sure we have a space after the binary -- operator. We could not do this in the scanner, because we did -- not know if a plus or minus was a binary or unary operator. if GNAT_Style_Check and then Source (Scan_Ptr) > ' ' then Error_Msg_S ("(style) space required"); end if; return Addop_Node (Token); end P_Binary_Adding_Operator; -------------------------------- -- 4.5 Unary Adding Operator -- -------------------------------- -- UNARY_ADDING_OPERATOR ::= + | - -- The value returned is the appropriate Node_Kind code for the operator. -- On return, Token points to the operator token (NOT past it). -- The caller has checked that the first token is a legitimate adding -- operator token (i.e. is one of the operator tokens listed above). -- Error recovery: cannot raise Error_Resync function P_Unary_Adding_Operator return Node_Kind is Addop_Node : constant array (Token_Class_Unary_Addop) of Node_Kind := (Tok_Minus => N_Op_Minus, Tok_Plus => N_Op_Plus); begin return Addop_Node (Token); end P_Unary_Adding_Operator; ------------------------------- -- 4.5 Multiplying Operator -- ------------------------------- -- MULTIPLYING_OPERATOR ::= * | / | MOD | REM -- The value returned is the appropriate Node_Kind code for the operator. -- On return, Token points to the operator token (NOT past it). -- The caller has checked that the first token is a legitimate multiplying -- operator token (i.e. is one of the operator tokens listed above). -- Error recovery: cannot raise Error_Resync function P_Multiplying_Operator return Node_Kind is Mulop_Node : constant array (Token_Class_Mulop) of Node_Kind := (Tok_Asterisk => N_Op_Multiply, Tok_Mod => N_Op_Mod, Tok_Rem => N_Op_Rem, Tok_Slash => N_Op_Divide); begin return Mulop_Node (Token); end P_Multiplying_Operator; -------------------------------------- -- 4.5 Highest Precedence Operator -- -------------------------------------- -- Parsed by P_Factor (4.4) -- Note: this rule is not in fact used by the grammar at any point! -------------------------- -- 4.6 Type Conversion -- -------------------------- -- Parsed by P_Primary as a Name (4.1) ------------------------------- -- 4.7 Qualified Expression -- ------------------------------- -- QUALIFIED_EXPRESSION ::= -- SUBTYPE_MARK ' (EXPRESSION) | SUBTYPE_MARK ' AGGREGATE -- The caller has scanned the name which is the Subtype_Mark parameter -- and scanned past the single quote following the subtype mark. The -- caller has not checked that this name is in fact appropriate for -- a subtype mark name (i.e. it is a selected component or identifier). -- Error_Recovery: cannot raise Error_Resync function P_Qualified_Expression (Subtype_Mark : Node_Id) return Node_Id is Qual_Node : Node_Id; begin Qual_Node := New_Node (N_Qualified_Expression, Prev_Token_Ptr); Set_Subtype_Mark (Qual_Node, Check_Subtype_Mark (Subtype_Mark)); Set_Expression (Qual_Node, P_Aggregate_Or_Paren_Expr); return Qual_Node; end P_Qualified_Expression; -------------------- -- 4.8 Allocator -- -------------------- -- ALLOCATOR ::= -- new SUBTYPE_INDICATION | new QUALIFIED_EXPRESSION -- The caller has checked that the initial token is NEW -- Error recovery: can raise Error_Resync function P_Allocator return Node_Id is Alloc_Node : Node_Id; Type_Node : Node_Id; begin Alloc_Node := New_Node (N_Allocator, Token_Ptr); T_New; Type_Node := P_Subtype_Mark_Resync; if Token = Tok_Apostrophe then Scan; -- past apostrophe Set_Expression (Alloc_Node, P_Qualified_Expression (Type_Node)); else Set_Expression (Alloc_Node, P_Subtype_Indication (Type_Node)); end if; return Alloc_Node; end P_Allocator; end Ch4; Null when Tok_Null => Scan; -- past NULL return New_Node (N_Null, Prev_Token_Ptr); -- Pragma, not allowed here, so just skip past it when Tok_Pragma => P_Pragmas_Misplaced; -- Anything else is illegal as the first token of a primary, but -- we test for a reserved identifier sognat-1.67-src/src/par-ch5.adb 444 10015 7640 210522 5506244344 11070 ----------------------------------------------------------------------------- -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P A R . C H 5 -- -- -- -- B o d y -- -- -- -- $Revision: 1.44 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ separate (Par) package body Ch5 is -- Local functions, used only in this chapter function P_Assignment_Statement (LHS : Node_Id) return Node_Id; function P_Begin_Statement (Block_Name_Node : Node_Id) return Node_Id; function P_Case_Statement return Node_Id; function P_Case_Statement_Alternative return Node_Id; function P_Declare_Statement (Block_Name_Node : Node_Id) return Node_Id; function P_Exit_Statement return Node_Id; function P_For_Statement (Loop_Name_Node : Node_Id) return Node_Id; function P_Goto_Statement return Node_Id; function P_If_Statement return Node_Id; function P_Label return Node_Id; function P_Loop_Parameter_Specification return Node_Id; function P_Loop_Statement (Loop_Name_Node : Node_Id) return Node_Id; function P_Null_Statement return Node_Id; function P_While_Statement (Loop_Name_Node : Node_Id) return Node_Id; --------------------------------- -- 5.1 Sequence of Statements -- --------------------------------- -- SEQUENCE_OF_STATEMENTS ::= STATEMENT {STATEMENT} -- STATEMENT ::= -- {LABEL} SIMPLE_STATEMENT | {LABEL} COMPOUND_STATEMENT -- SIMPLE_STATEMENT ::= -- NULL_STATEMENT | ASSIGNMENT_STATEMENT -- | EXIT_STATEMENT | RETURN_STATEMENT -- | GOTO_STATEMENT | PROCEDURE_CALL_STATEMENT -- | ENTRY_CALL_STATEMENT | REQUEUE_STATEMENT -- | DELAY_STATEMENT | ABORT_STATEMENT -- | RAISE_STATEMENT | CODE_STATEMENT -- COMPOUND_STATEMENT ::= -- IF_STATEMENT | CASE_STATEMENT -- | LOOP_STATEMENT | BLOCK_STATEMENT -- | ACCEPT_STATEMENT | SELECT_STATEMENT -- This procedure scans a sequence of statements. The caller sets SS_Flags -- to indicate acceptable termination conditions for the sequenece: -- SS_Flags.Eftm Terminate on ELSIF -- SS_Flags.Eltm Terminate on ELSE -- SS_Flags.Extm Terminate on EXCEPTION -- SS_Flags.Ortm Terminate on OR -- SS_Flags.Tatm Terminate on THEN ABORT (Token = ABORT on return) -- SS_Flags.Whtm Terminate on WHEN -- In addition, the scan is always terminated by encountering END or the -- end of file (EOF) condition. If one of the six above terminators is -- encountered with the corresponding SS_Flags flag not set, then the -- action taken is as follows: -- If the keyword occurs to the left of the expected column of the end -- for the current sequence (as recorded in the current end context), -- then it is assumed to belong to an outer context, and is considered -- to terminate the sequence of statements. -- If the keyword occurs to the right of, or in the expected column of -- the end for the current sequence, then an error message is output, -- the keyword together with its associated context is skipped, and -- the statement scan continues until another terminator is found. -- Note that the first action means that control can return to the caller -- with Token set to a terminator other than one of those specified by the -- SS parameter. The caller should treat such a case as equivalent to END. -- In addition, the flag SS_Flags.Sreq is set to True to indicate that at -- least one real statement (other than a pragma) is required in the -- statement sequence. During the processing of the sequence, this -- flag is manipulated to indicate the current status of the requirement -- for a statement. For example, it is turned off by the occurrence of a -- statement, and back on by a label (which requires a following statement) -- Error recovery: cannot raise Error_Resync. If an error occurs during -- parsing a statement, then the scan pointer is advanced past the next -- semicolon and the parse continues. function P_Sequence_Of_Statements (SS_Flags : SS_Rec) return List_Id is Statement_Required : Boolean; -- This flag indicates if a subsequent statement (other than a pragma) -- is required. It is initialized from the Sreq flag, and modified as -- statements are scanned (a statement turns it off, and a label turns -- it back on again since a statement must follow a label). Scan_State : Saved_Scan_State; Statement_List : List_Id; Statement_Node : Node_Id; Block_Label : Name_Id; Id_Node : Node_Id; Call_Name_Node : Node_Id; begin Statement_List := New_List; Statement_Required := SS_Flags.Sreq; loop begin if GNAT_Style_Check then GNAT_Column_Check (Token_Ptr); end if; -- If we are checking columns, then if the next statement is at -- the start of the line, it must start to the right of the opener -- of the enclosing construct. If not, then we terminate the scan -- for statements, and the caller will give an error message if -- we are not at an appropriate terminating token. if RM_Column_Check and then Token_Is_At_Start_Of_Line and then Start_Column <= Scope.Table (Scope.Last).Ecol then if Statement_Required then Error_Msg_BC ("incorrect layout for column check mode"); end if; return Statement_List; end if; -- Deal with reserved identifier (in assignment or call) if Is_Reserved_Identifier then Save_Scan_State (Scan_State); -- at possible bad identifier Scan; -- and scan past it -- We have an reserved word which is spelled in identifier -- style, so the question is whether it really is intended -- to be an identifier. if -- If followed by a semicolon, then it is an identifier, -- with the exception of the cases tested for below. (Token = Tok_Semicolon and then (Prev_Token /= Tok_Return and then Prev_Token /= Tok_Null and then Prev_Token /= Tok_Raise and then Prev_Token /= Tok_End and then Prev_Token /= Tok_Exit)) -- If followed by colon, colon-equal, or dot, then we -- definitely have an identifier (could not be reserved) or else Token = Tok_Colon or else Token = Tok_Colon_Equal or else Token = Tok_Dot -- Left paren means we have an identifier except for those -- reserved words that can legitimately be followed by a -- left paren. or else (Token = Tok_Left_Paren and then Prev_Token /= Tok_Case and then Prev_Token /= Tok_Delay and then Prev_Token /= Tok_If and then Prev_Token /= Tok_Elsif and then Prev_Token /= Tok_Return and then Prev_Token /= Tok_When and then Prev_Token /= Tok_While and then Prev_Token /= Tok_Separate) then -- Here we have an apparent reserved identifier and the -- token past it is appropriate to this usage (and would -- be a definite error if this is not an identifier). What -- we do is to use P_Identifier to fix up the identifier, -- and then fall into the normal processing. Restore_Scan_State (Scan_State); -- back to the ID Scan_Reserved_Identifier (Force_Msg => False); -- Not a reserved identifier after all (or at least we can't -- be sure that it is), so reset the scan and continue. else Restore_Scan_State (Scan_State); -- back to the reserved word end if; end if; -- Now look to see what kind of statement we have case Token is -- Case of end or EOF when Tok_End | Tok_EOF => -- These tokens always terminate the statement sequence if Statement_Required then Error_Msg_BC ("statement expected"); end if; return Statement_List; -- Case of ELSIF when Tok_Elsif => -- Terminate if Eftm set or if the ELSIF is to the left -- of the expected column of the end for this sequence if SS_Flags.Eftm or else Start_Column < Scope.Table (Scope.Last).Ecol then if Statement_Required then Error_Msg_BC ("statement expected"); end if; return Statement_List; -- Otherwise complain and skip past ELSIF Condition then else Error_Msg_SC ("ELSIF not allowed here"); Scan; -- past ELSIF Discard_Junk_Node (P_Expression_No_Right_Paren); TF_Then; Statement_Required := False; end if; -- Case of ELSE when Tok_Else => -- Terminate if Eltm set or if the else is to the left -- of the expected column of the end for this sequence if SS_Flags.Eltm or else Start_Column < Scope.Table (Scope.Last).Ecol then if Statement_Required then Error_Msg_BC ("statement expected"); end if; return Statement_List; -- Otherwise complain and skip past else else Error_Msg_SC ("ELSE not allowed here"); Scan; -- past ELSE Statement_Required := False; end if; -- Case of exception when Tok_Exception => if Statement_Required then Error_Msg_BC ("statement expected"); end if; -- If Extm not set and the exception is not to the left -- of the expected column of the end for this sequence, then -- we assume it belongs to the current sequence, even though -- it is not permitted. if not SS_Flags.Extm and then Start_Column >= Scope.Table (Scope.Last).Ecol then Error_Msg_SC ("exception handler not permitted here"); Discard_Junk_List (P_Exception_Handler_Part); end if; -- Always return, in the case where we scanned out handlers -- that we did not expect, P_Exception_Handler_Part returned -- with Token being either end or EOF, so we are OK return Statement_List; -- Case of OR when Tok_Or => -- Terminate if Ortm set or if the or is to the left -- of the expected column of the end for this sequence if SS_Flags.Ortm or else Start_Column < Scope.Table (Scope.Last).Ecol then if Statement_Required then Error_Msg_BC ("statement expected"); end if; return Statement_List; -- Otherwise complain and skip past or else Error_Msg_SC ("OR not allowed here"); Scan; -- past or Statement_Required := False; end if; -- Case of THEN, terminate if THEN ABORT allowed (ATC case) when Tok_Then => Save_Scan_State (Scan_State); -- at THEN Scan; -- past THEN if SS_Flags.Tatm and then Token = Tok_Abort then return Statement_List; -- Otherwise we treat then as some kind of mess where we -- did not see the associated IF, but we pick up assuming -- it had been there! else Restore_Scan_State (Scan_State); -- to THEN Append (P_If_Statement, Statement_List); Statement_Required := False; end if; -- Case of WHEN (error because we are not in a case) when Tok_When | Tok_Others => -- Terminate if Whtm set or if the WHEN is to the left -- of the expected column of the end for this sequence if SS_Flags.Whtm or else Start_Column < Scope.Table (Scope.Last).Ecol then if Statement_Required then Error_Msg_BC ("statement expected"); end if; return Statement_List; -- Otherwise complain and skip when Choice {| Choice} => else Error_Msg_SC ("WHEN when not allowed here"); Scan; -- past when Discard_Junk_List (P_Discrete_Choice_List); TF_Arrow; Statement_Required := False; end if; -- Cases of statements starting with an identifier when Tok_Identifier => -- Save scan pointers and line number in case block label Id_Node := Token_Node; Block_Label := Token_Name; Save_Scan_State (Scan_State); -- at Id Scan; -- past Id -- Check for common case of assignment, since it occurs -- frequently, and we want to process it efficiently. if Token = Tok_Colon_Equal then Append (P_Assignment_Statement (Id_Node), Statement_List); Statement_Required := False; -- Check common case of procedure call, another case that -- we want to speed up as much as possible. elsif Token = Tok_Semicolon then Append (P_Statement_Call_Name (Id_Node), Statement_List); Scan; -- past semicolon Statement_Required := False; -- Check for case of "go to" in place of "goto" elsif Token = Tok_Identifier and then Block_Label = Name_Go and then Token_Name = Name_To then Error_Msg_SP ("goto is one word"); Append (P_Goto_Statement, Statement_List); Statement_Required := False; -- Check common case of = used instead of :=, just so we -- give a better error message for this special misuse. elsif Token = Tok_Equal then T_Colon_Equal; -- give := expected message Append (P_Assignment_Statement (Id_Node), Statement_List); Statement_Required := False; -- Check case of loop label or block label elsif Token = Tok_Colon or else (Token in Token_Class_Labeled_Stmt and then not Token_Is_At_Start_Of_Line) then T_Colon; -- past colon (if there, or msg for missing one) -- Test for more than one label loop exit when Token /= Tok_Identifier; Save_Scan_State (Scan_State); -- at Id Scan; -- past Id if Token = Tok_Colon then Error_Msg_SP ("only one label allowed on block or loop"); Scan; -- past colon on extra label -- We will set Error_name as the Block_Label since -- we really don't know which of the labels might -- be used at the end of the loop or block! Block_Label := Error_Name; -- If Id with no colon, then backup to point to the -- Id and we will issue the message below when we try -- to scan out the statement as some other form. else Restore_Scan_State (Scan_State); -- to Id exit; end if; end loop; -- Loop_Statement (labeled Loop_Statement) if Token = Tok_Loop then Append (P_Loop_Statement (Id_Node), Statement_List); -- While statement (labeled loop statement with WHILE) elsif Token = Tok_While then Append (P_While_Statement (Id_Node), Statement_List); -- Declare statement (labeled block statement with -- DECLARE part) elsif Token = Tok_Declare then Append (P_Declare_Statement (Id_Node), Statement_List); -- Begin statement (labeled block statement with no -- DECLARE part) elsif Token = Tok_Begin then Append (P_Begin_Statement (Id_Node), Statement_List); -- For statement (labeled loop statement with FOR) elsif Token = Tok_For then Append (P_For_Statement (Id_Node), Statement_List); -- Improper statement follows label else Error_Msg_AP ("loop statement or block statement expected"); end if; Statement_Required := False; -- Here we have an identifier followed by something -- other than a colon, semicolon or assignment symbol. -- The only valid possibility is a name extension symbol elsif Token in Token_Class_Namext then Restore_Scan_State (Scan_State); -- to Id Call_Name_Node := P_Call_Name; -- Skip junk right parens in this context while Token = Tok_Right_Paren loop Error_Msg_SC ("extra right paren"); Scan; -- past ) end loop; -- Check context following call if Expr_Form /= EF_Call then if Token = Tok_Colon_Equal then Append (P_Assignment_Statement (Call_Name_Node), Statement_List); Statement_Required := False; -- Check common case of = used instead of := elsif Token = Tok_Equal then T_Colon_Equal; -- give := expected message Append (P_Assignment_Statement (Call_Name_Node), Statement_List); Statement_Required := False; -- Check apostrophe cases elsif Token = Tok_Apostrophe then Append (P_Code_Statement (Call_Name_Node), Statement_List); Statement_Required := False; -- The only other valid item after a name is ; which -- means that the item we just scanned was a call. elsif Token = Tok_Semicolon then Append (P_Statement_Call_Name (Call_Name_Node), Statement_List); Scan; -- past semicolon Statement_Required := False; -- Else we have a missing semicolon else TF_Semicolon; Statement_Required := False; end if; -- If we did not scan a name, then we must have a call -- or qualified expression (code statement), which means -- that the scan of the statement is complete. else -- Expr_Form = EF_Call TF_Semicolon; Append (P_Statement_Call_Name (Call_Name_Node), Statement_List); Statement_Required := False; end if; -- If junk after identifier, check if identifier is an -- instance of an incorrectly spelled keyword. If so, we -- do nothing. The Bad_Spelling_Of will have reset Token -- to the appropriate keyword, so the next time round the -- loop we will process the modified token. Note that we -- check for ELSIF before ELSE here. That's not accidental. -- We don't want to identify a misspelling of ELSE as -- ELSIF, and in particular we do not want to treat ELSEIF -- as ELSE IF. else Restore_Scan_State (Scan_State); -- to identifier if Bad_Spelling_Of (Tok_Abort) or else Bad_Spelling_Of (Tok_Accept) or else Bad_Spelling_Of (Tok_Case) or else Bad_Spelling_Of (Tok_Declare) or else Bad_Spelling_Of (Tok_Delay) or else Bad_Spelling_Of (Tok_Elsif) or else Bad_Spelling_Of (Tok_Else) or else Bad_Spelling_Of (Tok_End) or else Bad_Spelling_Of (Tok_Exception) or else Bad_Spelling_Of (Tok_Exit) or else Bad_Spelling_Of (Tok_For) or else Bad_Spelling_Of (Tok_Goto) or else Bad_Spelling_Of (Tok_If) or else Bad_Spelling_Of (Tok_Loop) or else Bad_Spelling_Of (Tok_Or) or else Bad_Spelling_Of (Tok_Pragma) or else Bad_Spelling_Of (Tok_Raise) or else Bad_Spelling_Of (Tok_Requeue) or else Bad_Spelling_Of (Tok_Return) or else Bad_Spelling_Of (Tok_Select) or else Bad_Spelling_Of (Tok_When) or else Bad_Spelling_Of (Tok_While) then null; -- If not a bad spelling, then we really have junk else Scan; -- past identifier again -- If next token is first token on line, then we -- consider that we were missing a semicolon after -- the identifier, and process it as a procedure -- call with no parameters. if Token_Is_At_Start_Of_Line then Append (P_Statement_Call_Name (Id_Node), Statement_List); T_Semicolon; -- to give error message Statement_Required := False; -- Otherwise we give a missing := message and -- simply abandon the junk that is there now. else T_Colon_Equal; -- give := expected message raise Error_Resync; end if; end if; end if; -- Statement starting with operator symbol. This could be -- a call, a name starting an assignment, or a qualified -- expression. when Tok_Operator_Symbol => Call_Name_Node := P_Call_Name; -- An attempt at a range attribute or a qualified expression -- must be illegal here (a code statement cannot possibly -- allow qualification by a function name). if Token = Tok_Apostrophe then Error_Msg_SC ("apostrophe illegal here"); raise Error_Resync; end if; -- Scan possible assignment if we have a name if Expr_Form /= EF_Call and then Token = Tok_Colon_Equal then Append (P_Assignment_Statement (Call_Name_Node), Statement_List); else Append (P_Statement_Call_Name (Call_Name_Node), Statement_List); end if; TF_Semicolon; Statement_Required := False; -- Label starting with << which must precede real statement when Tok_Less_Less => Append (P_Label, Statement_List); Statement_Required := True; -- Pragma appearing as a statement in a statement sequence when Tok_Pragma => Append (P_Pragma, Statement_List); -- Abort_Statement when Tok_Abort => Append (P_Abort_Statement, Statement_List); Statement_Required := False; -- Accept_Statement when Tok_Accept => Append (P_Accept_Statement, Statement_List); Statement_Required := False; -- Begin_Statement (Block_Statement with no declare, no label) when Tok_Begin => Append (P_Begin_Statement (Empty), Statement_List); Statement_Required := False; -- Case_Statement when Tok_Case => Append (P_Case_Statement, Statement_List); Statement_Required := False; -- Block_Statement with DECLARE and no label when Tok_Declare => Append (P_Declare_Statement (Empty), Statement_List); Statement_Required := False; -- Delay_Statement when Tok_Delay => Append (P_Delay_Statement, Statement_List); Statement_Required := False; -- Exit_Statement when Tok_Exit => Append (P_Exit_Statement, Statement_List); Statement_Required := False; -- Loop_Statement with FOR and no label when Tok_For => Append (P_For_Statement (Empty), Statement_List); Statement_Required := False; -- Goto_Statement when Tok_Goto => Append (P_Goto_Statement, Statement_List); Statement_Required := False; -- If_Statement when Tok_If => Append (P_If_Statement, Statement_List); Statement_Required := False; -- Loop_Statement when Tok_Loop => Append (P_Loop_Statement (Empty), Statement_List); Statement_Required := False; -- Null_Statement when Tok_Null => Append (P_Null_Statement, Statement_List); Statement_Required := False; -- Raise_Statement when Tok_Raise => Append (P_Raise_Statement, Statement_List); Statement_Required := False; -- Requeue_Statement when Tok_Requeue => Append (P_Requeue_Statement, Statement_List); Statement_Required := False; -- Return_Statement when Tok_Return => Append (P_Return_Statement, Statement_List); Statement_Required := False; -- Select_Statement when Tok_Select => Append (P_Select_Statement, Statement_List); Statement_Required := False; -- While_Statement (Block_Statement with while and no loop) when Tok_While => Append (P_While_Statement (Empty), Statement_List); Statement_Required := False; -- Anything else is some kind of junk, signal an error message -- and then raise Error_Resync, to merge with the normal -- handling of a bad statement. when others => Error_Msg_BC ("statement expected"); raise Error_Resync; end case; -- On error resynchronization, skip past next semicolon, and, since -- we are still in the statement loop, look for next statement. We -- set Statement_Required False to avoid an unnecessary error message -- complaining that no statement was found (i.e. we consider the -- junk to satisfy the requirement for a statement being present). exception when Error_Resync => Resync_Past_Semicolon_Or_To_Loop_Or_Then; Statement_Required := False; end; end loop; end P_Sequence_Of_Statements; -------------------- -- 5.1 Statement -- -------------------- -- Parsed by P_Sequence_Of_Statements (5.1), except for the case of a -- statement of the form of a call or name, which is handled here. The -- argument passed in is the tree for the call/name which has been -- scanned. The returned value is the corresponding statement form. -- This routine is also used by Par.Prag for processing the procedure -- call that appears as the second argument of a pragma Assert. -- Error recovery: cannot raise Error_Resync function P_Statement_Call_Name (Call_Name_Node : Node_Id) return Node_Id is Stmt_Node : Node_Id; begin -- Case of Indexed component, which is a procedure call with arguments if Nkind (Call_Name_Node) = N_Indexed_Component then declare Prefix_Node : Node_Id := Prefix (Call_Name_Node); Exprs_Node : List_Id := Expressions (Call_Name_Node); begin Change_Node (Call_Name_Node, N_Procedure_Call_Statement); Set_Name (Call_Name_Node, Prefix_Node); Set_Parameter_Associations (Call_Name_Node, Exprs_Node); return Call_Name_Node; end; -- Case of function call, which is a procedure call elsif Nkind (Call_Name_Node) = N_Function_Call then declare Name_Node : Node_Id := Name (Call_Name_Node); Params_List : List_Id := Parameter_Associations (Call_Name_Node); begin Change_Node (Call_Name_Node, N_Procedure_Call_Statement); Set_Name (Call_Name_Node, Name_Node); Set_Parameter_Associations (Call_Name_Node, Params_List); return Call_Name_Node; end; -- All other cases of names are parameterless procedure calls else Stmt_Node := New_Node (N_Procedure_Call_Statement, Sloc (Call_Name_Node)); Set_Name (Stmt_Node, Call_Name_Node); return Stmt_Node; end if; end P_Statement_Call_Name; --------------------------- -- 5.1 Simple Statement -- --------------------------- -- Parsed by P_Sequence_Of_Statements (5.1) ----------------------------- -- 5.1 Compound Statement -- ----------------------------- -- Parsed by P_Sequence_Of_Statements (5.1) ---------------- -- 5.1 Label -- ---------------- -- LABEL ::= <> -- STATEMENT_INDENTIFIER ::= DIRECT_NAME -- The IDENTIFIER of a STATEMENT_IDENTIFIER shall be an identifier -- (not an OPERATOR_SYMBOL) -- The caller has already checked that the current token is << -- Error recovery: can raise Error_Resync function P_Label return Node_Id is Label_Node : Node_Id; begin Label_Node := New_Node (N_Label, Token_Ptr); Scan; -- past << Set_Identifier (Label_Node, P_Identifier); T_Greater_Greater; Append_Elmt (Label_Node, Label_List); return Label_Node; end P_Label; ------------------------- -- 5.1 Null Statement -- ------------------------- -- NULL_STATEMENT ::= null; -- The caller has already checked that the current token is null -- Error recovery: cannot raise Error_Resync function P_Null_Statement return Node_Id is Null_Stmt_Node : Node_Id; begin Null_Stmt_Node := New_Node (N_Null_Statement, Token_Ptr); Scan; -- past NULL TF_Semicolon; return Null_Stmt_Node; end P_Null_Statement; ------------------------------- -- 5.2 Assignment Statement -- ------------------------------- -- ASSIGNMENT_STATEMENT ::= variable_NAME := EXPRESSION; -- On entry, the caller has scanned the left hand side (passed in as -- Lhs), and the scan points to the := (or = in the possible error case) -- Error recovery: can raise Error_Resync function P_Assignment_Statement (Lhs : Node_Id) return Node_Id is Assign_Node : Node_Id; begin Assign_Node := New_Node (N_Assignment_Statement, Token_Ptr); Scan; -- past colon equal or equal Set_Name (Assign_Node, LHS); Set_Expression (Assign_Node, P_Expression_No_Right_Paren); TF_Semicolon; return Assign_Node; end P_Assignment_Statement; ----------------------- -- 5.3 If Statement -- ----------------------- -- IF_STATEMENT ::= -- if CONDITION then -- SEQUENCE_OF_STATEMENTS -- {elsif CONDITION then -- SEQUENCE_OF_STATEMENTS} -- [else -- SEQUENCE_OF_STATEMENTS] -- end if; -- The caller has checked that the initial token is IF (or in the error -- case of a mysterious THEN, the initial token may simply be THEN, in -- which case, no condition (or IF) was scanned). -- Error recovery: can raise Error_Resync function P_If_Statement return Node_Id is If_Node : Node_Id; Elsif_Node : Node_Id; Loc : Source_Ptr; procedure Add_Elsif_Part; -- An internal procedure used to scan out a single ELSIF part. On entry -- the ELSIF (or an ELSE which has been determined should be ELSIF) is -- scanned out and is in Prev_Token. procedure Check_If_Column; -- An internal procedure used to check that THEN, ELSE ELSE, or ELSIF -- appear in the right place if column checking is enabled (i.e. if -- they are the first token on the line, then they must appear in -- the same column as the opening IF). procedure Check_Then; -- This procedure carries out the style checks for a THEN token -- Note that the caller has set Loc to the Source_Ptr value for -- the previous IF or ELSIF token. These checks apply only to a -- THEN at the start of a line. function Else_Should_Be_Elsif return Boolean; -- An internal routine used to do a special error recovery check when -- an ELSE is encountered. It determines if the ELSE should be treated -- as an ELSIF. A positive decision (TRUE returned, is made if the ELSE -- is followed by a sequence of tokens, starting on the same line as -- the ELSE, which are not expression terminators, followed by a THEN. -- On entry, the ELSE has been scanned out. procedure Add_Elsif_Part is begin if Elsif_Parts (If_Node) = No_List then Set_Elsif_Parts (If_Node, New_List); end if; Elsif_Node := New_Node (N_Elsif_Part, Prev_Token_Ptr); Loc := Prev_Token_Ptr; Set_Condition (Elsif_Node, P_Expression_No_Right_Paren); Check_Then; TF_Then; Set_Then_Statements (Elsif_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq)); Append (Elsif_Node, Elsif_Parts (If_Node)); end Add_Elsif_Part; procedure Check_If_Column is begin if RM_Column_Check and then Token_Is_At_Start_Of_Line and then Start_Column /= Scope.Table (Scope.Last).Ecol then Error_Msg_Col := Scope.Table (Scope.Last).Ecol; Error_Msg_SC ("this token should be@"); end if; end Check_If_Column; procedure Check_Then is begin if Token_Is_At_Start_Of_Line and then Token = Tok_Then then Check_If_Column; if GNAT_Style_Check and then Get_Line_Number (Token_Ptr) = Get_Line_Number (Loc) + 1 then Error_Msg_SC ("(style) misplaced THEN"); end if; end if; end Check_Then; function Else_Should_Be_Elsif return Boolean is Scan_State : Saved_Scan_State; begin if Token_Is_At_Start_Of_Line then return False; else Save_Scan_State (Scan_State); loop if Token in Token_Class_Eterm then Restore_Scan_State (Scan_State); return False; else Scan; -- past non-expression terminating token if Token = Tok_Then then Restore_Scan_State (Scan_State); return True; end if; end if; end loop; end if; end Else_Should_Be_Elsif; -- Start of processing for IF statement begin Push_Scope_Stack; Scope.Table (Scope.Last).Etyp := E_If; Scope.Table (Scope.Last).Ecol := Start_Column; Scope.Table (Scope.Last).Sloc := Token_Ptr; Scope.Table (Scope.Last).Labl := Error; If_Node := New_Node (N_If_Statement, Token_Ptr); if Token = Tok_If then Loc := Token_Ptr; Scan; -- past IF Set_Condition (If_Node, P_Expression_No_Right_Paren); -- Deal with misuse of IF expression => used instead -- of WHEN expression => if Token = Tok_Arrow then Error_Msg_SC ("THEN expected"); Scan; -- past the arrow Pop_Scope_Stack; -- remove unneeded entry raise Error_Resync; end if; Check_Then; else Error_Msg_SC ("no IF for this THEN"); Set_Condition (If_Node, Error); end if; TF_Then; while Token = Tok_Then loop Error_Msg_SC ("redundant THEN"); Scan; -- past junk THEN end loop; Set_Then_Statements (If_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq)); -- This loop scans out else and elsif parts loop if Token = Tok_Elsif then Check_If_Column; if List_Present (Else_Statements (If_Node)) then Error_Msg_SP ("ELSIF cannot appear after ELSE"); end if; Scan; -- past ELSIF Add_Elsif_Part; elsif Token = Tok_Else then Check_If_Column; Scan; -- past ELSE if Else_Should_Be_Elsif then Error_Msg_SP ("ELSE should be ELSIF"); Add_Elsif_Part; else -- Here we have an else that really is an else if List_Present (Else_Statements (If_Node)) then Error_Msg_SP ("Only one ELSE part allowed"); Append_List (P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq), Else_Statements (If_Node)); else Set_Else_Statements (If_Node, P_Sequence_Of_Statements (SS_Eftm_Eltm_Sreq)); end if; end if; -- If anything other than ELSE or ELSIF, exit the loop. The token -- had better be END (and in fact it had better be END IF), but -- we will let End_Statements take care of checking that. else exit; end if; end loop; End_Statements; return If_Node; end P_If_Statement; -------------------- -- 5.3 Condition -- -------------------- -- Condition is parsed by P_Expression (4.4) ------------------------- -- 5.4 Case Statement -- ------------------------- -- CASE_STATEMENT ::= -- case EXPRESSION is -- CASE_STATEMENT_ALTERNATIVE -- {CASE_STATEMENT_ALTERNATIVE} -- end case; -- The caller has checked that the first token is CASE -- Can raise Error_Resync function P_Case_Statement return Node_Id is Case_Node : Node_Id; Alternatives_List : List_Id; First_When_Loc : Source_Ptr; begin Push_Scope_Stack; Scope.Table (Scope.Last).Etyp := E_Case; Scope.Table (Scope.Last).Ecol := Start_Column; Scope.Table (Scope.Last).Sloc := Token_Ptr; Scope.Table (Scope.Last).Labl := Error; Case_Node := New_Node (N_Case_Statement, Token_Ptr); Scan; -- past CASE Set_Expression (Case_Node, P_Expression_No_Right_Paren); TF_Is; -- Prepare to parse case statement alternatives Alternatives_List := New_List; P_Pragmas_Misplaced; First_When_Loc := Token_Ptr; -- Loop through case statement alternatives loop -- If we have a WHEN or OTHERS, then that's fine keep going. Note -- that it is a semantic check to ensure the proper use of OTHERS if Token = Tok_When or else Token = Tok_Others then Append (P_Case_Statement_Alternative, Alternatives_List); -- If we have an END, then probably we are at the end of the case -- but we only exit if Check_End thinks the END was reasonable. elsif Token = Tok_End then exit when Check_End; -- Here if token is other than WHEN, OTHERS or END. We definitely -- have an error, but the question is whether or not to get out of -- the case statement. We don't want to get out early, or we will -- get a slew of junk error messages for subsequent when tokens. -- If the token is not at the start of the line, or if it is indented -- with respect to the current case statement, then the best guess is -- that we are still supposed to be inside the case statement. We -- complain about the missing WHEN, and discard the junk statements. elsif not Token_Is_At_Start_Of_Line or else Start_Column > Scope.Table (Scope.Last).Ecol then Error_Msg_BC ("WHEN (case statement alternative) expected"); Discard_Junk_List (P_Sequence_Of_Statements (SS_Whtm)); -- Here we have a junk token at the start of the line and it is -- not indented. If Check_End thinks there is a missing END, then -- we will get out of the case, otherwise we keep going. else exit when Check_End; end if; end loop; -- Make sure we have at least one alternative if Is_Empty_List (Alternatives_List) then Error_Msg ("WHEN expected, must have at least one alternative in case", First_When_Loc); return Error; else Set_Alternatives (Case_Node, Alternatives_List); return Case_Node; end if; end P_Case_Statement; ------------------------------------- -- 5.4 Case Statement Alternative -- ------------------------------------- -- CASE_STATEMENT_ALTERNATIVE ::= -- when DISCRETE_CHOICE_LIST => -- SEQUENCE_OF_STATEMENTS -- The caller has checked that the initial token is WHEN or OTHERS -- Error recovery: can raise Error_Resync function P_Case_Statement_Alternative return Node_Id is Case_Alt_Node : Node_Id; begin if GNAT_Style_Check then GNAT_Column_Check (Token_Ptr); end if; Case_Alt_Node := New_Node (N_Case_Statement_Alternative, Token_Ptr); T_When; -- past WHEN (or give error in OTHERS case) Set_Discrete_Choices (Case_Alt_Node, P_Discrete_Choice_List); TF_Arrow; Set_Statements (Case_Alt_Node, P_Sequence_Of_Statements (SS_Sreq_Whtm)); return Case_Alt_Node; end P_Case_Statement_Alternative; ------------------------- -- 5.5 Loop Statement -- ------------------------- -- This procedure scans only the cases where no iteration scheme is -- present. See also P_While_Statement, P_For_Statement. -- LOOP_STATEMENT ::= -- loop -- SEQUENCE_OF_STATEMENTS -- end loop; -- The caller has checked that the initial token is LOOP. The parameter -- is the node identifiers for the block label if any (or is set to Empty -- if there is no block label). -- Error recovery : can not raise Error_Resync function P_Loop_Statement (Loop_Name_Node : Node_Id) return Node_Id is Loop_Node : Node_Id; begin Push_Scope_Stack; Scope.Table (Scope.Last).Labl := Loop_Name_Node; Scope.Table (Scope.Last).Ecol := Start_Column; Scope.Table (Scope.Last).Sloc := Token_Ptr; Scope.Table (Scope.Last).Etyp := E_Loop; Loop_Node := New_Node (N_Loop_Statement, Token_Ptr); TF_Loop; if No (Loop_Name_Node) then Set_Has_Created_Identifier (Loop_Node, True); Set_Identifier (Loop_Node, Make_Identifier (Sloc (Loop_Node), New_Internal_Name ("loop"))); else Set_Identifier (Loop_Node, Loop_Name_Node); end if; Append_Elmt (Loop_Node, Label_List); Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq)); End_Statements; return Loop_Node; end P_Loop_Statement; ------------------------ -- 5.5 For Statement -- ------------------------ -- This procedure scans a loop statement with a FOR iteration scheme -- See also P_While_Statement, P_Loop_Statement for other cases. -- LOOP_STATEMENT ::= -- [LOOP_STATEMENT_IDENTIFIER:] -- [ITERATION_SCHEME] loop -- SEQUENCE_OF_STATEMENTS -- end loop [loop_IDENTIFIER]; -- ITERATION_SCHEME ::= -- for LOOP_PARAMETER_SPECIFICATION -- The caller has checked that the initial token is FOR. The parameter -- is the node identifier for the block label if any (or is set to Empty -- if there is no block label). -- Note: the caller fills in the Identifier field if a label was present -- Error recovery: can raise Error_Resync function P_For_Statement (Loop_Name_Node : Node_Id) return Node_Id is Loop_Node : Node_Id; Iter_Scheme_Node : Node_Id; Loop_For_Flag : Boolean; begin Push_Scope_Stack; Scope.Table (Scope.Last).Labl := Loop_Name_Node; Scope.Table (Scope.Last).Ecol := Start_Column; Scope.Table (Scope.Last).Sloc := Token_Ptr; Scope.Table (Scope.Last).Etyp := E_Loop; Loop_For_Flag := (Prev_Token = Tok_Loop); Scan; -- past FOR Iter_Scheme_Node := New_Node (N_Iteration_Scheme, Token_Ptr); Set_Loop_Parameter_Specification (Iter_Scheme_Node, P_Loop_Parameter_Specification); -- The following is a special test so that a miswritten for loop such -- as "loop for I in 1..10;" is handled nicely, without making an extra -- entry in the scope stack. We don't bother to actually fix up the -- tree in this case since it's not worth the effort. Instead we just -- eat up the loop junk, leaving the entry for what now looks like an -- unmodified loop intact. if Loop_For_Flag and then Token = Tok_Semicolon then Error_Msg_SC ("LOOP belongs here, not before FOR"); Pop_Scope_Stack; return Error; -- Normal case else Loop_Node := New_Node (N_Loop_Statement, Token_Ptr); TF_Loop; Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq)); End_Statements; Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node); if No (Loop_Name_Node) then Set_Has_Created_Identifier (Loop_Node, True); Set_Identifier (Loop_Node, Make_Identifier (Sloc (Loop_Node), New_Internal_Name ("loop"))); else Set_Identifier (Loop_Node, Loop_Name_Node); end if; Append_Elmt (Loop_Node, Label_List); return Loop_Node; end if; end P_For_Statement; -------------------------- -- 5.5 While Statement -- -------------------------- -- This procedure scans a loop statement with a WHILE iteration scheme -- See also P_For_Statement, P_Loop_Statement for other cases. -- LOOP_STATEMENT ::= -- [LOOP_STATEMENT_IDENTIFIER:] -- [ITERATION_SCHEME] loop -- SEQUENCE_OF_STATEMENTS -- end loop [loop_IDENTIFIER]; -- ITERATION_SCHEME ::= -- while CONDITION -- The caller has checked that the initial token is WHILE. The parameter -- is the node identifier for the block label if any (or is set to Empty -- if there is no block label). -- Error recovery: cannot raise Error_Resync function P_While_Statement (Loop_Name_Node : Node_Id) return Node_Id is Loop_Node : Node_Id; Iter_Scheme_Node : Node_Id; Loop_While_Flag : Boolean; begin Push_Scope_Stack; Scope.Table (Scope.Last).Labl := Loop_Name_Node; Scope.Table (Scope.Last).Ecol := Start_Column; Scope.Table (Scope.Last).Sloc := Token_Ptr; Scope.Table (Scope.Last).Etyp := E_Loop; Loop_While_Flag := (Prev_Token = Tok_Loop); Iter_Scheme_Node := New_Node (N_Iteration_Scheme, Token_Ptr); Scan; -- past WHILE Set_Condition (Iter_Scheme_Node, P_Expression_No_Right_Paren); -- The following is a special test so that a miswritten for loop such -- as "loop while I > 10;" is handled nicely, without making an extra -- entry in the scope stack. We don't bother to actually fix up the -- tree in this case since it's not worth the effort. Instead we just -- eat up the loop junk, leaving the entry for what now looks like an -- unmodified loop intact. if Loop_While_Flag and then Token = Tok_Semicolon then Error_Msg_SC ("LOOP belongs here, not before WHILE"); Pop_Scope_Stack; return Error; -- Normal case else Loop_Node := New_Node (N_Loop_Statement, Token_Ptr); TF_Loop; Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq)); End_Statements; Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node); if No (Loop_Name_Node) then Set_Has_Created_Identifier (Loop_Node, True); Set_Identifier (Loop_Node, Make_Identifier (Sloc (Loop_Node), New_Internal_Name ("loop"))); else Set_Identifier (Loop_Node, Loop_Name_Node); end if; Append_Elmt (Loop_Node, Label_List); return Loop_Node; end if; end P_While_Statement; --------------------------- -- 5.5 Iteration Scheme -- --------------------------- -- Parsed by P_For_Statement or P_While_Statement (5.5) --------------------------------------- -- 5.5 Loop Parameter Specification -- --------------------------------------- -- LOOP_PARAMETER_SPECIFICATION ::= -- DEFINING_IDENTIFIER in [reverse] DISCRETE_SUBTYPE_INDICATION -- Error recovery: cannot raise Error_Resync function P_Loop_Parameter_Specification return Node_Id is Loop_Param_Specification_Node : Node_Id; ID_Node : Node_Id; begin Loop_Param_Specification_Node := New_Node (N_Loop_Parameter_Specification, Token_Ptr); ID_Node := P_Defining_Identifier; Set_Defining_Identifier (Loop_Param_Specification_Node, ID_Node); T_In; if Token = Tok_Reverse then Scan; -- past REVERSE Set_Reverse_Present (Loop_Param_Specification_Node, True); end if; Set_Discrete_Subtype_Definition (Loop_Param_Specification_Node, P_Discrete_Subtype_Definition); return Loop_Param_Specification_Node; exception when Error_Resync => return Error; end P_Loop_Parameter_Specification; ---------------------------- -- 5.6 Declare Statement -- ---------------------------- -- This is a block statement with a DECLARE phrase present -- BLOCK_STATEMENT ::= -- [block_STATEMENT_IDENTIFIER:] -- declare -- DECLARATIVE_PART -- begin -- HANDLED_SEQUENCE_OF_STATEMENTS -- end [block_IDENTIFIER]; -- The caller has checked that the initial token is DECLARE. The parameter -- is the node identifier for the block label if any (or is set to Empty -- if there is no block label). -- Error recovery: cannot raise Error_Resync function P_Declare_Statement (Block_Name_Node : Node_Id) return Node_Id is Block_Node : Node_Id; begin Block_Node := New_Node (N_Block_Statement, Token_Ptr); Push_Scope_Stack; Scope.Table (Scope.Last).Etyp := E_Name; Scope.Table (Scope.Last).Lreq := Present (Block_Name_Node); Scope.Table (Scope.Last).Ecol := Start_Column; Scope.Table (Scope.Last).Labl := Block_Name_Node; Scope.Table (Scope.Last).Sloc := Token_Ptr; Scan; -- past DECLARE if No (Block_Name_Node) then Set_Has_Created_Identifier (Block_Node, True); Set_Identifier (Block_Node, Make_Identifier (Sloc (Block_Node), New_Internal_Name ("block"))); else Set_Identifier (Block_Node, Block_Name_Node); end if; Append_Elmt (Block_Node, Label_List); P_Decls_Begin_End (Block_Node); return Block_Node; end P_Declare_Statement; -------------------------- -- 5.6 Begin Statement -- -------------------------- -- This is a block statement with no DECLARE phrase present -- BLOCK_STATEMENT ::= -- [block_STATEMENT_IDENTIFIER:] -- begin -- HANDLED_SEQUENCE_OF_STATEMENTS -- end [block_IDENTIFIER]; -- The caller has checked that the initial token is BEGIN. The parameter -- is the node identifier for the block label if any (or is set to Empty -- if there is no block label). -- Error recovery: cannot raise Error_Resync function P_Begin_Statement (Block_Name_Node : Node_Id) return Node_Id is Block_Node : Node_Id; begin Block_Node := New_Node (N_Block_Statement, Token_Ptr); Push_Scope_Stack; Scope.Table (Scope.Last).Etyp := E_Name; Scope.Table (Scope.Last).Lreq := Present (Block_Name_Node); Scope.Table (Scope.Last).Ecol := Start_Column; Scope.Table (Scope.Last).Labl := Block_Name_Node; Scope.Table (Scope.Last).Sloc := Token_Ptr; if No (Block_Name_Node) then Set_Has_Created_Identifier (Block_Node, True); Set_Identifier (Block_Node, Make_Identifier (Sloc (Block_Node), New_Internal_Name ("block"))); else Set_Identifier (Block_Node, Block_Name_Node); end if; Append_Elmt (Block_Node, Label_List); Scope.Table (Scope.Last).Ecol := Start_Column; Scope.Table (Scope.Last).Sloc := Token_Ptr; Scan; -- past BEGIN Set_Handled_Statement_Sequence (Block_Node, P_Handled_Sequence_Of_Statements); End_Statements; return Block_Node; end P_Begin_Statement; ------------------------------------------------------ -- 5.6 Declarations/Begin/End (Also 6.3, 7.1, 9.1) -- ------------------------------------------------------ -- This function parses the construct: -- DECLARATIVE_PART -- begin -- HANDLED_SEQUENCE_OF_STATEMENTS -- end [NAME]; -- The caller has built the scope stack entry, and created the node to -- whose Declarations and Handled_Statement_Sequence fields are to be -- set. On return these fields are filled in (except in the case of a -- task body, where the handled statement sequence is optional, and may -- thus be Empty), and the scan is positioned past the End sequence. -- If the BEGIN is missing, then the parent node is used to help construct -- an appropriate missing BEGIN message. Possibilities for the parent are: -- N_Block_Statement declare block -- N_Entry_Body entry body -- N_Package_Body package body (begin part optional) -- N_Subprogram_Body procedure or function body -- N_Task_Body task body (begin part optional) -- Note: in the case of a block statement, there is definitely a DECLARE -- present (because a Begin statement without a DECLARE is handled by the -- P_Begin_Statement procedure, which does not call P_Decls_Begin_End. -- Error recovery: cannot raise Error_Resync procedure P_Decls_Begin_End (Parent : Node_Id) is Body_Decl : Node_Id; Body_Sloc : Source_Ptr; Decls : List_Id; Decl : Node_Id; Parent_Nkind : Node_Kind; Spec_Node : Node_Id; begin Decls := P_Declarative_Part; -- Check for misplacement of later vs basic declarations in Ada 83 if Ada_83 then Decl := First (Decls); -- Loop through sequence of basic declarative items Outer : while Present (Decl) loop if Nkind (Decl) /= N_Subprogram_Body and then Nkind (Decl) /= N_Package_Body and then Nkind (Decl) /= N_Task_Body and then Nkind (Decl) not in N_Body_Stub then Decl := Next (Decl); -- Once a body is encountered, we only allow later declarative -- items. The inner loop checks the rest of the list. else Body_Sloc := Sloc (Decl); Inner : while Present (Decl) loop if Nkind (Decl) not in N_Later_Decl_Item then Error_Msg_Sloc_1 := Body_Sloc; Error_Msg_N ("in Ada 83 decl cannot appear " & "after body on line #", Decl); end if; Decl := Next (Decl); end loop Inner; end if; end loop Outer; end if; -- Here is where we deal with the case of IS used instead of semicolon. -- Specifically, if the last declaration in the declarative part is a -- subprogram body still marked as having a bad IS, then this is where -- we decide that the IS should really have been a semicolon and that -- the body should have been a declaration. Note that if the bad IS -- had turned out to be OK (i.e. a decent begin/end was found for it), -- then the Bad_Is_Detected flag would have been reset by now. Body_Decl := Last (Decls); if Present (Body_Decl) and then Nkind (Body_Decl) = N_Subprogram_Body and then Bad_Is_Detected (Body_Decl) then -- OK, we have the case of a bad IS, so we need to fix up the tree. -- What we have now is a subprogram body with attached declarations -- and a possible statement sequence. -- First step is to take the declarations that were part of the bogus -- subprogram body and append them to the outer declaration chain. -- In other words we append them past the body (which we will later -- convert into a declaration). Append_List (Declarations (Body_Decl), Decls); -- Now take the handled statement sequence of the bogus body and -- set it as the statement sequence for the outer construct. Note -- that it may be empty (we specially allowed a missing BEGIN for -- a subprogram body marked as having a bad IS -- see below). Set_Handled_Statement_Sequence (Parent, Handled_Statement_Sequence (Body_Decl)); -- Next step is to convert the old body node to a declaration node Spec_Node := Specification (Body_Decl); Change_Node (Body_Decl, N_Subprogram_Declaration); Set_Specification (Body_Decl, Spec_Node); -- Final step is to put the declarations for the parent where -- they belong, and then fall through the IF to scan out the -- END statements. Set_Declarations (Parent, Decls); -- This is the normal case (i.e. any case except the bad IS case) -- If we have a BEGIN, then scan out the sequence of statements, and -- also reset the expected column for the END to match the BEGIN. else Set_Declarations (Parent, Decls); if Token = Tok_Begin then if GNAT_Style_Check then GNAT_Column_Check (Token_Ptr); end if; Scope.Table (Scope.Last).Ecol := Start_Column; Scope.Table (Scope.Last).Sloc := Token_Ptr; Scan; -- past BEGIN Set_Handled_Statement_Sequence (Parent, P_Handled_Sequence_Of_Statements); -- No BEGIN present else Parent_Nkind := Nkind (Parent); -- A special check for the missing IS case. If we have a -- subprogram body that was marked as having a suspicious -- IS, and the current token is END, then we simply confirm -- the suspicion, and do not require a BEGIN to be present if Parent_Nkind = N_Subprogram_Body and then Token = Tok_End and then Scope.Table (Scope.Last).Etyp = E_Suspicious_Is then Scope.Table (Scope.Last).Etyp := E_Bad_Is; -- Otherwise BEGIN is not required for a package body or task -- body. However if we have something other than a BEGIN which -- looks like it might be statements, then we signal a missing -- BEGIN for these cases as well. We define "something which -- looks like it might be statements" as a token other than -- END, EOF, or a token which starts declarations. elsif (Parent_Nkind = N_Package_Body or else Parent_Nkind = N_Task_Body) and then (Token = Tok_End or else Token = Tok_EOF or else Token in Token_Class_Declk) then null; -- BEGIN not required for these cases -- These are cases in which a BEGIN is required and not present else Error_Msg_Sloc_1 := Scope.Table (Scope.Last).Sloc; Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl; if Parent_Nkind = N_Block_Statement then Error_Msg_BC ("missing BEGIN for DECLARE on line #!"); elsif Parent_Nkind = N_Entry_Body then Error_Msg_BC ("Missing BEGIN for ENTRY on line #!"); elsif Parent_Nkind = N_Subprogram_Body then if Nkind (Specification (Parent)) = N_Function_Specification then Error_Msg_BC ("missing BEGIN for function& on line #!"); else Error_Msg_BC ("missing BEGIN for procedure& on line #!"); end if; -- The cases for package body and task body arise only when -- we have possible statement junk present. elsif Parent_Nkind = N_Package_Body then Error_Msg_BC ("missing BEGIN for package body& on line #!"); elsif Parent_Nkind = N_Task_Body then Error_Msg_BC ("missing BEGIN for task body& on line #!"); -- No other node type can appear in this position else Compiler_Abort; -- should be impossible! end if; -- Here we pick up the statements after the BEGIN that -- should have been present but was not. Set_Handled_Statement_Sequence (Parent, P_Handled_Sequence_Of_Statements); end if; end if; end if; -- Here with declarations and handled statement sequence scanned End_Statements; -- We know that End_Statements removed an entry from the scope stack -- (because it is required to do so under all circumstances). We can -- therefore reference the entry it removed one past the stack top. -- What we are interested in is whether it was a case of a bad IS. if Scope.Table (Scope.Last + 1).Etyp = E_Bad_Is then Error_Msg ("IS should be semicolon", Scope.Table (Scope.Last + 1).S_Is); Set_Bad_Is_Detected (Parent, True); end if; end P_Decls_Begin_End; ------------------------- -- 5.7 Exit Statement -- ------------------------- -- EXIT_STATEMENT ::= -- exit [loop_NAME] [when CONDITION]; -- The caller has checked that the initial token is EXIT -- Error recovery: can raise Error_Resync function P_Exit_Statement return Node_Id is Exit_Node : Node_Id; begin Exit_Node := New_Node (N_Exit_Statement, Token_Ptr); Scan; -- past EXIT if Token = Tok_Identifier then Set_Name (Exit_Node, Token_Node); Scan; -- past Identifier end if; if Token = Tok_When then Scan; -- past WHEN Set_Condition (Exit_Node, P_Expression_No_Right_Paren); -- Allow IF instead of WHEN, giving error message elsif Token = Tok_If then T_When; Scan; -- past IF used in place of WHEN Set_Condition (Exit_Node, P_Expression_No_Right_Paren); end if; TF_Semicolon; return Exit_Node; end P_Exit_Statement; --------------------------- -- 5.8 Return Statement -- --------------------------- -- RETURN_STATEMENT has been moved to section 6.5 ------------------------- -- 5.9 Goto Statement -- ------------------------- -- GOTO_STATEMENT ::= goto label_NAME; -- The caller has checked that the initial token is GOTO (or TO in the -- error case where GO and TO were incorrectly separated). -- Error recovery: can raise Error_Resync function P_Goto_Statement return Node_Id is Goto_Node : Node_Id; begin Goto_Node := New_Node (N_Goto_Statement, Token_Ptr); Scan; -- past GOTO (or TO) Set_Name (Goto_Node, P_Qualified_Simple_Name_Resync); No_Constraint; TF_Semicolon; return Goto_Node; end P_Goto_Statement; end Ch5; aration in the declarative part is a -- subprogram body still marked as having a bad IS, then this is where -- we decide that the IS should really have been a sgnat-1.67-src/src/par-ch6.adb 444 10015 7640 74172 5506244345 11063 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P A R . C H 6 -- -- -- -- B o d y -- -- -- -- $Revision: 1.35 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Sinfo.Change; use Sinfo.Change; separate (Par) package body Ch6 is -- Local subprograms, used only in this chapter function P_Defining_Designator return Node_Id; function P_Defining_Operator_Symbol return Node_Id; --------------------------------- -- 6.1 Subprogram Declaration -- --------------------------------- -- Parsed by P_Subprogram (6.1) ------------------------------ -- 6.1 Abstract Subprogram -- ------------------------------ -- Parsed by P_Subprogram (6.1) ----------------------------------- -- 6.1 Subprogram Specification -- ----------------------------------- -- SUBPROGRAM_SPECIFICATION ::= -- PROCEDURE DEFINING_PROGRAM_UNIT_NAME PARAMETER_PROFILE -- | FUNCTION DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE -- PARAMETER_PROFILE ::= [FORMAL_PART] -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK -- Subprogram specifications that appear in subprogram declarations -- are parsed by P_Subprogram (6.1). This routine is used in other -- contexts where subprogram specifications occur. -- Note: this routine does not affect the scope stack in any way -- Error recovery: can raise Error_Resync function P_Subprogram_Specification return Node_Id is Specification_Node : Node_Id; begin if Token = Tok_Function then Specification_Node := New_Node (N_Function_Specification, Token_Ptr); Scan; -- past FUNCTION Ignore (Tok_Body); Set_Defining_Unit_Name (Specification_Node, P_Defining_Designator); Set_Parameter_Specifications (Specification_Node, P_Formal_Part_Opt); TF_Return; Set_Subtype_Mark (Specification_Node, P_Subtype_Mark); No_Constraint; return Specification_Node; elsif Token = Tok_Procedure then Specification_Node := New_Node (N_Procedure_Specification, Token_Ptr); Scan; -- past PROCEDURE Ignore (Tok_Body); Set_Defining_Unit_Name (Specification_Node, P_Defining_Program_Unit_Name); Set_Parameter_Specifications (Specification_Node, P_Formal_Part_Opt); return Specification_Node; else Error_Msg_SC ("subprogram specification expected"); raise Error_Resync; end if; end P_Subprogram_Specification; --------------------- -- 6.1 Designator -- --------------------- -- DESIGNATOR ::= -- [PARENT_UNIT_NAME .] IDENTIFIER | OPERATOR_SYMBOL -- The caller has checked that the initial token is an identifier, -- operator symbol, or string literal. Note that we don't bother to -- do much error diagnosis in this routine, since it is only used for -- the label on END lines, and the routines in package Par.Endh will -- check that the label is appropriate. -- Error recovery: cannot raise Error_Resync function P_Designator return Node_Id is Ident_Node : Node_Id; Name_Node : Node_Id; Prefix_Node : Node_Id; begin Ident_Node := Token_Node; Scan; -- past initial token if Prev_Token = Tok_Operator_Symbol or else Prev_Token = Tok_String_Literal or else Token /= Tok_Dot then return Ident_Node; -- Child name case else Prefix_Node := Ident_Node; -- Loop through child names, on entry to this loop, Prefix contains -- the name scanned so far, and Ident_Node is the last identifier. loop exit when Token /= Tok_Dot; Name_Node := New_Node (N_Selected_Component, Token_Ptr); Scan; -- past period Set_Prefix (Name_Node, Prefix_Node); Ident_Node := P_Identifier; Set_Selector_Name (Name_Node, Ident_Node); Prefix_Node := Name_Node; end loop; -- On exit from the loop, Ident_Node is the last identifier scanned, -- i.e. the defining identifier, and Prefix_Node is a node for the -- entire name, structured (incorrectly!) as a selected component. Name_Node := Prefix (Prefix_Node); Change_Node (Prefix_Node, N_Designator); Set_Name (Prefix_Node, Name_Node); Set_Identifier (Prefix_Node, Ident_Node); return Prefix_Node; end if; exception when Error_Resync => while Token = Tok_Dot or else Token = Tok_Identifier loop Scan; end loop; return Error; end P_Designator; ------------------------------ -- 6.1 Defining Designator -- ------------------------------ -- DEFINING_DESIGNATOR ::= -- DEFINING_PROGRAM_UNIT_NAME | DEFINING_OPERATOR_SYMBOL -- Error recovery: cannot raise Error_Resync function P_Defining_Designator return Node_Id is begin if Token = Tok_Operator_Symbol then return P_Defining_Operator_Symbol; elsif Token = Tok_String_Literal then Error_Msg_SC ("invalid operator name"); Scan; -- past junk string return Error; else return P_Defining_Program_Unit_Name; end if; end P_Defining_Designator; ------------------------------------- -- 6.1 Defining Program Unit Name -- ------------------------------------- -- DEFINING_PROGRAM_UNIT_NAME ::= -- [parent_library_unit_package_NAME .] DEFINING_IDENTIFIER -- Note: NAME is allowed to be non-null only in 9X mode at the outer level -- Error recovery: cannot raise Error_Resync function P_Defining_Program_Unit_Name return Node_Id is Ident_Node : Node_Id; Name_Node : Node_Id; Prefix_Node : Node_Id; begin -- Set identifier casing if not already set and scan initial identifier if Token = Tok_Identifier and then File.Table (Scan_Unit).Identifier_Casing = Unknown then File.Table (Scan_Unit).Identifier_Casing := Determine_Token_Casing; end if; Ident_Node := P_Identifier; -- Normal case (not child library unit name) if Token /= Tok_Dot then Change_Identifier_To_Defining_Identifier (Ident_Node); return Ident_Node; -- Child library unit name case else if Scope.Last > 1 then Error_Msg_SP ("child package name allowed only at library level"); raise Error_Resync; elsif Ada_83 then Error_Msg_SP ("child packages not allowed in Ada 83"); end if; Prefix_Node := Ident_Node; -- Loop through child names, on entry to this loop, Prefix contains -- the name scanned so far, and Ident_Node is the last identifier. loop exit when Token /= Tok_Dot; Name_Node := New_Node (N_Selected_Component, Token_Ptr); Scan; -- past period Set_Prefix (Name_Node, Prefix_Node); Ident_Node := P_Identifier; Set_Selector_Name (Name_Node, Ident_Node); Prefix_Node := Name_Node; end loop; -- On exit from the loop, Ident_Node is the last identifier scanned, -- i.e. the defining identifier, and Prefix_Node is a node for the -- entire name, structured (incorrectly!) as a selected component. Name_Node := Prefix (Prefix_Node); Change_Node (Prefix_Node, N_Defining_Program_Unit_Name); Set_Name (Prefix_Node, Name_Node); Change_Identifier_To_Defining_Identifier (Ident_Node); Set_Defining_Identifier (Prefix_Node, Ident_Node); -- All set with unit name parsed return Prefix_Node; end if; exception when Error_Resync => while Token = Tok_Dot or else Token = Tok_Identifier loop Scan; end loop; return Error; end P_Defining_Program_Unit_Name; -------------------------- -- 6.1 Operator Symbol -- -------------------------- -- OPERATOR_SYMBOL ::= STRING_LITERAL -- Operator symbol is returned by the scanner as Tok_Operator_Symbol ----------------------------------- -- 6.1 Defining Operator Symbol -- ----------------------------------- -- DEFINING_OPERATOR_SYMBOL ::= OPERATOR_SYMBOL -- The caller has checked that the initial symbol is an operator symbol function P_Defining_Operator_Symbol return Node_Id is Op_Node : Node_Id; begin Op_Node := Token_Node; Change_Operator_Symbol_To_Defining_Operator_Symbol (Op_Node); Scan; -- past operator symbol return Op_Node; end P_Defining_Operator_Symbol; ---------------------------- -- 6.1 Parameter Profile -- ---------------------------- -- Parsed by routine for containing construct. There is no separate -- node in the tree for a parameter profile. Instead the list of -- parameter specifications appears directly in the parent node. --------------------------------------- -- 6.1 Parameter and Result Profile -- --------------------------------------- -- Parsed by routine for containing construct. There is no separate -- node in the tree for a parameter profile. Instead the list of -- parameter specifications and the subtype mark for the return type -- appear directly in the parent node. ---------------------- -- 6.1 Formal part -- ---------------------- -- FORMAL_PART ::= (PARAMETER_SPECIFICATION {; PARAMETER_SPECIFICATION}) -- PARAMETER_SPECIFICATION ::= -- DEFINING_IDENTIFIER_LIST : MODE SUBTYPE_MARK -- [:= DEFAULT_EXPRESSION] -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION -- [:= DEFAULT_EXPRESSION] -- This scans the construct Formal_Part. The caller has already checked -- that the initial token is a left parenthesis, and skipped past it, so -- that on entry Token is the first token following the left parenthesis. -- Error recovery: cannot raise Error_Resync function P_Formal_Part return List_Id is Specification_List : List_Id; Specification_Node : Node_Id; Scan_State : Saved_Scan_State; Num_Idents : Nat; Ident : Nat; Idents : array (Int range 1 .. 4096) of Entity_Id; -- This array holds the list of defining identifiers. The upper bound -- of 4096 is intended to be essentially infinite, and we do not even -- bother to check for it being exceeded. begin Specification_List := New_List; Specification_Loop : loop begin if Token = Tok_Pragma then P_Pragmas_Misplaced; end if; Idents (1) := P_Defining_Identifier; Num_Idents := 1; while Comma_Present loop Num_Idents := Num_Idents + 1; Idents (Num_Idents) := P_Defining_Identifier; end loop; T_Colon; -- If there are multiple identifiers, we repeatedly scan the -- type and initialization expression information by resetting -- the scan pointer (so that we get completely separate trees -- for each occurrence). if Num_Idents > 1 then Save_Scan_State (Scan_State); end if; -- Loop through defining identifiers in list Ident := 1; Ident_Loop : loop Specification_Node := New_Node (N_Parameter_Specification, Token_Ptr); Set_Defining_Identifier (Specification_Node, Idents (Ident)); if Token = Tok_Access then if Ada_83 then Error_Msg_SC ("access parameters not allowed in Ada 83"); end if; Set_Parameter_Type (Specification_Node, P_Access_Definition); else P_Mode (Specification_Node); Set_Parameter_Type (Specification_Node, P_Subtype_Mark); No_Constraint; end if; if Token = Tok_Colon_Equal then Scan; -- past := Set_Expression (Specification_Node, P_Expression); end if; if Ident > 1 then Set_Prev_Ids (Specification_Node, True); end if; if Ident < Num_Idents then Set_More_Ids (Specification_Node, True); end if; Append (Specification_Node, Specification_List); exit Ident_Loop when Ident = Num_Idents; Ident := Ident + 1; Restore_Scan_State (Scan_State); end loop Ident_Loop; exception when Error_Resync => Resync_Semicolon_List; end; if Token = Tok_Semicolon then Scan; -- past semicolon elsif Token = Tok_Right_Paren then exit; -- Special check for common error of using comma instead of semicolon elsif Token = Tok_Comma then T_Semicolon; Scan; -- past comma -- Special check for omitted separator elsif Token = Tok_Identifier then T_Semicolon; -- If nothing sensible, skip to next semicolon or right paren else T_Semicolon; Resync_Semicolon_List; if Token = Tok_Semicolon then Scan; -- past semicolon else exit; end if; end if; end loop Specification_Loop; T_Right_Paren; return Specification_List; end P_Formal_Part; -- This scans the construct [FORMAL_PART], returning Empty if no formal -- part is present. -- Error recovery: cannot raise Error_Resync function P_Formal_Part_Opt return List_Id is begin if Token = Tok_Left_Paren then Scan; -- part left paren return P_Formal_Part; else return No_List; end if; end P_Formal_Part_Opt; ---------------------------------- -- 6.1 Parameter specification -- ---------------------------------- -- Parsed by P_Formal_Part (6.1) --------------- -- 6.1 Mode -- --------------- -- MODE ::= [in] | in out | out -- There is no explicit node in the tree for the Mode. Instead the -- In_Present and Out_Present flags are set in the parent node to -- record the presence of keywords specifying the mode. -- Error_Recovery: cannot raise Error_Resync procedure P_Mode (Node : Node_Id) is begin if Token = Tok_In then Scan; -- past IN Set_In_Present (Node, True); end if; if Token = Tok_Out then Scan; -- past OUT Set_Out_Present (Node, True); end if; if Token = Tok_In then Error_Msg_SC ("IN must preceed OUT in parameter mode"); Scan; -- past IN Set_In_Present (Node, True); end if; end P_Mode; ------------------------------------------- -- 6.1 Subprogram (Also 6.3, 8.5, 12.3) -- ------------------------------------------- -- This routine scans out a subprogram declaration, subprogram body, -- subprogram renaming declaration or subprogram generic instantiation. -- SUBPROGRAM_DECLARATION ::= SUBPROGRAM_SPECIFICATION; -- ABSTRACT_SUBPROGRAM_DECLARATION ::= SUBPROGRAM_SPECIFICATION is <>; -- SUBPROGRAM_SPECIFICATION ::= -- function DEFINING_DESIGNATOR [FORMAL_PART] return SUBTYPE_MARK -- | procedure DEFINING_PROGRAM_UNIT_NAME [FORMAL_PART] -- SUBPROGRAM_BODY ::= -- SUBPROGRAM_SPECIFICATION is -- DECLARATIVE_PART -- begin -- HANDLED_SEQUENCE_OF_STATEMENTS -- end [DESIGNATOR]; -- SUBPROGRAM_RENAMING_DECLARATION ::= -- SUBPROGRAM_SPECIFICATION renames callable_entity_NAME; -- SUBPROGRAM_BODY_STUB ::= -- SUBPROGRAM_SPECIFICATION is separate; -- GENERIC_INSTANTIATION ::= -- procedure DEFINING_PROGRAM_UNIT_NAME is -- new generic_procedure_NAME [GENERIC_ACTUAL_PART]; -- | function DEFINING_DESIGNATOR is -- new generic_function_NAME [GENERIC_ACTUAL_PART]; -- The value in Pf_Flags indicates which of these possible declarations -- is acceptable to the caller: -- Pf_Flags.Decl Set if declaration OK -- Pf_Flags.Gins Set if generic instantiation OK -- Pf_Flags.Pbod Set if proper body OK -- Pf_Flags.Rnam Set if renaming declaration OK -- Pf_Flags.Stub Set if body stub OK -- If an inappropriate form is encountered, it is scanned out but an -- error message indicating that it is appearing in an inappropriate -- context is issued. The only possible values for Pf_Flags are those -- defined as constants in the Par package. -- The caller has checked that the initial token is FUNCTION or PROCEDURE -- Error recovery: cannot raise Error_Resync function P_Subprogram (Pf_Flags : Pf_Rec) return Node_Id is Specification_Node : Node_Id; Name_Node : Node_Id; Fpart_List : List_Id; Fpart_Sloc : Source_Ptr; Return_Node : Node_Id; Inst_Node : Node_Id; Body_Node : Node_Id; Decl_Node : Node_Id; Rename_Node : Node_Id; Absdec_Node : Node_Id; Stub_Node : Node_Id; Fproc_Sloc : Source_Ptr; Func : Boolean; Scan_State : Saved_Scan_State; begin -- Set up scope stack entry. Note that the Labl field will be set later SIS_Entry_Active := False; SIS_Missing_Semicolon_Message := No_Error_Msg; Push_Scope_Stack; Scope.Table (Scope.Last).Sloc := Token_Ptr; Scope.Table (Scope.Last).Etyp := E_Name; Scope.Table (Scope.Last).Ecol := Start_Column; Scope.Table (Scope.Last).Lreq := False; Func := Token = Tok_Function; Fproc_Sloc := Token_Ptr; Scan; -- past FUNCTION or PROCEDURE Ignore (Tok_Type); Ignore (Tok_Body); if Func then Name_Node := P_Defining_Designator; else Name_Node := P_Defining_Program_Unit_Name; end if; Scope.Table (Scope.Last).Labl := Name_Node; if Token = Tok_Colon then Error_Msg_SC ("redundant colon ignored"); Scan; -- past colon end if; -- Deal with generic instantiation, the one case in which we do not -- have a subprogram specification as part of whatever we are parsing if Token = Tok_Is then Save_Scan_State (Scan_State); -- at the IS T_Is; -- checks for redundant IS's if Token = Tok_New then if not Pf_Flags.Gins then Error_Msg_SC ("generic instantation not allowed here!"); end if; Scan; -- past NEW if Func then Inst_Node := New_Node (N_Function_Instantiation, Fproc_Sloc); Set_Name (Inst_Node, P_Function_Name); else Inst_Node := New_Node (N_Procedure_Instantiation, Fproc_Sloc); Set_Name (Inst_Node, P_Qualified_Simple_Name); end if; Set_Defining_Unit_Name (Inst_Node, Name_Node); Set_Generic_Associations (Inst_Node, P_Generic_Actual_Part_Opt); TF_Semicolon; Pop_Scope_Stack; -- Don't need scope stack entry in this case return Inst_Node; else Restore_Scan_State (Scan_State); -- to the IS end if; end if; -- If not a generic instantiation, then we definitely have a subprogram -- specification (all possibilities at this stage include one here) Fpart_Sloc := Token_Ptr; Fpart_List := P_Formal_Part_Opt; -- We treat what we have as a function specification if FUNCTION was -- used, or if a RETURN is present. This gives better error recovery -- since later RETURN statements will be valid in either case. if Token = Tok_Return then if not Func then Error_Msg ("should be FUNCTION (procedure cannot have RETURN)", Fproc_Sloc); Func := True; end if; Scan; -- past RETURN Return_Node := P_Subtype_Mark; No_Constraint; else if Func then TF_Return; Return_Node := Error; end if; end if; if Func then Specification_Node := New_Node (N_Function_Specification, Fproc_Sloc); Set_Subtype_Mark (Specification_Node, Return_Node); else Specification_Node := New_Node (N_Procedure_Specification, Fproc_Sloc); end if; Set_Defining_Unit_Name (Specification_Node, Name_Node); Set_Parameter_Specifications (Specification_Node, Fpart_List); -- Deal with case of semicolon ending a subprogram declaration if Token = Tok_Semicolon then if not Pf_Flags.Decl then T_Is; end if; Scan; -- past semicolon -- If semicolon is immediately followed by IS, then ignore the -- semicolon, and go process the body. if Token = Tok_Is then Error_Msg_SP ("unexpected semicolon ignored"); T_Is; -- ignroe redundant IS's goto Subprogram_Body; -- If BEGIN follows in an appropriate column, we immediately -- commence the error action of assuming that the previous -- subprogram declaration should have been a subprogram body, -- i.e. that the terminating semicolon should have been IS. elsif Token = Tok_Begin and then Start_Column >= Scope.Table (Scope.Last).Ecol then Error_Msg_SP ("semicolon should be IS!"); goto Subprogram_Body; else goto Subprogram_Declaration; end if; -- Subprogram renaming declaration case elsif Token = Tok_Renames then if not Pf_Flags.Rnam then Error_Msg_SC ("renaming declaration not allowed here!"); end if; Rename_Node := New_Node (N_Subprogram_Renaming_Declaration, Token_Ptr); Scan; -- past RENAMES Set_Name (Rename_Node, P_Name); Set_Specification (Rename_Node, Specification_Node); TF_Semicolon; Pop_Scope_Stack; return Rename_Node; -- Case of IS following subprogram specification elsif Token = Tok_Is then T_Is; -- ignore redundant Is's if Token_Name = Name_Abstract then Check_9X_Keyword (Tok_Abstract, Tok_Semicolon); end if; -- Deal nicely with (now obsolete) use of <> in place of abstract if Token = Tok_Box then Error_Msg_SC ("ABSTRACT expected"); Token := Tok_Abstract; end if; -- Abstract subprogram declaration case if Token = Tok_Abstract then Absdec_Node := New_Node (N_Abstract_Subprogram_Declaration, Token_Ptr); Set_Specification (Absdec_Node, Specification_Node); Pop_Scope_Stack; -- discard unneeded entry Scan; -- past ABSTRACT TF_Semicolon; return Absdec_Node; -- Check for IS NEW with Formal_Part present and handle nicely elsif Token = Tok_New then Error_Msg ("formal part not allowed in instantiation", Fpart_Sloc); Scan; -- past NEW if Func then Inst_Node := New_Node (N_Function_Instantiation, Fproc_Sloc); else Inst_Node := New_Node (N_Procedure_Instantiation, Fproc_Sloc); end if; Set_Defining_Unit_Name (Inst_Node, Name_Node); Set_Name (Inst_Node, P_Name); Set_Generic_Associations (Inst_Node, P_Generic_Actual_Part_Opt); TF_Semicolon; Pop_Scope_Stack; -- Don't need scope stack entry in this case return Inst_Node; else goto Subprogram_Body; end if; -- Here we have a missing IS or missing semicolon, we always guess a -- missing semicolon, since we are pretty good at fixing up a semicolon -- which should really be an IS else Error_Msg_AP ("missing semicolon"); SIS_Missing_Semicolon_Message := Get_Msg_Id; goto Subprogram_Declaration; end if; -- Processing for subprogram body <> if not Pf_Flags.Pbod then Error_Msg_SP ("subprogram body not allowed here!"); end if; -- Subprogram body stub case if Separate_Present then if not Pf_Flags.Stub then Error_Msg_SC ("body stub not allowed here!"); end if; Stub_Node := New_Node (N_Subprogram_Body_Stub, Sloc (Specification_Node)); Set_Specification (Stub_Node, Specification_Node); Scan; -- past SEPARATE Pop_Scope_Stack; TF_Semicolon; return Stub_Node; -- Subprogram body case else -- Here is the test for a suspicious IS (i.e. one that looks -- like it might more properly be a semicolon). See separate -- section discussing use of IS instead of semicolon in -- package Parse. if (Token in Token_Class_Declk or else Token = Tok_Identifier) and then Start_Column <= Scope.Table (Scope.Last).Ecol then Scope.Table (Scope.Last).Etyp := E_Suspicious_Is; Scope.Table (Scope.Last).S_Is := Prev_Token_Ptr; end if; Body_Node := New_Node (N_Subprogram_Body, Sloc (Specification_Node)); Set_Specification (Body_Node, Specification_Node); P_Decls_Begin_End (Body_Node); return Body_Node; end if; -- Processing for subprogram declaration <> Decl_Node := New_Node (N_Subprogram_Declaration, Sloc (Specification_Node)); Set_Specification (Decl_Node, Specification_Node); -- If this is a context in which a subprogram body is permitted, -- set active SIS entry in case (see section titled "Handling -- Semicolon Used in Place of IS" in body of Parser package) -- Note that SIS_Missing_Semicolon_Message is already set properly. if Pf_Flags.Pbod then SIS_Labl := Scope.Table (Scope.Last).Labl; SIS_Sloc := Scope.Table (Scope.Last).Sloc; SIS_Ecol := Scope.Table (Scope.Last).Ecol; SIS_Declaration_Node := Decl_Node; SIS_Semicolon_Sloc := Prev_Token_Ptr; SIS_Entry_Active := True; end if; Pop_Scope_Stack; return Decl_Node; end P_Subprogram; -------------------------- -- 6.3 Subprogram Body -- -------------------------- -- Parsed by P_Subprogram (6.1) ----------------------------------- -- 6.4 Procedure Call Statement -- ----------------------------------- -- Parsed by P_Sequence_Of_Statements (5.1) ------------------------ -- 6.4 Function Call -- ------------------------ -- Parsed by P_Call_Or_Name (4.1) -------------------------------- -- 6.4 Actual Parameter Part -- -------------------------------- -- Parsed by P_Call_Or_Name (4.1) -------------------------------- -- 6.4 Parameter Association -- -------------------------------- -- Parsed by P_Call_Or_Name (4.1) --------------------------- -- 6.4 Formal Parameter -- --------------------------- -- Parsed by P_Call_Or_Name (4.1) --------------------------- -- 6.4 Actual Parameter -- --------------------------- -- Parsed by P_Call_Or_Name (4.1) --------------------------- -- 6.5 Return Statement -- --------------------------- -- RETURN_STATEMENT ::= return [EXPRESSION]; -- The caller has checked that the initial token is RETURN -- Error recovery: can raise Error_Resync function P_Return_Statement return Node_Id is Return_Node : Node_Id; begin Return_Node := New_Node (N_Return_Statement, Token_Ptr); -- Sloc points to RETURN -- Expression (Op3) Scan; -- past RETURN if Token /= Tok_Semicolon then -- If no semicolon, then scan an expression, except that -- we avoid trying to scan an expression if we are at an -- expression terminator since in that case the best error -- message is probably that we have a missing semicolon. if Token not in Token_Class_Eterm then Set_Expression (Return_Node, P_Expression_No_Right_Paren); end if; end if; TF_Semicolon; return Return_Node; end P_Return_Statement; end Ch6; ifications (Specification_Node, Fpart_List); -- Deal with case of semicolon ending a subprogram declaration if Token = Tok_Semicolon then if not Pf_Flags.Decl then T_Is; end if; Scan; -- past semicolon -- If semicolon is immediately followed by IS, then ignore the -- semicolon, and go process the body. gnat-1.67-src/src/par-ch7.adb 444 10015 7640 22760 5506244346 11061 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P A R . C H 7 -- -- -- -- B o d y -- -- -- -- $Revision: 1.22 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ separate (Par) package body Ch7 is ------------------------------ -- 7.1 Package Declaration -- ------------------------------ -- Parsed by P_Package (7.1) -------------------------------- -- 7.1 Package Specification -- -------------------------------- -- Parsed by P_Package (7.1) ----------------------- -- 7.1 Package Body -- ----------------------- -- Parsed by P_Package (7.1) ----------------------------------------- -- 7.1 Package (also 8.5, 10.2, 12.3) -- ----------------------------------------- -- This routine scans out a package declaration, package body, or a -- renaming declaration or generic instantiation starting with PACKAGE -- PACKAGE_DECLARATION ::= PACKAGE_SPECIFICATION; -- PACKAGE_SPECIFICATION ::= -- package DEFINING_PROGRAM_UNIT_NAME is -- {BASIC_DECLARATIVE_ITEM} -- [private -- {BASIC_DECLARATIVE_ITEM}] -- end [[PARENT_UNIT_NAME .] IDENTIFIER] -- PACKAGE_BODY ::= -- package body DEFINING_PROGRAM_UNIT_NAME is -- DECLARATIVE_PART -- [begin -- HANDLED_SEQUENCE_OF_STATEMENTS] -- end [[PARENT_UNIT_NAME .] IDENTIFIER] -- PACKAGE_RENAMING_DECLARATION ::= -- package DEFINING_IDENTIFIER renames package_NAME; -- PACKAGE_BODY_STUB ::= -- package body DEFINING_IDENTIFIER is separate; -- The value in Pf_Flags indicates which of these possible declarations -- is acceptable to the caller: -- Pf_Flags.Spcn Set if specification OK -- Pf_Flags.Decl Set if declaration OK -- Pf_Flags.Gins Set if generic instantiation OK -- Pf_Flags.Pbod Set if proper body OK -- Pf_Flags.Rnam Set if renaming declaration OK -- Pf_Flags.Stub Set if body stub OK -- If an inappropriate form is encountered, it is scanned out but an -- error message indicating that it is appearing in an inappropriate -- context is issued. The only possible settings for Pf_Flags are those -- defined as constants in package Par. -- Note: in all contexts where a package specification is required, there -- is a terminating semicolon. This semicolon is scanned out in the case -- where Pf_Flags is set to Pf_Spcn, even though it is not strictly part -- of the package specification (it's just too much trouble, and really -- quite unnecessary, to deal with scanning out an END where the semicolon -- after the END is not considered to be part of the END. -- The caller has checked that the initial token is PACKAGE -- Error recovery: cannot raise Error_Resync function P_Package (Pf_Flags : Pf_Rec) return Node_Id is Package_Node : Node_Id; Specification_Node : Node_Id; Name_Node : Node_Id; Package_Sloc : Source_Ptr; begin Push_Scope_Stack; Scope.Table (Scope.Last).Etyp := E_Name; Scope.Table (Scope.Last).Ecol := Start_Column; Scope.Table (Scope.Last).Lreq := False; Package_Sloc := Token_Ptr; Scan; -- past PACKAGE if Token = Tok_Type then Error_Msg_SC ("TYPE not allowed here"); Scan; -- past TYPE end if; -- Case of package body. Note that we demand a package body if that -- is the only possibility (even if the BODY keyword is not present) if Token = Tok_Body or else Pf_Flags = Pf_Pbod then if not Pf_Flags.Pbod then Error_Msg_SC ("package body cannot appear here!"); end if; T_Body; Name_Node := P_Defining_Program_Unit_Name; Scope.Table (Scope.Last).Labl := Name_Node; TF_Is; if Separate_Present then if not Pf_Flags.Stub then Error_Msg_SC ("body stub cannot appear here!"); end if; Scan; -- past SEPARATE TF_Semicolon; Pop_Scope_Stack; Package_Node := New_Node (N_Package_Body_Stub, Package_Sloc); Set_Defining_Identifier (Package_Node, Name_Node); else Package_Node := New_Node (N_Package_Body, Package_Sloc); Set_Defining_Unit_Name (Package_Node, Name_Node); P_Decls_Begin_End (Package_Node); end if; return Package_Node; -- Cases other than Package_Body else Name_Node := P_Defining_Program_Unit_Name; Scope.Table (Scope.Last).Labl := Name_Node; -- Case of renaming declaration if Token = Tok_Renames then if not Pf_Flags.Rnam then Error_Msg_SC ("renaming declaration cannot appear here!"); end if; Scan; -- past RENAMES; Package_Node := New_Node (N_Package_Renaming_Declaration, Package_Sloc); Set_Defining_Unit_Name (Package_Node, Name_Node); Set_Name (Package_Node, P_Qualified_Simple_Name); No_Constraint; TF_Semicolon; Pop_Scope_Stack; return Package_Node; else TF_Is; -- Case of generic instantiation if Token = Tok_New then if not Pf_Flags.Gins then Error_Msg_SC ("generic instantiation cannot appear here!"); end if; Scan; -- past NEW Package_Node := New_Node (N_Package_Instantiation, Package_Sloc); Set_Defining_Unit_Name (Package_Node, Name_Node); Set_Name (Package_Node, P_Qualified_Simple_Name); Set_Generic_Associations (Package_Node, P_Generic_Actual_Part_Opt); TF_Semicolon; Pop_Scope_Stack; -- Case of package declaration or package specification else Specification_Node := New_Node (N_Package_Specification, Package_Sloc); Set_Defining_Unit_Name (Specification_Node, Name_Node); Set_Visible_Declarations (Specification_Node, P_Basic_Declarative_Items); if Token = Tok_Private then Scan; -- past PRIVATE Set_Private_Declarations (Specification_Node, P_Basic_Declarative_Items); -- Deal gracefully with multiple PRIVATE parts while Token = Tok_Private loop Error_Msg_SC ("only one private part allowed per package"); Scan; -- past PRIVATE Append_List (P_Basic_Declarative_Items, Private_Declarations (Specification_Node)); end loop; end if; if Pf_Flags = Pf_Spcn then Package_Node := Specification_Node; else Package_Node := New_Node (N_Package_Declaration, Package_Sloc); Set_Specification (Package_Node, Specification_Node); end if; if Token = Tok_Begin then Error_Msg_SC ("begin block not allowed in package spec"); Scan; -- past BEGIN Discard_Junk_List (P_Sequence_Of_Statements (SS_None)); end if; End_Statements; end if; return Package_Node; end if; end if; end P_Package; ----------------------------------- -- 7.4 Private Type Declaration -- ----------------------------------- -- Parsed by P_Type_Declaration (3.3.1) ---------------------------------------- -- 7.4 Private Extension Declaration -- ---------------------------------------- -- Parsed by P_Type_Declaration (3.3.1) end Ch7; is Packagegnat-1.67-src/src/par-ch8.adb 444 10015 7640 6717 5506244346 11046 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P A R . C H 8 -- -- -- -- B o d y -- -- -- -- $Revision: 1.8 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ separate (Par) package body Ch8 is --------------------- -- 8.4 Use Clause -- --------------------- -- USE_CLAUSE ::= USE_PACKAGE_CLAUSE | USE_TYPE_CLAUSE -- USE_PACKAGE_CLAUSE ::= use package_NAME {, package_NAME}; -- USE_TYPE_CLAUSE ::= use type SUBTYPE_MARK {, SUBTYPE_MARK}; -- The caller has checked that the initial token is USE -- Error recovery: cannot raise Error_Resync function P_Use_Clause return Node_Id is Use_Node : Node_Id; begin Scan; -- past USE if Token = Tok_Type then Use_Node := New_Node (N_Use_Type_Clause, Prev_Token_Ptr); Set_Subtype_Marks (Use_Node, New_List); if Ada_83 then Error_Msg_SC ("type based use clause not allowed in Ada 83!"); end if; Scan; -- past TYPE loop Append (P_Subtype_Mark, Subtype_Marks (Use_Node)); No_Constraint; exit when Token /= Tok_Comma; Scan; -- past comma end loop; else Use_Node := New_Node (N_Use_Package_Clause, Prev_Token_Ptr); Set_Names (Use_Node, New_List); loop Append (P_Qualified_Simple_Name, Names (Use_Node)); exit when Token /= Tok_Comma; Scan; -- past comma end loop; end if; TF_Semicolon; return Use_Node; end P_Use_Clause; ------------------------------- -- 8.5 Renaming Declaration -- ------------------------------- -- For renaming declaration, package, function and procedure cases are -- parsed in the procedures with those P_names, and the object and -- exception name cases are parsed in P_Identifier_Declaration. end Ch8; -- -- B ognat-1.67-src/src/par-ch9.adb 444 10015 7640 124550 5506244347 11104 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P A R . C H 9 -- -- -- -- B o d y -- -- -- -- $Revision: 1.40 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ separate (Par) package body Ch9 is -- Local subprograms, used only in this chapter function P_Accept_Alternative return Node_Id; function P_Delay_Alternative return Node_Id; function P_Entry_Body_Formal_Part return Node_Id; function P_Entry_Declaration return Node_Id; function P_Entry_Index_Specification return Node_Id; function P_Protected_Definition return Node_Id; function P_Protected_Operation_Declaration_Opt return Node_Id; function P_Protected_Operation_Items return List_Id; function P_Task_Definition return Node_Id; function P_Task_Items return List_Id; --------------------------- -- 9.1 Task (also 10.2) -- --------------------------- -- TASK_TYPE_DECLARATION ::= -- task type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] -- [is TASK_DEFINITION]; -- SINGLE_TASK_DECLARATION ::= -- task DEFINING_IDENTIFIER [is TASK_DEFINITION]; -- TASK_BODY ::= -- task body task_DEFINING_IDENTIFIER is -- DECLARATIVE_PART -- begin -- HANDLED_SEQUENCE_OF_STATEMENTS -- end [task_IDENTIFIER] -- TASK_BODY_STUB ::= -- task body DEFINING_IDENTIFIER is separate; -- This routine scans out a task declaration, task body, or task stub -- The caller has checked that the initial token is TASK and scanned -- past it, so that Token is set to the token after TASK -- Error recovery: cannot raise Error_Resync function P_Task return Node_Id is Name_Node : Node_Id; Task_Node : Node_Id; Task_Sloc : Source_Ptr; begin Push_Scope_Stack; Scope.Table (Scope.Last).Etyp := E_Name; Scope.Table (Scope.Last).Ecol := Start_Column; Scope.Table (Scope.Last).Lreq := False; Task_Sloc := Prev_Token_Ptr; if Token = Tok_Body then Scan; -- past BODY Name_Node := P_Defining_Identifier; Scope.Table (Scope.Last).Labl := Name_Node; TF_Is; -- Task stub if Token = Tok_Separate then Scan; -- past SEPARATE Task_Node := New_Node (N_Task_Body_Stub, Task_Sloc); Set_Defining_Identifier (Task_Node, Name_Node); TF_Semicolon; Pop_Scope_Stack; -- remove unused entry -- Task body else Task_Node := New_Node (N_Task_Body, Task_Sloc); Set_Defining_Identifier (Task_Node, Name_Node); P_Decls_Begin_End (Task_Node); end if; return Task_Node; -- Otherwise we must have a task declaration else if Token = Tok_Type then Scan; -- past TYPE Task_Node := New_Node (N_Task_Type_Declaration, Task_Sloc); Name_Node := P_Defining_Identifier; Set_Defining_Identifier (Task_Node, Name_Node); Scope.Table (Scope.Last).Labl := Name_Node; Set_Discriminant_Specifications (Task_Node, P_Known_Discriminant_Part_Opt); else Task_Node := New_Node (N_Single_Task_Declaration, Task_Sloc); Name_Node := P_Defining_Identifier; Set_Defining_Identifier (Task_Node, Name_Node); Scope.Table (Scope.Last).Labl := Name_Node; if Token = Tok_Left_Paren then Error_Msg_SC ("discriminant part not allowed here!"); Resync_Past_Right_Paren_Or_EOL; end if; end if; -- Parse optional task definition. Note that P_Task_Definition scans -- out the semicolon as well as the task definition itself. if Token = Tok_Semicolon then Pop_Scope_Stack; -- Remove unused entry Scan; -- past semicolon else TF_Is; -- must have IS if no semicolon Set_Task_Definition (Task_Node, P_Task_Definition); end if; return Task_Node; end if; end P_Task; -------------------------------- -- 9.1 Task Type Declaration -- -------------------------------- -- Parsed by P_Task (9.1) ---------------------------------- -- 9.1 Single Task Declaration -- ---------------------------------- -- Parsed by P_Task (9.1) -------------------- -- 9.1 Task Body -- -------------------- -- Parsed by P_Task (9.1) -------------------------- -- 9.1 Task Definition -- -------------------------- -- TASK_DEFINITION ::= -- {TASK_ITEM} -- [private -- {TASK_ITEM} -- end [task_IDENTIFIER]; -- The caller has already made the scope stack entry -- Note: there is a small deviation from official syntax here in that we -- regard the semicolon after end as part of the Task_Definition, and in -- the official syntax, it's part of the enclosing declaration. The reason -- for this deviation is that otherwise the end processing would have to -- be special cased, which would be a nuisance! -- Error recovery: cannot raise Error_Resync function P_Task_Definition return Node_Id is Def_Node : Node_Id; begin Def_Node := New_Node (N_Task_Definition, Token_Ptr); Set_Visible_Declarations (Def_Node, P_Task_Items); if Token = Tok_Private then Scan; -- past PRIVATE Set_Private_Declarations (Def_Node, P_Task_Items); -- Deal gracefully with multiple PRIVATE parts while Token = Tok_Private loop Error_Msg_SC ("Only one private part allowed per task"); Scan; -- past PRIVATE Append_List (P_Task_Items, Private_Declarations (Def_Node)); end loop; end if; End_Statements; return Def_Node; end P_Task_Definition; --------------------- -- 9.1 Task Items -- --------------------- -- TASK_ITEM ::= ENTRY_DECLARATION | REPRESENTATION_CLAUSE -- This subprogram scans a (possibly empty) list of task items and pragmas -- Error recovery: cannot raise Error_Resync -- Note: a pragma can also be returned in this position function P_Task_Items return List_Id is Items : List_Id; Item_Node : Node_Id; Decl_Sloc : Source_Ptr; begin -- Get rid of active SIS entry from outer scope. This means we will -- miss some nested cases, but it doesn't seem worth the effort. See -- discussion in Par for further details SIS_Entry_Active := False; -- Loop to scan out task items Items := New_List; Decl_Loop : loop Decl_Sloc := Token_Ptr; if Token = Tok_Pragma then Append (P_Pragma, Items); elsif Token = Tok_Entry then Append (P_Entry_Declaration, Items); elsif Token = Tok_For then -- Representation clause in task declaration. The only rep -- clause which is legal in a protected is an address clause, -- so that is what we try to scan out. Item_Node := P_Representation_Clause; if Nkind (Item_Node) = N_At_Clause then Append (Item_Node, Items); else Error_Msg ("the only representation clause " & "allowed here is an address clause!", Decl_Sloc); end if; elsif Token in Token_Class_Declk then Error_Msg_SC ("Illegal declaration in task definition!"); Resync_Past_Semicolon; else exit Decl_Loop; end if; end loop Decl_Loop; return Items; end P_Task_Items; -------------------------------- -- 9.4 Protected (also 10.2) -- -------------------------------- -- PROTECTED_TYPE_DECLARATION ::= -- protected type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] -- is PROTECTED_DEFINITION; -- SINGLE_PROTECTED_DECLARATION ::= -- protected DEFINING_IDENTIFIER is PROTECTED_DEFINITION; -- PROTECTED_BODY ::= -- protected body DEFINING_IDENTIFIER is -- {PROTECTED_OPERATION_ITEM} -- end [protected_IDENTIFIER]; -- PROTECTED_BODY_STUB ::= -- protected body DEFINING_IDENTIFIER is separate; -- This routine scans out a protected declaration, protected body -- or a protected stub. -- The caller has checked that the initial token is PROTECTED and -- scanned past it, so Token is set to the following token. -- Error recovery: cannot raise Error_Resync function P_Protected return Node_Id is Name_Node : Node_Id; Protected_Node : Node_Id; Protected_Sloc : Source_Ptr; begin Push_Scope_Stack; Scope.Table (Scope.Last).Etyp := E_Name; Scope.Table (Scope.Last).Ecol := Start_Column; Scope.Table (Scope.Last).Lreq := False; Protected_Sloc := Prev_Token_Ptr; if Token = Tok_Body then Scan; -- past BODY Name_Node := P_Defining_Identifier; Scope.Table (Scope.Last).Labl := Name_Node; TF_Is; -- Protected stub if Token = Tok_Separate then Scan; -- past SEPARATE Protected_Node := New_Node (N_Protected_Body_Stub, Protected_Sloc); Set_Defining_Identifier (Protected_Node, Name_Node); TF_Semicolon; Pop_Scope_Stack; -- remove unused entry -- Protected body else Protected_Node := New_Node (N_Protected_Body, Protected_Sloc); Set_Defining_Identifier (Protected_Node, Name_Node); Set_Declarations (Protected_Node, P_Protected_Operation_Items); End_Statements; end if; return Protected_Node; -- Otherwise we must have a protected declaration else if Token = Tok_Type then Scan; -- past TYPE Protected_Node := New_Node (N_Protected_Type_Declaration, Protected_Sloc); Name_Node := P_Defining_Identifier; Set_Defining_Identifier (Protected_Node, Name_Node); Scope.Table (Scope.Last).Labl := Name_Node; Set_Discriminant_Specifications (Protected_Node, P_Known_Discriminant_Part_Opt); else Protected_Node := New_Node (N_Single_Protected_Declaration, Protected_Sloc); Name_Node := P_Defining_Identifier; Set_Defining_Identifier (Protected_Node, Name_Node); if Token = Tok_Left_Paren then Error_Msg_SC ("discriminant part not allowed here!"); Resync_Past_Right_Paren_Or_EOL; end if; Scope.Table (Scope.Last).Labl := Name_Node; end if; T_Is; Set_Protected_Definition (Protected_Node, P_Protected_Definition); return Protected_Node; end if; end P_Protected; -------------------------------- -- 9.4 Protected Declaration -- -------------------------------- -- Parsed by P_Protected (9.5) ------------------------------------- -- 9.4 Protected Type Declaration -- ------------------------------------- -- Parsed by P_Protected (9.5) --------------------------------------- -- 9.4 Single Protected Declaration -- --------------------------------------- -- Parsed by P_Protected (9.5) ------------------------------- -- 9.4 Protected Definition -- ------------------------------- -- PROTECTED_DEFINITION ::= -- {PROTECTED_OPERATION_DECLARATION} -- [private -- {PROTECTED_ELEMENT_DECLARATION}] -- end [protected_IDENTIFIER] -- PROTECTED_ELEMENT_DECLARATION ::= -- PROTECTED_OPERATION_DECLARATION | COMPONENT_DECLARATION -- The caller has already established the scope stack entry -- Error recovery: cannot raise Error_Resync function P_Protected_Definition return Node_Id is Def_Node : Node_Id; Item_Node : Node_Id; begin Def_Node := New_Node (N_Protected_Definition, Token_Ptr); -- Get rid of active SIS entry from outer scope. This means we will -- miss some nested cases, but it doesn't seem worth the effort. See -- discussion in Par for further details SIS_Entry_Active := False; -- Loop to scan visible declarations (protected operation declarations) Set_Visible_Declarations (Def_Node, New_List); loop Item_Node := P_Protected_Operation_Declaration_Opt; exit when No (Item_Node); Append (Item_Node, Visible_Declarations (Def_Node)); end loop; -- Deal with PRIVATE part (including graceful handling -- of multiple PRIVATE parts). Private_Loop : while Token = Tok_Private loop if Private_Declarations (Def_Node) = No_List then Set_Private_Declarations (Def_Node, New_List); else Error_Msg_SC ("duplicate private part"); end if; Scan; -- past PRIVATE Declaration_Loop : loop if Token = Tok_Identifier then P_Component_Declarations (Private_Declarations (Def_Node)); else Item_Node := P_Protected_Operation_Declaration_Opt; exit Declaration_Loop when No (Item_Node); Append (Item_Node, Private_Declarations (Def_Node)); end if; end loop Declaration_Loop; end loop Private_Loop; End_Statements; return Def_Node; end P_Protected_Definition; ------------------------------------------ -- 9.4 Protected Operation Declaration -- ------------------------------------------ -- PROTECTED_OPERATION_DECLARATION ::= -- SUBPROGRAM_DECLARATION | ENTRY_DECLARATION -- Error recovery: cannot raise Error_Resync -- Note: a pragma can also be returned in this position function P_Protected_Operation_Declaration_Opt return Node_Id is begin -- This loop runs more than once only when a junk declaration -- is skipped. loop if Token = Tok_Pragma then return P_Pragma; elsif Token = Tok_Entry then return P_Entry_Declaration; elsif Token = Tok_Function or else Token = Tok_Procedure then return P_Subprogram (Pf_Decl); elsif Token = Tok_Identifier or else Token in Token_Class_Declk then Error_Msg_SC ("Illegal declaration in protected definition!"); Resync_Past_Semicolon; else return Empty; end if; end loop; end P_Protected_Operation_Declaration_Opt; ---------------------------------------- -- 9.4 Protected Element Declaration -- ---------------------------------------- -- Parsed by P_Protected_Definition (9.4) ------------------------- -- 9.4 Protected Body -- ------------------------- -- Parsed by P_Protected (9.5) ------------------------------------ -- 9.4 Protected Operation Items -- ------------------------------------ -- PROTECTED_OPERATION_ITEM ::= -- SUBPROGRAM_DECLARATION | SUBPROGRAM_BODY | ENTRY_BODY -- This procedure parses and returns a list of protected operation items function P_Protected_Operation_Items return List_Id is Item_List : List_Id; begin Item_List := New_List; loop if Token = Tok_Entry then Append (P_Entry_Body, Item_List); elsif Token = Tok_Function or else Token = Tok_Procedure then Append (P_Subprogram (Pf_Pbod), Item_List); elsif Token = Tok_Identifier then Error_Msg_SC ("all components must be declared in spec!"); Resync_Past_Semicolon; elsif Token in Token_Class_Declk then Error_Msg_SC ("illegal declaration in protected definition!"); Resync_Past_Semicolon; else exit; end if; end loop; return Item_List; end P_Protected_Operation_Items; ------------------------------ -- 9.5.2 Entry Declaration -- ------------------------------ -- ENTRY_DECLARATION ::= -- entry DEFINING_IDENTIFIER [(DISCRETE_SUBTYPE_DEFINITION)] -- PARAMETER_PROFILE -- The caller has checked that the initial token is ENTRY -- Error recovery: cannot raise Error_Resync function P_Entry_Declaration return Node_Id is Decl_Node : Node_Id; Scan_State : Saved_Scan_State; begin Decl_Node := New_Node (N_Entry_Declaration, Token_Ptr); Scan; -- past ENTRY Set_Defining_Identifier (Decl_Node, P_Defining_Identifier); -- If left paren, could be (Discrete_Subtype_Definition) or Formal_Part if Token = Tok_Left_Paren then Scan; -- past ( -- If identifier after left paren, could still be either if Token = Tok_Identifier then Save_Scan_State (Scan_State); -- at Id Scan; -- past Id -- If comma or colon after Id, must be Formal_Part if Token = Tok_Comma or else Token = Tok_Colon then Restore_Scan_State (Scan_State); -- to Id Set_Parameter_Specifications (Decl_Node, P_Formal_Part); -- Else if Id wi no comma or colon, must be discrete subtype defn else Restore_Scan_State (Scan_State); -- to Id Set_Discrete_Subtype_Definition (Decl_Node, P_Discrete_Subtype_Definition); T_Right_Paren; Set_Parameter_Specifications (Decl_Node, P_Formal_Part_Opt); end if; -- If no Id, must be discrete subtype definition else Set_Discrete_Subtype_Definition (Decl_Node, P_Discrete_Subtype_Definition); T_Right_Paren; Set_Parameter_Specifications (Decl_Node, P_Formal_Part_Opt); end if; end if; -- Error recovery check for illegal return if Token = Tok_Return then Error_Msg_SC ("entry cannot have return value!"); Resync_Past_Semicolon; else TF_Semicolon; end if; return Decl_Node; end P_Entry_Declaration; ----------------------------- -- 9.5.2 Accept Statement -- ----------------------------- -- ACCEPT_STATEMENT ::= -- accept entry_DIRECT_NAME -- [(ENTRY_INDEX)] PARAMETER_PROFILE [do -- HANDLED_SEQUENCE_OF_STATEMENTS -- end [entry_IDENTIFIER]]; -- The caller has checked that the initial token is ACCEPT -- Error recovery: cannot raise Error_Resync. If an error occurs, the -- scan is resynchronized past the next semicolon and control returns. function P_Accept_Statement return Node_Id is Scan_State : Saved_Scan_State; Accept_Node : Node_Id; begin Push_Scope_Stack; Scope.Table (Scope.Last).Sloc := Token_Ptr; Scope.Table (Scope.Last).Ecol := Start_Column; Accept_Node := New_Node (N_Accept_Statement, Token_Ptr); Scan; -- past ACCEPT Scope.Table (Scope.Last).Labl := Token_Node; Set_Accept_Name (Accept_Node, P_Identifier); -- Left paren could be (Entry_Index) or Formal_Part, determine which if Token = Tok_Left_Paren then Save_Scan_State (Scan_State); -- at left paren Scan; -- past left paren -- If first token after left paren not identifier, then Entry_Index if Token /= Tok_Identifier then Set_Entry_Index (Accept_Node, P_Expression); T_Right_Paren; Set_Parameter_Specifications (Accept_Node, P_Formal_Part_Opt); -- First token after left paren is identifier, could be either case else -- Token = Tok_Identifier Scan; -- past identifier -- If identifier followed by comma or colon, must be Formal_Part if Token = Tok_Comma or else Token = Tok_Colon then Restore_Scan_State (Scan_State); -- to left paren Set_Parameter_Specifications (Accept_Node, P_Formal_Part_Opt); -- If identifier not followed by comma/colon, must be entry index else Restore_Scan_State (Scan_State); -- to left paren Scan; -- past left paren (again!) Set_Entry_Index (Accept_Node, P_Expression); T_Right_Paren; Set_Parameter_Specifications (Accept_Node, P_Formal_Part_Opt); end if; end if; end if; -- Scan out DO if present if Token = Tok_Do then Scope.Table (Scope.Last).Etyp := E_Name; Scope.Table (Scope.Last).Lreq := False; Scan; -- past DO Set_Handled_Statement_Sequence (Accept_Node, P_Handled_Sequence_Of_Statements); End_Statements; else Pop_Scope_Stack; -- discard unused entry TF_Semicolon; end if; return Accept_Node; -- If error, resynchronize past semicolon exception when Error_Resync => Resync_Past_Semicolon; return Error; end P_Accept_Statement; ---------------------- -- 9.7 Entry Index -- ---------------------- -- Parsed by P_Expression (4.4) --------------------- -- 9.7 Entry Body -- --------------------- -- ENTRY_BARRIER ::= when CONDITION -- ENTRY_BODY ::= -- entry DEFINING_IDENTIFIER ENTRY_BODY_FORMAL_PART ENTRY_BARRIER is -- DECLARATIVE_PART -- begin -- HANDLED_SEQUENCE_OF_STATEMENTS -- end [entry_IDENTIFIER]; -- ENTRY_BARRIER ::= when CONDITION -- The caller has checked that the initial token is ENTRY -- Error_Recovery: cannot raise Error_Resync function P_Entry_Body return Node_Id is Entry_Node : Node_Id; Iterator_Node : Node_Id; Name_Node : Node_Id; begin Push_Scope_Stack; Entry_Node := New_Node (N_Entry_Body, Token_Ptr); Scan; -- past ENTRY Scope.Table (Scope.Last).Ecol := Start_Column; Scope.Table (Scope.Last).Lreq := False; Scope.Table (Scope.Last).Etyp := E_Name; Name_Node := P_Defining_Identifier; Set_Defining_Identifier (Entry_Node, Name_Node); Scope.Table (Scope.Last).Labl := Name_Node; Set_Entry_Body_Formal_Part (Entry_Node, P_Entry_Body_Formal_Part); if Token = Tok_When then Scan; -- past WHEN; Set_Condition (Entry_Node, P_Expression_No_Right_Paren); T_Is; else T_When; -- to give error message Set_Condition (Entry_Node, Error); TF_Is; end if; P_Decls_Begin_End (Entry_Node); return Entry_Node; end P_Entry_Body; --------------------------------- -- 9.7 Entry Body Formal Part -- --------------------------------- -- ENTRY_BODY_FORMAL_PART ::= -- [(ENTRY_INDEX_SPECIFICATION)] [FORMAL_PART] -- Error_Recovery: cannot raise Error_Resync function P_Entry_Body_Formal_Part return Node_Id is Fpart_Node : Node_Id; Scan_State : Saved_Scan_State; begin Fpart_Node := New_Node (N_Entry_Body_Formal_Part, Token_Ptr); -- See if entry index specification present, and if so parse it if Token = Tok_Left_Paren then Save_Scan_State (Scan_State); -- at left paren Scan; -- past left paren if Token = Tok_For then Set_Entry_Index_Specification (Fpart_Node, P_Entry_Index_Specification); T_Right_Paren; else Restore_Scan_State (Scan_State); -- to left paren end if; end if; Set_Parameter_Specifications (Fpart_Node, P_Formal_Part_Opt); return Fpart_Node; end P_Entry_Body_Formal_Part; ------------------------ -- 9.7 Entry Barrier -- ------------------------ -- Parsed by P_Entry_Body (9.7) -------------------------------------- -- 9.5.2 Entry Index Specification -- -------------------------------------- -- ENTRY_INDEX_SPECIFICATION ::= -- for DEFINING_IDENTIFIER in DISCRETE_SUBTYPE_DEFINITION -- Error recovery: can raise Error_Resync function P_Entry_Index_Specification return Node_Id is Iterator_Node : Node_Id; begin Iterator_Node := New_Node (N_Entry_Index_Specification, Token_Ptr); T_For; -- past FOR Set_Defining_Identifier (Iterator_Node, P_Defining_Identifier); T_In; Set_Discrete_Subtype_Definition (Iterator_Node, P_Discrete_Subtype_Definition); return Iterator_Node; end P_Entry_Index_Specification; --------------------------------- -- 9.5.3 Entry Call Statement -- --------------------------------- -- Parsed by Call_Name (4.1). Within a select, an entry call is parsed -- by P_Select_Statement (9.7) ------------------------------ -- 9.5.4 Requeue Statement -- ------------------------------ -- REQUEUE_STATEMENT ::= requeue entry_NAME [with abort]; -- The caller has checked that the initial token is requeue -- Error recovery: can raise Error_Resync function P_Requeue_Statement return Node_Id is Requeue_Node : Node_Id; begin Requeue_Node := New_Node (N_Requeue_Statement, Token_Ptr); Scan; -- past REQUEUE Set_Name (Requeue_Node, P_Name); if Token = Tok_With then Scan; -- past WITH T_Abort; Set_Abort_Present (Requeue_Node, True); end if; TF_Semicolon; return Requeue_Node; end P_Requeue_Statement; -------------------------- -- 9.6 Delay Statement -- -------------------------- -- DELAY_STATEMENT ::= -- DELAY_UNTIL_STATEMENT -- | DELAY_RELATIVE_STATEMENT -- DELAY_UNTIL_STATEMENT ::= delay until delay_EXPRESSION; -- DELAY_RELATIVE_STATEMENT ::= delay delay_EXPRESSION; -- The caller has checked that the initial token is DELAY -- Error recovery: cannot raise Error_Resync function P_Delay_Statement return Node_Id is Delay_Node : Node_Id; Delay_Sloc : Source_Ptr; Expr_Node : Node_Id; begin Delay_Sloc := Token_Ptr; Scan; -- past DELAY -- The following check for delay until misused in Ada 83 doesn't catch -- all cases, but it's good enough to catch most of them! if Token_Name = Name_Until then Check_9X_Keyword (Tok_Until, Tok_Left_Paren); Check_9X_Keyword (Tok_Until, Tok_Identifier); end if; if Token = Tok_Until then Delay_Node := New_Node (N_Delay_Until_Statement, Delay_Sloc); Scan; -- past UNTIL else Delay_Node := New_Node (N_Delay_Relative_Statement, Delay_Sloc); end if; Expr_Node := P_Expression_No_Right_Paren; if Nkind (Delay_Node) = N_Delay_Relative_Statement then Check_Simple_Expression_In_Ada_83 (Expr_Node); end if; Set_Expression (Delay_Node, Expr_Node); TF_Semicolon; return Delay_Node; end P_Delay_Statement; -------------------------------- -- 9.6 Delay Until Statement -- -------------------------------- -- Parsed by P_Delay_Statement (9.6) ----------------------------------- -- 9.6 Delay Relative Statement -- ----------------------------------- -- Parsed by P_Delay_Statement (9.6) --------------------------- -- 9.7 Select Statement -- --------------------------- -- SELECT_STATEMENT ::= -- SELECTIVE_ACCEPT -- | CONDITIONAL_ENTRY_CALL -- | TIMED_ENTRY_CALL -- | ASYNCHRONOUS_SELECT -- SELECTIVE_ACCEPT ::= -- select -- [GUARD] -- SELECT_ALTERNATIVE -- {or -- [GUARD] -- SELECT_ALTERNATIVE -- [else -- SEQUENCE_OF_STATEMENTS] -- end select; -- GUARD ::= when CONDITION => -- Note: the guard preceding a select alternative is included as part -- of the node generated for a selective accept alternative. -- SELECT_ALTERNATIVE ::= -- ACCEPT_ALTERNATIVE | DELAY_ALTERNATIVE | TERMINATE_ALTERNATIVE -- TIMED_ENTRY_CALL ::= -- select -- ENTRY_CALL_ALTERNATIVE -- or -- DELAY_ALTERNATIVE -- end select; -- CONDITIONAL_ENTRY_CALL ::= -- select -- ENTRY_CALL_ALTERNATIVE -- else -- SEQUENCE_OF_STATEMENTS -- end select; -- ENTRY_CALL_ALTERNATIVE ::= -- ENTRY_CALL_STATEMENT [SEQUENCE_OF_STATEMENTS] -- ASYNCHRONOUS_SELECT ::= -- select -- TRIGGERING_ALTERNATIVE -- then abort -- ABORTABLE_PART -- end select; -- TRIGGERING_ALTERNATIVE ::= -- TRIGGERING_STATEMENT [SEQUENCE_OF_STATEMENTS] -- TRIGGERING_STATEMENT ::= ENTRY_CALL_STATEMENT | DELAY_STATEMENT -- The caller has checked that the initial token is SELECT -- Error recovery: can raise Error_Resync function P_Select_Statement return Node_Id is Select_Node : Node_Id; Select_Sloc : Source_Ptr; Stmnt_Sloc : Source_Ptr; Ecall_Node : Node_Id; Alternative : Node_Id; Statement_List : List_Id; Alt_List : List_Id; Cond_Expr : Node_Id; Delay_Stmnt : Node_Id; begin Push_Scope_Stack; Scope.Table (Scope.Last).Etyp := E_Select; Scope.Table (Scope.Last).Ecol := Start_Column; Scope.Table (Scope.Last).Sloc := Token_Ptr; Scope.Table (Scope.Last).Labl := Error; Select_Sloc := Token_Ptr; Scan; -- past SELECT Stmnt_Sloc := Token_Ptr; -- If first token after select is designator, then we have an entry -- call, which must be the start of a conditional entry call, timed -- entry call or asynchronous select if Token in Token_Class_Desig then -- Scan entry call statement begin Ecall_Node := P_Call_Name; if Expr_Form = EF_Name then Error_Msg_SP ("entry name expected"); end if; TF_Semicolon; exception when Error_Resync => Resync_Past_Semicolon; return Error; end; Statement_List := P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm); -- OR follows, we have a timed entry call if Token = Tok_Or then Scan; -- past OR Select_Node := New_Node (N_Timed_Entry_Call, Select_Sloc); Set_Entry_Call_Alternative (Select_Node, Make_Entry_Call_Alternative (Stmnt_Sloc, Entry_Call_Statement => Ecall_Node, Statements => Statement_List)); -- Only possibility is delay alternative. If we have anything -- else, give message, and treat as conditional entry call. if Token /= Tok_Delay then Error_Msg_SC ("only allowed alternative in timed entry call is delay!"); Discard_Junk_List (P_Sequence_Of_Statements (SS_Sreq)); Set_Delay_Alternative (Select_Node, Error); else Set_Delay_Alternative (Select_Node, P_Delay_Alternative); end if; -- ELSE follows, we have a conditional entry call elsif Token = Tok_Else then Scan; -- past ELSE Select_Node := New_Node (N_Conditional_Entry_Call, Select_Sloc); Set_Entry_Call_Alternative (Select_Node, Make_Entry_Call_Alternative (Stmnt_Sloc, Entry_Call_Statement => Ecall_Node, Statements => Statement_List)); Set_Else_Statements (Select_Node, P_Sequence_Of_Statements (SS_Sreq)); -- Only remaining case is THEN ABORT (asynchronous select) elsif Token = Tok_Abort then Select_Node := Make_Asynchronous_Select (Select_Sloc, Triggering_Alternative => Make_Triggering_Alternative (Stmnt_Sloc, Triggering_Statement => Ecall_Node, Statements => Statement_List), Abortable_Part => P_Abortable_Part); -- Else error else if Ada_83 then Error_Msg_BC ("OR or ELSE expected"); else Error_Msg_BC ("OR or ELSE or THEN ABORT expected"); end if; Select_Node := Error; end if; End_Statements; -- Here we have a selective accept or an an asynchronous select (first -- token after SELECT is other than a designator token). else -- If we have delay with no guard, could be asynchronous select if Token = Tok_Delay then Delay_Stmnt := P_Delay_Statement; Statement_List := P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm); -- Asynchronous select if Token = Tok_Abort then Select_Node := Make_Asynchronous_Select (Select_Sloc, Triggering_Alternative => Make_Triggering_Alternative (Stmnt_Sloc, Triggering_Statement => Delay_Stmnt, Statements => Statement_List), Abortable_Part => P_Abortable_Part); End_Statements; return Select_Node; -- Delay which was not an asyncrhonous select. Must be a selective -- accept, and since at least one accept statement is required, -- we must have at least one OR phrase present. else Alt_List := New_List_1 ( Make_Delay_Alternative (Stmnt_Sloc, Delay_Statement => Delay_Stmnt, Statements => Statement_List)); T_Or; end if; -- If not a delay statement, then must be another possibility -- for a selective accept alternative, or perhaps a guard is present else Alt_List := New_List; end if; Select_Node := New_Node (N_Selective_Accept, Select_Sloc); Set_Selective_Accept_Alternatives (Select_Node, Alt_List); -- Scan out selective accept alternatives loop if Token = Tok_When then Scan; -- past WHEN Cond_Expr := P_Expression_No_Right_Paren; T_Arrow; else Cond_Expr := Empty; end if; if Token = Tok_Accept then Alternative := P_Accept_Alternative; -- Check for junk attempt at asynchronous select using -- an Accept alternative as the triggering statement if Token = Tok_Abort and then Is_Empty_List (Alt_List) and then No (Cond_Expr) then Error_Msg ("triggering statement must be entry call or delay", Sloc (Alternative)); Scan; -- past junk ABORT Discard_Junk_List (P_Sequence_Of_Statements (SS_Sreq)); End_Statements; return Error; end if; elsif Token = Tok_Delay then Alternative := P_Delay_Alternative; elsif Token = Tok_Terminate then Alternative := P_Terminate_Alternative; end if; -- THEN ABORT at this stage is just junk if Token = Tok_Abort then Error_Msg_SP ("misplaced `THEN ABORT`"); Scan; -- past junk ABORT Discard_Junk_List (P_Sequence_Of_Statements (SS_Sreq)); End_Statements; return Error; else exit when Token /= Tok_Or; end if; Append (Alternative, Alt_List); T_Or; end loop; if Token = Tok_Else then Scan; -- past ELSE Set_Else_Statements (Select_Node, P_Sequence_Of_Statements (SS_Ortm_Sreq)); if Token = Tok_Or then Error_Msg_SC ("select alternative cannot follow else part!"); end if; end if; End_Statements; end if; return Select_Node; end P_Select_Statement; ----------------------------- -- 9.7.1 Selective Accept -- ----------------------------- -- Parsed by P_Select_Statement (9.7.1) ------------------ -- 9.7.1 Guard -- ------------------ -- Parsed by P_Select_Statement (9.7.1) ------------------------------- -- 9.7.1 Select Alternative -- ------------------------------- -- SELECT_ALTERNATIVE ::= -- ACCEPT_ALTERNATIVE | DELAY_ALTERNATIVE | TERMINATE_ALTERNATIVE -- Note: the guard preceding a select alternative is included as part -- of the node generated for a selective accept alternative. -- Error recovery: cannot raise Error_Resync ------------------------------- -- 9.7.1 Accept Alternative -- ------------------------------- -- ACCEPT_ALTERNATIVE ::= -- ACCEPT_STATEMENT [SEQUENCE_OF_STATEMENTS] -- Error_Recovery: Cannot raise Error_Resync function P_Accept_Alternative return Node_Id is Accept_Alt_Node : Node_Id; begin Accept_Alt_Node := New_Node (N_Accept_Alternative, Token_Ptr); Set_Accept_Statement (Accept_Alt_Node, P_Accept_Statement); -- Note: the reason that we accept THEN ABORT as a terminator for -- the sequence of statements is for error recovery which allows -- for misuse of an accept statement as a triggering statememt. Set_Statements (Accept_Alt_Node, P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm)); return Accept_Alt_Node; end P_Accept_Alternative; ------------------------------ -- 9.7.1 Delay Alternative -- ------------------------------ -- DELAY_ALTERNATIVE ::= -- DELAY_STATEMENT [SEQUENCE_OF_STATEMENTS] -- Error_Recovery: Cannot raise Error_Resync function P_Delay_Alternative return Node_Id is Delay_Alt_Node : Node_Id; begin Delay_Alt_Node := New_Node (N_Delay_Alternative, Token_Ptr); Set_Delay_Statement (Delay_Alt_Node, P_Delay_Statement); -- Note: the reason that we accept THEN ABORT as a terminator for -- the sequence of statements is for error recovery which allows -- for misuse of an accept statement as a triggering statememt. Set_Statements (Delay_Alt_Node, P_Sequence_Of_Statements (SS_Eltm_Ortm_Tatm)); return Delay_Alt_Node; end P_Delay_Alternative; ---------------------------------- -- 9.7.1 Terminate Alternative -- ---------------------------------- -- TERMINATE_ALTERNATIVE ::= terminate; -- Error_Recovery: Cannot raise Error_Resync function P_Terminate_Alternative return Node_Id is Terminate_Alt_Node : Node_Id; begin Terminate_Alt_Node := New_Node (N_Terminate_Alternative, Token_Ptr); Scan; -- past TERMINATE TF_Semicolon; return Terminate_Alt_Node; end P_Terminate_Alternative; ----------------------------------- -- 9.7.2 Conditional Entry Call -- ----------------------------------- -- Parsed by P_Select_Statement (9.7) ----------------------------------- -- 9.7.2 Entry_Call_Alternative -- ----------------------------------- -- Parsed by P_Select_Statement (9.7) ----------------------------- -- 9.7.3 Timed Entry Call -- ----------------------------- -- Parsed by P_Select_Statement (9.7) -------------------------------- -- 9.7.4 Asynchronous Select -- -------------------------------- -- Parsed by P_Select_Statement (9.7) ----------------------------------- -- 9.7.4 Triggering Alternative -- ----------------------------------- -- Parsed by P_Select_Statement (9.7) --------------------------------- -- 9.7.4 Triggering Statement -- --------------------------------- -- Parsed by P_Select_Statement (9.7) --------------------------- -- 9.7.4 Abortable Part -- --------------------------- -- ABORTABLE_PART ::= SEQUENCE_OF_STATEMENTS -- The caller has verified that THEN ABORT is present, and Token is -- pointing to the ABORT on entry (or if not, then we have an error) -- Error recovery: cannot raise Error_Resync function P_Abortable_Part return Node_Id is Abortable_Part_Node : Node_Id; begin Abortable_Part_Node := New_Node (N_Abortable_Part, Token_Ptr); T_Abort; -- scan past ABORT if Ada_83 then Error_Msg_SP ("asynchronous select not allowed in Ada-83!"); end if; Set_Statements (Abortable_Part_Node, P_Sequence_Of_Statements (SS_Sreq)); return Abortable_Part_Node; end P_Abortable_Part; -------------------------- -- 9.8 Abort Statement -- -------------------------- -- ABORT_STATEMENT ::= abort task_NAME {, task_NAME}; -- The caller has checked that the initial token is ABORT -- Error recovery: cannot raise Error_Resync function P_Abort_Statement return Node_Id is Abort_Node : Node_Id; begin Abort_Node := New_Node (N_Abort_Statement, Token_Ptr); Scan; -- past ABORT Set_Names (Abort_Node, New_List); loop Append (P_Name, Names (Abort_Node)); exit when Token /= Tok_Comma; Scan; -- past comma end loop; TF_Semicolon; return Abort_Node; end P_Abort_Statement; end Ch9; - Delay which was not an asyncrhonous select. Must be a selective -- accept, and since at least one accept statement is required, gnat-1.67-src/src/par-endh.adb 444 10015 7640 100622 5506244350 11323 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P A R . E N D H -- -- -- -- B o d y -- -- -- -- $Revision: 1.26 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ separate (Par) package body Endh is ---------------- -- Local Data -- ---------------- 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_Type; -- 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 name on END line, or Empty if no name appeared. If -- this is non-empty, then it is either an N_Designator node for a child -- unit or a node with a Chars field that identifies the actual 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 -- or (a special case added in version 1.3) if we have the END RECORD -- case. Since RECORD cannot nest, this is as good as a matching label -- for being sure that we have the right one! 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 : Int); -- 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. 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; -- 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. Note that in the case of a -- suspicious IS, 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. 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 begin -- 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 -- Cases of keywords where no label is allowed if Token = Tok_Case then End_Type := E_Case; End_Labl := Empty; Scan; -- past CASE elsif Token = Tok_If then End_Type := E_If; End_Labl := Empty; Scan; -- past IF elsif Token = Tok_Record then End_Type := E_Record; End_Labl := Empty; Scan; -- past RECORD elsif Token = Tok_Select then End_Type := E_Select; End_Labl := Empty; 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 elsif Token = Tok_For or else Token = Tok_While 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; -- 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 if; end if; -- Here for case of name allowed, but no name present else End_Labl := Empty; if GNAT_Style_Check and then End_Type = E_Name and then Present (Scope.Table (Scope.Last).Labl) then Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl; Error_Msg_SP ("(style) `END &` required"); 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 T_Semicolon; 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 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 Scan; -- past semicolon return; end if; -- Otherwise skip past a token after the END. Note that we skip past -- for or while, to allow END for and END while to substitute for -- END loop (of course an error message has already been issued). if 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 Token = Tok_While 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 Scan; -- past 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 Scan; -- past 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). else while Token /= Tok_End 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 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 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 : Int) 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 := (Token_OK and then End_Type = E_Record) or else (Present (End_Labl) 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; return; end if; -- 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) if Label_OK then Syntax_OK := True; return; end if; -- If there was a label and it did not match, then we definitely -- do have a syntax error. if Present (End_Labl) then Syntax_OK := False; return; end if; -- Otherwise we have cases of no label on the END line. For the loop -- case, this is acceptable only if the loop is unlabeled. if End_Type = E_Loop then Syntax_OK := (Scope.Table (SS_Index).Labl = Empty); return; -- Cases where a label is definitely allowed on the END line elsif End_Type = E_Name then Syntax_OK := (Scope.Table (SS_Index).Labl = Empty or else not Scope.Table (SS_Index).Lreq); return; -- 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; return; end if; end Evaluate_End_Entry; ------------------------ -- 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 is Etype : SS_End_Type; begin Etype := Scope.Table (Scope.Last).Etyp; Error_Msg_Col := Scope.Table (Scope.Last).Ecol; Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl; Error_Msg_Sloc_1 := Scope.Table (Scope.Last).Sloc; if Etype = E_Case then Error_Msg_SC ("`END CASE;` expected@ for CASE on line #!"); elsif Etype = E_If then Error_Msg_SC ("`END IF;` expected@ for IF on line #!"); elsif Etype = E_Loop then if Error_Msg_Node_1 = Empty then Error_Msg_SC ("`END LOOP;` expected@ for LOOP on line #!"); else Error_Msg_SC ("`END LOOP&;` expected@!"); end if; elsif Etype = E_Record then Error_Msg_SC ("`END RECORD;` expected@ for RECORD on line #!"); elsif Etype = E_Select then Error_Msg_SC ("`END SELECT;` expected@ for SELECT on line #!"); elsif Etype = E_Name then if Error_Msg_Node_1 = Empty then Error_Msg_SC ("`END;` expected@ for BEGIN on line #!"); else Error_Msg_SC ("`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 -- Etype = E_Suspicious_Is or E_Bad_Is Scope.Table (Scope.Last).Etyp := E_Bad_Is; end if; end Output_End_Expected; ------------------------ -- Output End Missing -- ------------------------ procedure Output_End_Missing is Etype : SS_End_Type; begin Etype := Scope.Table (Scope.Last).Etyp; Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl; Error_Msg_Sloc_1 := Scope.Table (Scope.Last).Sloc; if Etype = E_Case then Error_Msg_BC ("missing `END CASE;` for CASE on line #!"); elsif Etype = E_If then Error_Msg_BC ("missing `END IF;` for IF on line #!"); elsif Etype = E_Loop then if Error_Msg_Node_1 = Empty then Error_Msg_BC ("missing `END LOOP;` for LOOP on line #!"); else Error_Msg_BC ("missing `END LOOP&;`!"); end if; elsif Etype = E_Record then Error_Msg_SC ("missing `END RECORD;` for RECORD on line #!"); elsif Etype = E_Select then Error_Msg_BC ("missing `END SELECT;` for SELECT on line #!"); elsif Etype = E_Name then if Error_Msg_Node_1 = Empty then Error_Msg_BC ("missing `END;` for BEGIN on line #!"); else Error_Msg_BC ("missing `END&;`!"); end if; else -- Etype = E_Suspicious_Is or E_Bad_Is Scope.Table (Scope.Last).Etyp := E_Bad_Is; end if; end Output_End_Missing; ---------------- -- 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; --------------------- -- Pop End Context -- --------------------- procedure Pop_End_Context is Pretty_Good : Boolean; -- This flag is set True if the END sequence is syntactically incorrect, -- but has the right token type and the right column (this means that -- it is wrong only in lacking a semicolon or having the wrong label) 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 sytax 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. if (Token = Tok_EOF or else Token = Tok_With or else Token = Tok_Separate) and then End_Type >= E_Name and then No (End_Labl) and then Scope.Last > 1 then Restore_Scan_State (Scan_State); -- to END Output_End_Expected; 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 /= Scope.Table (Scope.Last).Ecol and then Current_Line_Start > Scope.Table (Scope.Last).Sloc then Error_Msg_Col := Scope.Table (Scope.Last).Ecol; Error_Msg ("END in wrong column, should be@", End_Sloc); end if; 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. Pretty_Good := Token_OK and (Column_OK or Label_OK); -- 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 I in reverse 1 .. Scope.Last - 1 loop Evaluate_End_Entry (I); -- 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 <= Scope.Table (Scope.Last).Ecol or else (End_Type = Scope.Table (Scope.Last).Etyp and then End_Type = E_Loop) then Output_End_Expected; 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; end Endh; T eat it up in matching the current expected END. begin -- If not at END, then output END expectedgnat-1.67-src/src/par-labl.adb 444 10015 7640 10462 5506244351 11302 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P A R . L A B L -- -- -- -- B o d y -- -- -- -- $Revision: 1.6 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ separate (Par) procedure Labl is Parent_Node : Node_Id; -- Used to climb up parents of label node Label_Decl_Node : Node_Id; -- Implicit label declaration node Defining_Ident_Node : Node_Id; -- Defining identifier node for implicit label declaration Next_Label_Elmt : Elmt_Id; -- Next element on label element list Label_Node : Node_Id; -- Next label node to process begin Next_Label_Elmt := First_Elmt (Label_List); while Next_Label_Elmt /= No_Elmt loop Label_Node := Id_Of (Next_Label_Elmt); -- Climb parents until we find the closest enclosing body or block -- containing a declarative region Parent_Node := Parent (Label_Node); while Present (Parent_Node) and then Nkind (Parent_Node) /= N_Entry_Body and then Nkind (Parent_Node) /= N_Task_Body and then Nkind (Parent_Node) /= N_Package_Body and then Nkind (Parent_Node) /= N_Subprogram_Body and then Nkind (Parent_Node) /= N_Block_Statement loop Parent_Node := Parent (Parent_Node); end loop; -- If we didn't find a parent, then the label in question never got -- hooked into a reasonable declarative part. This happens only in -- error situations, and we simply ignore the entry (we aren't going -- to get into the semantics in any case given the error). if Present (Parent_Node) then -- Now create the implicit label declaration node and its -- corresponding defining identifier. Note that the defining -- occurrence of a label is the implicit label declaration that -- we are creating. The label itself is an applied occurrence. Label_Decl_Node := New_Node (N_Implicit_Label_Declaration, Sloc (Label_Node)); Set_Label (Label_Decl_Node, Label_Node); Defining_Ident_Node := Extend_Node (New_Node (N_Defining_Identifier, Sloc (Identifier (Label_Node)))); Set_Chars (Defining_Ident_Node, Chars (Identifier (Label_Node))); Set_Defining_Identifier (Label_Decl_Node, Defining_Ident_Node); -- Now attach the implicit label declaration to the appropriate -- declarative region, creating a declaration list if none exists if not List_Present (Declarations (Parent_Node)) then Set_Declarations (Parent_Node, New_List); end if; Append (Label_Decl_Node, Declarations (Parent_Node)); end if; Next_Label_Elmt := Next_Elmt (Next_Label_Elmt); end loop; end Labl; MERCHANT- -- -- ABILITY 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 witgnat-1.67-src/src/par-load.adb 444 10015 7640 20072 5506244351 11305 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P A R . L O A D -- -- -- -- B o d y -- -- -- -- $Revision: 1.16 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- The Lib_Load procedure loads all units that are definitely required before -- it makes any sense at all to proceed with semantic analysis, including -- with'ed units, corresponding specs for bodies, parents of child specs, -- and parents of subunits. All these units are loaded and pointers installed -- in the tree as described in the spec of package Lib. with Fname; use Fname; with Uname; use Uname; separate (Par) procedure Load is File_Name : File_Name_Type; -- Name of file for current unit, derived from unit name Cur_Unum : Unit_Number_Type := Scan_Unit; -- Unit number of unit that we just finished parsing. Note that we need -- to capture this, because Scan_Unit will change as we parse new sources. Cunit : constant Node_Id := File.Table (Cur_Unum).Cunit; -- Compilation unit node for current compilation unit With_Cunit : Node_Id; -- Compilation unit node for withed unit Context_Node : Node_Id; -- Next node in context items list With_Node : Node_Id; -- N_With_Clause node Spec_Name : Unit_Name_Type; -- Unit name of required spec Body_Name : Unit_Name_Type; -- Unit name of corresponding body Unum : Unit_Number_Type; -- Unit number of loaded unit Spec_Node : Node_Id; -- Package spec node begin -- Don't do any loads if we already had a fatal error if File.Table (Cur_Unum).Fatal_Error then return; end if; -- First step, make sure that the unit name matches the file name -- Do this only if no errors have been detected, since otherwise it -- may well not be interesting, and moreover, blowups are possible -- if no good name was found. File_Name := Get_File_Name (File.Table (Cur_Unum).Unit_Name); if File_Name /= File.Table (Cur_Unum).File_Name then Error_Msg_Name_1 := File_Name; Error_Msg ("?file name does not match unit name, should be{", Sloc (Cunit)); end if; -- Now we load with'ed units, loop through context items Context_Node := First (Context_Items (Cunit)); while Present (Context_Node) loop if Nkind (Context_Node) = N_With_Clause then With_Node := Context_Node; Spec_Name := Get_Unit_Name (With_Node); Unum := Lib.Load (Spec_Name, False, With_Node); -- If we find the unit, then set spec pointer in the N_With_Clause -- to point to the compilation unit for the spec. Remember that -- the Load routine itself sets our Fatal_Error flag if the loaded -- unit gets a fatal error, so we don't need to worry about that. if Unum /= No_Unit then Set_Library_Unit (With_Node, File.Table (Unum).Cunit); -- If the spec isn't found, then try finding the corresponding -- body, since it is possible that we have a subprogram body -- that is acting as a spec (since no spec is present). else Body_Name := Get_Body_Name (Spec_Name); Unum := Lib.Load (Body_Name, False, With_Node); -- If we got a subprogram body, then mark that we are using -- the body as a spec in the file table, and set the spec -- pointer in the N_With_Clause to point to the body entity. if Unum /= No_Unit and then Nkind (Unit (File.Table (Unum).Cunit)) = N_Subprogram_Body then File.Table (Unum).Body_Spec := True; With_Cunit := File.Table (Unum).Cunit; Set_Library_Unit (With_Node, With_Cunit); Set_Acts_As_Spec (With_Cunit, True); Set_Library_Unit (With_Cunit, With_Cunit); -- If we couldn't find the body, or if it wasn't a body spec -- then we are in trouble. We make one more call to Load to -- require the spec. We know it will fail of course, the -- purpose is to generate the required error message (we prefer -- that this message refer to the missing spec, not the body) else Unum := Lib.Load (Spec_Name, True, With_Node); end if; end if; end if; Context_Node := Next (Context_Node); end loop; -- If current unit is a body, load its corresponding spec if Nkind (Unit (Cunit)) = N_Package_Body or else Nkind (Unit (Cunit)) = N_Subprogram_Body then Spec_Name := Get_Spec_Name (File.Table (Cur_Unum).Unit_Name); Unum := Lib.Load (Spec_Name, False, Cunit); -- If we successfully load the unit, then set the spec pointer. Once -- again note that if the loaded unit has a fatal error, Load will -- have set our Fatal_Error flag to propagate this condition. if Unum /= No_Unit then Set_Library_Unit (Cunit, File.Table (Unum).Cunit); -- If we don't find the spec, then if we have a subprogram body, we -- are still OK, we just have a case of a body acting as its own spec elsif Nkind (Unit (Cunit)) = N_Subprogram_Body then Set_Acts_As_Spec (Cunit, True); Set_Library_Unit (Cunit, Cunit); -- Otherwise we do have an error, repeat the load request for the spec -- with Required set True to generate an appropriate error message. else Unum := Lib.Load (Spec_Name, True, Cunit); end if; -- If current unit is a child unit spec, load its parent elsif Nkind (Unit (Cunit)) = N_Package_Declaration or else Nkind (Unit (Cunit)) = N_Subprogram_Declaration or else Nkind (Unit (Cunit)) in N_Generic_Declaration or else Nkind (Unit (Cunit)) in N_Generic_Instantiation or else Nkind (Unit (Cunit)) in N_Renaming_Declaration then Spec_Name := Get_Parent_Spec_Name (File.Table (Cur_Unum).Unit_Name); if Spec_Name /= No_Name then Unum := Lib.Load (Spec_Name, True, Cunit); if Unum /= No_Unit then Set_Parent_Spec (Unit (Cunit), File.Table (Unum).Cunit); end if; end if; -- If current unit is a subunit, then load its parent body elsif Nkind (Unit (Cunit)) = N_Subunit then Body_Name := Get_Parent_Body_Name (File.Table (Cur_Unum).Unit_Name); Unum := Lib.Load (Body_Name, True, Cunit); if Unum /= No_Unit then Set_Library_Unit (Cunit, File.Table (Unum).Cunit); end if; end if; end Load; pointers installed -- in the tree as described in the spec of package Lib. with Fname; use Fname; with Uname; use Uname; separate (Par) procedure Load is File_Name : File_Name_Type; -- Name of file for current unit, derived from unit name Cur_Unum : Unit_Number_Type := Scan_Unit; -- Unit number of unit that we just finished parsing. Note that we need -- to capture this, because Scan_Unit will change as we parse new sources. gnat-1.67-src/src/par-prag.adb 444 10015 7640 120023 5506244352 11335 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P A R . P R A G -- -- -- -- B o d y -- -- -- -- $Revision: 1.45 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This function performs syntax checking on pragmas. Exactly what is syntax -- and what is semantics is not always clear. A documentation line called -- syntax check identifies the checks that are made in each case. The -- remaining semantic checks are in the subunit Sem.Prag. Note that in -- all cases (except pragma Restrictions), the syntax check includes -- checking for appropriate presence of identifiers in pragma arguments. -- Note that the checks here do *not* include any placement checks, since -- this routine is called at a point where the pragma node has not been -- linked into the tree. separate (Par) function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is Pragma_Id_Node : constant Node_Id := Identifier (Pragma_Node); Pragma_Sloc : constant Source_Ptr := Sloc (Pragma_Node); Nargs : Nat; Arg_Node : Node_Id; Expr_Node : Node_Id; ----------------------- -- Local Subprograms -- ----------------------- function Arg1 return Node_Id; function Arg2 return Node_Id; function Arg3 return Node_Id; -- Obtain specified Pragma_Argument_Association procedure Check_Ada_83_Warning; -- Issues a warning message for the current pragma if operating in Ada 83 -- mode (used for language pragmas that are not a standard part of Ada 83). -- This procedure does not raise Error_Resync. procedure Check_Ada_9X_Warning; -- Issues a warning message for the current pragma if operating in Ada 9X -- mode (used for pragmas that are now obsolete in Ada 9X). This procedure -- does not raise Error_Resync. procedure Check_Arg_Count (Required : Int); -- Check argument count for pragma = Required. -- If not give error and raise Error_Resync. procedure Check_At_Least_One_Argument; -- Check there is at least one argument. -- If not give error and raise Error_Resync. procedure Check_Expression_Is_Convention (Arg : Node_Id); -- Check the expression of the specified argument to make sure that it -- is a valid convention name. If not give error and raise Error_Resync. -- This procedure also checks for the possible allowed presence of the -- identifier Convention for this argument. procedure Check_Expression_Is_Entity (Arg : Node_Id); -- Check the expression of the specified argument to make sure that it -- is a valid entity name (i.e. either an identifier or an operator -- symbol). If not, give an error and raise Error_Resync. This procedure -- also checks for the possible allowed presence of the identifier -- Entity for this argument. procedure Check_Expression_Is_Identifier (Arg : Node_Id); -- Check the expression of the specified argument to make sure that it -- is an identifier. If not give error and raise Error_Resync. procedure Check_Expression_Is_Integer_Literal (Arg : Node_Id); -- Check the expression of the specified argument to make sure that it -- is an integer literal. If not give error and raise Error_Resync. procedure Check_Expression_Is_Library_Unit_Name (Arg : Node_Id); -- Check the expression of the specified argument to make sure that it -- is of the form of a library unit name, i.e. that it is an identifier -- or a selected component with a selector name that is itself an -- identifier. If not of this form, give error and raise Error_Resync. procedure Check_Expression_Is_Locking_Policy (Arg : Node_Id); -- Check the expression of the specified argument to make sure that it is -- a valid locking policy name. If not give error and raise Error_Resync. procedure Check_Expression_Is_Queuing_Policy (Arg : Node_Id); -- Check the expression of the specified argument to make sure that it is -- a valid queuing policy name. If not give error and raise Error_Resync. procedure Check_Expression_Is_Task_Dispatching_Policy (Arg : Node_Id); -- Check the expression of the specified argument to make sure that it is -- a valid task dispatching policy name. If not give error and raise -- Error_Resync. procedure Check_Expression_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id); -- Check the expression of the specified argument to make sure that it -- is an identifier whose name matches either N1 or N2. If not, then -- issue an error message and raise Error_Resync. procedure Check_Library_Unit_Pragma; -- Library unit pragmas (10.1.5) have at most one argument, which must -- be the current compilation unit. procedure Check_No_Identifier (Arg : Node_Id); -- Checks that the given argument does not have an identifier. If an -- identifier is present, then an error message is issued, and -- Error_Resync is raised. procedure Check_No_Identifiers; -- Checks that none of the arguments to the pragma has an identifier. -- If any argument has an identifier, then an error message is issued, -- and Error_Resync is raised. procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id); -- Checks if the given argument has an identifier, and if so, requires -- it to match the given identifier name. If there is a non-matching -- identifier, then an error message is given and Error_Resync raised. -------------- -- Arg1,2,3 -- -------------- function Arg1 return Node_Id is begin return First (Pragma_Argument_Associations (Pragma_Node)); end Arg1; function Arg2 return Node_Id is begin return Next (Arg1); end Arg2; function Arg3 return Node_Id is begin return Next (Arg2); end Arg3; -------------------------- -- Check_Ada_83_Warning -- -------------------------- procedure Check_Ada_83_Warning is begin if Ada_83 then Error_Msg ("pragma& is not standard in Ada 83?", Pragma_Sloc); end if; -- Put back the node for subsequent error messages, because this is a -- situation where we do not raise Error_Resync and get out immediately Error_Msg_Node_1 := Pragma_Id_Node; end Check_Ada_83_Warning; -------------------------- -- Check_Ada_9X_Warning -- -------------------------- procedure Check_Ada_9X_Warning is begin if Ada_9X then Error_Msg ("pragma& is obsolete in Ada 9X?", Pragma_Sloc); end if; -- Put back the node for subsequent error messages, because this is a -- situation where we do not raise Error_Resync and get out immediately Error_Msg_Node_1 := Pragma_Id_Node; end Check_Ada_9X_Warning; --------------------- -- Check_Arg_Count -- --------------------- procedure Check_Arg_Count (Required : Int) is begin if Nargs /= Required then Error_Msg ("wrong number of arguments for pragma&", Pragma_Sloc); raise Error_Resync; end if; end Check_Arg_Count; --------------------------------- -- Check_At_Least_One_Argument -- --------------------------------- procedure Check_At_Least_One_Argument is begin if Nargs = 0 then Error_Msg ("pragma& requires at least one argument", Pragma_Sloc); raise Error_Resync; end if; end Check_At_Least_One_Argument; ------------------------------------ -- Check_Expression_Is_Convention -- ------------------------------------ procedure Check_Expression_Is_Convention (Arg : Node_Id) is begin Check_Expression_Is_Identifier (Arg); Check_Optional_Identifier (Arg, Name_Convention); if not Is_Convention_Name (Chars (Expression (Arg))) then Error_Msg ("argument of pragma& is not valid convention name", Sloc (Expression (Arg))); raise Error_Resync; end if; end Check_Expression_Is_Convention; -------------------------------- -- Check_Expression_Is_Entity -- -------------------------------- procedure Check_Expression_Is_Entity (Arg : Node_Id) is begin if Nkind (Expression (Arg)) /= N_Operator_Symbol then Check_Expression_Is_Identifier (Arg); end if; Check_Optional_Identifier (Arg, Name_Entity); end Check_Expression_Is_Entity; ------------------------------------ -- Check_Expression_Is_Identifier -- ------------------------------------ procedure Check_Expression_Is_Identifier (Arg : Node_Id) is begin if Nkind (Expression (Arg)) /= N_Identifier then Error_Msg ("argument for pragma& must be identifier", Sloc (Expression (Arg))); raise Error_Resync; end if; end Check_Expression_Is_Identifier; ----------------------------------------- -- Check_Expression_Is_Integer_Literal -- ----------------------------------------- procedure Check_Expression_Is_Integer_Literal (Arg : Node_Id) is begin if Nkind (Expression (Arg)) /= N_Integer_Literal then Error_Msg ("argument for pragma& must be integer literal", Sloc (Expression (Arg))); raise Error_Resync; end if; end Check_Expression_Is_Integer_Literal; ------------------------------------------- -- Check_Expression_Is_Library_Unit_Name -- ------------------------------------------- procedure Check_Expression_Is_Library_Unit_Name (Arg : Node_Id) is Argx : constant Node_Id := Expression (Arg); begin if Nkind (Argx) /= N_Identifier and then (Nkind (Argx) /= N_Selected_Component or else Nkind (Selector_Name (Argx)) /= N_Identifier) then Error_Msg ("argument for pragma& must be library unit name", Sloc (Argx)); raise Error_Resync; end if; end Check_Expression_Is_Library_Unit_Name; ---------------------------------------- -- Check_Expression_Is_Locking_Policy -- ---------------------------------------- procedure Check_Expression_Is_Locking_Policy (Arg : Node_Id) is begin Check_Expression_Is_Identifier (Arg); if not Is_Locking_Policy_Name (Chars (Expression (Arg))) then Error_Msg ("argument of pragma& is not valid locking policy name", Sloc (Expression (Arg))); raise Error_Resync; end if; end Check_Expression_Is_Locking_Policy; ---------------------------------------- -- Check_Expression_Is_Queuing_Policy -- ---------------------------------------- procedure Check_Expression_Is_Queuing_Policy (Arg : Node_Id) is begin Check_Expression_Is_Identifier (Arg); if not Is_Queuing_Policy_Name (Chars (Expression (Arg))) then Error_Msg ("argument of pragma& is not valid queuing policy name", Sloc (Expression (Arg))); raise Error_Resync; end if; end Check_Expression_Is_Queuing_Policy; ------------------------------------------------- -- Check_Expression_Is_Task_Dispatching_Policy -- ------------------------------------------------- procedure Check_Expression_Is_Task_Dispatching_Policy (Arg : Node_Id) is begin Check_Expression_Is_Identifier (Arg); if not Is_Task_Dispatching_Policy_Name (Chars (Expression (Arg))) then Error_Msg ("argument of pragma& is not valid task dispatching policy name", Sloc (Expression (Arg))); raise Error_Resync; end if; end Check_Expression_Is_Task_Dispatching_Policy; -------------------------------- -- Check_Expression_Is_One_Of -- -------------------------------- procedure Check_Expression_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is Argx : constant Node_Id := Expression (Arg); begin Check_Expression_Is_Identifier (Arg); if Chars (Argx) /= N1 and then Chars (Argx) /= N2 then Error_Msg_Name_1 := N1; Error_Msg_Name_2 := N2; Error_Msg ("argument for pragma& must be% or%", Sloc (Argx)); raise Error_Resync; end if; end Check_Expression_Is_One_Of; ------------------------------- -- Check_Library_Unit_Pragma -- ------------------------------- procedure Check_Library_Unit_Pragma is begin Check_Ada_83_Warning; if Nargs /= 0 then Check_No_Identifiers; Check_Arg_Count (1); Check_Expression_Is_Library_Unit_Name (Arg1); end if; end Check_Library_Unit_Pragma; ------------------------- -- Check_No_Identifier -- ------------------------- procedure Check_No_Identifier (Arg : Node_Id) is begin if Present (Identifier (Arg)) then Error_Msg ("pragma& does not permit named arguments", Sloc (Identifier (Arg_Node))); raise Error_Resync; end if; end Check_No_Identifier; -------------------------- -- Check_No_Identifiers -- -------------------------- procedure Check_No_Identifiers is begin if Nargs > 0 then Arg_Node := Arg1; while Present (Arg_Node) loop Check_No_Identifier (Arg_Node); Arg_Node := Next (Arg_Node); end loop; end if; end Check_No_Identifiers; ------------------------------- -- Check_Optional_Identifier -- ------------------------------- procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is begin if Present (Arg) and then Present (Identifier (Arg)) then if Chars (Identifier (Arg)) /= Id then Error_Msg_Name_1 := Id; Error_Msg ("pragma& argument expects identifier%", Sloc (Identifier (Arg))); raise Error_Resync; end if; end if; end Check_Optional_Identifier; ---------- -- Prag -- ---------- begin Error_Msg_Node_1 := Pragma_Id_Node; -- Count number of arguments. This loop also checks if any of the arguments -- are Error, indicating a syntax error as they were parsed. If so, we -- simply return, because we get into trouble with cascaded errors if we -- try to perform our error checks on junk arguments. Nargs := 0; if List_Present (Pragma_Argument_Associations (Pragma_Node)) then Arg_Node := Arg1; while Arg_Node /= Empty loop Nargs := Nargs + 1; if Expression (Arg_Node) = Error then return Error; end if; Arg_Node := Next (Arg_Node); end loop; end if; -- Remaining processing is pragma dependent case Get_Pragma_Id (Chars (Pragma_Id_Node)) is ------------------------ -- Abort_Defer (GNAT) -- ------------------------ -- pragma Abort_Defer; -- This pragma is implementation (GNAT) defined. It must appear at -- the start of the statement sequence of a handled sequence of -- statements (right after the begin). It has the effect of deferring -- aborts for the sequence of statements (but not for the declarations -- or handlers, if any, associated with this statement sequence). -- Syntax check: no arguments when Pragma_Abort_Defer => Check_Arg_Count (0); ------------------- -- Ada_83 (GNAT) -- ------------------- -- pragma Ada_83; -- This pragma is implementation (GNAT) defined. Its effect is to -- establish Ada 83 mode for the remainder of current unit, regardless -- of the mode set by the command line switches. -- Syntax check: no arguments when Pragma_Ada_83 => Check_Arg_Count (0); Ada_83 := True; Ada_9X := False; ------------------- -- Ada_9X (GNAT) -- ------------------- -- pragma Ada_9X; -- This pragma is implementation (GNAT) defined. Its effect is to -- establish Ada 9X for the remainder of the current unit, regardless -- of the mode set by the command line switches. -- Syntax check: no arguments when Pragma_Ada_9X => Check_Arg_Count (0); Ada_83 := False; Ada_9X := True; ------------------------------ -- All_Calls_Remote (I.2.3) -- ------------------------------ -- pragma All_Calls_Remote (library_package_NAME); -- Syntax check: one argument when Pragma_All_Calls_Remote => Check_Ada_83_Warning; Check_No_Identifiers; Check_Arg_Count (1); ------------------- -- Assert (GNAT) -- ------------------- -- pragma Assert (Boolean_EXPRESSION [,PROCEDURE_CALL_STATEMENT]); -- This pragma is implementation (GNAT) defined. Its effect depends -- on the setting of the Assertions_Enabled flag in Opt. If this -- flag is off (False), then the pragma has no effect. If the flag -- is on (True), then the semantics of the pragma is equivalent to: -- if not Boolean_EXPRESSION then -- [PROCEDURE_CALL_STATEMENT;] -- raise System.Assertions.Assert_Failure; -- end if; -- Syntax check: one or two arguments. The second argument, if present, -- is of the form of a procedure call, which is parsed either as a name -- or as a function call. It is then converted to the corresponding -- procedure call. when Pragma_Assert => Check_No_Identifiers; if Nargs /= 2 then Check_Arg_Count (1); else declare Expr : constant Node_Id := New_Copy (Expression (Arg2)); begin if Nkind (Expr) /= N_Indexed_Component and then Nkind (Expr) /= N_Function_Call and then Nkind (Expr) /= N_Identifier and then Nkind (Expr) /= N_Selected_Component then Error_Msg ("2nd arg of pragma& is not procedure call", Sloc (Expr)); raise Error_Resync; else Set_Debug_Statement (Pragma_Node, P_Statement_Call_Name (Expr)); end if; end; end if; -------------------------- -- Asynchronous (I.4.1) -- -------------------------- -- pragma All_synchronous (DIRECT_NAME); -- Syntax check: one argument, which must be an identifier when Pragma_Asynchronous => Check_Ada_83_Warning; Check_No_Identifiers; Check_Arg_Count (1); Check_Expression_Is_Identifier (Arg1); ------------------ -- Atomic (G.5) -- ------------------ -- pragma Atomic (DIRECT_NAME); -- Syntax check: one argument, which must be an identifier when Pragma_Atomic => Check_Ada_83_Warning; Check_No_Identifiers; Check_Arg_Count (1); Check_Expression_Is_Identifier (Arg1); ----------------------------- -- Atomic_Components (G.5) -- ----------------------------- -- pragma Atomic_Components (array_DIRECT_NAME); -- Syntax check: one argument, which must be an identifier when Pragma_Atomic_Components => Check_Ada_83_Warning; Check_No_Identifiers; Check_Arg_Count (1); Check_Expression_Is_Identifier (Arg1); ---------------------------- -- Attach_Handler (G.3.1) -- ---------------------------- -- pragma Attach_Handler (handler_NAME, EXPRESSION); -- Syntax check: two arguments when Pragma_Attach_Handler => Check_Ada_83_Warning; Check_No_Identifiers; Check_Arg_Count (2); -------------------------- -- Controlled (13.11.3) -- -------------------------- -- pragma Controlled (first_subtype_DIRECT_NAME); -- Syntax check: one argument, which must be an identifier when Pragma_Controlled => Check_No_Identifiers; Check_Arg_Count (1); Check_Expression_Is_Identifier (Arg1); ---------------------- -- Convention (M.1) -- ---------------------- -- pragma Convention ([Convention =>] convention_IDENTIFIER, -- [Entity =>] DIRECT_NAME); when Pragma_Convention => Check_Ada_83_Warning; Check_Arg_Count (2); Check_Expression_Is_Convention (Arg1); Check_Expression_Is_Entity (Arg2); ------------------ -- Debug (GNAT) -- ------------------ -- pragma Debug (PROCEDURE_CALL_STATEMENT); -- This pragma is implementation (GNAT) defined. Its effect depends -- on the setting of the Assertions_Enabled flag in Opt. If this -- flag is off (False), then the pragma has no effect. If the flag -- is on (True), then the semantics of the pragma is equivalent to -- the procedure call. -- Syntax check: one argument which must be of the form of a procedure -- call, parsed either as a name or as a function call. It is then -- converted to the corresponding procedure call. when Pragma_Debug => Check_No_Identifiers; Check_Arg_Count (1); declare Expr : constant Node_Id := New_Copy (Expression (Arg1)); begin if Nkind (Expr) /= N_Indexed_Component and then Nkind (Expr) /= N_Function_Call and then Nkind (Expr) /= N_Identifier and then Nkind (Expr) /= N_Selected_Component then Error_Msg ("argument of pragma& is not procedure call", Sloc (Expr)); raise Error_Resync; else Set_Debug_Statement (Pragma_Node, P_Statement_Call_Name (Expr)); end if; end; --------------------- -- Elaborate (N.4) -- --------------------- -- pragma Elaborate (library_unit_NAME {, library_unit_NAME}); -- Syntax check: at least one argument, all arguments of the form -- of either identifiers, or selected components with the selector -- name being an identifier. when Pragma_Elaborate => Check_No_Identifiers; Check_At_Least_One_Argument; Arg_Node := Arg1; while Present (Arg_Node) loop Check_Expression_Is_Library_Unit_Name (Arg_Node); Arg_Node := Next (Arg_Node); end loop; ---------------------------- -- Elaborate_All (10.2.1) -- ---------------------------- -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME}); -- Syntax check: at least one argument, all arguments of the form -- of either identifiers, or selected components with the selector -- name being an identifier. when Pragma_Elaborate_All => Check_Ada_83_Warning; Check_No_Identifiers; Check_At_Least_One_Argument; Arg_Node := Arg1; while Present (Arg_Node) loop Check_Expression_Is_Library_Unit_Name (Arg_Node); Arg_Node := Next (Arg_Node); end loop; ----------------------------- -- Elaborate_Body (10.2.1) -- ----------------------------- -- pragma Elaborate_Body [(library_unit_NAME)]; -- Syntax check: at most one argument, which, if present, is the -- current compilation unit name when Pragma_Elaborate_Body => Check_Library_Unit_Pragma; ------------------ -- Export (M.1) -- ------------------ -- pragma Export ([Convention =>] convention_IDENTIFIER, -- [Entity =>] DIRECT_NAME [, [Link_Name =>] STRING_EXPRESSION]); -- Syntax check: 2 or 3 arguments. 1st argument must be a -- convention, 2nd argument must be an entity when Pragma_Export => Check_Ada_83_Warning; if Nargs = 3 then Check_Optional_Identifier (Arg3, Name_Link_Name); else Check_Arg_Count (2); end if; Check_Expression_Is_Convention (Arg1); Check_Expression_Is_Entity (Arg2); ------------------ -- Import (M.1) -- ------------------ -- pragma Import ([Convention =>] convention_IDENTIFIER, -- [Entity =>] DIRECT_NAME [, [Link_Name =>] STRING_EXPRESSION]); -- Syntax check: 2 or 3 arguments. 1st argument must be a convention, -- 2nd argument must be an entity when Pragma_Import => Check_Ada_83_Warning; if Nargs = 3 then Check_Optional_Identifier (Arg3, Name_Link_Name); else Check_Arg_Count (2); end if; Check_Expression_Is_Convention (Arg1); Check_Expression_Is_Entity (Arg2); -------------------- -- Improve (GNAT) -- -------------------- -- pragma Improve (Time | Space, IDENTIFIER); -- This pragma is implementation (GNAT) defined. It has is ignored -- semantically, and is provided only for compatibility with Alsys, -- where it is used to excercise control over variant record layout. -- Syntax check: Two arguments, the first is either Time or Space, -- and the second must be an identifier. when Pragma_Improve => Check_No_Identifiers; Check_Arg_Count (2); Check_Expression_Is_One_Of (Arg1, Name_Time, Name_Space); Check_Expression_Is_Identifier (Arg2); -------------------- -- Inline (6.3.2) -- -------------------- -- pragma Inline (NAME {, NAME}); -- Syntax check: at least one argument, and the arguments are either -- of the form of identifiers, or of selected components. when Pragma_Inline => Check_No_Identifiers; Check_At_Least_One_Argument; Arg_Node := Arg1; while Present (Arg_Node) loop Expr_Node := Expression (Arg_Node); if Nkind (Expr_Node) /= N_Identifier and then Nkind (Expr_Node) /= N_Selected_Component and then Nkind (Expr_Node) /= N_Operator_Symbol then Error_Msg ("argument of pragma& is not subprogram name", Sloc (Expr_Node)); end if; Arg_Node := Next (Arg_Node); end loop; ------------------------------ -- Inspection_Point (L.2.2) -- ------------------------------ -- pragma Inspection_Point [(object_NAME {, object_NAME})]; -- Syntax check: None when Pragma_Inspection_Point => Check_Ada_83_Warning; Check_No_Identifiers; ------------------------ -- Interface (Ada 83) -- ------------------------ -- pragma Interface (convention_IDENTIFIER, DIRECT_NAME); -- Syntax check: two arguments, first is a convention name when Pragma_Interface => Check_No_Identifiers; Check_Arg_Count (2); Check_Expression_Is_Convention (Arg1); --------------------------- -- Interface_Name (GNAT) -- --------------------------- -- pragma Interface_Name ([Entity =>] DIRECT_NAME, -- [Link_Name =>] STRING_EXPRESSION); -- This pragma is implementation (GNAT) defined. It is an alternative -- way of specifying the interface name for an interfaced subprogram, -- and is provided for compatibility with Ada 83 compilers that use -- the pragma for this purpose. -- Syntax check: two arguments, first is an entity name when Pragma_Interface_Name => Check_Arg_Count (2); Check_Expression_Is_Entity (Arg1); Check_Optional_Identifier (Arg2, Name_Link_Name); ------------------------------- -- Interrupt_Handler (G.3.1) -- ------------------------------- -- pragma Interrupt_Handler (handler_NAME); -- Syntax check: one argument when Pragma_Interrupt_Handler => Check_Ada_83_Warning; Check_Arg_Count (1); Check_No_Identifiers; ------------------------------ -- Interrupt_Priority (H.1) -- ------------------------------ -- pragma Interrupt_Priority [(EXPRESSION)]; -- Syntax check: one argument when Pragma_Interrupt_Priority => Check_Ada_83_Warning; if Nargs /= 0 then Check_Arg_Count (1); Check_No_Identifiers; end if; ----------------- -- List (2.18) -- ----------------- -- pragma List (Off | On) -- Syntax check: one argument, which must be On or Off when Pragma_List => Check_No_Identifiers; Check_Arg_Count (1); Check_Expression_Is_One_Of (Arg1, Name_On, Name_Off); -- We unconditionally make a List_On entry for the pragma, so that -- in the List (Off) case, the pragma will print even in a region -- of code with listing turned off (this is required!) List_Pragmas.Increment_Last; List_Pragmas.Table (List_Pragmas.Last) := (Ptyp => List_On, Ploc => Sloc (Pragma_Node)); -- Now generate the list off entry for pragma List (Off) if Chars (Expression (Arg1)) = Name_Off then List_Pragmas.Increment_Last; List_Pragmas.Table (List_Pragmas.Last) := (Ptyp => List_Off, Ploc => Semi); end if; -------------------------- -- Locking_Policy (H.3) -- -------------------------- -- pragma Locking_Policy (policy_IDENTIFIER); -- Syntax check: one argument which is a locking policy identifier when Pragma_Locking_Policy => Check_Ada_83_Warning; Check_Arg_Count (1); Check_No_Identifiers; Check_Expression_Is_Locking_Policy (Arg1); ------------------------------- -- Normalize_Scalars (L.1.1) -- ------------------------------- -- pragma Normalize_Scalars; -- Syntax check: no arguments when Pragma_Normalize_Scalars => Check_Ada_83_Warning; Check_Arg_Count (0); -------------------------- -- Memory_Size (Ada 83) -- -------------------------- -- pragma Memory_Size (NUMERIC_LITERAL) -- Syntax check: one argument, which must be a integer literal when Pragma_Memory_Size => Check_Ada_9X_Warning; Check_No_Identifiers; Check_Arg_Count (1); Check_Expression_Is_Integer_Literal (Arg1); -------------------- -- Optimize (2.8) -- -------------------- -- pragma Optimize (Time | Space) -- Syntax check: one argument, which must be Time or Space when Pragma_Optimize => Check_No_Identifiers; Check_Arg_Count (1); Check_Expression_Is_One_Of (Arg1, Name_Time, Name_Space); ----------------- -- Pack (13.2) -- ----------------- -- pragma Pack (first_subtype_DIRECT_NAME); -- The DIRECT_NAME must be an IDENTIFIER -- Syntax check: one argument, which must be an identifier when Pragma_Pack => Check_No_Identifiers; Check_Arg_Count (1); Check_Expression_Is_Identifier (Arg1); ---------------- -- Page (2.8) -- ---------------- -- pragma Page; -- Syntax check: no arguments when Pragma_Page => Check_No_Identifiers; Check_Arg_Count (0); List_Pragmas.Increment_Last; List_Pragmas.Table (List_Pragmas.Last) := (Page, Semi); --------------------------- -- Preelaborate (10.2.1) -- --------------------------- -- pragma Preelaborate [(library_unit_NAME)]; -- Syntax check: at most one argument, which, if present, is the -- current compilation unit name when Pragma_Preelaborate => Check_Library_Unit_Pragma; -------------------- -- Priority (H.1) -- -------------------- -- pragma Priority (EXPRESSION); -- Syntax check: one argument when Pragma_Priority => Check_No_Identifiers; Check_Arg_Count (1); ------------------- -- Pure (10.2.1) -- ------------------- -- pragma Pure [(library_unit_NAME)]; -- Syntax check: at most one argument, which, if present, is the -- current compilation unit name. when Pragma_Pure => Check_Library_Unit_Pragma; -------------------------- -- Queuing_Policy (H.4) -- -------------------------- -- pragma Queuing_Policy (policy_IDENTIFIER); -- Syntax check: one argument which is a queuing policy identifier when Pragma_Queuing_Policy => Check_Ada_83_Warning; Check_Arg_Count (1); Check_No_Identifiers; Check_Expression_Is_Queuing_Policy (Arg1); ----------------------------------- -- Remote_Call_Interface (I.2.3) -- ----------------------------------- -- Pragma Remote_Call_Interface [(library_package_NAME)]; -- Syntax check: at most one argument, which, if present, is the -- current compilation unit name when Pragma_Remote_Call_Interface => Check_Library_Unit_Pragma; -------------------------- -- Remote_Types (I.2.2) -- -------------------------- -- Pragma Remote_Types [(library_package_NAME)]; -- Syntax check: at most one argument, which, if present, is the -- current compilation unit name when Pragma_Remote_Types => Check_Library_Unit_Pragma; -------------------------- -- Restrictions (13.12) -- -------------------------- -- pragma Restrictions (RESTRICTION {, RESTRICTION}); -- RESTRICTION ::= -- restriction_IDENTIFIER -- | restriction_parameter_IDENTIFIER => EXPRESSION -- Syntax: at least one argument when Pragma_Restrictions => Check_Ada_83_Warning; Check_At_Least_One_Argument; ------------------------ -- Reviewable (L.2.1) -- ------------------------ -- pragma Reviewable; -- Syntax: no arguments when Pragma_Reviewable => Check_Ada_83_Warning; Check_Arg_Count (0); --------------------- -- Shared (Ada 83) -- --------------------- -- pragma Shared (DIRECT_NAME) -- Syntax check: one argument, which must be an identifier when Pragma_Shared => Check_Ada_9X_Warning; Check_No_Identifiers; Check_Arg_Count (1); Check_Expression_Is_Identifier (Arg1); ---------------------------- -- Shared_Passive (I.2.1) -- ---------------------------- -- Pragma Shared_Passive [(library_package_NAME)]; -- Syntax check: at most one argument, which, if present, is the -- current compilation unit name when Pragma_Shared_Passive => Check_Library_Unit_Pragma; --------------------------- -- Storage_Unit (Ada 83) -- --------------------------- -- pragma Storage_Unit (NUMERIC_LITERAL); -- Syntax check: one argument, which must be the integer literal 8 when Pragma_Storage_Unit => Check_Ada_9X_Warning; Check_No_Identifiers; Check_Arg_Count (1); Check_Expression_Is_Integer_Literal (Arg1); if Intval (Expression (Arg1)) /= 8 then Error_Msg ("the only allowed argument for pragma& is 8", Pragma_Sloc); end if; --------------------- -- Suppress (11.5) -- --------------------- -- pragma Suppress (IDENTIFIER [, [On =>] NAME]); -- Syntax check: first argument must be an identifier which is a -- valid check name. Second argument must be named On if name given. when Pragma_Suppress => Check_No_Identifier (Arg1); Check_Optional_Identifier (Arg2, Name_On); Check_At_Least_One_Argument; Check_Expression_Is_Identifier (Arg1); if not Is_Check_Name (Chars (Expression (Arg1))) then Error_Msg ("argument of pragma& is not valid check name", Sloc (Expression (Arg1))); end if; -------------------------- -- System_Name (Ada 83) -- -------------------------- -- pragma System_Name (DIRECT_NAME); -- Syntax check: one argument, which must be the identifier GNAT when Pragma_System_Name => Check_Ada_9X_Warning; Check_No_Identifiers; Check_Arg_Count (1); Check_Expression_Is_One_Of (Arg1, Name_Gcc, Name_Gnat); ------------------------------------- -- Task_Dispatching_Policy (H.2.2) -- ------------------------------------- -- pragma Task_Dispatching_Policy (DIRECT_NAME); -- Syntax check: one argument which is a task dispatching -- policy identifier when Pragma_Task_Dispatching_Policy => Check_Ada_83_Warning; Check_Arg_Count (1); Check_No_Identifiers; Check_Expression_Is_Task_Dispatching_Policy (Arg1); ---------------------------- -- Task_Stack_Size (GNAT) -- ---------------------------- -- pragma Task_Stack_Size (EXPRESSION); -- This pragma is implementation (GNAT) defined. It must occur within -- a task definition, and specifies the task stack size for the task -- in a manner similar to the use of an attribute definition clause -- specifying the Storage_Size of a task type. The expression may -- reference discriminants of the task type, allowing individual task -- objects to specify the task stack size. -- Syntax check: one argument when Pragma_Task_Stack_Size => Check_No_Identifiers; Check_Arg_Count (1); -------------------- -- Volatile (G.5) -- -------------------- -- pragma Volatile (DIRECT_NAME); -- Syntax check: one argument, which must be an identifier when Pragma_Volatile => Check_Ada_83_Warning; Check_No_Identifiers; Check_Arg_Count (1); Check_Expression_Is_Identifier (Arg1); ------------------------------- -- Volatile_Components (G.5) -- ------------------------------- -- pragma Volatile_Components (array_DIRECT_NAME); -- Syntax check: one argument, which must be an identifier when Pragma_Volatile_Components => Check_Ada_83_Warning; Check_No_Identifiers; Check_Arg_Count (1); Check_Expression_Is_Identifier (Arg1); end case; return Pragma_Node; -------------------- -- Error Handling -- -------------------- exception when Error_Resync => return Error; end Prag; - Syntax check: one argument, which must be Time or Space when Pragma_Optimize => Check_No_Identifiers; Check_Arg_Count (1); Check_Expression_Is_One_Of (Arg1, Name_Time, Name_Space); ----------------- -- Pack (13.2) -- ----------------- -- pragma Pack (first_subtype_DIRECT_NAME); -- The DIRECT_NAME must be an IDENTIFIER -- Syntax check: one argument, which must be an identifier when Pragma_Pack => gnat-1.67-src/src/par-sync.adb 444 10015 7640 20711 5506244352 11343 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P A R . S Y N C -- -- -- -- B o d y -- -- -- -- $Revision: 1.10 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ separate (Par) package body Sync is procedure Resync_Init; -- This routine is called on initiating a resyncrhonization action. It -- checks Last_Resync_Point and skips a token if the current token location -- matches, and, under control of the debug R flag, issues a debug message -- indicating that a resynchronization action is initiating. procedure Resync_Resume; -- This routine is called on completing a resynchronization action. It -- sets Last_Resync_Point, and, under control of the debug R flag, -- issues an error message indicating that the scan is resumed. ----------------- -- Resync_Init -- ----------------- procedure Resync_Init is begin if Token_Ptr = Last_Resync_Point then Scan; -- to skip at least one token end if; if Debug_Flag_R then Error_Msg_SC ("resynchronizing!"); end if; end Resync_Init; ------------------- -- Resync_Resume -- ------------------- procedure Resync_Resume is begin Last_Resync_Point := Token_Ptr; if Debug_Flag_R then Error_Msg_SC ("resuming here!"); end if; end Resync_Resume; ------------------- -- Resync_Choice -- ------------------- procedure Resync_Choice is begin Resync_Init; loop if Token in Token_Class_Cterm then exit; else Scan; end if; end loop; Resync_Resume; end Resync_Choice; ------------------ -- Resync_Cunit -- ------------------ procedure Resync_Cunit is begin Resync_Init; loop if Token in Token_Class_Cunit or else Token = Tok_EOF then exit; else Scan; end if; end loop; Resync_Resume; end Resync_Cunit; ----------------------- -- Resync_Expression -- ----------------------- procedure Resync_Expression is Paren_Count : Int; begin Resync_Init; Paren_Count := 0; loop -- Terminating tokens are those in class Eterm and also RANGE, -- DIGITS or DELTA if not preceded by an apostrophe (if they are -- preceded by an apostrophe, then they are attributes). if (Token in Token_Class_Eterm or else (Token in Token_Class_Atkwd and then Prev_Token /= Tok_Apostrophe)) or else (Paren_Count = 0 and then (Token = Tok_Comma or else Token = Tok_Right_Paren or else Token = Tok_Vertical_Bar)) then -- A special check: if we stop on the ELSE of OR ELSE or the -- THEN of AND THEN, keep going, because this is not really an -- expression terminator after all. Also, keep going past WITH -- since this can be part of an extension aggregate if (Token = Tok_Else and then Prev_Token = Tok_Or) or else (Token = Tok_Then and then Prev_Token = Tok_And) or else Token = Tok_With then null; else exit; end if; end if; if Token = Tok_Left_Paren then Paren_Count := Paren_Count + 1; elsif Token = Tok_Right_Paren then Paren_Count := Paren_Count - 1; end if; Scan; -- past token to be skipped end loop; Resync_Resume; end Resync_Expression; ------------------------------------ -- Resync_Past_Right_Paren_Or_Eol -- ------------------------------------ procedure Resync_Past_Right_Paren_Or_EOL is begin Resync_Init; loop if Prev_Token = Tok_Right_Paren or else Prev_Token_Ptr < Current_Line_Start then exit; else Scan; end if; end loop; Resync_Resume; end Resync_Past_Right_Paren_Or_EOL; --------------------------- -- Resync_Past_Semicolon -- --------------------------- procedure Resync_Past_Semicolon is begin Resync_Init; loop -- Done if we are at a semicolon if Token = Tok_Semicolon then Scan; -- past semicolon exit; -- Done if we are at a token which normally appears only after -- a semicolon. One special glitch is that the keyword private is -- in this category only if it does NOT appear after WITH. elsif Token in Token_Class_After_SM and then (Token /= Tok_Private or else Prev_Token /= Tok_With) then exit; -- Otherwise keep going else Scan; end if; end loop; -- Fall out of loop with resyncrhonization complete Resync_Resume; end Resync_Past_Semicolon; ---------------------------------------------- -- Resync_Past_Semicolon_Or_To_Loop_Or_Then -- ---------------------------------------------- procedure Resync_Past_Semicolon_Or_To_Loop_Or_Then is begin Resync_Init; loop -- Done if at semicolon if Token = Tok_Semicolon then Scan; -- past the semicolon exit; -- Done if we are at a token which normally appears only after -- a semicolon. One special glitch is that the keyword private is -- in this category only if it does NOT appear after WITH. elsif (Token in Token_Class_After_SM and then (Token /= Tok_Private or else Prev_Token /= Tok_With)) then exit; -- Done if we are at THEN or LOOP elsif Token = Tok_Then or else Token = Tok_Loop then exit; -- Otherwise keep going else Scan; end if; end loop; -- Fall out of loop with resyncrhonization complete Resync_Resume; end Resync_Past_Semicolon_Or_To_Loop_Or_Then; --------------------------- -- Resync_Semicolon_List -- --------------------------- procedure Resync_Semicolon_List is Paren_Count : Int; begin Resync_Init; Paren_Count := 0; loop if Token = Tok_EOF or else Token = Tok_Semicolon or else Token = Tok_Is or else Token in Token_Class_After_SM then exit; elsif Token = Tok_Left_Paren then Paren_Count := Paren_Count + 1; elsif Token = Tok_Right_Paren then if Paren_Count = 0 then exit; else Paren_Count := Paren_Count - 1; end if; end if; Scan; end loop; Resync_Resume; end Resync_Semicolon_List; end Sync; eck_No_Identifiers; Check_Arg_Count (1); gnat-1.67-src/src/par-tchk.adb 444 10015 7640 41021 5506244353 11316 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P A R . T C H K -- -- -- -- B o d y -- -- -- -- $Revision: 1.12 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ separate (Par) package body Tchk is -- Error recovery: none of these routines raise Error_Resync ------------- -- T_Abort -- ------------- procedure T_Abort is begin if Token = Tok_Abort then Scan; else Error_Msg_SC ("ABORT expected"); end if; end T_Abort; ------------- -- T_Arrow -- ------------- procedure T_Arrow is begin if Token = Tok_Arrow then Scan; -- A little recovery helper, accept then in place of => elsif Token = Tok_Then then Error_Msg_BC ("""=>"" expected"); Scan; -- past then used in place of => else Error_Msg_AP ("""=>"" expected>"); end if; end T_Arrow; ---------- -- T_At -- ---------- procedure T_At is begin if Token = Tok_At then Scan; else Error_Msg_SC ("AT expected"); end if; end T_At; ------------- -- T_Begin -- ------------- procedure T_Begin is begin if Token = Tok_Begin then Scan; else Error_Msg_SC ("BEGIN expected"); end if; end T_Begin; ------------ -- T_Body -- ------------ procedure T_Body is begin if Token = Tok_Body then Scan; else Error_Msg_BC ("BODY expected"); end if; end T_Body; ----------- -- T_Box -- ----------- procedure T_Box is begin if Token = Tok_Box then Scan; else Error_Msg_AP ("""<>"" expected"); end if; end T_Box; ------------ -- T_Case -- ------------ procedure T_Case is begin if Token = Tok_Case then Scan; else Error_Msg_SC ("CASE expected"); end if; end T_Case; ------------- -- T_Colon -- ------------- procedure T_Colon is begin if Token = Tok_Colon then Scan; else Error_Msg_AP (""":"" expected"); end if; end T_Colon; ------------------- -- T_Colon_Equal -- ------------------- procedure T_Colon_Equal is begin if Token = Tok_Colon_Equal then Scan; elsif Token = Tok_Equal then Error_Msg_SC ("assignment symbol is :="); Scan; else Error_Msg_AP (""":="" expected"); end if; end T_Colon_Equal; ------------- -- T_Comma -- ------------- procedure T_Comma is begin if Token = Tok_Comma then Scan; else if Token = Tok_Pragma then P_Pragmas_Misplaced; end if; if Token = Tok_Comma then Scan; else Error_Msg_AP (""","" expected"); end if; end if; if Token = Tok_Pragma then P_Pragmas_Misplaced; end if; end T_Comma; --------------- -- T_Dot_Dot -- --------------- procedure T_Dot_Dot is begin if Token = Tok_Dot_Dot then Scan; else Error_Msg_AP (""".."" expected"); end if; end T_Dot_Dot; ----------- -- T_For -- ----------- procedure T_For is begin if Token = Tok_For then Scan; else Error_Msg_AP ("FOR expected"); end if; end T_For; ----------------------- -- T_Greater_Greater -- ----------------------- procedure T_Greater_Greater is begin if Token = Tok_Greater_Greater then Scan; else Error_Msg_AP (""">>"" expected"); end if; end T_Greater_Greater; ------------------ -- T_Identifier -- ------------------ procedure T_Identifier is begin if Token = Tok_Identifier then Scan; elsif Token in Token_Class_Literal then Error_Msg_SC ("identifier expected"); Scan; else Error_Msg_AP ("identifier expected"); end if; end T_Identifier; ---------- -- T_In -- ---------- procedure T_In is begin if Token = Tok_In then Scan; else Error_Msg_AP ("IN expected"); end if; end T_In; ---------- -- T_Is -- ---------- procedure T_Is is begin if Token = Tok_Is then Scan; -- Allow OF, => or = to substitute for IS with complaint elsif Token = Tok_Arrow or else Token = Tok_Of or else Token = Tok_Equal then Error_Msg_SC ("IS expected"); Scan; -- token used in place of IS else Error_Msg_AP ("IS expected"); end if; while Token = Tok_Is loop Error_Msg_SC ("redundant IS ignored"); Scan; end loop; end T_Is; ------------------ -- T_Left_Paren -- ------------------ procedure T_Left_Paren is begin if Token = Tok_Left_Paren then Scan; else Error_Msg_AP ("missing ""("""); end if; end T_Left_Paren; ------------ -- T_Loop -- ------------ procedure T_Loop is begin if Token = Tok_Loop then Scan; else Error_Msg_SC ("LOOP expected"); if Token = Tok_Then then Scan; end if; end if; end T_Loop; ----------- -- T_Mod -- ----------- procedure T_Mod is begin if Token = Tok_Mod then Scan; else Error_Msg_AP ("MOD expected"); end if; end T_Mod; ----------- -- T_New -- ----------- procedure T_New is begin if Token = Tok_New then Scan; else Error_Msg_AP ("NEW expected"); end if; end T_New; ---------- -- T_Of -- ---------- procedure T_Of is begin if Token = Tok_Of then Scan; else Error_Msg_AP ("missing OF"); end if; end T_Of; ---------- -- T_Or -- ---------- procedure T_Or is begin if Token = Tok_Or then Scan; else Error_Msg_AP ("OR expected"); end if; end T_Or; --------------- -- T_Private -- --------------- procedure T_Private is begin if Token = Tok_Private then Scan; else Error_Msg_SC ("PRIVATE expected"); end if; end T_Private; ------------- -- T_Range -- ------------- procedure T_Range is begin if Token = Tok_Range then Scan; else Error_Msg_AP ("RANGE expected"); end if; end T_Range; ------------------- -- T_Right_Paren -- ------------------- procedure T_Right_Paren is begin if Token = Tok_Right_Paren then Scan; else Error_Msg_AP ("missing "")"""); end if; end T_Right_Paren; -------------- -- T_Record -- -------------- procedure T_Record is begin if Token = Tok_Record then Scan; else Error_Msg_AP ("RECORD expected"); end if; end T_Record; ----------------- -- T_Semicolon -- ----------------- procedure T_Semicolon is begin if Token = Tok_Semicolon then Scan; -- An interesting little kludge here. If the previous token is a -- semicolon, then there is no way that we can legitimately need -- another semicolon. This could only arise in an error situation -- where an error has already been signalled. By simply ignoring -- the request for a semicolon in this case, we avoid some spurious -- missing semicolon messages. elsif Prev_Token = Tok_Semicolon then return; -- Otherwise we really do have a missing semicolon else Error_Msg_AP ("missing "";"""); end if; end T_Semicolon; ------------ -- T_Then -- ------------ procedure T_Then is begin if Token = Tok_Then then Scan; else Error_Msg_AP ("THEN expected"); end if; end T_Then; ------------ -- T_Type -- ------------ procedure T_Type is begin if Token = Tok_Type then Scan; else Error_Msg_AP ("TYPE expected"); end if; end T_Type; ----------- -- T_Use -- ----------- procedure T_Use is begin if Token = Tok_Use then Scan; else Error_Msg_SC ("USE expected"); end if; end T_Use; ------------ -- T_When -- ------------ procedure T_When is begin if Token = Tok_When then Scan; else Error_Msg_SC ("WHEN expected"); end if; end T_When; -------------- -- TF_Arrow -- -------------- procedure TF_Arrow is Scan_State : Saved_Scan_State; begin if Token = Tok_Arrow then Scan; -- skip arrow and we are done else T_Arrow; -- give missing arrow message Save_Scan_State (Scan_State); -- at start of junk tokens loop if Prev_Token_Ptr < Current_Line_Start or else Token = Tok_Semicolon then Restore_Scan_State (Scan_State); -- to where we were! return; end if; Scan; -- continue search! if Token = Tok_Arrow then Scan; -- past arrow return; end if; end loop; end if; end TF_Arrow; ----------- -- TF_Is -- ----------- procedure TF_Is is Scan_State : Saved_Scan_State; begin if Token = Tok_Is then T_Is; -- past IS and we are done -- Allow OF or => or = in place of IS (with error message) elsif Token = Tok_Of or else Token = Tok_Arrow or else Token = Tok_Equal then T_Is; -- give missing IS message and skip bad token else T_Is; -- give missing IS message Save_Scan_State (Scan_State); -- at start of junk tokens loop if Prev_Token_Ptr < Current_Line_Start or else Token = Tok_Semicolon then Restore_Scan_State (Scan_State); -- to where we were! return; end if; Scan; -- continue search! if Token = Tok_Is or else Token = Tok_Of or else Token = Tok_Arrow then Scan; -- past IS or OF or => return; end if; end loop; end if; end TF_Is; ------------- -- TF_Loop -- ------------- procedure TF_Loop is Scan_State : Saved_Scan_State; begin if Token = Tok_Loop then Scan; -- past LOOP and we are done -- Allow THEN in place of LOOP elsif Token = Tok_Then then T_Loop; -- give missing LOOP message else T_Loop; -- give missing LOOP message Save_Scan_State (Scan_State); -- at start of junk tokens loop if Prev_Token_Ptr < Current_Line_Start or else Token = Tok_Semicolon then Restore_Scan_State (Scan_State); -- to where we were! return; end if; Scan; -- continue search! if Token = Tok_Loop or else Token = Tok_Then then Scan; -- past loop or then (message already generated) return; end if; end loop; end if; end TF_Loop; -------------- -- TF_Return-- -------------- procedure TF_Return is Scan_State : Saved_Scan_State; begin if Token = Tok_Return then Scan; -- skip RETURN and we are done else Error_Msg_SC ("RETURN expected"); Save_Scan_State (Scan_State); -- at start of junk tokens loop if Prev_Token_Ptr < Current_Line_Start or else Token = Tok_Semicolon then Restore_Scan_State (Scan_State); -- to where we were! return; end if; Scan; -- continue search! if Token = Tok_Return then Scan; -- past RETURN return; end if; end loop; end if; end TF_Return; ------------------ -- TF_Semicolon -- ------------------ procedure TF_Semicolon is Scan_State : Saved_Scan_State; begin if Token = Tok_Semicolon then Scan; -- past ; and we are done return; -- An interesting little kludge here. If the previous token is a -- semicolon, then there is no way that we can legitimately need -- another semicolon. This could only arise in an error situation -- where an error has already been signalled. By simply ignoring -- the request for a semicolon in this case, we avoid some spurious -- missing semicolon messages. elsif Prev_Token = Tok_Semicolon then return; else if Token = Tok_Pragma then P_Pragmas_Misplaced; if Token = Tok_Semicolon then Scan; -- past semicolon return; end if; end if; T_Semicolon; -- give missing semicolon message Save_Scan_State (Scan_State); -- at start of junk tokens loop if Prev_Token_Ptr < Current_Line_Start then Restore_Scan_State (Scan_State); -- to where we were return; end if; Scan; -- continue search if Token = Tok_Semicolon then Scan; -- past semicolon return; elsif Token in Token_Class_After_SM then return; end if; end loop; end if; end TF_Semicolon; ------------- -- TF_Then -- ------------- procedure TF_Then is Scan_State : Saved_Scan_State; begin if Token = Tok_Then then Scan; -- past THEN and we are done else T_Then; -- give missing THEN message Save_Scan_State (Scan_State); -- at start of junk tokens loop if Prev_Token_Ptr < Current_Line_Start or else Token = Tok_Semicolon then Restore_Scan_State (Scan_State); -- to where we were return; end if; Scan; -- continue search! if Token = Tok_Then then Scan; -- past THEN return; end if; end loop; end if; end TF_Then; ------------ -- TF_Use -- ------------ procedure TF_Use is Scan_State : Saved_Scan_State; begin if Token = Tok_Use then Scan; -- past USE and we are done else T_Use; -- give USE expected message Save_Scan_State (Scan_State); -- at start of junk tokens loop if Prev_Token_Ptr < Current_Line_Start or else Token = Tok_Semicolon then Restore_Scan_State (Scan_State); -- to where we were return; end if; Scan; -- continue search! if Token = Tok_Use then Scan; -- past use return; end if; end loop; end if; end TF_Use; end Tchk; -- ----------------- procedure T_Semicolon is begin if Token = Tok_Semicolon then Scan; -- An interesting little kludge here. If the previous token is a -- semicolon, then there is no way that we can legitimately need -- another semicolon. This could only arise in an error situation -- where an error has already been signalled. By simply ignoring -- the request for a semicolon in this case, we avoid some spurious -- missingnat-1.67-src/src/par-util.adb 444 10015 7640 40671 5506244353 11354 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P A R . U T I L -- -- -- -- B o d y -- -- -- -- $Revision: 1.29 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Uintp; use Uintp; separate (Par) package body Util is ----------------------- -- Local Subprograms -- ----------------------- procedure Set_Keyword_Name; -- Builds a names table entry for the current token and stores the Name_Id -- in Error_Msg_Name_1, ready for incorporation into an error message. --------------------- -- Bad_Spelling_Of -- --------------------- function Bad_Spelling_Of (T : Token_Type) return Boolean is Tname : constant String := Token_Type'Image (T); -- Characters of token name S : Str (1 .. Int (Tname'Last) - 4); -- Characters of token name folded to lowe case, omitting TOK_ at start M : Str (1 .. 42) := "Incorrect spelling of keyword ????????????"; -- Buffer used to construct error message P : constant := 30; -- Starting subscript in M for keyword name SL : constant Int := S'Length; -- Length of token name excluding TOK_ at start begin if Token /= Tok_Identifier then return False; end if; for I in S'range loop S (I) := Fold_Lower (To_Char (Tname (Integer (I) + 4))); end loop; Get_Name_String (Token_Name); -- Special case: if prefix matches, then assume that we have the -- missing space case and give appropriate error message. The scan -- pointer is adjusted to point just past the token in this case if Name_Len > SL and then S = Name_Buffer (1 .. SL) then Scan_Ptr := Token_Ptr + S'Length; Error_Msg_S ("missing space"); Token := T; return True; end if; -- If first character does not match, then definitely not misspelling if S (1) /= Name_Buffer (1) then return False; end if; -- Lengths match. Execute loop to check for a single error, single -- transposition or exact match (we only fall through this loop if -- one of these three conditions is found). if Name_Len = SL then -- Loop to check for single mismatch or exact match (we only fall -- through this loop if one of these two conditions is met). for I in Int range 2 .. Name_Len - 1 loop if Name_Buffer (I) /= S (I) then exit when Name_Buffer (I + 1) = S (I + 1) and then Name_Buffer (I + 2 .. Name_Len) = S (I + 2 .. SL); exit when Name_Buffer (I) = S (I + 1) and then Name_Buffer (I + 1) = S (I) and then Name_Buffer (I + 2 .. Name_Len) = S (I + 2 .. SL); return False; end if; end loop; -- Length is 1 too short. Execute loop to check for single deletion -- (we only fall through this loop if a single insertion is found) elsif Name_Len = S'Last - 1 then for I in Int range 2 .. Name_Len loop if Name_Buffer (I) /= S (I) then exit when Name_Buffer (I .. Name_Len) = S (I + 1 .. SL); return False; end if; end loop; -- Length is 1 too long. Execute loop to check for single insertion -- (we only fall through this loop if a single insertion is found) elsif Name_Len = S'Last + 1 then for I in Int range 2 .. S'Last loop if Name_Buffer (I) /= S (I) then exit when Name_Buffer (I + 1 .. Name_Len) = S (I .. SL); return False; end if; end loop; -- Length is completely wrong else return False; end if; -- Fall through to here if we have a bad spelling for I in 1 .. S'Last loop M (P + I - 1) := Fold_Upper (S (I)); end loop; Error_Msg_SC (M (1 .. 29 + S'Last)); Token := T; return True; end Bad_Spelling_Of; ---------------------- -- Check_9X_Keyword -- ---------------------- -- On entry, the caller has checked that current token is an identifier -- whose name matches the name of the 9X keyword New_Tok. procedure Check_9X_Keyword (Token_9X, Next : Token_Type) is Scan_State : Saved_Scan_State; begin Save_Scan_State (Scan_State); -- at identifier/keyword Scan; -- past identifier/keyword if Token = Next then Restore_Scan_State (Scan_State); -- to identifier Error_Msg_Name_1 := Token_Name; Error_Msg_SC ("the keyword* cannot be used in Ada 83"); Token := Token_9X; else Restore_Scan_State (Scan_State); -- to identifier end if; end Check_9X_Keyword; ----------------------------- -- Check_Simple_Expression -- ----------------------------- procedure Check_Simple_Expression (E : Node_Id) is begin if Expr_Form = EF_Non_Simple then Error_Msg_N ("this expression must be parenthesized", E); end if; end Check_Simple_Expression; --------------------------------------- -- Check_Simple_Expression_In_Ada_83 -- --------------------------------------- procedure Check_Simple_Expression_In_Ada_83 (E : Node_Id) is begin if Expr_Form = EF_Non_Simple and then Ada_83 then Error_Msg_N ("this expression must be parenthesized in Ada 83", E); end if; end Check_Simple_Expression_In_Ada_83; ------------------------ -- Check_Subtype_Mark -- ------------------------ function Check_Subtype_Mark (Mark : Node_Id) return Node_Id is begin if Nkind (Mark) = N_Identifier or else Nkind (Mark) = N_Selected_Component or else (Nkind (Mark) = N_Attribute_Reference and then Is_Type_Attribute_Name (Chars (Identifier (Mark)))) or else Mark = Error then return Mark; else Error_Msg ("subtype mark expected", Sloc (Mark)); return Error; end if; end Check_Subtype_Mark; ------------------- -- Comma_Present -- ------------------- function Comma_Present return Boolean is Scan_State : Saved_Scan_State; Paren_Count : Nat; begin -- First check, if a comma is present, then a comma is present! if Token = Tok_Comma then T_Comma; return True; -- If we have a right paren, then that is taken as ending the list -- i.e. no comma is present. elsif Token = Tok_Right_Paren then return False; -- If pragmas, then get rid of them and make a recursive call -- to process what follows these pragmas. elsif Token = Tok_Pragma then P_Pragmas_Misplaced; return Comma_Present; -- At this stage we have an error, and the goal is to decide on whether -- or not we should diagnose an error and report a (non-existent) -- comma as being present, or simply to report no comma is present -- If we are a semicolon, then the question is whether we have a missing -- right paren, or whether the semicolon should have been a comma. To -- guess the right answer, we scan ahead keeping track of the paren -- level, looking for a clue that helps us make the right decision. -- This approach is highly accurate in the single error case, and does -- not make bad mistakes in the multiple error case (indeed we can't -- really make a very bad decision at this point in any case). elsif Token = Tok_Semicolon then Save_Scan_State (Scan_State); Scan; -- past semicolon Paren_Count := 0; -- Here is the look ahead loop, Paren_Count tells us whether the -- token we are looking at is at the same paren level as the -- suspicious semicolon that we are trying to figure out. loop -- If we hit another semicolon or an end of file, and we have -- not seen a right paren or another comma on the way, then -- probably the semicolon did end the list. Indeed that is -- certainly the only single error correction possible here. if Token = Tok_Semicolon or else Token = Tok_EOF then Restore_Scan_State (Scan_State); return False; -- A comma at the same paren level as the semicolon is a strong -- indicator that the semicolon should have been a comma, indeed -- again this is the only possible single error correction. elsif Token = Tok_Comma then exit when Paren_Count = 0; -- A left paren just bumps the paren count elsif Token = Tok_Left_Paren then Paren_Count := Paren_Count + 1; -- A right paren that is at the same paren level as the semicolon -- also means that the only possible single error correction is -- to assume that the semicolon should have been a comma. If we -- are not at the same paren level, then adjust the paren level. elsif Token = Tok_Right_Paren then exit when Paren_Count = 0; Paren_Count := Paren_Count - 1; end if; -- Keep going, we haven't made a decision yet Scan; end loop; -- If we fall through the loop, it means that we found a terminating -- right paren or another comma. In either case it is reasonable to -- assume that the semicolon was really intended to be a comma. Restore_Scan_State (Scan_State); Error_Msg_SC (""";"" illegal here, replaced by "","""); Scan; -- past the semicolon return True; -- If we are not at semicolon or a right paren, then we base the -- decision on whether or not the next token can be part of an -- expression. If not, then decide that no comma is present (the -- caller will eventually generate a missing right parent message) elsif Token in Token_Class_Eterm then return False; -- Otherwise we assume a comma is present, even if none is present, -- since the next token must be part of an expression, so if we were -- at the end of the list, then there is more than one error present. else T_Comma; -- to give error return True; end if; end Comma_Present; ----------------------- -- Discard_Junk_List -- ----------------------- procedure Discard_Junk_List (L : List_Id) is begin null; end Discard_Junk_List; ----------------------- -- Discard_Junk_Node -- ----------------------- procedure Discard_Junk_Node (N : Node_Id) is begin null; end Discard_Junk_Node; ------------ -- Ignore -- ------------ procedure Ignore (T : Token_Type) is begin if Token = T then Set_Keyword_Name; Error_Msg_SC ("unexpected keyword% ignored"); Scan; end if; end Ignore; ---------------------------- -- Is_Reserved_Identifier -- ---------------------------- function Is_Reserved_Identifier return Boolean is Ident_Casing : Casing_Type := File.Table (Scan_Unit).Identifier_Casing; begin if not Is_Reserved_Keyword (Token) then return False; -- If we have a reserved word, check its casing with the default -- identifier casing. A match is an exact equality of case styles, -- or a case in which the current identifier case mode is unknown. else if Determine_Token_Casing = Ident_Casing then return True; elsif Ident_Casing = Unknown then return True; else return False; end if; end if; end Is_Reserved_Identifier; ------------------- -- No_Constraint -- ------------------- procedure No_Constraint is begin if Token in Token_Class_Consk then Error_Msg_SC ("constraint not allowed here"); Discard_Junk_Node (P_Constraint_Opt); end if; end No_Constraint; --------------------- -- Pop_Scope_Stack -- --------------------- procedure Pop_Scope_Stack is begin if Scope.Last = 0 then Error_Msg_SC ("compiler error: scope stack underflow!"); Compiler_Abort; end if; Scope.Decrement_Last; if Debug_Flag_P then Error_Msg_Uint_1 := UI_From_Int (Scope.Last); Error_Msg_SC ("decrement scope stack ptr, new value = ^!"); end if; end Pop_Scope_Stack; ---------------------- -- Push_Scope_Stack -- ---------------------- procedure Push_Scope_Stack is begin Scope.Increment_Last; if Debug_Flag_P then Error_Msg_Uint_1 := UI_From_Int (Scope.Last); Error_Msg_SC ("increment scope stack ptr, new value = ^!"); end if; end Push_Scope_Stack; ---------------------- -- Separate_Present -- ---------------------- function Separate_Present return Boolean is Scan_State : Saved_Scan_State; begin if Token = Tok_Separate then return True; elsif Token /= Tok_Identifier then return False; else Save_Scan_State (Scan_State); Scan; -- past identifier if Token = Tok_Semicolon then Restore_Scan_State (Scan_State); return Bad_Spelling_Of (Tok_Separate); else Restore_Scan_State (Scan_State); return False; end if; end if; end Separate_Present; ---------------------- -- Set_Keyword_Name -- ---------------------- procedure Set_Keyword_Name is Tname : constant String := Token_Type'Image (Token); -- Characters of token name (note we omit TOK_ at the start) begin Name_Len := Int (Tname'Last) - 4; for I in 1 .. Name_Len loop Name_Buffer (I) := Fold_Lower (To_Char (Tname (Integer (I) + 4))); end loop; Error_Msg_Name_1 := Name_Find; end Set_Keyword_Name; ------------------------------- -- Token_Is_At_Start_Of_Line -- ------------------------------- function Token_Is_At_Start_Of_Line return Boolean is begin return Prev_Token_Ptr < Current_Line_Start; end Token_Is_At_Start_Of_Line; --------------------- -- Write_Node_Name -- --------------------- procedure Write_Node_Name (Name_Node : Node_Id) is begin if Nkind (Name_Node) = N_Defining_Program_Unit_Name then Write_Node_Name (Name (Name_Node)); Write_Char ('.'); Write_Node_Name (Defining_Identifier (Name_Node)); elsif Nkind (Name_Node) = N_Designator then Write_Node_Name (Name (Name_Node)); Write_Char ('.'); Write_Node_Name (Identifier (Name_Node)); elsif Nkind (Name_Node) = N_Selected_Component then Write_Node_Name (Prefix (Name_Node)); Write_Char ('.'); Write_Node_Name (Selector_Name (Name_Node)); else Write_Name (Chars (Name_Node)); end if; end Write_Node_Name; end Util; simply to report no comma is present -- If we are a semicolon,gnat-1.67-src/src/par.adb 444 10015 7640 133612 5506244354 10420 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P A R -- -- -- -- B o d y -- -- -- -- $Revision: 1.65 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Casing; use Casing; with Comperr; use Comperr; with Csets; use Csets; with Debug; use Debug; with Errout; use Errout; with Excep; use Excep; with Lib; use Lib; with Namet; use Namet; with Nmake; use Nmake; with Opt; use Opt; with Output; use Output; with Scans; use Scans; with Scn; use Scn; with Sinput; use Sinput; with Sinfo; use Sinfo; with Snames; use Snames; with Table; with Tbuild; use Tbuild; with Types; use Types; procedure Par is Unit_Node : Node_Id; -- Stores compilation unit node for current unit Save_Ada_83_Mode : Boolean; -- Saves state of Ada 83 mode switch for restore on exit (since it may -- get reset by occurrence of the Ada_83 or Ada_9X pragmas). -------------------- -- Error Recovery -- -------------------- -- When an error is encountered, a call is made to one of the Error_Msg -- routines to record the error. If the syntax scan is not derailed by the -- error (e.g. a complaint that logical operators are inconsistent in an -- EXPRESSION), then control returns from the Error_Msg call, and the -- parse continues unimpeded. -- If on the other hand, the Error_Msg represents a situation from which -- the parser cannot recover locally, the exception Error_Resync is raised -- immediately after the call to Error_Msg. Handlers for Error_Resync -- are located at strategic points to resynchronize the parse. For example, -- when an error occurs in a statement, the handler skips to the next -- semicolon and continues the scan from there. -- Each parsing procedure contains a note with the heading "Error recovery" -- which shows if it can propagate the Error_Resync exception. In order -- not to propagate the exception, a procedure must either contain its own -- handler for this exception, or it must not call any other routines which -- propagate the exception. -- Note: the arrangement of Error_Resync handlers is such that it should -- never be possible to transfer control through a procedure which made -- an entry in the scope stack, invalidating the contents of the stack. -- Note: the actual definition of the exception is in module Exceptions. Last_Resync_Point : Source_Ptr; -- The resynchronization routines in Par.Sync run a risk of getting -- stuck in an infinite loop if they do not skip a token, and the caller -- keeps repeating the same resync call. On the other hand, if they skip -- a token unconditionally, some recovery opportunities are missed. The -- variable Last_Resync_Point records the token location previously set -- by a Resync call, and if a subsequent Resync call occurs at the same -- location, then the Resync routine does guarantee to skip a token. -------------------------------------------- -- Handling Semicolon Used in Place of IS -- -------------------------------------------- -- The following global variables are used in handling the error situation -- of using a semicolon in place of IS in a subprogram declaration as in: -- procedure X (Y : Integer); -- Q : Integer; -- begin -- ... -- end; -- The two contexts in which this can appear are at the outer level, and -- within a declarative region. At the outer level, we know something is -- wrong as soon as we see the Q (or begin, if there are no declarations), -- and we can immediately decide that the semicolon should have been IS. -- The situation in a declarative region is more complex. The declaration -- of Q could belong to the outer region, and we do not know that we have -- an error until we hit the begin. It is still not clear at this point -- from a syntactic point of view that something is wrong, because the -- begin could belong to the enclosing subprogram or package. However, we -- can incorporate a bit of semantic knowledge and note that the body of -- X is missing, so we definitely DO have an error. We diagnose this error -- as semicolon in place of IS on the subprogram line. -- There are two styles for this diagnostic. If the begin immediately -- follows the semicolon, then we can place a flag (IS expected) right -- on the semicolon. Otherwise we do not detect the error until we hit -- the begin which refers back to the line with the semicolon. -- To control the process in the second case, the following global -- variables are set to indicate that we have a subprogram declaration -- whose body is required and has not yet been found. The prefix SIS -- stands for "Subprogram IS" handling. SIS_Entry_Active : Boolean; -- Set True to indicate that an entry is active (i.e. that a subprogram -- declaration has been encountered, and no body for this subprogram has -- been encountered). The remaining fields are valid only if this is True. SIS_Labl : Node_Id; -- Subprogram designator SIS_Sloc : Source_Ptr; -- Source location of FUNCTION/PROCEDURE keyword SIS_Ecol : Column_Number_Type; -- Column number of FUNCTION/PROCEDURE keyword SIS_Semicolon_Sloc : Source_Ptr; -- Source location of semicolon at end of subprogram declaration SIS_Declaration_Node : Node_Id; -- Pointer to tree node for subprogram declaration SIS_Missing_Semicolon_Message : Error_Msg_Id; -- Used to save message ID of missing semicolon message (which will be -- modified to missing IS if necessary). Set to No_Error_Msg in the -- normal (non-error) case. -- Five things can happen to an active SIS entry -- 1. If a BEGIN is encountered with an SIS entry active, then we have -- exactly the situation in which we know the body of the subprogram is -- missing. After posting an error message, we change the spec to a body, -- rechaining the declarations that intervened between the spec and BEGIN. -- 2. Another subprogram declaration or body is encountered. In this -- case the entry gets overwritten with the information for the new -- subprogram declaration. We don't catch some nested cases this way, -- but it doesn't seem worth the effort. -- 3. A nested declarative region (e.g. package declaration or package -- body) is encountered. The SIS active indication is reset at the start -- of such a nested region. Again, like case 2, this causes us to miss -- some nested cases, but it doesn't seen worth the effort to stack and -- unstack the SIS information. Maybe we will reconsider this if we ever -- get a complaint about a missed case :-) -- 4. We encounter a valid pragma INTERFACE or IMPORT that effectively -- supplies the missing body. In this case we reset the entry. -- 5. We encounter the end of the declarative region without encoutering -- a BEGIN first. In this situation we simply reset the entry. We know -- that there is a missing body, but it seems more reasonable to let the -- later semantic checking discover this. -------------------------------------------- -- Handling IS Used in Place of Semicolon -- -------------------------------------------- -- This is a somewhat trickier situation, and we can't catch it in all -- cases, but we do our best to detect common situations resulting from -- a "cut and paste" operation which forgets to change the IS to semicolon. -- Consider the following example: -- package body X is -- procedure A; -- procedure B is -- procedure C; -- ... -- procedure D is -- begin -- ... -- end; -- begin -- ... -- end; -- The trouble is that the section of text from PROCEDURE B through END; -- consitutes a valid procedure body, and the danger is that we find out -- far too late that something is wrong (indeed most compilers will behave -- uncomfortably on the above example). -- We have two approaches to helping to control this situation. First we -- make every attempt to avoid swallowing the last END; if we can be -- sure that some error will result from doing so. In particular, we won't -- accept the END; unless it is exactly correct (in particular it must not -- have incorrect name tokens), and we won't accept it if it is immediately -- followed by end of file, WITH or SEPARATE (all tokens that unmistakeably -- signal the start of a compilation unit, and which therefore allow us to -- reserve the END; for the outer level.) For more details on this aspect -- of the handling, see package Par.Endh. -- If we can avoid eating up the END; then the result in the absense of -- any additional steps would be to post a missing END referring back to -- the subprogram with the bogus IS. Similarly, if the enclosing package -- has no BEGIN, then the result is a missing BEGIN message, which again -- refers back to the subprogram header. -- Such an error message is not too bad (it's already a big improvement -- over what many parsers do), but it's not ideal, because the declarations -- following the IS have been absorbed into the wrong scope. In the above -- case, this could result for example in a bogus complaint that the body -- of D was missing from the package. -- To catch at least some of these cases, we take the following additional -- steps. First, a subprogram body is marked as having a suspicious IS if -- the declaration line is followed by a line which starts with a symbol -- that can start a declaration in the same column, or to the left of the -- column in which the FUNCTION or PROCEDURE starts (normal style is to -- indent any declarations which really belong a subprogram). If such a -- subprogram encounters a missing BEGIN or missing END, then we decide -- that the IS should have been a semicolon, and the subprogram body node -- is marked (by setting the Bad_Is_Detected flag true. -- The processing for a declarative part checks to see if the last -- declaration scanned is marked in this way, and if it is, the tree -- is modified to reflect the IS being interpreted as a semicolon. --------------------------------------------------- -- Parser Type Definitions and Control Variables -- --------------------------------------------------- -- The following variable and associated type declaration are used by the -- expression parsing routines to return more detailed information about -- the categorization of a parsed expression. type Expr_Form_Type is ( EF_Simple_Name, -- Simple name, i.e. possibly qualified identifier EF_Name, -- Simple expression which could also be a name EF_Call_Name, -- Simple expression which could also be a call or name EF_Call, -- Simple expression which could also be a call EF_Simple, -- Simple expression which is not call or name EF_Non_Simple); -- Expression that is not a simple expression Expr_Form : Expr_Form_Type; -- The following type is used for calls to P_Subprogram, P_Package, P_Task, -- P_Protected to indicate which of several possibilities is acceptable. type Pf_Rec is record Spcn : Boolean; -- True if specification OK Decl : Boolean; -- True if declaration OK Gins : Boolean; -- True if generic instantiation OK Pbod : Boolean; -- True if proper body OK Rnam : Boolean; -- True if renaming declaration OK Stub : Boolean; -- True if body stub OK Fil1 : Boolean; -- Filler to fill to 8 bits Fil2 : Boolean; -- Filler to fill to 8 bits end record; pragma Pack (Pf_Rec); function T return Boolean renames True; function F return Boolean renames False; Pf_Decl_Gins_Pbod_Rnam_Stub : constant Pf_Rec := Pf_Rec'(F, T, T, T, T, T, F, F); Pf_Decl : constant Pf_Rec := Pf_Rec'(F, T, F, F, F, F, F, F); Pf_Decl_Gins_Pbod_Rnam : constant Pf_Rec := Pf_Rec'(F, T, T, T, T, F, F, F); Pf_Pbod : constant Pf_Rec := Pf_Rec'(F, F, F, T, F, F, F, F); Pf_Spcn : constant Pf_Rec := Pf_Rec'(T, F, F, F, F, F, F, F); -- The above are the only allowed values of Pf_Rec arguments type SS_Rec is record Eftm : Boolean; -- ELSIF can terminate sequence Eltm : Boolean; -- ELSE can terminate sequence Extm : Boolean; -- EXCEPTION can terminate sequence Ortm : Boolean; -- OR can terminate sequence Sreq : Boolean; -- at least one statement required Tatm : Boolean; -- THEN ABORT can terminate sequence Whtm : Boolean; -- WHEN can terminate sequence end record; pragma Pack (SS_Rec); SS_Eftm_Eltm_Sreq : constant SS_Rec := SS_Rec'(T, T, F, F, T, F, F); SS_Eltm : constant SS_Rec := SS_Rec'(F, T, F, F, F, F, F); SS_Eltm_Ortm : constant SS_Rec := SS_Rec'(F, T, F, T, F, F, F); SS_Eltm_Ortm_Tatm : constant SS_Rec := SS_Rec'(F, T, F, T, F, T, F); SS_Extm_Sreq : constant SS_Rec := SS_Rec'(F, F, T, F, T, F, F); SS_None : constant SS_Rec := SS_Rec'(F, F, F, F, F, F, F); SS_Ortm : constant SS_Rec := SS_Rec'(F, F, F, T, F, F, F); SS_Ortm_Sreq : constant SS_Rec := SS_Rec'(F, F, F, T, T, F, F); SS_Sreq : constant SS_Rec := SS_Rec'(F, F, F, F, T, F, F); SS_Sreq_Whtm : constant SS_Rec := SS_Rec'(F, F, F, F, T, F, T); SS_Whtm : constant SS_Rec := SS_Rec'(F, F, F, F, F, F, T); 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. Label_List : Elist_Id; -- List of label nodes for labels appearing in the current compilation. -- Used by Par.Labl to construct the corresponding implicit declarations. ----------------- -- Scope Table -- ----------------- -- The scope table, also referred to as the scope stack, is used to -- record the current scope context. It is organized as a stack, with -- inner nested entries corresponding to higher entries on the stack. -- An entry is made when the parser encounters the opening of a nested -- construct (such as a record, task, package etc.), and then package -- Par.Endh uses this stack to deal with END lines (including properly -- dealing with END nesting errors). type SS_End_Type is -- Type of end entry required for this scope. The last two entries are -- used only in the subprogram body case to mark the case of a suspicious -- IS, or a bad IS (i.e. suspicions confirmed by missing BEGIN or END). -- See separate section on dealing with IS used in place of semicolon. -- Note that for many purposes E_Name, E_Suspicious_Is and E_Bad_Is are -- treated the same (E_Suspicious_Is and E_Bad_Is are simply special cases -- of E_Name). They are placed at the end of the enumeration so that a -- test for >= E_Name catches all three cases efficiently. (E_Dummy, -- dummy entry at outer level E_Case, -- END CASE; E_If, -- END IF; E_Loop, -- END LOOP; E_Record, -- END RECORD; E_Select, -- END SELECT; E_Name, -- END [name]; E_Suspicious_Is, -- END [name]; (case of suspicious IS) E_Bad_Is); -- END [name]; (case of bad IS) type Scope_Table_Entry is record Etyp : SS_End_Type; Lreq : Boolean; Ecol : Column_Number_Type; Labl : Node_Id; Decl : List_Id; Sloc : Source_Ptr; S_Is : Source_Ptr; end record; -- Single entry in the table. The fields are used as follows: -- The Lreq field is a flag indicating whether the label, if present, -- is required to appear on the end line. It is referenced only in the -- case of Etyp = E_Name or E_Suspicious_Is where the name may or may not -- be required (yes for labeled block, no in other cases). Note that for -- all cases except begin, the question of whether a label is required -- can be determined from the other fields (for loop, it is required if -- it is present, and for the other constructs it is never required or -- allowed). -- The Ecol field contains the absolute column number (with tabs expanded) -- of the expected column of the end assuming normal Ada indentation usage. -- If the RM_Column_Check mode is set, this value is used in assessing the -- syntactic correctness of various constructs. Otherwise it is used only -- to control heuristic error recovery actions. -- The Labl field is used only for the LOOP and BEGIN cases, and is the -- Node_Id value of the label name. For all cases except child units, -- this value is an entity whose Chars field contains the name pointer -- that identifies the label uniquely. For the child unit case the Labl -- field references an N_Defining_Program_Unit_Name node for the name. -- For cases other than LOOP or BEGIN, the Label field is set to Error, -- indicating that it is an error to have a label on the end line. -- The Decl field points to the list of declarations (i.e. the declarative -- part) associated with this construct. It is set only in the END [name] -- cases, and is set to No_List for all other cases which do not have a -- declarative unit associated with them. This is used for determining the -- proper location for implicit label declarations. -- Sloc is the source location of the opening token of the construct. This -- is used to refer back to this line in error messages (such as missing -- or incorrect end lines). The Sloc field is not used, and is not set, if -- a label is present (the Labl field provides the text name of the label -- in this case, which is fine for error messages). -- S_Is is relevant only if Etyp is set to E_Suspicious_Is or E_Bad_Is. -- It records the location of the IS that is considered to be suspicious. -- The following declares the scope table itself. The Last field is the -- stack pointer, so that Scope.Table (Scope.Last) is the top entry. The -- oldest entry, at Scope_Stack (0), is a dummy entry with Etyp set to -- E_Dummy, and the other fields undefined. This dummy entry ensures that -- Scope_Stack (Scope_Stack_Ptr).Etyp can always be tested, and that the -- scope stack pointer is always in range. package Scope is new Table ( Component_Type => Scope_Table_Entry, Index_Type => Int, Low_Bound => 0, Initial => 50, Increment => 100, Table_Name => "Scope"); --------------------------------- -- Parsing Routines by Chapter -- --------------------------------- -- Uncommented declarations in this section simply parse the construct -- corresponding to their name, and return an ID value for the Node or -- List that is created. package Ch2 is function P_Identifier return Node_Id; function P_Pragma return Node_Id; procedure P_Pragmas_Misplaced; -- Skips misplaced pragmas with a complaint procedure P_Pragmas_Opt (List : List_Id); -- Parses optional pragmas and appends them to the List end Ch2; package Ch3 is function P_Access_Definition return Node_Id; function P_Access_Type_Definition return Node_Id; function P_Array_Type_Definition return Node_Id; function P_Basic_Declarative_Items return List_Id; function P_Constraint_Opt return Node_Id; function P_Declarative_Part return List_Id; function P_Defining_Identifier return Node_Id; function P_Discrete_Choice_List return List_Id; function P_Discrete_Range return Node_Id; function P_Discrete_Subtype_Definition return Node_Id; function P_Known_Discriminant_Part_Opt return List_Id; function P_Signed_Integer_Type_Definition return Node_Id; function P_Range return Node_Id; function P_Range_Constraint return Node_Id; function P_Record_Definition return Node_Id; function P_Subtype_Indication return Node_Id; function P_Subtype_Mark return Node_Id; function P_Subtype_Mark_Resync return Node_Id; function P_Unknown_Discriminant_Part_Opt return Boolean; procedure P_Component_Declarations (Decls : List_Id); -- Scan out one or more component declarations and append them to -- the given list. Only scans out more than one declaration in the -- case where the source has a single declaration with multiple -- defining identifiers. function P_Subtype_Indication (Subtype_Mark : Node_Id) return Node_Id; -- This version of P_Subtype_Indication is called when the caller has -- already scanned out the subtype mark which is passed as a parameter. function P_Subtype_Mark_Attribute (Type_Node : Node_Id) return Node_Id; -- Parse a subtype mark attribute. The caller has already parsed the -- subtype mark, which is passed in as the argument, and has checked -- that the current token is apostrophe. end Ch3; package Ch4 is function P_Aggregate return Node_Id; function P_Call_Name return Node_Id; function P_Expression return Node_Id; function P_Expression_No_Right_Paren return Node_Id; function P_Function_Name return Node_Id; function P_Name return Node_Id; function P_Qualified_Simple_Name return Node_Id; function P_Qualified_Simple_Name_Resync return Node_Id; function P_Qualified_Expression (Subtype_Mark : Node_Id) return Node_Id; -- This routine scans out a qualified expression when the caller has -- already scanned out the name and apostrophe of the construct. function P_Range_Attribute (Prefix_Node : Node_Id) return Node_Id; -- Scan a range attribute. The caller has scanned out the prefix. -- The current token is known to be an apostrophe and the following -- token is known to be RANGE. end Ch4; package Ch5 is function P_Statement_Call_Name (Call_Name_Node : Node_Id) return Node_Id; -- Given a node representing a function call or name, converts it -- to the syntactically corresponding procedure call statement. procedure P_Decls_Begin_End (Parent : Node_Id); -- Parses declarations and handled statement sequence, setting -- fields of Parent node appropriately. function P_Sequence_Of_Statements (SS_Flags : SS_Rec) return List_Id; -- The argument indicates the acceptable termination tokens. -- See body in Par.Ch5 for details of the use of this parameter. end Ch5; package Ch6 is function P_Designator return Node_Id; function P_Defining_Program_Unit_Name return Node_Id; function P_Formal_Part return List_Id; function P_Formal_Part_Opt return List_Id; function P_Subprogram (Pf_Flags : Pf_Rec) return Node_Id; function P_Return_Statement return Node_Id; function P_Subprogram_Specification return Node_Id; procedure P_Mode (Node : Node_Id); -- Sets In_Present and/or Out_Present flags in Node scanning past -- IN, OUT or IN OUT tokens in the source. end Ch6; package Ch7 is function P_Package (Pf_Flags : Pf_Rec) return Node_Id; end Ch7; package Ch8 is function P_Use_Clause return Node_Id; end Ch8; package Ch9 is function P_Abort_Statement return Node_Id; function P_Abortable_Part return Node_Id; function P_Accept_Statement return Node_Id; function P_Delay_Statement return Node_Id; function P_Entry_Body return Node_Id; function P_Protected return Node_Id; function P_Requeue_Statement return Node_Id; function P_Select_Statement return Node_Id; function P_Task return Node_Id; function P_Terminate_Alternative return Node_Id; end Ch9; package Ch10 is function P_Compilation_Unit return Node_Id; end Ch10; package Ch11 is function P_Exception_Handler_Part return List_Id; function P_Handled_Sequence_Of_Statements return Node_Id; function P_Raise_Statement return Node_Id; end Ch11; package Ch12 is function P_Generic return Node_Id; function P_Generic_Actual_Part_Opt return List_Id; end Ch12; package Ch13 is function P_Representation_Clause return Node_Id; function P_Code_Statement (Subtype_Mark : Node_Id) return Node_Id; -- Function to parse a code statement. The caller has scanned out -- the name to be used as the subtype mark (but has not checked that -- it is suitable for use as a subtype mark, i.e. is either an -- identifier or a selected component). The current token is an -- apostrophe and the following token is either a left paren or -- RANGE (the latter being an error to be caught by P_Code_Statement. end Ch13; ------------------ -- End Handling -- ------------------ -- Routines for handling end lines, including scope recovery package Endh is function Check_End return Boolean; -- Called when an end sequence is required. In the absence of an error -- situation, Token contains Tok_End on entry, but in a missing end -- case, this may not be the case. Pop_End_Context is used to determine -- the appropriate action to be taken. The returned result is True if -- an End sequence was encountered and False if no End sequence was -- present. This occurs if the END keyword encountered was determined -- to be improper and deleted (i.e. Pop_End_Context set End_Action to -- Skip_And_Reject). Note that the END sequence includes a semicolon, -- except in the case of END RECORD, where a semicolon follows the END -- RECORD, but is not part of the record type definition itself. procedure End_Skip; -- Skip past an end sequence. On entry Token contains Tok_End, and we -- 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. procedure End_Statements; -- Called when an end is required or expected to terminate a sequence -- of statements. The caller has already made an appropriate entry in -- the Scope.Table to describe the expected form of the end. This can -- only be used in cases where the only appropriate terminator is end. 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 take, signalling the result by setting End_Action as described in -- the global variable section. end Endh; ------------------------------------ -- Resynchronization After Errors -- ------------------------------------ -- These procedures are used to resynchronize after errors. Following an -- error which is not immediately locally recoverable, the exception -- Error_Resync is raised. The handler for Error_Resync typically calls -- one of these recovery procedures to resynchronize the source position -- to a point from which parsing can be restarted. -- Note: these procedures output an information message that tokens are -- being skipped, but this message is output only if the option for -- Multiple_Errors_Per_Line is set in Options. package Sync is procedure Resync_Choice; -- Used if an error occurs scanning a choice. The scan pointer is -- advanced to the next vertical bar, arrow, or semicolon, whichever -- comes first. We also quit if we encounter an end of file. procedure Resync_Expression; -- Used if an error is detected during the parsing of an expression. -- It skips past tokens until either a token which cannot be part of -- an expression is encountered (an expression terminator), or if a -- comma or right parenthesis or vertical bar is encountered at the -- current parenthesis level (a parenthesis level counter is maintained -- to carry out this test). procedure Resync_Past_Right_Paren_Or_EOL; -- Used to skip a junk list of items enclosed in parentheses which are -- expected to lie on the current line. Tokens are skipped until a -- right paren is skipped, or until end of line, whichever is first. procedure Resync_Past_Semicolon; -- Used if an error occurs while scanning a sequence of declarations. -- The scan pointer is positioned past the next semicolon and the scan -- resumes. The scan is also resumed on encountering a token which -- starts a declaration (but we make sure to skip at least one token -- in this case, to avoid getting stuck in a loop). procedure Resync_Past_Semicolon_Or_To_Loop_Or_Then; -- Used if an error occurs while scanning a sequence of statements. -- The scan pointer is positioned past the next semicolon, or to the -- next occurrence of either then or loop, and the scan resumes. procedure Resync_Semicolon_List; -- Used if an error occurs while scanning a parenthesized list of items -- separated by semicolons. The scan pointer is advanced to the next -- semicolon or right parenthesis at the outer parenthesis level, or -- to the next is or RETURN keyword occurence, whichever comes first. procedure Resync_Cunit; -- Synchronize to next token which could be the start of a compilation -- unit, or to the end of file token. end Sync; ------------------------- -- Token Scan Routines -- ------------------------- -- Routines to check for expected tokens package Tchk is -- Procedures with names of the form T_xxx, where Tok_xxx is a token -- name, check that the current token matches the required token, and -- if so, scan past it. If not, an error is issued indicating that -- the required token is not present (xxx expected). In most cases, the -- scan pointer is not moved in the not-found case, but there are some -- exceptions to this, see for example T_Id, where the scan pointer is -- moved across a literal appearing where an identifier is expected. procedure T_Abort; procedure T_Arrow; procedure T_At; procedure T_Begin; procedure T_Body; procedure T_Box; procedure T_Colon; procedure T_Colon_Equal; procedure T_Comma; procedure T_Dot_Dot; procedure T_For; procedure T_Greater_Greater; procedure T_Identifier; procedure T_In; procedure T_Is; procedure T_Left_Paren; procedure T_Loop; procedure T_Mod; procedure T_New; procedure T_Of; procedure T_Or; procedure T_Private; procedure T_Range; procedure T_Record; procedure T_Right_Paren; procedure T_Semicolon; procedure T_Then; procedure T_Type; procedure T_Use; procedure T_When; -- Procedures have names of the form TF_xxx, where Tok_xxx is a token -- name check that the current token matches the required token, and -- if so, scan past it. If not, an error message is issued indicating -- that the required token is not present (xxx expected). -- If the missing token is at the end of the line, then control returns -- immediately after posting the message. If there are remaining tokens -- on the current line, a search is conducted to see if the token -- appears later on the current line, as follows: -- A call to Scan_Save is issued and a forward search for the token -- is carried out. If the token is found on the current line before a -- semicolon, then it is scanned out and the scan continues from that -- point. If not the scan is restored to the point where it was missing. procedure TF_Arrow; procedure TF_Is; procedure TF_Loop; procedure TF_Return; procedure TF_Semicolon; procedure TF_Then; procedure TF_Use; end Tchk; ---------------------- -- Utility Routines -- ---------------------- package Util is function Bad_Spelling_Of (T : Token_Type) return Boolean; -- This function is called in an error situation. It checks if the -- current token is an identifier whose name is a plausible bad -- spelling of the given keyword token, and if so, issues an error -- message, sets Token from T, and returns True. Otherwise Token is -- unchanged, and False is returned. procedure Check_9X_Keyword (Token_9X, Next : Token_Type); -- This routine checks if the token after the current one matches the -- Next argument. If so, the scan is backed up to the current token -- and Token_Type is changed to Token_9X after issuing an appropriate -- error message ("the Ada 9X keyword xx cannot be used in Ada 83"). If -- not, the scan is backed up with Token_Type unchanged. This routine -- is used to deal with an attempt to use a 9X keyword in Ada 83 mode. -- The caller has typically checked that the current token, an -- identifier, matches one of the 9X keywords. procedure Check_Simple_Expression (E : Node_Id); -- Given an expression E, that has just been scanned, so that Expr_Form -- is still set, outputs an error if E is a non-simple expression. E is -- not modified by this call. procedure Check_Simple_Expression_In_Ada_83 (E : Node_Id); -- Like Check_Simple_Expression, except that the error message is only -- given when operating in Ada 83 mode, and includes "in Ada 83". function Check_Subtype_Mark (Mark : Node_Id) return Node_Id; -- Called to check that a node representing a name (or call) is -- suitable for a subtype mark, i.e, that it is an identifier or -- a selected component. If so, or if it is already Error, then -- it is returned unchanged. Otherwise an error message is issued -- and Error is returned. function Comma_Present return Boolean; -- Used in comma delimited lists to determine if a comma is present, or -- can reasonably be assumed to have been present (an error message is -- generated in the latter case). If True is returned, the scan has been -- positioned past the comma. If False is returned, the scan position -- is unchanged. Note that all comma-delimited lists are terminated by -- a right paren, so the only legitimate tokens when Comma_Present is -- called are right paren and comma. If some other token is found, then -- Comma_Present has the job of deciding whether it is better to pretend -- a comma was present, post a message for a missing comma and return -- True, or return False and let the caller diagnose the missing right -- parenthesis. procedure Discard_Junk_Node (N : Node_Id); procedure Discard_Junk_List (L : List_Id); pragma Inline (Discard_Junk_Node); pragma Inline (Discard_Junk_List); -- These procedures do nothing at all, their effect is simply to discard -- the argument. A typical use is to skip by some junk that is not -- expected in the current context. procedure Ignore (T : Token_Type); -- If current token matches T, then give an error message and skip -- past it, otherwise the call has no effect at all. function Is_Reserved_Identifier return Boolean; -- Test if current token is a reserved identifier. This test is based -- on the token being a keyword and being spelled in typical identifier -- style (i.e. starting with an upper case letter). procedure No_Constraint; -- Called in a place where no constraint is allowed, but one might -- appear due to a common error (e.g. after the type mark in a procedure -- parameter. If a constraint is present, an error message is posted, -- and the constraint is scanned and discarded. procedure Push_Scope_Stack; pragma Inline (Push_Scope_Stack); -- Push a new entry onto the scope stack. Scope.Last (the stack pointer) -- is incremented. The caller can then fill in the new top stack entry -- at Scope.Table (Scope.Last). procedure Pop_Scope_Stack; -- Pop an entry off the top of the scope stack. Scope_Last (the scope -- table stack pointer) is decremented by one. It is a fatal error to -- try to pop off the dummy entry at the bottom of the stack (i.e. -- Scope.Last must be non-zero at the time of call). function Separate_Present return Boolean; -- Determines if the current token is either Tok_Separate, or an -- identifier that is a possible misspelling of "separate" followed -- by a semicolon. True is returned if so, otherwise False. function Token_Is_At_Start_Of_Line return Boolean; pragma Inline (Token_Is_At_Start_Of_Line); -- Determines if the current token is the first token on the line procedure Write_Node_Name (Name_Node : Node_Id); -- Writes name associated with given node, which is either a defining -- program unit name node, in which case the name is written out with -- the required separating dots, or is a node with a Chars field, in -- which case the name written is simply this Chars field name. end Util; --------------------------------------- -- Specialized Syntax Check Routines -- --------------------------------------- function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id; -- This function is passed a tree for a pragma that has been scanned out. -- The pragma is syntactically well formed according to the general syntax -- for pragmas and the pragma identifier is for one of the recognized -- pragmas. It performs specific syntactic checks for specific pragmas. -- The result is the input node if it is OK, or Error otherwise. The -- reason that this is separated out is to facilitate the addition -- of implementation defined pragmas. The second parameter records the -- location of the semicolon following the pragma (this is needed for -- correct processing of the List and Page pragmas). The returned value -- is a copy of Pragma_Node, or Error if an error is found. ------------------------- -- Subsidiary Routines -- ------------------------- procedure Labl; -- This procedure creates implicit label declarations for all label that -- are declared in the current unit. Note that this could conceptually -- be done at the point where the labels are declared, but it is tricky -- to do it then, since the tree is not hooked up at the point where the -- label is declared (e.g. a sequence of statements is not yet attached -- to its containing scope at the point a label in the sequence is found) procedure Load; -- This procedure loads all subsidiary units that are required by this -- unit, including with'ed units, specs for bodies, and parents for child -- units. It does not load bodies for inlined procedures and generics, -- since we don't know till semantic analysis is complete what is needed. ----------- -- Stubs -- ----------- -- The package bodies can see all routines defined in all other subpackages use Ch2; use Ch3; use Ch4; use Ch5; use Ch6; use Ch7; use Ch8; use Ch9; use Ch10; use Ch11; use Ch12; use Ch13; use Endh; use Tchk; use Sync; use Util; package body Ch2 is separate; package body Ch3 is separate; package body Ch4 is separate; package body Ch5 is separate; package body Ch6 is separate; package body Ch7 is separate; package body Ch8 is separate; package body Ch9 is separate; package body Ch10 is separate; package body Ch11 is separate; package body Ch12 is separate; package body Ch13 is separate; package body Endh is separate; package body Tchk is separate; package body Sync is separate; package body Util is separate; function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is separate; procedure Labl is separate; procedure Load is separate; --------- -- Par -- --------- -- This function is the parse routine called at the outer level. It parses -- the current compilation unit and adds implicit label declarations. begin -- Save old Ada 83 mode, and initialize from compiler switch value Save_Ada_83_Mode := Ada_83; Ada_83 := Ada_83_Switch; Ada_9X := not Ada_83; -- Initialize scope table and other parser control variables Compiler_State := Parsing; Scope.Init; Scope.Increment_Last; Scope.Table (0).Etyp := E_Dummy; SIS_Entry_Active := False; Last_Resync_Point := Source'First; -- Scan the compilation Label_List := New_Elmt_List; Unit_Node := P_Compilation_Unit; -- An internal error check, the scope stack should now be empty if Scope.Last /= 0 then Compiler_Error; Write_Eol; Write_Str ("compiler error: scope stack not reset to empty"); Write_Eol; Compiler_Abort; end if; -- Remaining steps are to create implicit label declarations and to -- load required subsidiary sources. These steps are required only -- if we are doing semantic checking. if Operating_Mode /= Check_Syntax or else Debug_Flag_F then Par.Labl; Par.Load; end if; -- Restore settings of Ada 83 and Ada 9X mode switches to entry values Ada_83 := Save_Ada_83_Mode; Ada_9X := not Ada_83; end Par; e_Id); -- Like Check_Simple_Expression, except that the error message is only -- given when operating ingnat-1.67-src/src/rtsfind.ads 444 10015 7640 35315 5506244355 11312 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- R T S F I N D -- -- -- -- S p e c -- -- -- -- $Revision: 1.16 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Rtsfind is -- This package contains the routine that is used to obtain runtime library -- entities, loading in the required runtime library packages on demand. It -- is also used for such purposes as finding System.Address when System has -- not been explicitly With'ed. ------------------------ -- Runtime Unit Table -- ------------------------ -- The following type includes an enumeration entry for each runtime -- unit. The enumeration literal represents the fully qualified -- name of the unit, as follows: -- Names of the form RTU_xxx are top level library packages whose name -- is xxx. For example the name RTU_System corresponds to package System. -- Names of the form RTUA_xxx are first level children of Ada, whose -- name is Ada.xxx. For example, the name RTUA_Tags corresponds to -- package Ada.Tags. -- Names of the form RTUS_xxx are first level children of System, whose -- name is System.xxx. For example, the name RTUS_Task_Ids corresponds -- to package System.Task_Ids. -- This list can contain both subprogram and package unit names. For -- packages, the accessible entities in the package are separately -- listed in the package entity table. type RTU_Id is ( RTU_System, -- package System -- Runtime packages, for list of accessible entities in each package, -- see declarations in the runtime entity table below. RTUA_Tags, -- package Ada.Tags RTUS_Abort_Control, -- package System.Abort_Control RTUS_Assertions, -- package System.Assertions RTUS_Image, -- package System.Image RTUS_Machine_Specifics, -- package System.Machine_Specifics RTUS_Rendezvous, -- package System.Rendezvous RTUS_Task_IDs, -- package System.Task_IDs RTUS_Task_Stages, -- package System.Task_Stages RTUS_Traceback, -- package System.Traceback -- Functions for Image attribute RTUS_Img_B, -- Boolean'Image RTUS_Img_C, -- Character'Image RTUS_Img_F, -- Float'Image RTUS_Img_I, -- Integer'Image RTUS_Img_LF, -- Long_Float'Image RTUS_Img_LLF, -- Long_Long_Float'Image RTUS_Img_LLI, -- Long_Long_Integer'Image RTUS_Img_SF, -- Short_Float'Image -- Functions for exponentiation RTUS_Xp_F, -- exponentiate Float RTUS_Xp_I, -- exponentiate Integer RTUS_Xp_LF, -- exponentiate Long_Float RTUS_Xp_LLF, -- exponentiate Long_Long_Float RTUS_Xp_LI, -- exponentiate Long_Integer RTUS_Xp_LLI, -- exponentiate Long_Long_Integer RTUS_Xp_SF, -- exponentiate Short_Float RTUS_Xp_SI, -- exponentiate Short_Integer RTUS_Xp_SSI); -- exponentiate Short_Short_Integer -------------------------- -- Runtime Entity Table -- -------------------------- -- This is the enumeration type used to define the argument passed to -- the RTE function. The name must exactly match the name of the entity -- involved, and in the case of a package entity, this name must uniquely -- imply the package containing the entity (i.e. it is not permissible for -- two runtime packages to share an entity name if the compiler must be -- able to generate references to both entities). -- Note that not all entities in the units contained in the runtime unit -- table are included in the following table, only those that actually -- have to be referenced from generated code. type RE_Id is ( -- Functions for exponentiation RE_Xp_F, RE_Xp_I, RE_Xp_LF, RE_Xp_LLF, RE_Xp_LI, RE_Xp_LLI, RE_Xp_SF, RE_Xp_SI, RE_Xp_SSI, -- Functions for Image attribute RE_Img_B, RE_Img_C, RE_Img_F, RE_Img_I, RE_Img_LF, RE_Img_LLF, RE_Img_LLI, RE_Img_SF, -- Entities defined in runtime package System RE_Address, RE_Any_Priority, RE_Default_Priority, RE_Interrupt_Priority, RE_Null_Address, RE_Priority, -- Entities defined in runtime package Ada.Tags RE_Tag, RE_Expanded_Name, RE_External_Tag, RE_Internal_Tag, RE_Tag_Error, -- Entities defined in runtime package System.Abort_Control RE_Abort, RE_Abort_Defer, RE_Abort_Undefer, -- Entities defined in runtime package System.Assertions RE_Assert_Failure, -- Entities defined in runtime package System.Machine_Specifics RE_Init_State, RE_Pre_Call_State, RE_Task_Storage_Size, RE_Machine_Exceptions, RE_Interrupt_ID, RE_Interrupt_Info, RE_Error_Information, -- Entities defined in runtime package System.Rendezvous RE_Accept_Alternative, RE_Accept_Call, RE_Accept_List, RE_Accept_Trivial, RE_Callable, RE_Call_Simple, RE_Cancel_Task_Entry_Call, RE_Complete_Rendezvous, RE_Complete_Task_Entry_Call, RE_Count, RE_Exceptional_Cancel_Task_Entry_Call, RE_Exceptional_Complete_Rendezvous, RE_Max_Select, RE_Max_Task_Entry, RE_No_Rendezvous, RE_Null_Task_Entry, RE_Positive_Select_Index, RE_Requeue_Protected_Entry, RE_Requeue_Task_Entry, RE_Select_Index, RE_Select_Modes, RE_Selective_Wait, RE_Task_Entry_Call, RE_Task_Entry_Index, -- Entities defined in runtime package System.Task_IDs RE_Self, RE_Task_ID, RE_Task_Image, RE_Task_String, -- Entities defined in runtime package System.Task_Stages RE_Activate_Tasks, RE_Activation_Chain, RE_Complete_Activation, RE_Current_Master, RE_Complete_Master, RE_Complete_Task, RE_Create_Task, RE_Enter_Master, RE_Expunge_Unactivated_Tasks, RE_Master_Id, RE_Size_Type, RE_Terminated, RE_Unspecified_Priority, RE_Unspecified_Size, -- Entities defined in runtime package System.Traceback RE_TB_Line_Num, RE_Store_TB, RE_Output_Traceback); -- The following declarations build a table that is indexed by the -- RTE function to determine the unit containing the given entity. RE_Unit_Table : array (RE_Id) of RTU_Id := ( RE_Img_B => RTUS_Img_B, RE_Img_C => RTUS_Img_C, RE_Img_F => RTUS_Img_F, RE_Img_I => RTUS_Img_I, RE_Img_LF => RTUS_Img_LF, RE_Img_LLF => RTUS_Img_LLF, RE_Img_LLI => RTUS_Img_LLI, RE_Img_SF => RTUS_Img_SF, RE_Xp_F => RTUS_Xp_F, RE_Xp_I => RTUS_Xp_I, RE_Xp_LF => RTUS_Xp_LF, RE_Xp_LLF => RTUS_Xp_LLF, RE_Xp_LI => RTUS_Xp_LI, RE_Xp_LLI => RTUS_Xp_LLI, RE_Xp_SF => RTUS_Xp_SF, RE_Xp_SI => RTUS_Xp_SI, RE_Xp_SSI => RTUS_Xp_SSI, RE_Address => RTU_System, RE_Any_Priority => RTU_System, RE_Default_Priority => RTU_System, RE_Interrupt_Priority => RTU_System, RE_Null_Address => RTU_System, RE_Priority => RTU_System, RE_Tag => RTUA_Tags, RE_Expanded_Name => RTUA_Tags, RE_External_Tag => RTUA_Tags, RE_Internal_Tag => RTUA_Tags, RE_Tag_Error => RTUA_Tags, RE_Abort => RTUS_Abort_Control, RE_Abort_Defer => RTUS_Abort_Control, RE_Abort_Undefer => RTUS_Abort_Control, RE_Assert_Failure => RTUS_Assertions, RE_Init_State => RTUS_Machine_Specifics, RE_Pre_Call_State => RTUS_Machine_Specifics, RE_Task_Storage_Size => RTUS_Machine_Specifics, RE_Machine_Exceptions => RTUS_Machine_Specifics, RE_Interrupt_ID => RTUS_Machine_Specifics, RE_Interrupt_Info => RTUS_Machine_Specifics, RE_Error_Information => RTUS_Machine_Specifics, RE_Accept_Alternative => RTUS_Rendezvous, RE_Accept_Call => RTUS_Rendezvous, RE_Accept_List => RTUS_Rendezvous, RE_Accept_Trivial => RTUS_Rendezvous, RE_Callable => RTUS_Rendezvous, RE_Call_Simple => RTUS_Rendezvous, RE_Cancel_Task_Entry_Call => RTUS_Rendezvous, RE_Complete_Rendezvous => RTUS_Rendezvous, RE_Complete_Task_Entry_Call => RTUS_Rendezvous, RE_Count => RTUS_Rendezvous, RE_Exceptional_Cancel_Task_Entry_Call => RTUS_Rendezvous, RE_Exceptional_Complete_Rendezvous => RTUS_Rendezvous, RE_Max_Select => RTUS_Rendezvous, RE_Max_Task_Entry => RTUS_Rendezvous, RE_No_Rendezvous => RTUS_Rendezvous, RE_Null_Task_Entry => RTUS_Rendezvous, RE_Positive_Select_Index => RTUS_Rendezvous, RE_Requeue_Protected_Entry => RTUS_Rendezvous, RE_Requeue_Task_Entry => RTUS_Rendezvous, RE_Select_Index => RTUS_Rendezvous, RE_Select_Modes => RTUS_Rendezvous, RE_Selective_Wait => RTUS_Rendezvous, RE_Task_Entry_Call => RTUS_Rendezvous, RE_Task_Entry_Index => RTUS_Rendezvous, RE_Self => RTUS_Task_IDs, RE_Task_ID => RTUS_Task_IDs, RE_Task_Image => RTUS_Task_IDs, RE_Task_String => RTUS_Task_IDs, RE_Activate_Tasks => RTUS_Task_Stages, RE_Activation_Chain => RTUS_Task_Stages, RE_Complete_Activation => RTUS_Task_Stages, RE_Create_Task => RTUS_Task_Stages, RE_Current_Master => RTUS_Task_Stages, RE_Complete_Master => RTUS_Task_Stages, RE_Complete_Task => RTUS_Task_Stages, RE_Enter_Master => RTUS_Task_Stages, RE_Expunge_Unactivated_Tasks => RTUS_Task_Stages, RE_Master_Id => RTUS_Task_Stages, RE_Size_Type => RTUS_Task_Stages, RE_Terminated => RTUS_Task_Stages, RE_Unspecified_Priority => RTUS_Task_Stages, RE_Unspecified_Size => RTUS_Task_Stages, RE_TB_Line_Num => RTUS_Traceback, RE_Store_TB => RTUS_Traceback, RE_Output_Traceback => RTUS_Traceback); ----------------- -- Subprograms -- ----------------- procedure Initialize_Rtsfind; -- Procedure to initialize data structures used by RTE. Called at the -- start of processing a new main source file. Must be called after -- Initialize_Snames (since names it enters into name table must come -- after names entered by Snames). function RTE (E : RE_Id) return Entity_Id; -- Given the entity defined in the above tables, as identified by the -- corresponding value in the RE_Id enumeration type, returns the Id -- of the corresponding entity, first loading in (parsing, analyzing and -- expanding) its spec if the unit has not already been loaded. If the -- unit cannot be found, or if it does not contain the specified entity, -- then an appropriate error message is output ("Runtime Configuration -- Error") and an Unrecoverable_Error exception is raised. end Rtsfind; e, -- Entities defined in runtime package System.Machine_Specifics RE_Init_State, RE_Pre_Call_State, RE_Task_Storage_Size, RE_Machine_Exceptions, RE_Interrupt_ID, RE_Interrupt_Info, RE_Error_Information, -- Entities defined in runtime package Systegnat-1.67-src/src/rtsfind.adb 444 10015 7640 22611 5506244355 11264 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- R T S F I N D -- -- -- -- B o d y -- -- -- -- $Revision: 1.20 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Casing; use Casing; with Comperr; use Comperr; with Csets; use Csets; with Einfo; use Einfo; with Excep; use Excep; with Fname; use Fname; with Lib; use Lib; with Namet; use Namet; with Nmake; use Nmake; with Output; use Output; with Sem; use Sem; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Tbuild; use Tbuild; package body Rtsfind is ---------------- -- Unit table -- ---------------- -- The unit table has one entry for each unit included in the definition -- of the type RTU_Id in the spec. The table entries are initialized in -- Initialize_Rtsfind to set the Entity field to Empty, indicating that -- the corresponding unit has not yet been loaded. The fields are set -- when a unit is loaded to contain the defining entity for the unit, -- the unit name, and the unit number. type RT_Unit_Table_Record is record Entity : Entity_Id; Uname : Unit_Name_Type; Unum : Unit_Number_Type; end record; RT_Unit_Table : array (RTU_Id) of RT_Unit_Table_Record; -------------------------- -- Runtime Entity Table -- -------------------------- -- There is one entry in the runtime entity table for each entity that is -- included in the definition of the RE_Id type in the spec. The entries -- are set by Initialize_Rtsfind to contain Empty, indicating that the -- entity has not yet been located. Once the entity is located for the -- first time, its ID is stored in this array, so that subsequent calls -- for the same entity can be satisfied immediately. RE_Table : array (RE_Id) of Entity_Id; ------------------------ -- Initialize_Rtsfind -- ------------------------ procedure Initialize_Rtsfind is begin -- Initialize the unit table for I in RTU_Id loop RT_Unit_Table (I).Entity := Empty; end loop; for I in RE_Id loop RE_Table (I) := Empty; end loop; end Initialize_Rtsfind; --------- -- RTE -- --------- function RTE (E : RE_Id) return Entity_Id is U_Id : constant RTU_Id := RE_Unit_Table (E); U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id); Lib_Unit : Node_Id; Pkg_Ent : Entity_Id; Ename : Name_Id; Withn : Node_Id; Loaded : Boolean; -- Internal procedure called if we can't find the entity. The -- parameter is a detailed error message that is to be given procedure Failure (S : Str) is Ent_Name : constant String := RE_Id'Image (E); begin Set_Standard_Error; Write_String ("fatal error: runtime library configuration error"); Write_Eol; Write_String ("cannot locate """); for I in 4 .. Ent_Name'Length loop Name_Buffer (Int (I) - 3) := To_Char (Ent_Name (I)); end loop; Name_Len := Ent_Name'Length - 3; Set_Casing (Mixed_Case); Write_Str (Name_Buffer (1 .. Name_Len)); Write_String (""" in file """); Write_Name (Get_File_Name (U.Uname)); Write_String (""" ("); Write_Str (S); Write_Char (')'); Write_Eol; Set_Standard_Output; raise Unrecoverable_Error; end Failure; -- Start of processing for RTE begin -- Immediate return if entity previously located if Present (RE_Table (E)) then return RE_Table (E); end if; -- Load unit if unit table entry not previously built if No (U.Entity) then -- Build unit name from the enumeration literal name declare Uname_Chars : constant String := RTU_Id'Image (U_Id); Copy_From : Int; Copy_To : Int; begin -- Note the test for lower case letters here is clearly not -- necessary, it reflects a bug that was present at one time -- in Gigi and should disappear when this bug is fixed. TBSL. if Uname_Chars (4) = '_' then Copy_From := 5; Copy_To := 1; elsif Uname_Chars (4) = 'A' or else Uname_Chars (4) = 'a' then Copy_From := 6; Name_Buffer (1 .. 4) := "ada."; Copy_To := 5; elsif Uname_Chars (4) = 'S' or else Uname_Chars (4) = 's' then Copy_From := 6; Name_Buffer (1 .. 7) := "system."; Copy_To := 8; else Compiler_Abort; end if; for I in Integer (Copy_From) .. Uname_Chars'Last loop Name_Buffer (Int (I) - (Copy_From - Copy_To)) := Fold_Lower (To_Char (Uname_Chars (I))); end loop; Name_Len := Int (Uname_Chars'Length) - (Copy_From - Copy_To); end; -- Add %s at end for spec Name_Buffer (Name_Len + 1) := '%'; Name_Buffer (Name_Len + 2) := 's'; Name_Len := Name_Len + 2; U.Uname := Name_Find; Loaded := Is_Loaded (U.Uname); U.Unum := Load (U.Uname, False, Empty); if U.Unum = No_Unit then Failure ("unit not found"); elsif File.Table (U.Unum).Fatal_Error then Failure ("parser errors"); end if; -- Make sure that the unit is analyzed if not Analyzed (File.Table (U.Unum).Cunit) then Semantics (File.Table (U.Unum).Cunit); if File.Table (U.Unum).Fatal_Error then Failure ("semantic errors"); end if; end if; Lib_Unit := Unit (File.Table (U.Unum).Cunit); U.Entity := Defining_Unit_Simple_Name (Specification (Lib_Unit)); -- Add to with list if we loaded the unit if not Loaded then Withn := Make_With_Clause (Standard_Location, Name => New_Reference_To (U.Entity, Standard_Location)); Set_Library_Unit (Withn, File.Table (U.Unum).Cunit); Set_Corresponding_Spec (Withn, U.Entity); Set_First_Name (Withn, True); Set_Implicit_With (Withn, True); Mark_Rewrite_Insertion (Withn); Append (Withn, Context_Items (File.Table (Main_Unit).Cunit)); end if; end if; -- Merge here with unit loaded Lib_Unit := Unit (File.Table (U.Unum).Cunit); -- In the subprogram case, we are all done if Nkind (Lib_Unit) = N_Subprogram_Declaration or else Nkind (Lib_Unit) = N_Subprogram_Body or else Nkind (Lib_Unit) = N_Procedure_Instantiation or else Nkind (Lib_Unit) = N_Function_Instantiation then RE_Table (E) := U.Entity; return RE_Table (E); -- Otherwise search the package entity chain for the entity we want else declare RE_Name_Chars : constant String := RE_Id'Image (E); begin -- Copy name skipping initial RE_ characters for I in 4 .. RE_Name_Chars'Last loop Name_Buffer (Int (I - 3)) := Fold_Lower (To_Char (RE_Name_Chars (I))); end loop; Name_Len := Int (RE_Name_Chars'Length - 3); Ename := Name_Find; end; Pkg_Ent := First_Entity (U.Entity); while Present (Pkg_Ent) loop if Ename = Chars (Pkg_Ent) then RE_Table (E) := Pkg_Ent; return Pkg_Ent; end if; Pkg_Ent := Next_Entity (Pkg_Ent); end loop; -- If we didn't find the unit we want, something is wrong! Failure ("entity undefined"); end if; end RTE; end Rtsfind; E_Img_LLI => RTUS_Img_LLI, RE_Img_SF => RTUS_Img_SF, gnat-1.67-src/src/system-traceback.adb 444 10015 7640 15576 5506244356 13071 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . T R A C E B A C K -- -- -- -- B o d y -- -- -- -- $Revision: 1.9 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Debug; use Debug; pragma Ada_9X; package body System.Traceback is ----------------------- -- Local Subprograms -- ----------------------- procedure Output_Traceback_Entry (L : Line_Num; F : Address; S : Address); -- Outputs one traceback entry line, where L is the line number, F is -- the file name address, and S is the subprogram name address. -------------------------- -- C Library procedures -- -------------------------- procedure puts (S : Address); pragma Interface (C, puts); procedure printf (F : Address; S : Address); pragma Interface (C, printf); procedure putchar (C : Character); pragma Interface (C, putchar); function strlen (S : Address) return Natural; pragma Interface (C, strlen); --------------------- -- Local Variables -- --------------------- Bufsize : constant := 256; -- Number of entries in traceback buffer, must be a power of 2 subtype Bufptr is Natural range 0 .. Bufsize - 1; Lines : array (Bufptr) of Line_Num := (others => 0); -- Lines entries in traceback buffer. Zero indicates an unused entry Fnams : array (Bufptr) of Address; -- File name entries in traceback buffer Snams : array (Bufptr) of Address; -- Subprogram name entries in traceback buffer Buffer_Ptr : Bufptr := 0; -- Traceback buffer pointer: next location to be set. The entries are used -- in a circular manner. P_String : constant String := "%s" & Ascii.NUL; -- Format for printing string with printf -------------- -- Store_TB -- -------------- procedure Store_TB (N : Line_Num; F : Address; S : Address) is begin -- If no debug flag J, then just store the traceback table entry if not Debug_Flag_J then Lines (Buffer_Ptr) := N; Fnams (Buffer_Ptr) := F; Snams (Buffer_Ptr) := S; Buffer_Ptr := (Buffer_Ptr + 1) mod Bufsize; Tracebacks_Stored := True; -- If debug flag J is set, otuput the trace message now else Output_Traceback_Entry (N, F, S); end if; end Store_TB; ---------------------- -- Output_Traceback -- ---------------------- procedure Output_Traceback is Header : constant String := "Abort: traceback follows" & Ascii.Nul; L : Natural; I : Bufptr; begin putchar (Ascii.LF); puts (Header'Address); putchar (Ascii.LF); I := Buffer_Ptr; loop if Lines (I) /= 0 then Output_Traceback_Entry (Lines (I), Fnams (I), Snams (I)); end if; I := (I + 1) mod Bufsize; exit when I = Buffer_Ptr; end loop; putchar (Ascii.LF); putchar (Ascii.LF); end Output_Traceback; ---------------------------- -- Output_Traceback_Entry -- ---------------------------- procedure Output_Traceback_Entry (L : Line_Num; F : Address; S : Address) is D : Natural; begin -- Output line number (5 digits, leading zero suppressed) D := 10000; for J in 1 .. 5 loop if D > 1 and then L < D then putchar (' '); else putchar (Character'Val (48 + (L / D) mod 10)); end if; D := D / 10; end loop; putchar ('.'); putchar (' '); -- Output the file name printf (P_String'Address, F); -- Following test should really use Null_Address, but that wasn't -- working in GNAT version 1.62, so zero was substituted ???. if S /= 0 then putchar (' '); for I in strlen (F) .. 18 loop putchar (' '); end loop; printf (P_String'Address, S); end if; putchar (Ascii.LF); end Output_Traceback_Entry; end System.Traceback; e_Len := Int (RE_Name_Chars'Length - 3); Ename := Name_Find; end; Pkg_Ent := First_Entity (U.Entitygnat-1.67-src/src/system-traceback.ads 444 10015 7640 5313 5506244356 13056 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . T R A C E B A C K -- -- -- -- S p e c -- -- -- -- $Revision: 1.4 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This module provides the software traceback facility. An internal buffer -- is maintained which stores the last N entries made (N is an internal -- constant defined in the body). pragma Ada_9X; package System.Traceback is -- The following type is used to pass traceback name information subtype Line_Num is Natural; -- Line numbers in traceback buffer Tracebacks_Stored : Boolean := False; -- Set True if any entries made in traceback buffer procedure Store_TB (N : Line_Num; F : Address; S : Address); -- Store a traceback entry in the traceback buffer. N is the line number, -- F is the address of the null terminated file name, and S is the address -- of the null terminated subprogram name, with Null_Address indicating -- that no subprogram name is available. procedure Output_Traceback; -- Output a traceback dump. Does not affect the contents of the buffer. end System.Traceback; H¹$$system-assertions.adsº‹\¹% table.adsº‹p¹& table.adbº‹„¹' tbuild.ads‹˜¹( tbuild.adb‹¬¹) treepr.ads‹À¹* treepr.adb‹Ô¹+ treeprs.adtè¹, ttypes.ads‹ü¹- ttypes.adt‹¹. types.adsº‹$¹/ types.adbº‹8¹0 gnat-1.67-src/src/scans.ads 444 10015 7640 44402 5506244357 10747 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S C A N S -- -- -- -- S p e c -- -- -- -- $Revision: 1.24 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Scans is -- The scanner maintains a current state in the global variables defined -- in this package. The call to the Scan routine advances this state to -- the next token. The state is initialized by the call to one of the -- initialization routines in Sinput. -- The following type is used to identify token types returned by Scan. -- The class column in this table indicates the token classes which -- apply to the token, as defined by subsquent subtype declarations. -- Note: the coding in SCN depends on the fact that the first entry in -- this type declaration is *not* for a reserved word. For details on -- why there is this requirement, see Scn.Initialize_Scanner. type Token_Type is ( -- Token name Token type Class(es) Tok_Integer_Literal, -- numeric lit Literal Tok_Real_Literal, -- numeric lit Literal Tok_String_Literal, -- string lit Literal Tok_Char_Literal, -- char lit Name, Literal Tok_Operator_Symbol, -- op symbol Name, Literal, Desig Tok_Identifier, -- identifer Name, Desig Tok_Double_Asterisk, -- ** Tok_Ampersand, -- & Binary_Addop Tok_Minus, -- - Binary_Addop, Unary_Addop Tok_Plus, -- + Binary_Addop, Unary_Addop Tok_Asterisk, -- * Mulop Tok_Mod, -- MOD Mulop Tok_Rem, -- REM Mulop Tok_Slash, -- / Mulop Tok_New, -- NEW Tok_Abs, -- ABS Tok_Others, -- OTHERS Tok_Null, -- NULL Tok_Dot, -- . Namext Tok_Apostrophe, -- ' Namext Tok_Left_Paren, -- ( Namext, Consk Tok_Delta, -- DELTA Atkwd, Sterm, Consk Tok_Digits, -- DIGITS Atkwd, Sterm, Consk Tok_Range, -- RANGE Atkwd, Sterm, Consk Tok_Right_Paren, -- ) Sterm Tok_Comma, -- , Sterm Tok_And, -- AND Logop, Sterm Tok_Or, -- OR Logop, Sterm Tok_Xor, -- XOR Logop, Sterm Tok_Less, -- < Relop, Sterm Tok_Equal, -- = Relop, Sterm Tok_Greater, -- > Relop, Sterm Tok_Not_Equal, -- /= Relop, Sterm Tok_Greater_Equal, -- >= Relop, Sterm Tok_Less_Equal, -- <= Relop, Sterm Tok_In, -- IN Relop, Sterm Tok_Not, -- NOT Relop, Sterm Tok_Box, -- <> Relop, Eterm, Sterm Tok_Colon_Equal, -- := Eterm, Sterm Tok_Colon, -- : Eterm, Sterm Tok_Greater_Greater, -- >> Eterm, Sterm Tok_Abstract, -- ABSTRACT Eterm, Sterm Tok_Access, -- ACCESS Eterm, Sterm Tok_Aliased, -- ALIASED Eterm, Sterm Tok_All, -- ALL Eterm, Sterm Tok_Array, -- ARRAY Eterm, Sterm Tok_At, -- AT Eterm, Sterm Tok_Body, -- BODY Eterm, Sterm Tok_Constant, -- CONSTANT Eterm, Sterm Tok_Do, -- DO Eterm, Sterm Tok_Is, -- IS Eterm, Sterm Tok_Limited, -- LIMITED Eterm, Sterm Tok_Of, -- OF Eterm, Sterm Tok_Out, -- OUT Eterm, Sterm Tok_Record, -- RECORD Eterm, Sterm Tok_Renames, -- RENAMES Eterm, Sterm Tok_Reverse, -- REVERSE Eterm, Sterm Tok_Tagged, -- TAGGED Eterm, Sterm Tok_Then, -- THEN Eterm, Sterm Tok_Less_Less, -- << Eterm, Sterm, After_SM Tok_Abort, -- ABORT Eterm, Sterm, After_SM Tok_Accept, -- ACCEPT Eterm, Sterm, After_SM Tok_Case, -- CASE Eterm, Sterm, After_SM Tok_Delay, -- DELAY Eterm, Sterm, After_SM Tok_Else, -- ELSE Eterm, Sterm, After_SM Tok_Elsif, -- ELSIF Eterm, Sterm, After_SM Tok_End, -- END Eterm, Sterm, After_SM Tok_Exception, -- EXCEPTION Eterm, Sterm, After_SM Tok_Exit, -- EXIT Eterm, Sterm, After_SM Tok_Goto, -- GOTO Eterm, Sterm, After_SM Tok_If, -- IF Eterm, Sterm, After_SM Tok_Pragma, -- PRAGMA Eterm, Sterm, After_SM Tok_Raise, -- RAISE Eterm, Sterm, After_SM Tok_Requeue, -- REQUEUE Eterm, Sterm, After_SM Tok_Return, -- RETURN Eterm, Sterm, After_SM Tok_Select, -- SELECT Eterm, Sterm, After_SM Tok_Terminate, -- TERMINATE Eterm, Sterm, After_SM Tok_Until, -- UNTIL Eterm, Sterm, After_SM Tok_When, -- WHEN Eterm, Sterm, After_SM Tok_Begin, -- BEGIN Eterm, Sterm, After_SM, Labeled_Stmt Tok_Declare, -- DECLARE Eterm, Sterm, After_SM, Labeled_Stmt Tok_For, -- FOR Eterm, Sterm, After_SM, Labeled_Stmt Tok_Loop, -- LOOP Eterm, Sterm, After_SM, Labeled_Stmt Tok_While, -- WHILE Eterm, Sterm, After_SM, Labeled_Stmt Tok_Entry, -- ENTRY Eterm, Sterm, Declk, Deckn, After_SM Tok_Protected, -- PROTECTED Eterm, Sterm, Declk, Deckn, After_SM Tok_Task, -- TASK Eterm, Sterm, Declk, Deckn, After_SM Tok_Type, -- TYPE Eterm, Sterm, Declk, Deckn, After_SM Tok_Subtype, -- SUBTYPE Eterm, Sterm, Declk, Deckn, After_SM Tok_Use, -- USE Eterm, Sterm, Declk, Deckn, After_SM Tok_Function, -- FUNCTION Eterm, Sterm, Cunit, Declk, After_SM Tok_Generic, -- GENERIC Eterm, Sterm, Cunit, Declk, After_SM Tok_Package, -- PACKAGE Eterm, Sterm, Cunit, Declk, After_SM Tok_Procedure, -- PROCEDURE Eterm, Sterm, Cunit, Declk, After_SM Tok_Private, -- PRIVATE Eterm, Sterm, Cunit, After_SM Tok_With, -- WITH Eterm, Sterm, Cunit, After_SM Tok_Separate, -- SEPARATE Eterm, Sterm, Cunit, After_SM Tok_EOF, -- End of file Eterm, Sterm, Cterm, After_SM Tok_Semicolon, -- ; Eterm, Sterm, Cterm Tok_Arrow, -- => Sterm, Cterm, Chtok Tok_Vertical_Bar, -- | Cterm, Sterm, Chtok Tok_Dot_Dot, -- .. Sterm, Chtok No_Token); -- No_Token is used for initializing Token values to indicate that -- no value has been set yet. -- Note: in the RM, operator symbol is a special case of string literal. -- We distinguish at the lexical level in this compiler, since there are -- many syntactic situations in which only an operator symbol is allowed. -- The following subtype declarations group the token types into classes. -- These are used for class tests in the parser. subtype Token_Class_Numeric_Literal is Token_Type range Tok_Integer_Literal .. Tok_Real_Literal; -- Numeric literal subtype Token_Class_Literal is Token_Type range Tok_Integer_Literal .. Tok_Operator_Symbol; -- Literal subtype Token_Class_Binary_Addop is Token_Type range Tok_Ampersand .. Tok_Plus; -- Binary adding operator (& + -) subtype Token_Class_Unary_Addop is Token_Type range Tok_Minus .. Tok_Plus; -- Unary adding operator (+ -) subtype Token_Class_Mulop is Token_Type range Tok_Asterisk .. Tok_Slash; -- Multiplying operator subtype Token_Class_Logop is Token_Type range Tok_And .. Tok_Xor; -- Logical operator (and, or, xor) subtype Token_Class_Relop is Token_Type range Tok_Less .. Tok_Box; -- Relational operator (= /= < <= > >= not, in plus <> to catch misuse -- of Pascal style not equal operator). subtype Token_Class_Name is Token_Type range Tok_Char_Literal .. Tok_Identifier; -- First token of name (4.1), -- (identifier, char literal, operator symbol) subtype Token_Class_Desig is Token_Type range Tok_Operator_Symbol .. Tok_Identifier; -- Token which can be a Designator (identifier, operator symbol) subtype Token_Class_Namext is Token_Type range Tok_Dot .. Tok_Left_Paren; -- Name extension tokens. These are tokens which can appear immediately -- after a name to extend it recursively (period, quote, left paren) subtype Token_Class_Consk is Token_Type range Tok_Left_Paren .. Tok_Range; -- Keywords which can start constraint -- (left paren, delta, digits, range) subtype Token_Class_Eterm is Token_Type range Tok_Colon_Equal .. Tok_Semicolon; -- Expression terminators. These tokens can never appear within a simple -- expression. This is used for error recovery purposes (if we encounter -- an error in an expression, we simply scan to the next Eterm token). subtype Token_Class_Sterm is Token_Type range Tok_Delta .. Tok_Dot_Dot; -- Simple_Expression terminators. A Simple_Expression must be followed -- by a token in this class, or an error message is issued complaining -- about a missing binary operator. subtype Token_Class_Atkwd is Token_Type range Tok_Delta .. Tok_Range; -- Attribute keywords. This class includes keywords which can be used -- as an Attribute_Designator, namely DELTA, DIGITS and RANGE subtype Token_Class_Cterm is Token_Type range Tok_EOF .. Tok_Vertical_Bar; -- Choice terminators. These tokens terminate a choice. This is used for -- error recovery purposes (if we encounter an error in a Choice, we -- simply scan to the next Cterm token). subtype Token_Class_Chtok is Token_Type range Tok_Arrow .. Tok_Dot_Dot; -- Choice tokens. These tokens signal a choice when used in an Aggregate subtype Token_Class_Cunit is Token_Type range Tok_Function .. Tok_Separate; -- Tokens which can begin a compilation unit subtype Token_Class_Declk is Token_Type range Tok_Entry .. Tok_Procedure; -- Keywords which start a declaration subtype Token_Class_Deckn is Token_Type range Tok_Entry .. Tok_Use; -- Keywords which start a declaration but can't start a compilation unit subtype Token_Class_After_SM is Token_Type range Tok_Less_Less .. Tok_EOF; -- Tokens which always, or almost always, appear after a semicolon. Used -- in the Resync_Past_Semicolon routine to avoid gobbling up stuff when -- a semicolon is missing. Of significance only for error recovery. subtype Token_Class_Labeled_Stmt is Token_Type range Tok_Begin .. Tok_While; -- Tokens which start labeled statements type Token_Flag_Array is array (Token_Type) of Boolean; Is_Reserved_Keyword : constant Token_Flag_Array := Token_Flag_Array'( Tok_Mod .. Tok_Rem => True, Tok_New .. Tok_Null => True, Tok_Delta .. Tok_Range => True, Tok_And .. Tok_Xor => True, Tok_In .. Tok_Not => True, Tok_Abstract .. Tok_Then => True, Tok_Abort .. Tok_Separate => True, others => False); -- Flag array used to test for reserved word -------------------------- -- Scan State Variables -- -------------------------- -- Note: these variables can only be referenced during the parsing of a -- file. Reference to any of them from Sem or the expander is wrong. Scan_Unit : Unit_Number_Type; -- Unit number of source file currently being scanned Source : Source_Buffer_Ptr; -- Current source (copy of File.Table (Scan_Unit).Source) Source_Cache : Source_Buffer_Ptr; -- This is used to cache the most recently referenced source buffer to -- save lookups in the file table. It must always contain a valid source -- buffer pointer, but from the point of view of correctness it doesn't -- matter which one. It is initialized to the value in Source when a new -- Source file is established to ensure that it always has a valid value. Scan_Ptr : Source_Ptr; -- Scan pointer. After the Initialize call and after subsequent Next_Line -- calls, it points to the first character of the current input line. -- After calls to Scan, it is set to point just past the current token. Token : Token_Type; -- Type of current token Token_Ptr : Source_Ptr; -- Pointer to first character of current token Current_Line_Start : Source_Ptr; -- Pointer to first character of line containing current token Start_Column : Column_Number_Type; -- Starting column number (zero origin) of the first non-blank character -- on the line containing the current token. This is used for error -- recovery circuits which depend on looking at the column line up. Token_Node : Node_Id := Empty; -- Node table Id for the current token. This is set only if the current -- token is one for which the scanner constructs a node (i.e. it is an -- identifier, operator symbol, or literal. For other token types, -- Token_Node is undefined. Token_Name : Name_Id := No_Name; -- For identifiers, this is set to the Name_Id of the identifier scanned. -- For all other tokens, Token_Name is set to Error_Name. Note that it -- would be possible for the caller to extract this information from -- Token_Node. We set Token_Name separately for two reasons. First it -- allows a quicker test for a specific identifier. Second, it allows -- a version of the parser to be built that does not build tree nodes, -- usable as a syntax checker. Prev_Token : Token_Type := No_Token; -- Type of previous token Prev_Token_Ptr : Source_Ptr; -- Pointer to first character of previous token Version_To_Be_Found : Boolean; -- This flag is True if the scanner is still looking for an RCS version -- number in a comment. Normally it is initialized to False so that this -- circuit is not activated. If the -dv switch is set, then this flag is -- initialized to True, and then reset when the version number is found. -- We do things this way to minimize the impact on comment scanning. -------------------------------------------------------- -- Procedures for Saving and Restoring the Scan State -- -------------------------------------------------------- -- The following procedures can be used to save and restore the entire -- scan state. They are used in cases where it is necessary to backup -- the scan during the parse. type Saved_Scan_State is record Save_Scan_Ptr : Source_Ptr; -- save Scan_Ptr Save_Token : Token_Type; -- save Token Save_Token_Ptr : Source_Ptr; -- save Token_Ptr Save_Current_Line_Start : Source_Ptr; -- save Current_Line_Start Save_Token_Node : Node_Id; -- save Token_Node Save_Token_Name : Name_Id; -- save Token_Name Save_Prev_Token : Token_Type; -- save Prev_Token Save_Prev_Token_Ptr : Source_Ptr; -- save Prev_Token_Ptr Save_Start_Column : Column_Number_Type; -- save Start_Column end record; -- Used for saving and restoring the scan state procedure Save_Scan_State (Saved_State : out Saved_Scan_State); pragma Inline (Save_Scan_State); -- Saves the current scan state for possible later restoration. Note that -- there is no harm in saving the state and then never restoring it. procedure Restore_Scan_State (Saved_State : in Saved_Scan_State); pragma Inline (Restore_Scan_State); -- Restores a scan state saved by a call to Save_Scan_State. -- The saved scan state must refer to the current source file. private -- type Saved_Scan_State is record ... -- -- To be returned here when private types are working! end Scans; rst token of name (4.1), -- (identifier, char literal, operator symbol) subtype Token_Class_Desig is Token_Type range Tok_Operator_Symbol .. Tok_Identifier; -- Token which can be a Designator (identifier, operator symbol) gnat-1.67-src/src/scans.adb 444 10015 7640 6276 5506244357 10715 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S C A N S -- -- -- -- B o d y -- -- -- -- $Revision: 1.7 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ package body Scans is --------------------- -- Save_Scan_State -- --------------------- procedure Save_Scan_State (Saved_State : out Saved_Scan_State) is begin Saved_State.Save_Scan_Ptr := Scan_Ptr; Saved_State.Save_Token := Token; Saved_State.Save_Token_Ptr := Token_Ptr; Saved_State.Save_Current_Line_Start := Current_Line_Start; Saved_State.Save_Start_Column := Start_Column; Saved_State.Save_Token_Node := Token_Node; Saved_State.Save_Token_Name := Token_Name; Saved_State.Save_Prev_Token := Prev_Token; Saved_State.Save_Prev_Token_Ptr := Prev_Token_Ptr; end Save_Scan_State; ------------------------ -- Restore_Scan_State -- ------------------------ procedure Restore_Scan_State (Saved_State : in Saved_Scan_State) is begin Scan_Ptr := Saved_State.Save_Scan_Ptr; Token := Saved_State.Save_Token; Token_Ptr := Saved_State.Save_Token_Ptr; Current_Line_Start := Saved_State.Save_Current_Line_Start; Start_Column := Saved_State.Save_Start_Column; Token_Node := Saved_State.Save_Token_Node; Token_Name := Saved_State.Save_Token_Name; Prev_Token := Saved_State.Save_Prev_Token; Prev_Token_Ptr := Saved_State.Save_Prev_Token_Ptr; end Restore_Scan_State; end Scans; -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under gnat-1.67-src/src/scn.ads 444 10015 7640 6704 5506244357 10406 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S C N -- -- -- -- S p e c -- -- -- -- $Revision: 1.9 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Scn is -- This package contains the lexical analyzer routines procedure Initialize_Scanner (Unit : Unit_Number_Type); -- Initialize lexical scanner for scanning a new file. The caller has -- completed the construction of the File.Table entry for the specified -- Unit (and the Source field is known to be non-null). procedure Scan; -- Scan scans out the next token, and advances the scan state accordingly -- (see package Scan_State for details). If the scan encounters an illegal -- token, then an error message is issued pointing to the bad character, -- and Scan returns a reasonable substitute token of some kind. function Scan_First_Char return Source_Ptr; -- This routine returns the position in Source of the first non-blank -- character on the current line, used for certain error recovery actions. procedure Scan_Reserved_Identifier (Force_Msg : Boolean); -- This procedure is called to convert the current token, which the caller -- has checked is for a reserved word, to an equivalent identifier. This is -- of course only used in error situations where the parser can detect that -- a reserved word is being used as an identifier. An appropriate error -- message, pointing to the token, is also issued if either this is the -- first occurrence of misuse of this identifier, or if Force_Msg is True. procedure GNAT_Column_Check (P : Source_Ptr); -- Check to see if P points to the first non-blank character of the -- current line, and if so, check that it is in an appropriate column. -- Called only if GNAT style check mode is set (GNAT_Style_Check is True). end Scn; patches-gas138.os2˜¹n patches-gcc257.os28¬¹ognat-1.67-src/src/scn-nlit.adb 444 10015 7640 23477 5506244357 11357 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S C N . N L I T -- -- -- -- B o d y -- -- -- -- $Revision: 1.13 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Uintp; use Uintp; separate (Scn) procedure Nlit is C : Char; -- Current source program character Base_Char : Char; -- Either # or : (character at start of based number) Base : Int; -- Value of base UI_Base : Uint; -- Value of base in Uint format UI_Int_Value : Uint; -- Value of integer scanned by Scan_Integer in Uint format UI_Num_Value : Uint; -- Value of integer in numeric value being scanned Scale : Int; -- Scale value for real literal UI_Scale : Uint; -- Scale in Uint format Scanp : Source_Ptr; -- Used to save scan pointer values Exponent_Is_Negative : Boolean; -- Set true for negative exponent Extended_Digit_Value : Int; -- Extended digit value Point_Scanned : Boolean; -- Flag for decimal point scanned in numeric literal ----------------------- -- Local Subprograms -- ----------------------- procedure Error_Digit_Expected; -- Signal error of bad digit, Scan_Ptr points to the location at which -- the digit was expected on input, and is unchanged on return. procedure Scan_Integer; -- Procedure to scan integer literal. On entry, Scan_Ptr points to a -- digit, on exit Scan_Ptr points past the last character of the integer. -- For each digit encountered, UI_Int_Value is multiplied by 10, and the -- value of the digit added to the result. In addition, the value in -- Scale is decremented by one for each actual digit scanned. -------------------------- -- Error_Digit_Expected -- -------------------------- procedure Error_Digit_Expected is begin Error_Msg_S ("digit expected"); end Error_Digit_Expected; ------------------- -- Scan_Integer -- ------------------- procedure Scan_Integer is C : Char; -- Next character scanned begin C := Source (Scan_Ptr); -- Loop through digits (allowing underlines) loop UI_Int_Value := UI_Sum (UI_Product (UI_Int_Value, Uint_10), UI_From_Int (Char'Pos (C) - Char'Pos ('0'))); Scan_Ptr := Scan_Ptr + 1; Scale := Scale - 1; C := Source (Scan_Ptr); if C = '_' then loop Scan_Ptr := Scan_Ptr + 1; C := Source (Scan_Ptr); exit when C /= '_'; Error_No_Double_Underline; end loop; if C not in '0' .. '9' then Error_Digit_Expected; exit; end if; else exit when C not in '0' .. '9'; end if; end loop; end Scan_Integer; ---------------------------------- -- Start of Processing for Nlit -- ---------------------------------- begin Base := 10; UI_Base := Uint_10; UI_Int_Value := Uint_0; Scale := 0; Scan_Integer; Scale := 0; Point_Scanned := False; UI_Num_Value := UI_Int_Value; -- Various possibilities now for continuing the literal are -- period, E/e (for exponent), or :/# (for based literal). Scale := 0; C := Source (Scan_Ptr); if C = '.' then while C = '.' and then Source (Scan_Ptr + 1) /= '.' loop if Point_Scanned then Error_Msg_S ("duplicate point ignored"); end if; Point_Scanned := True; Scan_Ptr := Scan_Ptr + 1; C := Source (Scan_Ptr); if C not in '0' .. '9' then Error_Msg ("real literal cannot end with point", Scan_Ptr - 1); else Scan_Integer; UI_Num_Value := UI_Int_Value; end if; end loop; -- Based literal case. The base is the value we already scanned. -- Note also the check for := to catch the well known tricky -- bug otherwise arising from "x : integer range 1 .. 10:= 6;" elsif C = '#' or else (C = ':' and then Source (Scan_Ptr + 1) /= '=') then Base_Char := C; if Base_Char = ':' and then Ada_9X then Error_Msg_S ("obsolescent feature: use of colon for sharp?"); end if; UI_Base := UI_Int_Value; if UI_Lt (UI_Base, Uint_2) or else UI_Gt (UI_Base, Uint_16) then Error_Msg_SC ("base not 2-16"); UI_Base := Uint_16; end if; Base := UI_To_Int (UI_Base); Scan_Ptr := Scan_Ptr + 1; -- Scan out extended integer [. integer] C := Source (Scan_Ptr); UI_Int_Value := Uint_0; Scale := 0; loop if C in '0' .. '9' then Extended_Digit_Value := Int (Char'Pos (C) - Char'Pos ('0')); elsif C in 'A' .. 'F' then Extended_Digit_Value := Int (Char'Pos (C) - Char'Pos ('A') + 10); elsif C in 'a' .. 'f' then Extended_Digit_Value := Int (Char'Pos (C) - Char'Pos ('a') + 10); else Error_Msg_S ("extended digit expected"); exit; end if; if Extended_Digit_Value >= Base then Error_Msg_S ("digit >= base"); end if; UI_Int_Value := UI_Sum (UI_Product (UI_Int_Value, UI_Base), UI_From_Int (Extended_Digit_Value)); Scale := Scale - 1; Scan_Ptr := Scan_Ptr + 1; C := Source (Scan_Ptr); if C = '_' then Scan_Ptr := Scan_Ptr + 1; C := Source (Scan_Ptr); if C = '_' then Error_No_Double_Underline; Scan_Ptr := Scan_Ptr + 1; C := Source (Scan_Ptr); end if; elsif C = '.' then if Point_Scanned then Error_Msg_S ("duplicate point ignored"); end if; Scan_Ptr := Scan_Ptr + 1; C := Source (Scan_Ptr); Point_Scanned := True; Scale := 0; elsif C = Base_Char then Scan_Ptr := Scan_Ptr + 1; exit; elsif C = '#' or else C = ':' then Error_Msg_S ("based number delimiters must match"); Scan_Ptr := Scan_Ptr + 1; exit; end if; end loop; UI_Num_Value := UI_Int_Value; end if; -- Scan out exponent if not Point_Scanned then Scale := 0; UI_Scale := Uint_0; else UI_Scale := UI_From_Int (Scale); end if; if Source (Scan_Ptr) = 'e' or else Source (Scan_Ptr) = 'E' then Scan_Ptr := Scan_Ptr + 1; Exponent_Is_Negative := False; if Source (Scan_Ptr) = '+' then Scan_Ptr := Scan_Ptr + 1; elsif Source (Scan_Ptr) = '-' then if not Point_Scanned then Error_Msg_S ("negative exponent not allowed for integer literal"); else Exponent_Is_Negative := True; end if; Scan_Ptr := Scan_Ptr + 1; end if; UI_Int_Value := Uint_0; if Source (Scan_Ptr) in '0' .. '9' then Scan_Integer; else Error_Digit_Expected; end if; if Exponent_Is_Negative then UI_Scale := UI_Difference (UI_Scale, UI_Int_Value); else UI_Scale := UI_Sum (UI_Scale, UI_Int_Value); end if; end if; -- Case of real literal to be returned if Point_Scanned then Token := Tok_Real_Literal; Token_Node := New_Node (N_Real_Literal, Token_Ptr); if Base = 10 then Set_Decimal (Token_Node, True); Set_Denominator (Token_Node, UI_Negate (UI_Scale)); elsif UI_Is_Negative (UI_Scale) then Set_Denominator (Token_Node, UI_Exponentiate (UI_Base, UI_Negate (UI_Scale))); else UI_Num_Value := UI_Product (UI_Num_Value, UI_Exponentiate (UI_Base, UI_Scale)); Set_Denominator (Token_Node, Uint_0); Set_Decimal (Token_Node, True); end if; Set_Numerator (Token_Node, UI_Num_Value); -- Case of integer literal to be returned else Token := Tok_Integer_Literal; Token_Node := New_Node (N_Integer_Literal, Token_Ptr); if UI_Ne (UI_Scale, Uint_0) then Set_Intval (Token_Node, UI_Product (UI_Num_Value, UI_Exponentiate (UI_Base, UI_Scale))); else Set_Intval (Token_Node, UI_Num_Value); end if; end if; return; end Nlit; in the Resync_Past_Semicolon routine to avoid gobbling up stuff when -- a semicolon is missing. Of significance only for error recovery. subtype Token_Class_Labeled_Stmt is gnat-1.67-src/src/scn-slit.adb 444 10015 7640 24132 5506244360 11343 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S C N . S L I T -- -- -- -- B o d y -- -- -- -- $Revision: 1.10 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Stringt; use Stringt; separate (Scn) procedure Slit is Delimiter : Char; -- Delimiter (first character of string) C : Char; -- Current source program character String_Literal_Id : String_Id; -- Id for currently scanned string value procedure Error_Bad_String_Char; -- Signal bad character in string/character constant. On entry Scan_Ptr -- points to the improper character encountered during the scan, and on -- exit Scan_Ptr is bumped past the bad character. procedure Error_Unterminated_String; -- Procedure called if a line terminator character is encountered during -- scanning a string, meaning that the string is not properly terminated. procedure Set_String; -- Procedure used to distinguish between string and operator symbol. -- On entry the string has been scanned out, and its characters start -- at Token_Ptr and end one character before Scan_Ptr. On exit Token -- is set to Tok_String_Literal or Tok_Operator_Symbol as appropriate, -- and Token_Node is appropriately initialized. In addition, in the -- operator symbol case, Token_Name is appropriately set. --------------------------- -- Error_Bad_String_Char -- --------------------------- procedure Error_Bad_String_Char is C : constant Char := Source (Scan_Ptr); begin if C = HT then Error_Msg_S ("horizontal tab not allowed in string"); elsif C = VT or else C = FF then Error_Msg_S ("format effector not allowed in string"); elsif C in Upper_Half_Character then Error_Msg_S ("upper half character not allowed in string in Ada 83"); else Error_Illegal_Character; end if; end Error_Bad_String_Char; ------------------------------- -- Error_Unterminated_String -- ------------------------------- procedure Error_Unterminated_String is begin -- An interesting little refinement. Consider the following examples: -- A := "this is an unterminated string; -- A := "this is an unterminated string & -- P(A, "this is a parameter that didn't get terminated); -- We fiddle a little to do slightly better placement in these cases -- also if there is white space at the end of the line we place the -- flag at the start of this white space, not at the end. Note that -- we only have to test for blanks, since tabs aren't allowed in -- strings in the first place and would have caused an error message. -- Two more cases that we treat specially are: -- A := "this string uses the wrong terminator' -- A := "this string uses the wrong terminator' & -- In these cases we give a different error message as well -- We actually reposition the scan pointer to the point where we -- place the flag in these cases, since it seems a better bet on -- the original intention. while Source (Scan_Ptr - 1) = ' ' or else Source (Scan_Ptr - 1) = '&' loop Scan_Ptr := Scan_Ptr - 1; Unstore_String_Char; end loop; if Source (Scan_Ptr - 1) = ''' then Unstore_String_Char; Error_Msg ("incorrect string terminator character", Scan_Ptr - 1); return; end if; if Source (Scan_Ptr - 1) = ';' then Scan_Ptr := Scan_Ptr - 1; Unstore_String_Char; if Source (Scan_Ptr - 1) = ')' then Scan_Ptr := Scan_Ptr - 1; Unstore_String_Char; end if; end if; Error_Msg_S ("missing string quote"); end Error_Unterminated_String; ---------------- -- Set_String -- ---------------- procedure Set_String is Slen : Int := Int (Scan_Ptr - Token_Ptr - 2); C1, C2, C3 : Char; begin -- Token_Name is currently set to Error_Name. The following section of -- code resets Token_Name to the proper Name_Op_xx value if the string -- is a valid operator symbol, otherwise it is left set to Error_Name. if Slen = 1 then C1 := Source (Token_Ptr + 1); case C1 is when '=' => Token_Name := Name_Op_Eq; when '>' => Token_Name := Name_Op_Gt; when '<' => Token_Name := Name_Op_Lt; when '+' => Token_Name := Name_Op_Add; when '-' => Token_Name := Name_Op_Subtract; when '&' => Token_Name := Name_Op_Concat; when '*' => Token_Name := Name_Op_Multiply; when '/' => Token_Name := Name_Op_Divide; when others => null; end case; elsif Slen = 2 then C1 := Source (Token_Ptr + 1); C2 := Source (Token_Ptr + 2); if C1 = '*' and then C2 = '*' then Token_Name := Name_Op_Expon; elsif C2 = '=' then if C1 = '/' then Token_Name := Name_Op_Ne; elsif C1 = '<' then Token_Name := Name_Op_Le; elsif C1 = '>' then Token_Name := Name_Op_Ge; end if; elsif (C1 = 'O' or else C1 = 'o') and then -- OR (C2 = 'R' or else C2 = 'r') then Token_Name := Name_Op_Or; end if; elsif Slen = 3 then C1 := Source (Token_Ptr + 1); C2 := Source (Token_Ptr + 2); C3 := Source (Token_Ptr + 3); if (C1 = 'A' or else C1 = 'a') and then -- AND (C2 = 'N' or else C2 = 'n') and then (C3 = 'D' or else C3 = 'd') then Token_Name := Name_Op_And; elsif (C1 = 'A' or else C1 = 'a') and then -- ABS (C2 = 'B' or else C2 = 'b') and then (C3 = 'S' or else C3 = 's') then Token_Name := Name_Op_Abs; elsif (C1 = 'M' or else C1 = 'm') and then -- MOD (C2 = 'O' or else C2 = 'o') and then (C3 = 'D' or else C3 = 'd') then Token_Name := Name_Op_Mod; elsif (C1 = 'N' or else C1 = 'n') and then -- NOT (C2 = 'O' or else C2 = 'o') and then (C3 = 'T' or else C3 = 't') then Token_Name := Name_Op_Not; elsif (C1 = 'R' or else C1 = 'r') and then -- REM (C2 = 'E' or else C2 = 'e') and then (C3 = 'M' or else C3 = 'm') then Token_Name := Name_Op_Rem; elsif (C1 = 'X' or else C1 = 'x') and then -- XOR (C2 = 'O' or else C2 = 'o') and then (C3 = 'R' or else C3 = 'r') then Token_Name := Name_Op_Xor; end if; end if; -- If it is an operator symbol, then Token_Name is set. If it is some -- other string value, then Token_Name still contains Error_Name. if Token_Name = Error_Name then Token := Tok_String_Literal; Token_Node := New_Node (N_String_Literal, Token_Ptr); else Token := Tok_Operator_Symbol; Token_Node := New_Node (N_Operator_Symbol, Token_Ptr); Set_Chars (Token_Node, Token_Name); end if; Set_Strval (Token_Node, String_Literal_Id); end Set_String; ---------- -- Slit -- ---------- begin -- On entry, Scan_Ptr points to the opening character of the string which -- is either a percent, double quote, or apostrophe (single quote). The -- latter case is an error detected by the character literal circuit. Delimiter := Source (Scan_Ptr); Start_String; -- Loop to scan out characters of string constant loop Scan_Ptr := Scan_Ptr + 1; C := Source (Scan_Ptr); if C = Delimiter then Scan_Ptr := Scan_Ptr + 1; exit when Source (Scan_Ptr) /= Delimiter; else if C = '"' and then Delimiter = '%' then Error_Msg_S ("quote not allowed in percent delimited string"); elsif C not in Graphic_Character then if C in Line_Terminator then Error_Unterminated_String; exit; elsif C not in Upper_Half_Character or else Ada_83 then Error_Bad_String_Char; end if; end if; end if; Store_String_Char (Get_Char_Code (C)); end loop; String_Literal_Id := End_String; Set_String; return; end Slit; acter in string/character constant. On entry Scan_Ptr -- points to the improper character encountered during the scan, and on -- exit Scan_Ptr is bumped past the bad character. procedure Error_Unterminated_String; -- Procedure called if a line terminator character is encountered during -- scanning a string, meaning that the string is not properly terminated. procedure Set_String; -- Procedurgnat-1.67-src/src/scn.adb 444 10015 7640 252374 5506244361 10426 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S C N -- -- -- -- B o d y -- -- -- -- $Revision: 1.42 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Csets; use Csets; with Debug; use Debug; with Errout; use Errout; with Limits; use Limits; with Lib; use Lib; with Namet; use Namet; with Opt; use Opt; with Scans; use Scans; with Sinput; use Sinput; with Sinfo; use Sinfo; with Snames; use Snames; package body Scn is Used_As_Identifier : array (Token_Type) of Boolean; -- Flags set True if a given keyword is used as an identifier (used to -- make sure that we only post an error message for incorrect use of a -- keyword as an identifier once for a given keyword). Max_Allowed_Line_Length : Source_Ptr := Max_Line_Length; -- Maximum allowed line length (gets reset to 79 if GNAT style checking -- mode is active, i.e. GNAT_Style_Check set to True). ----------------------- -- Local Subprograms -- ----------------------- function Double_Char_Token (C : Char) return Boolean; -- This function is used for double character tokens like := or <>. It -- checks if the character following Source (Scan_Ptr) is C, and if so -- bumps Scan_Ptr past the pair of characters and returns True. A space -- between the two characters is also recognized with an appropriate -- error message being issued. If C is not present, False is returned. procedure GNAT_Comment_Check; -- Called with Scan_Ptr pointing to the first minus of a comment only -- if GNAT_Style_Check is set on. Checks for proper formatting and -- positioning of comment lines. procedure Error_Illegal_Character; -- Give illegal character error, Scan_Ptr points to character. On return, -- Scan_Ptr is bumped past the illegal character. procedure Error_Long_Line; -- Signal error of excessively long line procedure Error_No_Double_Underline; -- Signal error of double underline character procedure No_HT_Allowed (S : Source_Ptr); -- Called if HT encountered with GNAT_Style_Check set True. Issues an -- appropriate error message at the given location. procedure Require_Following_Space; -- Require token to be followed by white space. Used if in GNAT style -- checking mode (GNAT_Style_Check switch set to True). procedure Require_Preceding_Space; -- Require token to be preceded by white space. Used if in GNAT style -- checking mode (GNAT_Style_Check switch set to True). procedure Require_Surrounding_Space; -- Require token to be surrounded by white space. Used if in GNAT style -- checking mode (GNAT_Style_Check switch set to True). procedure Set_Name_Char (C : Char); pragma Inline (Set_Name_Char); -- Stores next character in Namet.Name_Buffer, incrementing count of -- currently stored characters in Name_Len. The caller is responsible -- for initializing Name_Len to zero before using this routine. procedure Set_Start_Column; -- This routine is called with Scan_Ptr pointing to the first character -- of a line. On exit, Scan_Ptr is advanced to the first non-blank -- character of this line (or to the terminating format effector if the -- line contains no non-blank characters), and Start_Column is set to the -- column number of this non-blank character (zero origin). procedure Nlit is separate; -- This is the procedure for scanning out numeric literals procedure Slit is separate; -- This is the procedure for scanning out string literals procedure Version_Comment_Scan; -- Called if Version_To_Be_Found is set and a comment is encountered to -- look for an RCS revision sequence inside the comment. If one is found, -- it is recorded in the file table, and Version_To_Be_Found is reset. On -- entry Scan_Ptr points to the -- and it is not modified by the call. ----------------------- -- Double_Char_Token -- ----------------------- function Double_Char_Token (C : Char) return Boolean is begin if Source (Scan_Ptr + 1) = C then Scan_Ptr := Scan_Ptr + 2; return True; elsif Source (Scan_Ptr + 1) = ' ' and then Source (Scan_Ptr + 2) = C then Scan_Ptr := Scan_Ptr + 1; Error_Msg_S ("no space allowed here"); Scan_Ptr := Scan_Ptr + 2; return True; else return False; end if; end Double_Char_Token; ----------------------------- -- Error_Illegal_Character -- ----------------------------- procedure Error_Illegal_Character is begin Error_Msg_S ("illegal character"); Scan_Ptr := Scan_Ptr + 1; end Error_Illegal_Character; --------------------- -- Error_Long_Line -- --------------------- procedure Error_Long_Line is begin Error_Msg ("this line is too long", Current_Line_Start); end Error_Long_Line; ------------------------------- -- Error_No_Double_Underline -- ------------------------------- procedure Error_No_Double_Underline is begin Error_Msg_S ("two consecutive underlines not permitted"); end Error_No_Double_Underline; ------------------- -- No_HT_Allowed -- ------------------- procedure No_HT_Allowed (S : Source_Ptr) is begin Error_Msg ("(style) horizontal tab not allowed", S); end No_HT_Allowed; ----------------------------- -- Require_Following_Space -- ----------------------------- procedure Require_Following_Space is begin if Source (Scan_Ptr) > ' ' then Error_Msg_S ("(style) space required"); end if; end Require_Following_Space; ----------------------------- -- Require_Preceding_Space -- ----------------------------- procedure Require_Preceding_Space is begin if Token_Ptr > Source'First and then Source (Token_Ptr - 1) > ' ' then Error_Msg_SC ("(style) space required"); end if; end Require_Preceding_Space; ------------------------------- -- Require_Surrounding_Space -- ------------------------------- procedure Require_Surrounding_Space is begin Require_Preceding_Space; Require_Following_Space; end Require_Surrounding_Space; ------------------- -- Set_Name_Char -- ------------------- procedure Set_Name_Char (C : Char) is begin Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := C; end Set_Name_Char; ------------------------ -- Initialize_Scanner -- ------------------------ procedure Initialize_Scanner (Unit : Unit_Number_Type) is begin -- Set up Token_Type values in Names Table entries for reserved keywords -- We use the Pos value of the Token_Type value. Note we are relying on -- the fact that Token_Type'Val (0) is not a reserved word! Set_Name_Table_Byte (Name_Abort, Token_Type'Pos (Tok_Abort)); Set_Name_Table_Byte (Name_Abs, Token_Type'Pos (Tok_Abs)); Set_Name_Table_Byte (Name_Abstract, Token_Type'Pos (Tok_Abstract)); Set_Name_Table_Byte (Name_Accept, Token_Type'Pos (Tok_Accept)); Set_Name_Table_Byte (Name_Access, Token_Type'Pos (Tok_Access)); Set_Name_Table_Byte (Name_And, Token_Type'Pos (Tok_And)); Set_Name_Table_Byte (Name_Aliased, Token_Type'Pos (Tok_Aliased)); Set_Name_Table_Byte (Name_All, Token_Type'Pos (Tok_All)); Set_Name_Table_Byte (Name_Array, Token_Type'Pos (Tok_Array)); Set_Name_Table_Byte (Name_At, Token_Type'Pos (Tok_At)); Set_Name_Table_Byte (Name_Begin, Token_Type'Pos (Tok_Begin)); Set_Name_Table_Byte (Name_Body, Token_Type'Pos (Tok_Body)); Set_Name_Table_Byte (Name_Case, Token_Type'Pos (Tok_Case)); Set_Name_Table_Byte (Name_Constant, Token_Type'Pos (Tok_Constant)); Set_Name_Table_Byte (Name_Declare, Token_Type'Pos (Tok_Declare)); Set_Name_Table_Byte (Name_Delay, Token_Type'Pos (Tok_Delay)); Set_Name_Table_Byte (Name_Delta, Token_Type'Pos (Tok_Delta)); Set_Name_Table_Byte (Name_Digits, Token_Type'Pos (Tok_Digits)); Set_Name_Table_Byte (Name_Do, Token_Type'Pos (Tok_Do)); Set_Name_Table_Byte (Name_Else, Token_Type'Pos (Tok_Else)); Set_Name_Table_Byte (Name_Elsif, Token_Type'Pos (Tok_Elsif)); Set_Name_Table_Byte (Name_End, Token_Type'Pos (Tok_End)); Set_Name_Table_Byte (Name_Entry, Token_Type'Pos (Tok_Entry)); Set_Name_Table_Byte (Name_Exception, Token_Type'Pos (Tok_Exception)); Set_Name_Table_Byte (Name_Exit, Token_Type'Pos (Tok_Exit)); Set_Name_Table_Byte (Name_For, Token_Type'Pos (Tok_For)); Set_Name_Table_Byte (Name_Function, Token_Type'Pos (Tok_Function)); Set_Name_Table_Byte (Name_Generic, Token_Type'Pos (Tok_Generic)); Set_Name_Table_Byte (Name_Goto, Token_Type'Pos (Tok_Goto)); Set_Name_Table_Byte (Name_If, Token_Type'Pos (Tok_If)); Set_Name_Table_Byte (Name_In, Token_Type'Pos (Tok_In)); Set_Name_Table_Byte (Name_Is, Token_Type'Pos (Tok_Is)); Set_Name_Table_Byte (Name_Limited, Token_Type'Pos (Tok_Limited)); Set_Name_Table_Byte (Name_Loop, Token_Type'Pos (Tok_Loop)); Set_Name_Table_Byte (Name_Mod, Token_Type'Pos (Tok_Mod)); Set_Name_Table_Byte (Name_New, Token_Type'Pos (Tok_New)); Set_Name_Table_Byte (Name_Not, Token_Type'Pos (Tok_Not)); Set_Name_Table_Byte (Name_Null, Token_Type'Pos (Tok_Null)); Set_Name_Table_Byte (Name_Of, Token_Type'Pos (Tok_Of)); Set_Name_Table_Byte (Name_Or, Token_Type'Pos (Tok_Or)); Set_Name_Table_Byte (Name_Others, Token_Type'Pos (Tok_Others)); Set_Name_Table_Byte (Name_Out, Token_Type'Pos (Tok_Out)); Set_Name_Table_Byte (Name_Package, Token_Type'Pos (Tok_Package)); Set_Name_Table_Byte (Name_Pragma, Token_Type'Pos (Tok_Pragma)); Set_Name_Table_Byte (Name_Private, Token_Type'Pos (Tok_Private)); Set_Name_Table_Byte (Name_Procedure, Token_Type'Pos (Tok_Procedure)); Set_Name_Table_Byte (Name_Protected, Token_Type'Pos (Tok_Protected)); Set_Name_Table_Byte (Name_Raise, Token_Type'Pos (Tok_Raise)); Set_Name_Table_Byte (Name_Range, Token_Type'Pos (Tok_Range)); Set_Name_Table_Byte (Name_Record, Token_Type'Pos (Tok_Record)); Set_Name_Table_Byte (Name_Rem, Token_Type'Pos (Tok_Rem)); Set_Name_Table_Byte (Name_Renames, Token_Type'Pos (Tok_Renames)); Set_Name_Table_Byte (Name_Requeue, Token_Type'Pos (Tok_Requeue)); Set_Name_Table_Byte (Name_Return, Token_Type'Pos (Tok_Return)); Set_Name_Table_Byte (Name_Reverse, Token_Type'Pos (Tok_Reverse)); Set_Name_Table_Byte (Name_Select, Token_Type'Pos (Tok_Select)); Set_Name_Table_Byte (Name_Separate, Token_Type'Pos (Tok_Separate)); Set_Name_Table_Byte (Name_Subtype, Token_Type'Pos (Tok_Subtype)); Set_Name_Table_Byte (Name_Tagged, Token_Type'Pos (Tok_Tagged)); Set_Name_Table_Byte (Name_Task, Token_Type'Pos (Tok_Task)); Set_Name_Table_Byte (Name_Terminate, Token_Type'Pos (Tok_Terminate)); Set_Name_Table_Byte (Name_Then, Token_Type'Pos (Tok_Then)); Set_Name_Table_Byte (Name_Type, Token_Type'Pos (Tok_Type)); Set_Name_Table_Byte (Name_Until, Token_Type'Pos (Tok_Until)); Set_Name_Table_Byte (Name_Use, Token_Type'Pos (Tok_Use)); Set_Name_Table_Byte (Name_When, Token_Type'Pos (Tok_When)); Set_Name_Table_Byte (Name_While, Token_Type'Pos (Tok_While)); Set_Name_Table_Byte (Name_With, Token_Type'Pos (Tok_With)); Set_Name_Table_Byte (Name_Xor, Token_Type'Pos (Tok_Xor)); -- Initialize scan control variables Source := File.Table (Unit).Source; Source_Cache := Source; Scan_Unit := Unit; Scan_Ptr := Source'First; Token := No_Token; Token_Ptr := Source'First; Current_Line_Start := Source'First; Token_Node := Empty; Token_Name := No_Name; Version_To_Be_Found := Debug_Flag_V; Set_Start_Column; if GNAT_Style_Check then Max_Allowed_Line_Length := 79; end if; -- Scan initial token (note this initializes Prev_Token, Prev_Token_Ptr) Scan; -- Clear flags for reserved words used as indentifiers for I in Token_Type loop Used_As_Identifier (I) := False; end loop; end Initialize_Scanner; ---------- -- Scan -- ---------- procedure Scan is begin Prev_Token := Token; Prev_Token_Ptr := Token_Ptr; Token_Name := Error_Name; -- The following loop runs more than once only if a format effector -- (tab, vertical tab, form feed, line feed, carriage return) is -- encountered and skipped, or some error situation, such as an -- illegal character, is encountered. loop -- Skip past blanks, loop is opened up for speed while Source (Scan_Ptr) = ' ' loop if Source (Scan_Ptr + 1) /= ' ' then Scan_Ptr := Scan_Ptr + 1; exit; end if; if Source (Scan_Ptr + 2) /= ' ' then Scan_Ptr := Scan_Ptr + 2; exit; end if; if Source (Scan_Ptr + 3) /= ' ' then Scan_Ptr := Scan_Ptr + 3; exit; end if; if Source (Scan_Ptr + 4) /= ' ' then Scan_Ptr := Scan_Ptr + 4; exit; end if; if Source (Scan_Ptr + 5) /= ' ' then Scan_Ptr := Scan_Ptr + 5; exit; end if; if Source (Scan_Ptr + 6) /= ' ' then Scan_Ptr := Scan_Ptr + 6; exit; end if; if Source (Scan_Ptr + 7) /= ' ' then Scan_Ptr := Scan_Ptr + 7; exit; end if; Scan_Ptr := Scan_Ptr + 8; end loop; -- Switch on non-blank character encountered Token_Ptr := Scan_Ptr; case Source (Scan_Ptr) is -- CR ends a physical line. If it is immediately followed by a LF, -- then this LF is considered to be part of the same line terminator. when CR => if Scan_Ptr - Current_Line_Start > Max_Allowed_Line_Length then Error_Long_Line; end if; Scan_Ptr := Scan_Ptr + 1; if Source (Scan_Ptr) = LF then Scan_Ptr := Scan_Ptr + 1; end if; Next_Line; Set_Start_Column; -- FF never terminates a physical line when FF => Scan_Ptr := Scan_Ptr + 1; Set_Start_Column; -- LF ends a physical line. If it is immediately followed by a CR, -- then this CR is considered to be part of the same line terminator. when LF => if Scan_Ptr - Current_Line_Start > Max_Allowed_Line_Length then Error_Long_Line; end if; Scan_Ptr := Scan_Ptr + 1; if Source (Scan_Ptr) = CR then Scan_Ptr := Scan_Ptr + 1; end if; Next_Line; Set_Start_Column; -- VT never terminates a physical line when VT => Scan_Ptr := Scan_Ptr + 1; Set_Start_Column; -- Horizontal tab, just skip past it when HT => if GNAT_Style_Check then No_HT_Allowed (Scan_Ptr); end if; Scan_Ptr := Scan_Ptr + 1; -- End of file character when EOF => Token := Tok_EOF; return; -- Ampersand when '&' => if Source (Scan_Ptr + 1) = '&' then Error_Msg_S ("'&'& should be `AND THEN`"); Scan_Ptr := Scan_Ptr + 2; Token := Tok_And; return; else Scan_Ptr := Scan_Ptr + 1; Token := Tok_Ampersand; if GNAT_Style_Check then Require_Surrounding_Space; end if; return; end if; -- Asterisk (can be multiplication operator or double asterisk -- which is the exponentiation compound delimtier). when '*' => if Source (Scan_Ptr + 1) = '*' then Scan_Ptr := Scan_Ptr + 2; Token := Tok_Double_Asterisk; return; else Scan_Ptr := Scan_Ptr + 1; Token := Tok_Asterisk; if GNAT_Style_Check then Require_Surrounding_Space; end if; return; end if; -- Colon, which can either be an isolated colon, or part of an -- assignment compound delimiter. when ':' => if Double_Char_Token ('=') then Token := Tok_Colon_Equal; if GNAT_Style_Check then Require_Surrounding_Space; end if; return; else Scan_Ptr := Scan_Ptr + 1; Token := Tok_Colon; if GNAT_Style_Check then Require_Surrounding_Space; end if; return; end if; -- Left parenthesis when '(' => if GNAT_Style_Check then if Letter_Or_Digit (Source (Scan_Ptr - 1)) then Error_Msg_S ("(style) space required"); end if; end if; Scan_Ptr := Scan_Ptr + 1; Token := Tok_Left_Paren; return; -- Left bracket, treated as left paren when '[' => Error_Msg_S ("illegal character ""["", replaced by ""("""); Scan_Ptr := Scan_Ptr + 1; Token := Tok_Left_Paren; return; -- Comma when ',' => -- In GNAT style check mode, a comma must be either the first -- token on a line, or be preceded by a blank. It must also -- always be followed by a blank. if GNAT_Style_Check then if Source (Scan_Ptr - 1) = ' ' and then Prev_Token_Ptr >= Current_Line_Start then Error_Msg ("(style) no space allowed", Scan_Ptr - 1); elsif Source (Scan_Ptr + 1) > ' ' then Error_Msg ("(style) space required", Scan_Ptr + 1); end if; end if; Scan_Ptr := Scan_Ptr + 1; Token := Tok_Comma; return; -- Dot, which is either an isolated period, or part of a double -- dot compound delimiter sequence. We also check for the case of -- a digit following the period, to give a better error message. when '.' => if Source (Scan_Ptr + 1) = '.' then Scan_Ptr := Scan_Ptr + 2; Token := Tok_Dot_Dot; if GNAT_Style_Check then Require_Surrounding_Space; end if; return; elsif Source (Scan_Ptr + 1) in '0' .. '9' then Error_Msg_S ("numeric literal cannot start with point"); Scan_Ptr := Scan_Ptr + 1; else Scan_Ptr := Scan_Ptr + 1; Token := Tok_Dot; return; end if; -- Equal, which can either be an equality operator, or part of the -- arrow (=>) compound delimiter. when '=' => if Double_Char_Token ('>') then Token := Tok_Arrow; if GNAT_Style_Check then Require_Surrounding_Space; end if; return; elsif Source (Scan_Ptr + 1) = '=' then Error_Msg_S ("== should be ="); Scan_Ptr := Scan_Ptr + 1; end if; Scan_Ptr := Scan_Ptr + 1; Token := Tok_Equal; if GNAT_Style_Check then Require_Surrounding_Space; end if; return; -- Greater than, which can be a greater than operator, greater than -- or equal operator, or first character of a right label bracket. when '>' => if Double_Char_Token ('=') then Token := Tok_Greater_Equal; if GNAT_Style_Check then Require_Surrounding_Space; end if; return; elsif Double_Char_Token ('>') then Token := Tok_Greater_Greater; return; else Scan_Ptr := Scan_Ptr + 1; Token := Tok_Greater; return; end if; -- Less than, which can be a less than operator, less than or equal -- operator, or the first character of a left label bracket, or the -- first character of a box (<>) compound delimiter. when '<' => if Double_Char_Token ('=') then Token := Tok_Less_Equal; if GNAT_Style_Check then Require_Surrounding_Space; end if; return; elsif Double_Char_Token ('>') then Token := Tok_Box; if Prev_Token /= Tok_Left_Paren and then GNAT_Style_Check then Require_Preceding_Space; end if; return; elsif Double_Char_Token ('<') then Token := Tok_Less_Less; return; else Scan_Ptr := Scan_Ptr + 1; Token := Tok_Less; if GNAT_Style_Check then Require_Surrounding_Space; end if; return; end if; -- Minus, which is either a subtraction operator, or the first -- character of double minus starting a comment when '-' => if Source (Scan_Ptr + 1) = '>' then Error_Msg_S ("-> should be =>"); Scan_Ptr := Scan_Ptr + 2; Token := Tok_Arrow; if GNAT_Style_Check then Require_Surrounding_Space; end if; return; elsif Source (Scan_Ptr + 1) /= '-' then Scan_Ptr := Scan_Ptr + 1; if GNAT_Style_Check and then Source (Token_Ptr - 1) /= '(' then Require_Preceding_Space; end if; Token := Tok_Minus; return; -- Comment else -- Source (Scan_Ptr + 1) = '-' then if GNAT_Style_Check then GNAT_Comment_Check; end if; if Version_To_Be_Found then Version_Comment_Scan; end if; Scan_Ptr := Scan_Ptr + 2; -- Loop to scan comment (this loop runs more than once only if -- a horizontal tab or other non-graphic character is scanned) loop -- Scan to non graphic character (opened up for speed) loop exit when Source (Scan_Ptr) not in Graphic_Character; Scan_Ptr := Scan_Ptr + 1; exit when Source (Scan_Ptr) not in Graphic_Character; Scan_Ptr := Scan_Ptr + 1; exit when Source (Scan_Ptr) not in Graphic_Character; Scan_Ptr := Scan_Ptr + 1; exit when Source (Scan_Ptr) not in Graphic_Character; Scan_Ptr := Scan_Ptr + 1; exit when Source (Scan_Ptr) not in Graphic_Character; Scan_Ptr := Scan_Ptr + 1; end loop; -- Keep going if horizontal tab if Source (Scan_Ptr) = HT then if GNAT_Style_Check then No_HT_Allowed (Scan_Ptr); end if; Scan_Ptr := Scan_Ptr + 1; -- Terminate scan of comment if line terminator or EOF elsif Source (Scan_Ptr) in Line_Terminator or else Source (Scan_Ptr) = EOF then if Scan_Ptr - Current_Line_Start > Max_Allowed_Line_Length then Error_Long_Line; end if; exit; -- Terminate scan of comment if end of file encountered -- (embedded EOF character or real last character in file) elsif Source (Scan_Ptr) = EOF then exit; -- Keep going if character in 80-FF range. These characters -- are allowed in comments according to the approved AI. -- Also allow ESC, which just got added to the AI (June 93) elsif Source (Scan_Ptr) in Upper_Half_Character or else Source (Scan_Ptr) = ESC then Scan_Ptr := Scan_Ptr + 1; -- Otherwise we have an illegal comment character else Error_Illegal_Character; end if; end loop; -- Note that we do NOT execute a return here, instead we fall -- through to reexecute the scan loop to look for a token. end if; -- Double quote starting a string constant when '"' => Slit; return; -- Percent starting a string constant when '%' => if Ada_9X then Error_Msg_S ("obsolescent feature: use of percent for double quote?"); end if; Slit; return; -- Apostrophe. This can either be the start of a character literal, -- or an isolated apostrophe used in a qualified expression or an -- attribute. We treat it as a character literal if it does not -- follow a right parenthesis, identifier or literal. This means -- that we correctly treat constructs like: -- A := CHARACTER'('A'); -- which appears to be illegal according to 2.2(2) (since the rule -- there would seem to require separators to avoid the confusion -- with the character literal), but all compilers accept the above -- statement, and there are at least six ACVC tests that use this -- type of lexical sequence, expecting it to be legal, so in fact -- all compilers must accept this and we must too! when ''' => Scan_Ptr := Scan_Ptr + 1; -- Here is where we make the test to distinguish the cases. Treat -- as apostrophe if previous token is an identifier, right paren -- or the reserved word "all" (latter case as in A.all'Address) -- Also treat it as apostrophe after a literal (wrong anyway, but -- that's probably the better choice). if Prev_Token = Tok_Identifier or else Prev_Token = Tok_Right_Paren or else Prev_Token = Tok_All or else Prev_Token in Token_Class_Literal then Token := Tok_Apostrophe; return; -- Otherwise the apostrophe starts a character literal else -- If we do not find a closing quote in the expected place then -- assume that we have a misguided attempt at a string literal. if Source (Scan_Ptr + 1) /= ''' then Scan_Ptr := Scan_Ptr - 1; Error_Msg_S ("strings are delimited by double quote character"); Slit; return; -- Otherwise we have an OK character literal else if Source (Scan_Ptr) not in Graphic_Character and then Source (Scan_Ptr) not in Upper_Half_Character then Error_Illegal_Character; end if; Token := Tok_Char_Literal; Token_Node := New_Node (N_Character_Literal, Token_Ptr); Set_Char_Literal_Value (Token_Node, Get_Char_Code (Source (Scan_Ptr))); Name_Len := 0; Set_Name_Char ('''); Set_Name_Char (Source (Scan_Ptr)); Set_Name_Char ('''); Token_Name := Name_Find; Set_Chars (Token_Node, Token_Name); Scan_Ptr := Scan_Ptr + 2; return; end if; end if; -- Right parenthesis when ')' => Scan_Ptr := Scan_Ptr + 1; Token := Tok_Right_Paren; return; -- Right bracket, treated as right paren when ']' => Error_Msg_S ("illegal character ""]"", replaced by "")"""); Scan_Ptr := Scan_Ptr + 1; Token := Tok_Right_Paren; return; -- Slash (can be division operator or first character of not equal) when '/' => if Double_Char_Token ('=') then Token := Tok_Not_Equal; if GNAT_Style_Check then Require_Surrounding_Space; end if; return; else Scan_Ptr := Scan_Ptr + 1; Token := Tok_Slash; if GNAT_Style_Check then Require_Surrounding_Space; end if; return; end if; -- Semicolon when ';' => if GNAT_Style_Check then if Source (Scan_Ptr - 1) = ' ' then Error_Msg ("(style) no space allowed", Scan_Ptr - 1); elsif Source (Scan_Ptr + 1) > ' ' then Error_Msg ("(style) space required", Scan_Ptr + 1); end if; end if; Scan_Ptr := Scan_Ptr + 1; Token := Tok_Semicolon; return; -- Vertical bar when '|' => if Source (Scan_Ptr + 1) = '|' then Error_Msg_S ("|| should be `OR ELSE`"); Scan_Ptr := Scan_Ptr + 2; Token := Tok_Or; return; else Scan_Ptr := Scan_Ptr + 1; Token := Tok_Vertical_Bar; if GNAT_Style_Check then Require_Surrounding_Space; end if; return; end if; -- Exclamation, replacement character for vertical bar when '!' => if Source (Scan_Ptr + 1) = '=' then Error_Msg_S ("'!= should be /="); Scan_Ptr := Scan_Ptr + 2; Token := Tok_Not_Equal; return; elsif Ada_9X then Error_Msg_S ("obsolescent feature: use of exclamation for vertical bar?"); end if; Scan_Ptr := Scan_Ptr + 1; Token := Tok_Vertical_Bar; return; -- Plus when '+' => Scan_Ptr := Scan_Ptr + 1; if GNAT_Style_Check and then Source (Token_Ptr - 1) /= '(' then Require_Preceding_Space; end if; Token := Tok_Plus; return; -- Digits starting a numeric constant when '0' .. '9' => Nlit; if Letter_Or_Digit (Source (Scan_Ptr)) then Error_Msg ("delimiter required between literal and identifier", Scan_Ptr); end if; return; -- Keyword scan routines. These are separated by initial lower case -- letter and for each letter, the appropriate keywords are tested -- directly. If a keyword is scanned, then control is passed to -- Scan_Keyword, otherwise control passes to Scan_Identifier_n, -- where n is a digit which indicates the number of characters, -- starting at Scan_Ptr, which are known to be letters. -- The assumption is that keywords are most likely to be spelled -- in lower case letters, and that identifiers are likely to be -- spelled with an initial upper case letter. If an identifier -- starts with a lower case letter, then everything is fine since -- control goes to Scan_Identifier_n as described above. If a -- keyword is spelled in upper case, then things are also OK, but -- the mechanism for recognizing the keywords is quite different -- and depends on the use of the Name table (see Scan_Identifier). -- Keywords starting with A when 'a' => -- ABORT if Source (Scan_Ptr + 1) = 'b' then if Source (Scan_Ptr + 2) = 'o' then if Source (Scan_Ptr + 3) = 'r' then if Source (Scan_Ptr + 4) = 't' then Token := Tok_Abort; Scan_Ptr := Scan_Ptr + 5; goto Scan_Keyword; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; -- ABSTRACT elsif Source (Scan_Ptr + 2) = 's' then if Ada_9X and then Source (Scan_Ptr + 3) = 't' then if Source (Scan_Ptr + 4) = 'r' then if Source (Scan_Ptr + 5) = 'a' then if Source (Scan_Ptr + 6) = 'c' then if Source (Scan_Ptr + 7) = 't' then Token := Tok_Abstract; Scan_Ptr := Scan_Ptr + 8; goto Scan_Keyword; else goto Scan_Identifier_7; end if; else goto Scan_Identifier_6; end if; else goto Scan_Identifier_5; end if; else goto Scan_Identifier_4; end if; -- ABS else Token := Tok_Abs; Scan_Ptr := Scan_Ptr + 3; goto Scan_Keyword; end if; else goto Scan_Identifier_2; end if; -- ACCEPT elsif Source (Scan_Ptr + 1) = 'c' then if Source (Scan_Ptr + 2) = 'c' then if Source (Scan_Ptr + 3) = 'e' then if Source (Scan_Ptr + 4) = 'p' then if Source (Scan_Ptr + 5) = 't' then Token := Tok_Accept; Scan_Ptr := Scan_Ptr + 6; goto Scan_Keyword; else goto Scan_Identifier_5; end if; -- ACCESS elsif Source (Scan_Ptr + 4) = 's' then if Source (Scan_Ptr + 5) = 's' then Token := Tok_Access; Scan_Ptr := Scan_Ptr + 6; goto Scan_Keyword; else goto Scan_Identifier_5; end if; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; else goto Scan_Identifier_2; end if; -- ALL elsif Source (Scan_Ptr + 1) = 'l' then if Source (Scan_Ptr + 2) = 'l' then Token := Tok_All; Scan_Ptr := Scan_Ptr + 3; goto Scan_Keyword; -- ALIASED (9X only) elsif Ada_9X and then Source (Scan_Ptr + 2) = 'i' then if Source (Scan_Ptr + 3) = 'a' then if Source (Scan_Ptr + 4) = 's' then if Source (Scan_Ptr + 5) = 'e' then if Source (Scan_Ptr + 6) = 'd' then Token := Tok_Aliased; Scan_Ptr := Scan_Ptr + 7; goto Scan_Keyword; else goto Scan_Identifier_6; end if; else goto Scan_Identifier_5; end if; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; else goto Scan_Identifier_2; end if; -- AND elsif Source (Scan_Ptr + 1) = 'n' then if Source (Scan_Ptr + 2) = 'd' then Token := Tok_And; Scan_Ptr := Scan_Ptr + 3; goto Scan_Keyword; else goto Scan_Identifier_2; end if; -- ARRAY elsif Source (Scan_Ptr + 1) = 'r' then if Source (Scan_Ptr + 2) = 'r' then if Source (Scan_Ptr + 3) = 'a' then if Source (Scan_Ptr + 4) = 'y' then Token := Tok_Array; Scan_Ptr := Scan_Ptr + 5; goto Scan_Keyword; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; else goto Scan_Identifier_2; end if; -- AT elsif Source (Scan_Ptr + 1) = 't' then Token := Tok_At; Scan_Ptr := Scan_Ptr + 2; goto Scan_Keyword; else goto Scan_Identifier_1; end if; -- Keywords starting with B when 'b' => -- BEGIN if Source (Scan_Ptr + 1) = 'e' then if Source (Scan_Ptr + 2) = 'g' then if Source (Scan_Ptr + 3) = 'i' then if Source (Scan_Ptr + 4) = 'n' then Token := Tok_Begin; Scan_Ptr := Scan_Ptr + 5; goto Scan_Keyword; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; else goto Scan_Identifier_2; end if; -- BODY elsif Source (Scan_Ptr + 1) = 'o' then if Source (Scan_Ptr + 2) = 'd' then if Source (Scan_Ptr + 3) = 'y' then Token := Tok_Body; Scan_Ptr := Scan_Ptr + 4; goto Scan_Keyword; else goto Scan_Identifier_3; end if; else goto Scan_Identifier_2; end if; else goto Scan_Identifier_1; end if; -- Keywords starting with C when 'c' => -- CASE if Source (Scan_Ptr + 1) = 'a' then if Source (Scan_Ptr + 2) = 's' then if Source (Scan_Ptr + 3) = 'e' then Token := Tok_Case; Scan_Ptr := Scan_Ptr + 4; goto Scan_Keyword; else goto Scan_Identifier_3; end if; else goto Scan_Identifier_2; end if; -- CONSTANT elsif Source (Scan_Ptr + 1) = 'o' then if Source (Scan_Ptr + 2) = 'n' then if Source (Scan_Ptr + 3) = 's' then if Source (Scan_Ptr + 4) = 't' then if Source (Scan_Ptr + 5) = 'a' then if Source (Scan_Ptr + 6) = 'n' then if Source (Scan_Ptr + 7) = 't' then Token := Tok_Constant; Scan_Ptr := Scan_Ptr + 8; goto Scan_Keyword; else goto Scan_Identifier_7; end if; else goto Scan_Identifier_6; end if; else goto Scan_Identifier_5; end if; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; else goto Scan_Identifier_2; end if; else goto Scan_Identifier_1; end if; -- Keywords starting with D when 'd' => -- DECLARE if Source (Scan_Ptr + 1) = 'e' then if Source (Scan_Ptr + 2) = 'c' then if Source (Scan_Ptr + 3) = 'l' then if Source (Scan_Ptr + 4) = 'a' then if Source (Scan_Ptr + 5) = 'r' then if Source (Scan_Ptr + 6) = 'e' then Token := Tok_Declare; Scan_Ptr := Scan_Ptr + 7; goto Scan_Keyword; else goto Scan_Identifier_6; end if; else goto Scan_Identifier_5; end if; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; -- DELAY elsif Source (Scan_Ptr + 2) = 'l' then if Source (Scan_Ptr + 3) = 'a' then if Source (Scan_Ptr + 4) = 'y' then Token := Tok_Delay; Scan_Ptr := Scan_Ptr + 5; goto Scan_Keyword; else goto Scan_Identifier_4; end if; -- DELTA elsif Source (Scan_Ptr + 3) = 't' then if Source (Scan_Ptr + 4) = 'a' then Token := Tok_Delta; Scan_Ptr := Scan_Ptr + 5; goto Scan_Keyword; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; else goto Scan_Identifier_2; end if; -- DIGITS elsif Source (Scan_Ptr + 1) = 'i' then if Source (Scan_Ptr + 2) = 'g' then if Source (Scan_Ptr + 3) = 'i' then if Source (Scan_Ptr + 4) = 't' then if Source (Scan_Ptr + 5) = 's' then Token := Tok_Digits; Scan_Ptr := Scan_Ptr + 6; goto Scan_Keyword; else goto Scan_Identifier_5; end if; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; else goto Scan_Identifier_2; end if; -- DO elsif Source (Scan_Ptr + 1) = 'o' then Token := Tok_Do; Scan_Ptr := Scan_Ptr + 2; goto Scan_Keyword; else goto Scan_Identifier_1; end if; -- Keywords starting with E when 'e' => -- ELSE if Source (Scan_Ptr + 1) = 'l' then if Source (Scan_Ptr + 2) = 's' then if Source (Scan_Ptr + 3) = 'e' then Token := Tok_Else; Scan_Ptr := Scan_Ptr + 4; goto Scan_Keyword; -- ELSIF elsif Source (Scan_Ptr + 3) = 'i' then if Source (Scan_Ptr + 4) = 'f' then Token := Tok_Elsif; Scan_Ptr := Scan_Ptr + 5; goto Scan_Keyword; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; else goto Scan_Identifier_2; end if; -- END elsif Source (Scan_Ptr + 1) = 'n' then if Source (Scan_Ptr + 2) = 'd' then Token := Tok_End; Scan_Ptr := Scan_Ptr + 3; goto Scan_Keyword; -- ENTRY elsif Source (Scan_Ptr + 2) = 't' then if Source (Scan_Ptr + 3) = 'r' then if Source (Scan_Ptr + 4) = 'y' then Token := Tok_Entry; Scan_Ptr := Scan_Ptr + 5; goto Scan_Keyword; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; else goto Scan_Identifier_2; end if; -- EXCEPTION elsif Source (Scan_Ptr + 1) = 'x' then if Source (Scan_Ptr + 2) = 'c' then if Source (Scan_Ptr + 3) = 'e' then if Source (Scan_Ptr + 4) = 'p' then if Source (Scan_Ptr + 5) = 't' then if Source (Scan_Ptr + 6) = 'i' then if Source (Scan_Ptr + 7) = 'o' then if Source (Scan_Ptr + 8) = 'n' then Token := Tok_Exception; Scan_Ptr := Scan_Ptr + 9; goto Scan_Keyword; else goto Scan_Identifier_8; end if; else goto Scan_Identifier_7; end if; else goto Scan_Identifier_6; end if; else goto Scan_Identifier_5; end if; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; -- EXIT elsif Source (Scan_Ptr + 2) = 'i' then if Source (Scan_Ptr + 3) = 't' then Token := Tok_Exit; Scan_Ptr := Scan_Ptr + 4; goto Scan_Keyword; else goto Scan_Identifier_3; end if; else goto Scan_Identifier_2; end if; else goto Scan_Identifier_1; end if; -- Keywords starting with F when 'f' => -- FOR if Source (Scan_Ptr + 1) = 'o' then if Source (Scan_Ptr + 2) = 'r' then Token := Tok_For; Scan_Ptr := Scan_Ptr + 3; goto Scan_Keyword; else goto Scan_Identifier_2; end if; -- FUNCTION elsif Source (Scan_Ptr + 1) = 'u' then if Source (Scan_Ptr + 2) = 'n' then if Source (Scan_Ptr + 3) = 'c' then if Source (Scan_Ptr + 4) = 't' then if Source (Scan_Ptr + 5) = 'i' then if Source (Scan_Ptr + 6) = 'o' then if Source (Scan_Ptr + 7) = 'n' then Token := Tok_Function; Scan_Ptr := Scan_Ptr + 8; goto Scan_Keyword; else goto Scan_Identifier_7; end if; else goto Scan_Identifier_6; end if; else goto Scan_Identifier_5; end if; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; else goto Scan_Identifier_2; end if; else goto Scan_Identifier_1; end if; -- Keywords starting with G when 'g' => -- GENERIC if Source (Scan_Ptr + 1) = 'e' then if Source (Scan_Ptr + 2) = 'n' then if Source (Scan_Ptr + 3) = 'e' then if Source (Scan_Ptr + 4) = 'r' then if Source (Scan_Ptr + 5) = 'i' then if Source (Scan_Ptr + 6) = 'c' then Token := Tok_Generic; Scan_Ptr := Scan_Ptr + 7; goto Scan_Keyword; else goto Scan_Identifier_6; end if; else goto Scan_Identifier_5; end if; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; else goto Scan_Identifier_2; end if; -- GOTO elsif Source (Scan_Ptr + 1) = 'o' then if Source (Scan_Ptr + 2) = 't' then if Source (Scan_Ptr + 3) = 'o' then Token := Tok_Goto; Scan_Ptr := Scan_Ptr + 4; goto Scan_Keyword; else goto Scan_Identifier_3; end if; else goto Scan_Identifier_2; end if; else goto Scan_Identifier_1; end if; -- Keywords starting with I when 'i' => -- IF if Source (Scan_Ptr + 1) = 'f' then Token := Tok_If; Scan_Ptr := Scan_Ptr + 2; goto Scan_Keyword; -- IN elsif Source (Scan_Ptr + 1) = 'n' then Token := Tok_In; Scan_Ptr := Scan_Ptr + 2; goto Scan_Keyword; -- IS elsif Source (Scan_Ptr + 1) = 's' then Token := Tok_Is; Scan_Ptr := Scan_Ptr + 2; goto Scan_Keyword; else goto Scan_Identifier_1; end if; -- Keywords starting with L when 'l' => -- LIMITED if Source (Scan_Ptr + 1) = 'i' then if Source (Scan_Ptr + 2) = 'm' then if Source (Scan_Ptr + 3) = 'i' then if Source (Scan_Ptr + 4) = 't' then if Source (Scan_Ptr + 5) = 'e' then if Source (Scan_Ptr + 6) = 'd' then Token := Tok_Limited; Scan_Ptr := Scan_Ptr + 7; goto Scan_Keyword; else goto Scan_Identifier_6; end if; else goto Scan_Identifier_5; end if; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; else goto Scan_Identifier_2; end if; -- LOOP elsif Source (Scan_Ptr + 1) = 'o' then if Source (Scan_Ptr + 2) = 'o' then if Source (Scan_Ptr + 3) = 'p' then Token := Tok_Loop; Scan_Ptr := Scan_Ptr + 4; goto Scan_Keyword; else goto Scan_Identifier_3; end if; else goto Scan_Identifier_2; end if; else goto Scan_Identifier_1; end if; -- Keywords starting with M when 'm' => -- MOD if Source (Scan_Ptr + 1) = 'o' then if Source (Scan_Ptr + 2) = 'd' then Token := Tok_Mod; Scan_Ptr := Scan_Ptr + 3; goto Scan_Keyword; else goto Scan_Identifier_2; end if; else goto Scan_Identifier_1; end if; -- Keywords starting with N when 'n' => -- NEW if Source (Scan_Ptr + 1) = 'e' then if Source (Scan_Ptr + 2) = 'w' then Token := Tok_New; Scan_Ptr := Scan_Ptr + 3; goto Scan_Keyword; else goto Scan_Identifier_2; end if; -- NOT elsif Source (Scan_Ptr + 1) = 'o' then if Source (Scan_Ptr + 2) = 't' then Token := Tok_Not; Scan_Ptr := Scan_Ptr + 3; goto Scan_Keyword; else goto Scan_Identifier_2; end if; -- NULL elsif Source (Scan_Ptr + 1) = 'u' then if Source (Scan_Ptr + 2) = 'l' then if Source (Scan_Ptr + 3) = 'l' then Token := Tok_Null; Scan_Ptr := Scan_Ptr + 4; goto Scan_Keyword; else goto Scan_Identifier_3; end if; else goto Scan_Identifier_2; end if; else goto Scan_Identifier_1; end if; -- Keywords starting with O when 'o' => -- OF if Source (Scan_Ptr + 1) = 'f' then Token := Tok_Of; Scan_Ptr := Scan_Ptr + 2; goto Scan_Keyword; -- OR elsif Source (Scan_Ptr + 1) = 'r' then Token := Tok_Or; Scan_Ptr := Scan_Ptr + 2; goto Scan_Keyword; -- OTHERS elsif Source (Scan_Ptr + 1) = 't' then if Source (Scan_Ptr + 2) = 'h' then if Source (Scan_Ptr + 3) = 'e' then if Source (Scan_Ptr + 4) = 'r' then if Source (Scan_Ptr + 5) = 's' then Token := Tok_Others; Scan_Ptr := Scan_Ptr + 6; goto Scan_Keyword; else goto Scan_Identifier_5; end if; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; else goto Scan_Identifier_2; end if; -- OUT elsif Source (Scan_Ptr + 1) = 'u' then if Source (Scan_Ptr + 2) = 't' then Token := Tok_Out; Scan_Ptr := Scan_Ptr + 3; goto Scan_Keyword; else goto Scan_Identifier_2; end if; else goto Scan_Identifier_1; end if; -- Keywords starting with P when 'p' => -- PACKAGE if Source (Scan_Ptr + 1) = 'a' then if Source (Scan_Ptr + 2) = 'c' then if Source (Scan_Ptr + 3) = 'k' then if Source (Scan_Ptr + 4) = 'a' then if Source (Scan_Ptr + 5) = 'g' then if Source (Scan_Ptr + 6) = 'e' then Token := Tok_Package; Scan_Ptr := Scan_Ptr + 7; goto Scan_Keyword; else goto Scan_Identifier_6; end if; else goto Scan_Identifier_5; end if; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; else goto Scan_Identifier_2; end if; -- PRAGMA elsif Source (Scan_Ptr + 1) = 'r' then if Source (Scan_Ptr + 2) = 'a' then if Source (Scan_Ptr + 3) = 'g' then if Source (Scan_Ptr + 4) = 'm' then if Source (Scan_Ptr + 5) = 'a' then Token := Tok_Pragma; Scan_Ptr := Scan_Ptr + 6; goto Scan_Keyword; else goto Scan_Identifier_5; end if; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; -- PRIVATE elsif Source (Scan_Ptr + 2) = 'i' then if Source (Scan_Ptr + 3) = 'v' then if Source (Scan_Ptr + 4) = 'a' then if Source (Scan_Ptr + 5) = 't' then if Source (Scan_Ptr + 6) = 'e' then Token := Tok_Private; Scan_Ptr := Scan_Ptr + 7; goto Scan_Keyword; else goto Scan_Identifier_6; end if; else goto Scan_Identifier_5; end if; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; -- PROCEDURE elsif Source (Scan_Ptr + 2) = 'o' then if Source (Scan_Ptr + 3) = 'c' then if Source (Scan_Ptr + 4) = 'e' then if Source (Scan_Ptr + 5) = 'd' then if Source (Scan_Ptr + 6) = 'u' then if Source (Scan_Ptr + 7) = 'r' then if Source (Scan_Ptr + 8) = 'e' then Token := Tok_Procedure; Scan_Ptr := Scan_Ptr + 9; goto Scan_Keyword; else goto Scan_Identifier_8; end if; else goto Scan_Identifier_7; end if; else goto Scan_Identifier_6; end if; else goto Scan_Identifier_5; end if; else goto Scan_Identifier_4; end if; -- PROTECTED (9X only) elsif Ada_9X and then Source (Scan_Ptr + 3) = 't' then if Source (Scan_Ptr + 4) = 'e' then if Source (Scan_Ptr + 5) = 'c' then if Source (Scan_Ptr + 6) = 't' then if Source (Scan_Ptr + 7) = 'e' then if Source (Scan_Ptr + 8) = 'd' then Token := Tok_Protected; Scan_Ptr := Scan_Ptr + 9; goto Scan_Keyword; else goto Scan_Identifier_8; end if; else goto Scan_Identifier_7; end if; else goto Scan_Identifier_6; end if; else goto Scan_Identifier_5; end if; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; else goto Scan_Identifier_2; end if; else goto Scan_Identifier_1; end if; -- Keywords starting with R when 'r' => -- RAISE if Source (Scan_Ptr + 1) = 'a' then if Source (Scan_Ptr + 2) = 'i' then if Source (Scan_Ptr + 3) = 's' then if Source (Scan_Ptr + 4) = 'e' then Token := Tok_Raise; Scan_Ptr := Scan_Ptr + 5; goto Scan_Keyword; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; -- RANGE elsif Source (Scan_Ptr + 2) = 'n' then if Source (Scan_Ptr + 3) = 'g' then if Source (Scan_Ptr + 4) = 'e' then Token := Tok_Range; Scan_Ptr := Scan_Ptr + 5; goto Scan_Keyword; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; else goto Scan_Identifier_2; end if; -- RECORD elsif Source (Scan_Ptr + 1) = 'e' then if Source (Scan_Ptr + 2) = 'c' then if Source (Scan_Ptr + 3) = 'o' then if Source (Scan_Ptr + 4) = 'r' then if Source (Scan_Ptr + 5) = 'd' then Token := Tok_Record; Scan_Ptr := Scan_Ptr + 6; goto Scan_Keyword; else goto Scan_Identifier_5; end if; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; -- REM elsif Source (Scan_Ptr + 2) = 'm' then Token := Tok_Rem; Scan_Ptr := Scan_Ptr + 3; goto Scan_Keyword; -- RENAMES elsif Source (Scan_Ptr + 2) = 'n' then if Source (Scan_Ptr + 3) = 'a' then if Source (Scan_Ptr + 4) = 'm' then if Source (Scan_Ptr + 5) = 'e' then if Source (Scan_Ptr + 6) = 's' then Token := Tok_Renames; Scan_Ptr := Scan_Ptr + 7; goto Scan_Keyword; else goto Scan_Identifier_6; end if; else goto Scan_Identifier_5; end if; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; -- REQUEUE (9X only) elsif Ada_9X and then Source (Scan_Ptr + 2) = 'q' then if Source (Scan_Ptr + 3) = 'u' then if Source (Scan_Ptr + 4) = 'e' then if Source (Scan_Ptr + 5) = 'u' then if Source (Scan_Ptr + 6) = 'e' then Token := Tok_Requeue; Scan_Ptr := Scan_Ptr + 7; goto Scan_Keyword; else goto Scan_Identifier_6; end if; else goto Scan_Identifier_5; end if; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; -- RETURN elsif Source (Scan_Ptr + 2) = 't' then if Source (Scan_Ptr + 3) = 'u' then if Source (Scan_Ptr + 4) = 'r' then if Source (Scan_Ptr + 5) = 'n' then Token := Tok_Return; Scan_Ptr := Scan_Ptr + 6; goto Scan_Keyword; else goto Scan_Identifier_5; end if; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; -- REVERSE elsif Source (Scan_Ptr + 2) = 'v' then if Source (Scan_Ptr + 3) = 'e' then if Source (Scan_Ptr + 4) = 'r' then if Source (Scan_Ptr + 5) = 's' then if Source (Scan_Ptr + 6) = 'e' then Token := Tok_Reverse; Scan_Ptr := Scan_Ptr + 7; goto Scan_Keyword; else goto Scan_Identifier_6; end if; else goto Scan_Identifier_5; end if; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; else goto Scan_Identifier_2; end if; else goto Scan_Identifier_1; end if; -- Keywords starting with S when 's' => -- SELECT if Source (Scan_Ptr + 1) = 'e' then if Source (Scan_Ptr + 2) = 'l' then if Source (Scan_Ptr + 3) = 'e' then if Source (Scan_Ptr + 4) = 'c' then if Source (Scan_Ptr + 5) = 't' then Token := Tok_Select; Scan_Ptr := Scan_Ptr + 6; goto Scan_Keyword; else goto Scan_Identifier_5; end if; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; -- SEPARATE elsif Source (Scan_Ptr + 2) = 'p' then if Source (Scan_Ptr + 3) = 'a' then if Source (Scan_Ptr + 4) = 'r' then if Source (Scan_Ptr + 5) = 'a' then if Source (Scan_Ptr + 6) = 't' then if Source (Scan_Ptr + 7) = 'e' then Token := Tok_Separate; Scan_Ptr := Scan_Ptr + 8; goto Scan_Keyword; else goto Scan_Identifier_7; end if; else goto Scan_Identifier_6; end if; else goto Scan_Identifier_5; end if; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; else goto Scan_Identifier_2; end if; -- SUBTYPE elsif Source (Scan_Ptr + 1) = 'u' then if Source (Scan_Ptr + 2) = 'b' then if Source (Scan_Ptr + 3) = 't' then if Source (Scan_Ptr + 4) = 'y' then if Source (Scan_Ptr + 5) = 'p' then if Source (Scan_Ptr + 6) = 'e' then Token := Tok_Subtype; Scan_Ptr := Scan_Ptr + 7; goto Scan_Keyword; else goto Scan_Identifier_6; end if; else goto Scan_Identifier_5; end if; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; else goto Scan_Identifier_2; end if; else goto Scan_Identifier_1; end if; -- Keywords starting with T when 't' => -- TAGGED (9X only) if Source (Scan_Ptr + 1) = 'a' then if Ada_9X and then Source (Scan_Ptr + 2) = 'g' then if Source (Scan_Ptr + 3) = 'g' then if Source (Scan_Ptr + 4) = 'e' then if Source (Scan_Ptr + 5) = 'd' then Token := Tok_Tagged; Scan_Ptr := Scan_Ptr + 6; goto Scan_Keyword; else goto Scan_Identifier_5; end if; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; -- TASK elsif Source (Scan_Ptr + 2) = 's' then if Source (Scan_Ptr + 3) = 'k' then Token := Tok_Task; Scan_Ptr := Scan_Ptr + 4; goto Scan_Keyword; else goto Scan_Identifier_3; end if; else goto Scan_Identifier_2; end if; -- TERMINATE elsif Source (Scan_Ptr + 1) = 'e' then if Source (Scan_Ptr + 2) = 'r' then if Source (Scan_Ptr + 3) = 'm' then if Source (Scan_Ptr + 4) = 'i' then if Source (Scan_Ptr + 5) = 'n' then if Source (Scan_Ptr + 6) = 'a' then if Source (Scan_Ptr + 7) = 't' then if Source (Scan_Ptr + 8) = 'e' then Token := Tok_Terminate; Scan_Ptr := Scan_Ptr + 9; goto Scan_Keyword; else goto Scan_Identifier_8; end if; else goto Scan_Identifier_7; end if; else goto Scan_Identifier_6; end if; else goto Scan_Identifier_5; end if; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; else goto Scan_Identifier_2; end if; -- THEN elsif Source (Scan_Ptr + 1) = 'h' then if Source (Scan_Ptr + 2) = 'e' then if Source (Scan_Ptr + 3) = 'n' then Token := Tok_Then; Scan_Ptr := Scan_Ptr + 4; goto Scan_Keyword; else goto Scan_Identifier_3; end if; else goto Scan_Identifier_2; end if; -- TYPE elsif Source (Scan_Ptr + 1) = 'y' then if Source (Scan_Ptr + 2) = 'p' then if Source (Scan_Ptr + 3) = 'e' then Token := Tok_Type; Scan_Ptr := Scan_Ptr + 4; goto Scan_Keyword; else goto Scan_Identifier_3; end if; else goto Scan_Identifier_2; end if; else goto Scan_Identifier_1; end if; -- Keywords starting with U when 'u' => -- UNTIL (9X only) if Ada_9X and then Source (Scan_Ptr + 1) = 'n' then if Source (Scan_Ptr + 2) = 't' then if Source (Scan_Ptr + 3) = 'i' then if Source (Scan_Ptr + 4) = 'l' then Token := Tok_Until; Scan_Ptr := Scan_Ptr + 5; goto Scan_Keyword; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; else goto Scan_Identifier_2; end if; -- USE elsif Source (Scan_Ptr + 1) = 's' then if Source (Scan_Ptr + 2) = 'e' then Token := Tok_Use; Scan_Ptr := Scan_Ptr + 3; goto Scan_Keyword; else goto Scan_Identifier_2; end if; else goto Scan_Identifier_1; end if; -- Keywords starting with W when 'w' => -- WHEN if Source (Scan_Ptr + 1) = 'h' then if Source (Scan_Ptr + 2) = 'e' then if Source (Scan_Ptr + 3) = 'n' then Token := Tok_When; Scan_Ptr := Scan_Ptr + 4; goto Scan_Keyword; else goto Scan_Identifier_3; end if; -- WHILE elsif Source (Scan_Ptr + 2) = 'i' then if Source (Scan_Ptr + 3) = 'l' then if Source (Scan_Ptr + 4) = 'e' then Token := Tok_While; Scan_Ptr := Scan_Ptr + 5; goto Scan_Keyword; else goto Scan_Identifier_4; end if; else goto Scan_Identifier_3; end if; else goto Scan_Identifier_2; end if; -- WITH elsif Source (Scan_Ptr + 1) = 'i' then if Source (Scan_Ptr + 2) = 't' then if Source (Scan_Ptr + 3) = 'h' then Token := Tok_With; Scan_Ptr := Scan_Ptr + 4; goto Scan_Keyword; else goto Scan_Identifier_3; end if; else goto Scan_Identifier_2; end if; else goto Scan_Identifier_1; end if; -- Keywords starting with X when 'x' => -- XOR if Source (Scan_Ptr + 1) = 'o' then if Source (Scan_Ptr + 2) = 'r' then Token := Tok_Xor; Scan_Ptr := Scan_Ptr + 3; goto Scan_Keyword; else goto Scan_Identifier_2; end if; else goto Scan_Identifier_1; end if; -- Upper case letters and lower case letters which cannot start -- a keyword. We assume, for the moment that these are identifiers. -- For upper case letters, we may turn out to have a keyword, but -- we will find that out later on in the Scan_Identifier routine. when 'A' .. 'Z' | 'h' | 'j' | 'k' | 'q' | 'v' | 'y' | 'z' => goto Scan_Identifier_1; -- Underline character when '_' => Error_Msg_S ("identifier cannot start with underline"); goto Scan_Identifier_1; -- Space (not possible, because we scanned past blanks) when ' ' => null; -- Invalid control characters when NUL | SOH | STX | ETX | EOT | ENQ | ACK | BEL | BS | SO | SI | DLE | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN | EM | ESC | FS | GS | RS | US | DEL => Error_Illegal_Character; -- Invalid graphic characters when '#' | '$' | '?' | '@' | '`' | '\' | '^' | '{' | '}' | '~' => Error_Illegal_Character; -- Characters in top half of ASCII 8-bit chart when Upper_Half_Character => -- Upper half characters may possibly be identifier letters but -- can never be digits, so Letter_Or_Digit can be used to test -- for a valid start of identifier character. if Letter_Or_Digit (Source (Scan_Ptr)) then goto Scan_Identifier_1; else Error_Illegal_Character; end if; -- End switch on non-blank character end case; -- End loop past format effectors. The exit from this loop is by -- executing a return statement following completion of token scan -- (control never falls out of this loop to the code which follows) end loop; -- Keyword scanning routine. Control is passed to this routine (with a -- goto, for maximum speed) after scanning out a sequence of letters -- matching a keyword. Scan_Ptr is updated past the keyword characters -- and Token contains the right code. If a terminator character follows -- then this is definitely a keyword, and control should be returned. -- Otherwise is is simply an identifier whose leading characters match -- the characters of a keyword. <> if not Identifier_Char (Source (Scan_Ptr)) then return; else Name_Len := 0; for I in Token_Ptr .. Scan_Ptr loop Set_Name_Char (Fold_Lower (Source (I))); end loop; Scan_Ptr := Scan_Ptr + 1; goto Scan_Identifier; end if; -- Come here after encountering either an underline character -- The Scan_Identifier_N routines are passed control after scanning -- out N letters starting at Scan_Ptr which are letters (but which -- do not form the name of a keyword). <> Name_Len := 0; Set_Name_Char (Fold_Lower (Source (Scan_Ptr))); Scan_Ptr := Scan_Ptr + 1; goto Scan_Identifier_7C; <> Name_Len := 0; <> Set_Name_Char (Fold_Lower (Source (Scan_Ptr))); Scan_Ptr := Scan_Ptr + 1; goto Scan_Identifier_6C; <> Name_Len := 0; <> Set_Name_Char (Fold_Lower (Source (Scan_Ptr))); Scan_Ptr := Scan_Ptr + 1; goto Scan_Identifier_5C; <> Name_Len := 0; <> Set_Name_Char (Fold_Lower (Source (Scan_Ptr))); Scan_Ptr := Scan_Ptr + 1; goto Scan_Identifier_4C; <> Name_Len := 0; <> Set_Name_Char (Fold_Lower (Source (Scan_Ptr))); Scan_Ptr := Scan_Ptr + 1; goto Scan_Identifier_3C; <> Name_Len := 0; <> Set_Name_Char (Fold_Lower (Source (Scan_Ptr))); Scan_Ptr := Scan_Ptr + 1; goto Scan_Identifier_2C; <> Name_Len := 0; <> Set_Name_Char (Fold_Lower (Source (Scan_Ptr))); Scan_Ptr := Scan_Ptr + 1; goto Scan_Identifier_1C; <> Name_Len := 0; <> Set_Name_Char (Fold_Lower (Source (Scan_Ptr))); Scan_Ptr := Scan_Ptr + 1; -- Here we scan out an identifier, Scan_Ptr has been updated past an -- initial sequence of one or more letters (so an underline character -- can follow immediately). The loop is opened out to speed up the -- scanning of long identifiers. <> while Letter_Or_Digit (Source (Scan_Ptr)) loop Set_Name_Char (Fold_Lower (Source (Scan_Ptr))); Scan_Ptr := Scan_Ptr + 1; end loop; -- If we fall through, then we have encountered either an underline -- character, or an identifier terminator. if Source (Scan_Ptr) = '_' then Set_Name_Char ('_'); Scan_Ptr := Scan_Ptr + 1; if Letter_Or_Digit (Source (Scan_Ptr)) then Set_Name_Char (Fold_Lower (Source (Scan_Ptr))); Scan_Ptr := Scan_Ptr + 1; goto Scan_Identifier; elsif Source (Scan_Ptr) = '_' then Error_No_Double_Underline; goto Scan_Identifier; elsif Ada_83 then Error_Msg ("identifier cannot end with underline in Ada 83", Scan_Ptr - 1); end if; end if; Token_Name := Name_Find; -- Here is where we check if it was a keyword after all (happens -- when a keyword is spelled with an initial upper case letter) if Get_Name_Table_Byte (Token_Name) /= 0 and then (Ada_9X or else Token_Name not in Ada_9X_Reserved_Words) then if GNAT_Style_Check then Error_Msg_SC ("(style) incorrectly spelled keyword"); end if; Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name)); return; -- It is an identifier after all else Token_Node := New_Node (N_Identifier, Token_Ptr); Set_Chars (Token_Node, Token_Name); Token := Tok_Identifier; return; end if; end Scan; --------------------- -- Scan_First_Char -- --------------------- function Scan_First_Char return Source_Ptr is Ptr : Source_Ptr := Current_Line_Start; begin loop if Source (Ptr) = ' ' then Ptr := Ptr + 1; elsif Source (Ptr) = HT then if GNAT_Style_Check then No_HT_Allowed (Ptr); end if; Ptr := Ptr + 1; else return Ptr; end if; end loop; end Scan_First_Char; ------------------------------ -- Scan_Reserved_Identifier -- ------------------------------ procedure Scan_Reserved_Identifier (Force_Msg : Boolean) is Token_Chars : constant String := Token_Type'Image (Token); begin -- We have in Token_Chars the image of the Token name, i.e. Tok_xxx. -- This code extracts the xxx and makes an identifier out of it. Name_Len := 0; for I in 5 .. Token_Chars'Length loop Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := To_Char (Token_Chars (I)); end loop; Token_Name := Name_Find; if not Used_As_Identifier (Token) or else Force_Msg then Error_Msg_Name_1 := Token_Name; Error_Msg_SC ("reserved word* cannot be used as identifier!"); Used_As_Identifier (Token) := True; end if; Token := Tok_Identifier; Token_Node := New_Node (N_Identifier, Token_Ptr); Set_Chars (Token_Node, Token_Name); end Scan_Reserved_Identifier; ---------------------- -- Set_Start_Column -- ---------------------- -- Note: it seems at first glance a little expensive to compute this value -- for every source line (since it is certainly not used for all source -- lines). On the other hand, it doesn't take much more work to skip past -- the initial white space on the line counting the columns than it would -- to scan past the qhite space using the standard scanning circuits. procedure Set_Start_Column is begin Start_Column := 0; loop -- Inner loop scans past blanks as fast as possible, bumping Scan_Ptr -- past the blanks and adjusting Start_Column to account for them. loop if Source (Scan_Ptr) = ' ' then if Source (Scan_Ptr + 1) = ' ' then if Source (Scan_Ptr + 2) = ' ' then if Source (Scan_Ptr + 3) = ' ' then if Source (Scan_Ptr + 4) = ' ' then if Source (Scan_Ptr + 5) = ' ' then if Source (Scan_Ptr + 6) = ' ' then Scan_Ptr := Scan_Ptr + 7; Start_Column := Start_Column + 7; else Scan_Ptr := Scan_Ptr + 6; Start_Column := Start_Column + 6; exit; end if; else Scan_Ptr := Scan_Ptr + 5; Start_Column := Start_Column + 5; exit; end if; else Scan_Ptr := Scan_Ptr + 4; Start_Column := Start_Column + 4; exit; end if; else Scan_Ptr := Scan_Ptr + 3; Start_Column := Start_Column + 3; exit; end if; else Scan_Ptr := Scan_Ptr + 2; Start_Column := Start_Column + 2; exit; end if; else Scan_Ptr := Scan_Ptr + 1; Start_Column := Start_Column + 1; exit; end if; else exit; end if; end loop; -- Outer loop keeps going only if a horizontal tab follows if Source (Scan_Ptr) = HT then if GNAT_Style_Check then No_HT_Allowed (Scan_Ptr); end if; Scan_Ptr := Scan_Ptr + 1; Start_Column := (Start_Column / 8) * 8 + 8; else exit; end if; end loop; end Set_Start_Column; ----------------------- -- GNAT_Column_Check -- ----------------------- procedure GNAT_Column_Check (P : Source_Ptr) is begin for S in Current_Line_Start .. P - 1 loop if Source (S) > ' ' then return; end if; end loop; if Start_Column mod 3 /= 0 then Error_Msg ("(style) bad column", P); end if; end GNAT_Column_Check; ------------------------ -- GNAT_Comment_Check -- ------------------------ procedure GNAT_Comment_Check is DM_Found : Boolean; begin -- Can never have a non-blank character preceding the first minus if Scan_Ptr > Source'First and then Source (Scan_Ptr - 1) > ' ' then Error_Msg_S ("(style) space required"); end if; for S in Current_Line_Start .. Scan_Ptr - 1 loop if Source (S) > ' ' then -- Case of a comment that is not at the start of a line. The -- only required check is that we cannot have a non-blank -- character immediately following the second minus. if Source (Scan_Ptr + 2) > ' ' then Error_Msg ("(style) space required", Scan_Ptr + 2); end if; return; end if; end loop; -- Comment is at start of line if Start_Column mod 3 /= 0 then Error_Msg ("(style) bad column", Scan_Ptr); end if; -- Finally, a comment that is not a box comment (defined as a comment -- line ending with two minus signs), there must be a second space -- after the second minus. if Source (Scan_Ptr + 2) < ' ' or else Source (Scan_Ptr + 3) = ' ' then return; end if; DM_Found := False; for S in Scan_Ptr + 2 .. Source'Last loop if Source (S) = EOF or else Source (S) in Line_Terminator then if not DM_Found then Error_Msg ("(style) space required", Scan_Ptr + 3); end if; return; elsif Source (S) = '-' and then Source (S - 1) = '-' then DM_Found := True; elsif Source (S) > ' ' then DM_Found := False; end if; end loop; end GNAT_Comment_Check; -------------------------- -- Version_Comment_Scan -- -------------------------- procedure Version_Comment_Scan is P : Source_Ptr := Scan_Ptr + 2; begin loop if Source (P) = ' ' then P := P + 1; elsif Source (P) < ' ' and then Source (P) /= HT then return; elsif Source (P) /= '$' then P := P + 1; -- Here we have a $ sign, might be $Revision: else P := P + 1; -- If too near end of file, return, not found after all if P + 9 >= Source'Last then return; -- If not $Revision, then just keep looking (we avoid the use of -- a slice compare here because it was not working at one point) elsif Source (P + 0) /= 'R' or else Source (P + 1) /= 'e' or else Source (P + 2) /= 'v' or else Source (P + 3) /= 'i' or else Source (P + 4) /= 's' or else Source (P + 5) /= 'i' or else Source (P + 6) /= 'o' or else Source (P + 7) /= 'n' or else Source (P + 8) /= ':' or else Source (P + 9) /= ' ' then P := P + 1; -- $Revision: found, acquire version else P := P + 10; for I in Int range 1 .. 6 loop exit when Source (P) <= ' '; File.Table (Scan_Unit).Version (I) := Source (P); P := P + 1; end loop; Version_To_Be_Found := False; return; end if; end if; end loop; end Version_Comment_Scan; end Scn; ine_Start; begin loop if Source (Ptr) = ' ' then Ptr := Ptr + 1; elsif Source (Ptr) = HT then if GNAT_Style_Check then No_HT_Allowed (Ptr); end if; Ptr := Ptr + 1; else retugnat-1.67-src/src/sem.ads 444 10015 7640 20666 5506244361 10425 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M -- -- -- -- S p e c -- -- -- -- $Revision: 1.45 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Opt; use Opt; with Snames; use Snames; with Table; with Types; use Types; package Sem is Subunit_Found : exception; -- This exception is used when the main unit is a subunit, and the current -- unit is one of its parents. In this case the parent is being analyzed -- only to provide the necessary context for the subunit, so as soon as -- the subunit has been analyzed, there is no need to continue with the -- analysis of the parent, so this exception is raised to get out. Implicit_Type_List : List_Id; -- A list of N_Anonynmous_Type nodes which represent implicitly declared -- entities resulting from a given declaration. These nodes are placed on -- this list by New_Implicit_Type and are inserted in the declarations -- list by Analyze_Declaration after the analysis of each declaration. Scope_Suppress : Suppress_Record := Suppress_Options; -- This record contains the current scope based settings of the suppress -- switches. It is initialized from the options as shown, and then modified -- by pragma Suppress. On entry to each scope, the current setting is saved -- the scope stack, and then restored on exit from the scope. ----------------- -- Scope Stack -- ----------------- -- The scope stack holds all entries of the scope table. As in the parser, -- we use Last as the stack pointer, so that we can always find the scope -- that is currently open in Scope_Stack.Table (Scope_Stack.Last). The -- oldest entry, at Scope_Stack (0) is Standard. The entries in the table -- include the entity for the referenced scope, together with information -- used to restore the proper setting of check suppressions on scope exit. -- There are two kinds of suppress checks, scope based suppress checks -- (from initial command line arguments, or from Suppress pragmas not -- including an entity name). The scope based suppress checks are recorded -- in the Sem.Supress variable, and all that is necessary is to save the -- state of this variable on scope entry, and restore it on scope exit. -- The other kind of suppress check is entity based suppress checks, from -- Suppress pragmas giving an Entity_Id. These checks are reflected by the -- appropriate bit being set in the corresponding entity, and restoring the -- setting of these bits is a little trickier. In particular a given pragma -- Suppress may or may not affect the current state. If it sets a check for -- an entity that is already checked, then it is important that this check -- not be restored on scope exit. The situation is made more complicated -- by the fact that a given suppress pragma can specify multiple entities -- (in the overloaded case), and multiple checks (by using All_Checks), so -- that it may be partially effective. On exit only checks that were in -- fact effective must be removed. Logically we could do this by saving -- the entire state of the entity flags on scope entry and restoring them -- on scope exit, but that would be ludicrous, so what we do instead is to -- maintain the following differential structure that shows what checks -- were installed for the current scope. -- Note: Suppress pragmas that specify entities defined in a package -- spec do not make entries in this table, since such checks suppress -- requests are valid for the entire life of the entity. type Entity_Check_Suppress_Record is record Entity : Entity_Id; -- Entity to which the check applies Check : Check_Id; -- Check which is set (note this cannot be All_Checks, if the All_Checks -- case, a sequence of eentries appears for the individual checks. end record; -- Entity_Suppress is a stack, to which new entries are added as they -- are processed (see pragma Suppress circuit in Sem_Prag). The scope -- stack entry simply saves the stack pointer on entry, and restores -- it on exit by reversing the checks one by one. package Entity_Suppress is new Table ( Component_Type => Entity_Check_Suppress_Record, Index_Type => Int, Low_Bound => 0, Initial => 1000, Increment => 100, Table_Name => "Sem.Entity_Suppress"); -- Here is the scope stack itself type Scope_Stack_Entry is record Entity : Entity_Id; -- Entity representing the scope Save_Scope_Suppress : Suppress_Record; -- Save contents of Scope_Suppress on entry Save_Entity_Suppress : Int; -- Save contents of Entity_Suppress.Last on entry Transient : Boolean; -- A flag set true for transient scopes. See section "Handling of -- Transient Data" in the body of package Sem_Ch8 for details. end record; package Scope_Stack is new Table ( Component_Type => Scope_Stack_Entry, Index_Type => Int, Low_Bound => 0, Initial => 50, Increment => 100, Table_Name => "Sem.Scope_Stack"); Transient_Scopes_Present : Boolean := False; -- A global flag that is set True if the scope stack for the current -- unit contains a transient scope (at most one such scope can be present) ----------------- -- Subprograms -- ----------------- procedure Semantics (Cunit : Node_Id); -- This procedure is called to perform semantic analysis on the specified -- node which is the N_Compilation_Unit node for the unit. procedure Analyze (N : Node_Id); -- This is the recursive procedure which is applied to individual nodes -- of the tree, starting at the top level node (compilation unit node) -- and then moving down the tree in a top down traversal. It calls -- individual routines with names Analyze_xxx to analyze node xxx. Each -- of these routines is responsible for calling Analyze on the components -- of the subtree. -- Note: Analyze routines must be written in an idempotent manner, so that -- they can be repeatedly called on the same node without any deleterious -- effects. However, there is an Analyzed flag in each node that is used -- to avoid such duplicate Analyze calls where posssible to speed up -- processing, but it is not considered correct to rely on this. -- Note: In the case of expression components (nodes whose Nkind is in -- N_Subexpr), the call to Analyze does not complete the semantic analysis -- of the node, since the type resolution cannot be completed until the -- complete context is analyzed. The completion of the type analysis occurs -- in the corresponding Resolve routine, which gets called from the top of -- the complete context during the downward pass. end Sem; ld have received a copy of the GNU -- -- General Public License along witgnat-1.67-src/src/sem.adb 444 10015 7640 54274 5506244362 10407 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M -- -- -- -- B o d y -- -- -- -- $Revision: 1.160 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Comperr; use Comperr; with Debug; use Debug; with Debug_Sem; use Debug_Sem; with Errout; use Errout; with Expand; with Exp_Util; use Exp_Util; with Lib; use Lib; with Output; use Output; with Sem_Attr; use Sem_Attr; with Sem_Ch3; use Sem_Ch3; with Sem_Ch4; use Sem_Ch4; with Sem_Ch5; use Sem_Ch5; with Sem_Ch6; use Sem_Ch6; with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; with Sem_Ch9; use Sem_Ch9; with Sem_Ch10; use Sem_Ch10; with Sem_Ch11; use Sem_Ch11; with Sem_Ch12; use Sem_Ch12; with Sem_Ch13; use Sem_Ch13; with Sem_Prag; use Sem_Prag; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Sinput; use Sinput; with Stand; use Stand; package body Sem is ---------------- -- Local Data -- ---------------- -- Implicit_Types is a stack which holds the list headers corresponding -- to lists of Implicit_Type_List. Since the Semantics procedure is called -- recursively, it is necessary to save the current Implicit_Type_List. -- Semantics saves the Implicit_Type_List on the top of this stack and -- initializes a new Implicit_Type_List to be an empty list. Before -- returning it restores Implicit_Type_List and and pops the stack. package Implicit_Types is new Table ( Component_Type => List_Id, Index_Type => Int, Low_Bound => 0, Initial => 50, Increment => 100, Table_Name => "Sem.Implicit_Types"); use Implicit_Types; --------------- -- Semantics -- --------------- procedure Semantics (Cunit : Node_Id) is Save_Ada_83_Mode : constant Boolean := Ada_83; -- Saves state of Ada 83 mode switch for restore on exit (since it may -- have been reset by occurrences of the Ada_83 or Ada_9X pragmas) Save_Transient_Scopes_Present : Boolean := Transient_Scopes_Present; -- A flag used to save the current setting of the flag that shows -- whether transient scopes are present. This setting is restored -- on exit (allows for proper recursive entry to Semantics) begin Compiler_State := Analyzing; Transient_Scopes_Present := False; Expander_Mode_Save_And_Set (Operating_Mode = Generate_Code or Debug_Flag_X); -- Only do analysis of unit that has not already been analyzed if not Analyzed (Cunit) then -- Initialize Ada 83 and Ada 9X mode from compiler switches Ada_83 := Ada_83_Switch; Ada_9X := not Ada_83; -- Push a scope stack entry for Standard on the bottom of the stack. -- Note that we don't need to remove this on exit, since the scope -- stack is local to Sem in any case and disappears on exit. Implicit_Types.Increment_Last; Implicit_Types.Table (Implicit_Types.Last) := Implicit_Type_List; Implicit_Type_List := New_List; New_Scope (Standard_Standard); Scope_Suppress := Suppress_Options; -- Now analyze the top level compilation unit node Analyze (Cunit); if Current_Scope /= Standard_Standard and then Cunit /= File.Table (Main_Unit).Cunit then Compiler_Error; Write_Str ("scope mismatch on exit from compilation"); Write_Eol; end if; Pop_Scope; -- pop entry for Standard Implicit_Type_List := Implicit_Types.Table (Implicit_Types.Last); Implicit_Types.Decrement_Last; end if; -- Restore settings of Ada 83 and 9X mode switches to entry values -- and also the setting of the transient scopes flag. Ada_83 := Save_Ada_83_Mode; Ada_9X := not Ada_83; Expander_Mode_Restore; Transient_Scopes_Present := Save_Transient_Scopes_Present; exception -- The exception Subunit_Found is raised when we are done prematurely -- with the unit because it turned out that we were analyzing it only -- for the benefit of a subunit, and the rest of our unit was -- irrelevant. The action in this case is simply to return. Nothing -- else needs to be done. when Subunit_Found => Ada_83 := Save_Ada_83_Mode; Ada_9X := not Ada_83; Expander_Mode_Restore; Transient_Scopes_Present := Save_Transient_Scopes_Present; return; end Semantics; ------------- -- Analyze -- ------------- procedure Analyze (N : Node_Id) is begin pragma Debug (Debug_A_Entry ("analyzing ", N)); -- Immediate return if already analyzed if Analyzed (N) then pragma Debug (Debug_A_Exit ("analyzing ", N, " (done, analyzed already)")); return; end if; -- Otherwise processing depends on the node kind. Note: some entries -- in this table generate a Compiler_Abort. This means that the node -- is always analyzed within the semantic chapter routines, and there -- should never be a case of making a call to the main Analyze routine -- for the particular node kind. For example, an N_Access_Definition -- node appears only in the context of a type declaration, and is -- processed by the analyze routine for type declarations. case Nkind (N) is when N_Abortable_Part => Analyze_Abortable_Part (N); when N_Abort_Statement => Analyze_Abort_Statement (N); when N_Abstract_Subprogram_Declaration => Analyze_Abstract_Subprogram_Declaration (N); when N_Accept_Alternative => Analyze_Accept_Alternative (N); when N_Accept_Statement => Analyze_Accept_Statement (N); when N_Access_Definition => Compiler_Abort; when N_Access_Function_Definition => Compiler_Abort; when N_Access_Procedure_Definition => Compiler_Abort; when N_Access_To_Object_Definition => Compiler_Abort; when N_Aggregate => Analyze_Aggregate (N); when N_Allocator => Analyze_Allocator (N); when N_Assignment_Statement => Analyze_Assignment (N); when N_Asynchronous_Select => Analyze_Asynchronous_Select (N); when N_At_Clause => Analyze_At_Clause (N); when N_Attribute_Reference => Analyze_Attribute (N); when N_Attribute_Definition_Clause => Analyze_Attribute_Definition_Clause (N); when N_Block_Statement => Analyze_Block_Statement (N); when N_Case_Statement => Analyze_Case_Statement (N); when N_Case_Statement_Alternative => Compiler_Abort; when N_Character_Literal => Set_Etype (N, Any_Character); when N_Code_Statement => Analyze_Code_Statement (N); when N_Compilation_Unit => Analyze_Compilation_Unit (N); when N_Component_Association => Compiler_Abort; when N_Component_Clause => Analyze_Component_Clause (N); when N_Component_Declaration => Analyze_Component_Declaration (N); when N_Component_List => Compiler_Abort; when N_Concat_Multiple => Compiler_Abort; when N_Conditional_Entry_Call => Analyze_Conditional_Entry_Call (N); when N_Constrained_Array_Definition => Compiler_Abort; when N_Decimal_Fixed_Point_Definition => Compiler_Abort; when N_Defining_Character_Literal => Compiler_Abort; when N_Defining_Identifier => Compiler_Abort; when N_Defining_Operator_Symbol => Compiler_Abort; when N_Defining_Program_Unit_Name => Compiler_Abort; when N_Delay_Alternative => Analyze_Delay_Alternative (N); when N_Delay_Relative_Statement => Analyze_Delay_Relative (N); when N_Delay_Until_Statement => Analyze_Delay_Until (N); when N_Delta_Constraint => Compiler_Abort; when N_Derived_Type_Definition => Compiler_Abort; when N_Designator => Compiler_Abort; when N_Digits_Constraint => Compiler_Abort; when N_Discriminant_Association => Compiler_Abort; when N_Discriminant_Specification => Compiler_Abort; when N_Elsif_Part => Compiler_Abort; when N_Empty => Compiler_Abort; when N_Entry_Body => Analyze_Entry_Body (N); when N_Entry_Body_Formal_Part => Analyze_Entry_Body_Formal_Part (N); when N_Entry_Call_Alternative => Analyze_Entry_Call_Alternative (N); when N_Entry_Call_Statement => Analyze_Entry_Call (N); when N_Entry_Declaration => Analyze_Entry_Declaration (N); when N_Entry_Index_Specification => Analyze_Entry_Index_Specification (N); when N_Enumeration_Representation_Clause => Analyze_Enumeration_Representation_Clause (N); when N_Enumeration_Type_Definition => Compiler_Abort; when N_Error => Compiler_Abort; when N_Exception_Declaration => Analyze_Exception_Declaration (N); when N_Exception_Handler => Compiler_Abort; when N_Exception_Renaming_Declaration => Analyze_Exception_Renaming (N); when N_Exit_Statement => Analyze_Exit_Statement (N); when N_Expanded_Name => null; when N_Explicit_Dereference => Analyze_Explicit_Dereference (N); when N_Expression_Actions => Analyze_Expression_Actions (N); when N_Extension_Aggregate => Unimplemented (N, "extension aggregates"); when N_Floating_Point_Definition => Compiler_Abort; when N_Formal_Decimal_Fixed_Point_Definition => Compiler_Abort; when N_Formal_Derived_Type_Definition => Compiler_Abort; when N_Formal_Discrete_Type_Definition => Compiler_Abort; when N_Formal_Floating_Point_Definition => Compiler_Abort; when N_Formal_Modular_Type_Definition => Compiler_Abort; when N_Formal_Object_Declaration => Analyze_Formal_Object_Declaration (N); when N_Formal_Ordinary_Fixed_Point_Definition => Compiler_Abort; when N_Formal_Package_Declaration => Analyze_Formal_Package (N); when N_Formal_Private_Type_Definition => Compiler_Abort; when N_Formal_Signed_Integer_Type_Definition => Compiler_Abort; when N_Formal_Subprogram_Declaration => Analyze_Formal_Subprogram (N); when N_Formal_Type_Declaration => Analyze_Formal_Type_Declaration (N); when N_Freeze_Entity => null; when N_Full_Type_Declaration => Analyze_Type_Declaration (N); when N_Function_Call => Analyze_Function_Call (N); when N_Function_Instantiation => Analyze_Function_Instantiation (N); when N_Function_Specification => Compiler_Abort; when N_Generic_Association => Analyze_Generic_Association (N); when N_Generic_Function_Renaming_Declaration => Unimplemented (N, "generic renaming declarations"); when N_Generic_Package_Declaration => Analyze_Generic_Package_Declaration (N); when N_Generic_Package_Renaming_Declaration => Unimplemented (N, "generic renaming declarations"); when N_Generic_Procedure_Renaming_Declaration => Unimplemented (N, "generic renaming declarations"); when N_Generic_Subprogram_Declaration => Analyze_Generic_Subprogram_Declaration (N); when N_Goto_Statement => Analyze_Goto_Statement (N); when N_Handled_Sequence_Of_Statements => Analyze_Handled_Statements (N); when N_Identifier => Find_Simple_Name (N); when N_Implicit_Type => Analyze_Implicit_Type (N); when N_If_Statement => Analyze_If_Statement (N); when N_Implicit_Label_Declaration => Analyze_Implicit_Label_Declaration (N); when N_Incomplete_Type_Declaration => Analyze_Incomplete_Type_Decl (N); when N_Indexed_Component => Find_Name (N); when N_Index_Or_Discriminant_Constraint => Compiler_Abort; when N_Integer_Literal => Set_Etype (N, Universal_Integer); when N_Iteration_Scheme => Compiler_Abort; when N_Label => Compiler_Abort; when N_Loop_Parameter_Specification => Compiler_Abort; when N_Loop_Statement => Analyze_Loop_Statement (N); when N_Mod_Clause => Analyze_Mod_Clause (N); when N_Modular_Type_Definition => Compiler_Abort; when N_Null => Analyze_Null (N); when N_Null_Statement => null; when N_Number_Declaration => Analyze_Number_Declaration (N); when N_Object_Declaration => Analyze_Object_Declaration (N); when N_Object_Renaming_Declaration => Analyze_Object_Renaming (N); when N_Operator_Symbol => Analyze_Operator_Symbol (N); when N_Op_Abs => Analyze_Unary_Op (N); when N_Op_Add => Analyze_Arithmetic_Op (N); when N_Op_And => Analyze_Logical_Op (N); when N_Op_And_Then => Analyze_Short_Circuit (N); when N_Op_Concat => Analyze_Concatenation (N); when N_Op_Divide => Analyze_Arithmetic_Op (N); when N_Op_Eq => Analyze_Equality_Op (N); when N_Op_Expon => Analyze_Arithmetic_Op (N); when N_Op_Ge => Analyze_Comparison_Op (N); when N_Op_Gt => Analyze_Comparison_Op (N); when N_Op_In => Analyze_Membership_Op (N); when N_Op_Le => Analyze_Comparison_Op (N); when N_Op_Lt => Analyze_Comparison_Op (N); when N_Op_Minus => Analyze_Unary_Op (N); when N_Op_Mod => Analyze_Arithmetic_Op (N); when N_Op_Multiply => Analyze_Arithmetic_Op (N); when N_Op_Ne => Analyze_Equality_Op (N); when N_Op_Not => Analyze_Negation (N); when N_Op_Not_In => Analyze_Membership_Op (N); when N_Op_Or => Analyze_Logical_Op (N); when N_Op_Or_Else => Analyze_Short_Circuit (N); when N_Op_Plus => Analyze_Unary_Op (N); when N_Op_Rem => Analyze_Arithmetic_Op (N); when N_Op_Subtract => Analyze_Arithmetic_Op (N); when N_Op_Xor => Analyze_Logical_Op (N); when N_Ordinary_Fixed_Point_Definition => Compiler_Abort; when N_Others_Choice => null; when N_Package_Body => Analyze_Package_Body (N); when N_Package_Body_Stub => Analyze_Package_Body_Stub (N); when N_Package_Declaration => Analyze_Package_Declaration (N); when N_Package_Instantiation => Analyze_Package_Instantiation (N); when N_Package_Renaming_Declaration => Analyze_Package_Renaming (N); when N_Package_Specification => Analyze_Package_Specification (N); when N_Parameter_Association => Analyze (Actual_Parameter (N)); when N_Parameter_Specification => Compiler_Abort; when N_Parenthesized_Expression => Analyze_N_Parenthesized_Expression (N); when N_Pragma => Analyze_Pragma (N); when N_Pragma_Argument_Association => Compiler_Abort; when N_Private_Extension_Declaration => Analyze_Private_Extension_Declaration (N); when N_Private_Type_Declaration => Analyze_Private_Type_Declaration (N); when N_Procedure_Call_Statement => Analyze_Procedure_Call (N); when N_Procedure_Specification => Compiler_Abort; when N_Procedure_Instantiation => Analyze_Procedure_Instantiation (N); when N_Protected_Body => Analyze_Protected_Body (N); when N_Protected_Body_Stub => Compiler_Abort; when N_Protected_Definition => Analyze_Protected_Definition (N); when N_Protected_Type_Declaration => Analyze_Protected_Type (N); when N_Qualified_Expression => Analyze_Qualified_Expression (N); when N_Raise_Statement => Analyze_Raise_Statement (N); when N_Range => Analyze_Range (N); when N_Range_Constraint => Analyze_Range (Range_Expression (N)); when N_Real_Literal => Set_Etype (N, Universal_Real); when N_Real_Range_Specification => Compiler_Abort; when N_Record_Definition => Compiler_Abort; when N_Record_Representation_Clause => Analyze_Record_Representation_Clause (N); when N_Reference => Analyze_Reference (N); when N_Requeue_Statement => Analyze_Requeue (N); when N_Return_Statement => Analyze_Return_Statement (N); when N_Selected_Component => Find_Selected_Component (N); when N_Selective_Accept => Analyze_Selective_Accept (N); when N_Signed_Integer_Type_Definition => Compiler_Abort; when N_Single_Protected_Declaration => Analyze_Single_Protected (N); when N_Single_Task_Declaration => Analyze_Single_Task (N); when N_Slice => Find_Name (N); when N_String_Literal => Set_Etype (N, Any_String); when N_Subprogram_Body => Analyze_Subprogram_Body (N); when N_Subprogram_Body_Stub => Analyze_Subprogram_Body_Stub (N); when N_Subprogram_Declaration => Analyze_Subprogram_Declaration (N); when N_Subprogram_Renaming_Declaration => Analyze_Subprogram_Renaming (N); when N_Subtype_Declaration => Analyze_Subtype_Declaration (N); when N_Subtype_Indication => Analyze_Subtype_Indication (N); when N_Subunit => Analyze_Subunit (N); when N_Task_Body => Analyze_Task_Body (N); when N_Task_Body_Stub => Analyze_Concurrent_Body_Stub (N); when N_Task_Definition => Analyze_Task_Definition (N); when N_Task_Type_Declaration => Analyze_Task_Type (N); when N_Terminate_Alternative => Analyze_Terminate_Alternative (N); when N_Timed_Entry_Call => Analyze_Timed_Entry_Call (N); when N_Triggering_Alternative => Analyze_Asynchronous_Select (N); when N_Type_Conversion => Analyze_Conversion (N); when N_Unconstrained_Array_Definition => Compiler_Abort; when N_Unused_At_Start => Compiler_Abort; when N_Unused_At_End => Compiler_Abort; when N_Use_Package_Clause => Analyze_Use_Package (N); when N_Use_Type_Clause => Analyze_Use_Type (N); when N_Variant => Compiler_Abort; when N_Variant_Part => Analyze_Variant_Part (N); when N_With_Clause => Analyze_With_Clause (N); end case; pragma Debug (Debug_A_Exit ("analyzing ", N, " (done)")); -- Now that we have analyzed the node, we call the expander to -- perform possible expansion. This is done only for nodes that -- are not subexpressions, because in the case of subexpressions, -- we don't have the type yet, and the expander will need to know -- the type before it can do its job. For subexpression nodes, the -- call to the expander happens in the Resolve routine in chapter 4. -- The Analyzed flag is also set at this point for non-subexpression -- nodes (in the case of subexpression nodes, we can't set the flag -- yet, since resolution and expansion have not yet been completed) if Nkind (N) not in N_Subexpr then Expand (N); Set_Analyzed (N, True); end if; end Analyze; end Sem; ication => Compiler_Abort; when N_Loop_Statement => Analyze_Loop_Statement (N); when N_Mod_Clause => Analyze_Mod_Clause (N); when N_Modular_Type_Definition => Compiler_Abort; when N_Null => Analyze_Null (N); when N_Null_Stagnat-1.67-src/src/sem_attr.ads 444 10015 7640 6123 5506244362 11430 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ A T T R -- -- -- -- S p e c -- -- -- -- $Revision: 1.3 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Attribute handling is isolated in a separate package to ease the addition -- of implementation defined attributes. Logically this processing belongs -- in chapter 4. See Sem_Ch4 for a description of the relation of the -- Analyze and Resolve routines for expression components. with Types; use Types; package Sem_Attr is procedure Analyze_Attribute (N : Node_Id); -- Performs bottom up semantic analysis of an attribute. Note that the -- parser has already checked that type returning attributes appear only -- in appropriate contexts (i.e. in subtype marks, or as prefixes for -- other attributes). procedure Resolve_Attribute (N : Node_Id; Typ : Entity_Id); -- Performs type resolution of attribute. If the attribute yields -- a universal value, mark its type as that of the context. On -- the other hand, if the context itself is universal (as in -- T'Val (T'Pos (X)), mark the type as being the largest type of -- that class that can be used at run-time. This is correct since -- either the value gets folded (in which case it doesn't matter -- what type of the class we give if, since the folding uses universal -- arithmetic anyway) or it doesn't get folded (in which case it is -- going to be dealt with at runtime, and the largest type is right). end Sem_Attr; b- G°¹exref.ads yĹfxref.adbit ܹg xref_tab.ads- -¹h xref_tab.adbral¹i xrefprov.adbbli,¹j sysid~d.adsD¹k Makefile.os2ith`¹l CreateMiscFiles.cmd|¹m patches-gas138.os2N˜¹n patches-gcc257.os2 ¬¹o sysid.ads, ȹp Makefile.in.diffRRAܹqGCC-BASE imð¹r a-einfo.hHA¹s README.SPARCESS¹t gnat-1.67-src/src/sem_attr.adb 444 10015 7640 142726 5506244363 11462 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ A T T R -- -- -- -- B o d y -- -- -- -- $Revision: 1.62 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Einfo; use Einfo; with Errout; use Errout; with Nmake; use Nmake; with Opt; use Opt; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Stand; use Stand; with Sinfo; use Sinfo; with Snames; use Snames; with Table; with Tbuild; use Tbuild; with Uintp; use Uintp; package body Sem_Attr is ----------------------- -- Local Subprograms -- ----------------------- procedure Analyze_Access (N : Node_Id); procedure Analyze_Address (N : Node_Id); procedure Analyze_Adjacent (N : Node_Id); procedure Analyze_Aft (N : Node_Id); procedure Analyze_Alignment (N : Node_Id); procedure Analyze_Base (N : Node_Id); procedure Analyze_Bit_Order (N : Node_Id); procedure Analyze_Body_Version (N : Node_Id); procedure Analyze_Callable (N : Node_Id); procedure Analyze_Caller (N : Node_Id); procedure Analyze_Ceiling (N : Node_Id); procedure Analyze_Class (N : Node_Id); procedure Analyze_Component_Size (N : Node_Id); procedure Analyze_Compose (N : Node_Id); procedure Analyze_Constrained (N : Node_Id); procedure Analyze_Copy_Sign (N : Node_Id); procedure Analyze_Count (N : Node_Id); procedure Analyze_Delta (N : Node_Id); procedure Analyze_Denorm (N : Node_Id); procedure Analyze_Digits (N : Node_Id); procedure Analyze_Emax (N : Node_Id); procedure Analyze_Epsilon (N : Node_Id); procedure Analyze_Exponent (N : Node_Id); procedure Analyze_External_Tag (N : Node_Id); procedure Analyze_First (N : Node_Id); procedure Analyze_First_Bit (N : Node_Id); procedure Analyze_Floor (N : Node_Id); procedure Analyze_Fore (N : Node_Id); procedure Analyze_Fraction (N : Node_Id); procedure Analyze_Identity (N : Node_Id); procedure Analyze_Image (N : Node_Id); procedure Analyze_Input (N : Node_Id); procedure Analyze_Large (N : Node_Id); procedure Analyze_Last (N : Node_Id); procedure Analyze_Last_Bit (N : Node_Id); procedure Analyze_Leading_Part (N : Node_Id); procedure Analyze_Length (N : Node_Id); procedure Analyze_Machine (N : Node_Id); procedure Analyze_Machine_Emax (N : Node_Id); procedure Analyze_Machine_Emin (N : Node_Id); procedure Analyze_Machine_Mantissa (N : Node_Id); procedure Analyze_Machine_Overflows (N : Node_Id); procedure Analyze_Machine_Radix (N : Node_Id); procedure Analyze_Machine_Rounds (N : Node_Id); procedure Analyze_Mantissa (N : Node_Id); procedure Analyze_Max (N : Node_Id); procedure Analyze_Max_Size_In_Storage_Elements (N : Node_Id); procedure Analyze_Min (N : Node_Id); procedure Analyze_Model (N : Node_Id); procedure Analyze_Model_Emax (N : Node_Id); procedure Analyze_Model_Emin (N : Node_Id); procedure Analyze_Model_Epsilon (N : Node_Id); procedure Analyze_Model_Large (N : Node_Id); procedure Analyze_Model_Mantissa (N : Node_Id); procedure Analyze_Model_Small (N : Node_Id); procedure Analyze_Output (N : Node_Id); procedure Analyze_Pos (N : Node_Id); procedure Analyze_Position (N : Node_Id); procedure Analyze_Pred (N : Node_Id); procedure Analyze_Range_Attribute (N : Node_Id); procedure Analyze_Read (N : Node_Id); procedure Analyze_Remainder (N : Node_Id); procedure Analyze_Round (N : Node_Id); procedure Analyze_Rounding (N : Node_Id); procedure Analyze_Safe_Emax (N : Node_Id); procedure Analyze_Safe_First (N : Node_Id); procedure Analyze_Safe_Large (N : Node_Id); procedure Analyze_Safe_Last (N : Node_Id); procedure Analyze_Safe_Small (N : Node_Id); procedure Analyze_Scale (N : Node_Id); procedure Analyze_Signed_Zeros (N : Node_Id); procedure Analyze_Size (N : Node_Id); procedure Analyze_Small (N : Node_Id); procedure Analyze_Standard_Access (N : Node_Id); procedure Analyze_Storage_Pool (N : Node_Id); procedure Analyze_Storage_Size (N : Node_Id); procedure Analyze_Succ (N : Node_Id); procedure Analyze_Tag (N : Node_Id); procedure Analyze_Terminated (N : Node_Id); procedure Analyze_Truncation (N : Node_Id); procedure Analyze_Unbiased_Rounding (N : Node_Id); procedure Analyze_Unchecked_Access (N : Node_Id); procedure Analyze_Val (N : Node_Id); procedure Analyze_Valid (N : Node_Id); procedure Analyze_Value (N : Node_Id); procedure Analyze_Version (N : Node_Id); procedure Analyze_Wide_Image (N : Node_Id); procedure Analyze_Wide_Value (N : Node_Id); procedure Analyze_Width (N : Node_Id); procedure Analyze_Write (N : Node_Id); function Check_Array_Type (N : Node_Id; T : Entity_Id) return Boolean; -- Common semantic checks for all array attributes procedure Check_Array_Or_Scalar_Type (N : Node_Id; T : Entity_Id); -- Common procedure used by First, Last, Range procedure Check_Discrete_Type (N : Node_Id; T : Entity_Id); -- Verify that type is discrete type procedure Check_Float_Type (N : Node_Id; T : Entity_Id); -- Verify that type is float type procedure Check_Fixed_Type (N : Node_Id; T : Entity_Id); -- Verify that type is fixed type procedure Check_Real_Type (N : Node_Id; T : Entity_Id); -- Verify that type is fixed or float type procedure Check_Discrete_Attribute (N : Node_Id); -- Common processing for attributes operating on discrete types procedure Unimplemented_Attribute (N : Node_Id); -- Give error message for unimplemented attribute ---------------------- -- Check_Array_Type -- ---------------------- function Check_Array_Type (N : Node_Id; T : Entity_Id) return Boolean is P : constant Node_Id := Prefix (N); E : constant Node_Id := Expression (N); D : Int; -- Dimension number for array attributes. begin if Is_Array_Type (T) then if (not Is_Constrained (T)) and then Is_Name (P) and then Is_Type (Entity (P)) then Error_Msg_N ("expect constrained array prefix for attribute", N); return False; end if; D := Number_Dimensions (T); elsif Is_Access_Type (T) and then Is_Array_Type (Designated_Type (T)) then if Is_Name (P) and then Is_Type (Entity (P)) then Error_Msg_N ("prefix of attribute cannot be access type", N); return False; end if; D := Number_Dimensions (Designated_Type (T)); else Error_Msg_N ("expect array prefix for attribute", N); return False; end if; if Present (E) then Resolve_Subexpr (E, Any_Integer); Set_Etype (E, Standard_Integer); if not Is_Static_Expression (E) then Error_Msg_N ("expect static expression for dimension", E); return False; elsif UI_To_Int (Intval (E)) > D or else UI_To_Int (Intval (E)) < 1 then Error_Msg_N ("Invalid dimension number for array type", E); return False; end if; end if; return True; end Check_Array_Type; -------------------------------- -- Check_Array_Or_Scalar_Type -- -------------------------------- procedure Check_Array_Or_Scalar_Type (N : Node_Id; T : Entity_Id) is E : constant Node_Id := Expression (N); Index_Type : Entity_Id; D : Int; -- Dimension number for array attributes. begin Set_Etype (N, Any_Type); if Is_Scalar_Type (T) then if Present (E) then Error_Msg_N ("invalid second argument in scalar attribute", E); else Set_Etype (N, Base_Type (T)); return; end if; elsif Check_Array_Type (N, T) then -- We know prefix is appropriate for an array, and the expression -- is static and within range of the dimensions of the type. if Is_Array_Type (T) then Index_Type := First_Index (T); elsif Is_Access_Type (T) then Index_Type := First_Index (Designated_Type (T)); end if; if No (E) then -- First dimension assumed Set_Etype (N, Etype (Index_Type)); else D := UI_To_Int (Intval (E)); for I in 1 .. D - 1 loop Index_Type := Next_Index (Index_Type); end loop; Set_Etype (N, Etype (Index_Type)); Set_Etype (E, Standard_Integer); end if; end if; end Check_Array_Or_Scalar_Type; ------------------------- -- Check_Discrete_Type -- ------------------------- procedure Check_Discrete_Type (N : Node_Id; T : Entity_Id) is begin if not Is_Discrete_Type (T) then Error_Msg_N ("prefix of attribute must be discrete type", N); end if; end Check_Discrete_Type; ---------------------- -- Check_Float_Type -- ---------------------- procedure Check_Float_Type (N : Node_Id; T : Entity_Id) is begin if not Is_Float_Type (T) then Error_Msg_N ("prefix of attribute must be floating type", N); end if; end Check_Float_Type; ---------------------- -- Check_Fixed_Type -- ---------------------- procedure Check_Fixed_Type (N : Node_Id; T : Entity_Id) is begin if not Is_Fixed_Type (T) then Error_Msg_N ("prefix of attribute must be fixed type", N); end if; end Check_Fixed_Type; --------------------- -- Check_Real_Type -- --------------------- procedure Check_Real_Type (N : Node_Id; T : Entity_Id) is begin if not Is_Real_Type (T) then Error_Msg_N ("prefix of attribute must be real type", N); end if; end Check_Real_Type; ------------------------------ -- Check_Discrete_Attribute -- ------------------------------ procedure Check_Discrete_Attribute (N : Node_Id) is T : Entity_Id := Etype (Prefix (N)); E : Node_Id := Expression (N); begin Check_Discrete_Type (N, T); if No (E) then Error_Msg_N ("missing second argument of discrete attribute", N); else Resolve_Subexpr (E, T); end if; end Check_Discrete_Attribute; ----------------------------- -- Unimplemented_Attribute -- ----------------------------- procedure Unimplemented_Attribute (N : Node_Id) is begin Unimplemented (N, "attribute"); end Unimplemented_Attribute; ----------------------- -- Resolve_Attribute -- ----------------------- procedure Resolve_Attribute (N : Node_Id; Typ : Entity_Id) is Index : Interp_Index; It : Interp; P : Node_Id := Prefix (N); begin if Etype (N) = Universal_Integer or else Etype (N) = Universal_Real then if Typ = Universal_Integer then Set_Etype (N, Standard_Longest_Runtime_Integer); elsif Typ = Universal_Real then Set_Etype (N, Standard_Longest_Runtime_Real); else Set_Etype (N, Typ); end if; else case Get_Attribute_Id (Chars (Identifier (N))) is -- For these attributes, if the prefix denotes an entity, it is -- interpreted as a name, never as a call. It may be overloaded, -- in which case resolution uses the profile of the context type. -- Otherwise prefix must be resolved. when Attribute_Access | Attribute_Address | Attribute_Unchecked_Access => if Is_Name (P) then if Is_Overloaded (P) then Get_First_Interp (P, Index, It); while Present (It.Nam) loop if Type_Conformant (It.Nam, Designated_Type (Typ)) then Set_Entity (P, It.Nam); exit; end if; Get_Next_Interp (Index, It); end loop; end if; if Is_Abstract (Entity (P)) then Error_Msg_N ("prefix of attribute cannot be abstract subprogram", N); end if; else Resolve_Subexpr (P, Etype (P)); end if; Set_Etype (N, Typ); when Attribute_Range => if not Is_Name (P) or else not Is_Type (Entity (P)) then Resolve_Subexpr (P, Etype (P)); end if; -- We now replace the Range attribute node with a range -- expression whose bounds are the 'First and 'Last attributes -- applied to the same prefix. The reason that we do this -- transformation here instead of in the expander is that it -- simplifies other parts of the semantic analysis (note that -- the RM specifically mentions this equivalence, we take care -- that the prefix is only evaluated once). Set_Evaluate_Once (P, True); Rewrite_Substitute_Tree (N, Make_Range (Sloc (N), Low_Bound => Make_Attribute_Reference (Sloc (N), Prefix => P, Identifier => Make_Identifier (Sloc (N), Name_First), Expression => Expression (N)), High_Bound => Make_Attribute_Reference (Sloc (N), Prefix => P, Identifier => Make_Identifier (Sloc (N), Name_Last), Expression => Expression (N)))); Analyze (N); -- For other attributes, resolve prefix if it is not a type. when others => if not Is_Name (P) or else not Is_Type (Entity (P)) then Resolve_Subexpr (P, Etype (P)); end if; end case; end if; end Resolve_Attribute; ----------------------- -- Analyze_Attribute -- ----------------------- procedure Analyze_Attribute (N : Node_Id) is Id : constant Attribute_Id := Get_Attribute_Id (Chars (Identifier (N))); P : constant Node_Id := Prefix (N); E : constant Node_Id := Expression (N); P_Type : Entity_Id; begin -- Analyze prefix and expression, and dispatch to specific proc Set_Etype (N, Any_Type); Analyze (P); P_Type := Etype (P); -- Immediate exit if prefix had previous error if P_Type = Any_Type then return; end if; if Present (E) then Analyze (E); -- Immediate exit if expression had previous error if Etype (E) = Any_Type then return; end if; end if; if Is_Overloaded (P) and then Id /= Attribute_Access then Error_Msg_N ("ambiguous prefix for attribute", N); return; end if; case Id is when Attribute_Access => Analyze_Access (N); when Attribute_Address => Analyze_Address (N); when Attribute_Adjacent => Analyze_Adjacent (N); when Attribute_Aft => Analyze_Aft (N); when Attribute_Alignment => Analyze_Alignment (N); when Attribute_Base => Analyze_Base (N); when Attribute_Bit_Order => Analyze_Bit_Order (N); when Attribute_Body_Version => Analyze_Body_Version (N); when Attribute_Caller => Analyze_Caller (N); when Attribute_Callable => Analyze_Callable (N); when Attribute_Ceiling => Analyze_Ceiling (N); when Attribute_Class => Analyze_Class (N); when Attribute_Component_Size => Analyze_Component_Size (N); when Attribute_Compose => Analyze_Compose (N); when Attribute_Constrained => Analyze_Constrained (N); when Attribute_Copy_Sign => Analyze_Copy_Sign (N); when Attribute_Count => Analyze_Count (N); when Attribute_Delta => Analyze_Delta (N); when Attribute_Denorm => Analyze_Denorm (N); when Attribute_Digits => Analyze_Digits (N); when Attribute_Emax => Analyze_Emax (N); when Attribute_Epsilon => Analyze_Epsilon (N); when Attribute_Exponent => Analyze_Exponent (N); when Attribute_External_Tag => Analyze_External_Tag (N); when Attribute_First => Analyze_First (N); when Attribute_First_Bit => Analyze_First_Bit (N); when Attribute_Floor => Analyze_Floor (N); when Attribute_Fore => Analyze_Fore (N); when Attribute_Fraction => Analyze_Fraction (N); when Attribute_Identity => Analyze_Identity (N); when Attribute_Image => Analyze_Image (N); when Attribute_Input => Analyze_Input (N); when Attribute_Large => Analyze_Large (N); when Attribute_Last => Analyze_Last (N); when Attribute_Last_Bit => Analyze_Last_Bit (N); when Attribute_Leading_Part => Analyze_Leading_Part (N); when Attribute_Length => Analyze_Length (N); when Attribute_Machine => Analyze_Machine (N); when Attribute_Machine_Emax => Analyze_Machine_Emax (N); when Attribute_Machine_Emin => Analyze_Machine_Emin (N); when Attribute_Machine_Mantissa => Analyze_Machine_Mantissa (N); when Attribute_Machine_Overflows => Analyze_Machine_Overflows (N); when Attribute_Machine_Radix => Analyze_Machine_Radix (N); when Attribute_Machine_Rounds => Analyze_Machine_Rounds (N); when Attribute_Mantissa => Analyze_Mantissa (N); when Attribute_Max => Analyze_Max (N); when Attribute_Max_Size_In_Storage_Elements => Analyze_Max_Size_In_Storage_Elements (N); when Attribute_Min => Analyze_Min (N); when Attribute_Model => Analyze_Model (N); when Attribute_Model_Emax => Analyze_Model_Emax (N); when Attribute_Model_Emin => Analyze_Model_Emin (N); when Attribute_Model_Epsilon => Analyze_Model_Epsilon (N); when Attribute_Model_Large => Analyze_Model_Large (N); when Attribute_Model_Mantissa => Analyze_Model_Mantissa (N); when Attribute_Model_Small => Analyze_Model_Small (N); when Attribute_Output => Analyze_Output (N); when Attribute_Pos => Analyze_Pos (N); when Attribute_Position => Analyze_Position (N); when Attribute_Pred => Analyze_Pred (N); when Attribute_Range => Analyze_Range_Attribute (N); when Attribute_Read => Analyze_Read (N); when Attribute_Remainder => Analyze_Remainder (N); when Attribute_Round => Analyze_Round (N); when Attribute_Rounding => Analyze_Rounding (N); when Attribute_Safe_Emax => Analyze_Safe_Emax (N); when Attribute_Safe_First => Analyze_Safe_First (N); when Attribute_Safe_Large => Analyze_Safe_Large (N); when Attribute_Safe_Last => Analyze_Safe_Last (N); when Attribute_Safe_Small => Analyze_Safe_Small (N); when Attribute_Scale => Analyze_Scale (N); when Attribute_Signed_Zeros => Analyze_Signed_Zeros (N); when Attribute_Size => Analyze_Size (N); when Attribute_Small => Analyze_Small (N); when Attribute_Storage_Pool => Analyze_Storage_Pool (N); when Attribute_Standard_Access => Analyze_Standard_Access (N); when Attribute_Storage_Size => Analyze_Storage_Size (N); when Attribute_Succ => Analyze_Succ (N); when Attribute_Tag => Analyze_Tag (N); when Attribute_Terminated => Analyze_Terminated (N); when Attribute_Truncation => Analyze_Truncation (N); when Attribute_Unbiased_Rounding => Analyze_Unbiased_Rounding (N); when Attribute_Unchecked_Access => Analyze_Unchecked_Access (N); when Attribute_Val => Analyze_Val (N); when Attribute_Valid => Analyze_Valid (N); when Attribute_Value => Analyze_Value (N); when Attribute_Version => Analyze_Version (N); when Attribute_Wide_Image => Analyze_Wide_Image (N); when Attribute_Wide_Value => Analyze_Wide_Value (N); when Attribute_Width => Analyze_Width (N); when Attribute_Write => Analyze_Write (N); end case; end Analyze_Attribute; -------------------- -- Analyze_Access -- -------------------- procedure Analyze_Access (N : Node_Id) is P : constant Node_Id := Prefix (N); T : constant Entity_Id := Etype (P); Index : Interp_Index; It : Interp; Acc_Type : Entity_Id; function Valid_Aliased_View (Obj : Node_Id) return Boolean is E : Entity_Id; begin if Is_Name (Obj) then E := Entity (Obj); return (Is_Aliased (E) or else (Present (Renamed_Object (E)) and then Valid_Aliased_View (Renamed_Object (E))) or else (Ekind (E) = E_In_Out_Parameter and then Is_Tagged_Type (Etype (E))) or else (Ekind (E) = E_Generic_In_Out_Parameter and then Is_Tagged_Type (Etype (E))) or else ((Ekind (E) = E_Task_Type or else Ekind (E) = E_Protected_Type) and then In_Open_Scopes (E))); elsif Nkind (Obj) = N_Selected_Component then return Is_Aliased (Entity (Selector_Name (Obj))); elsif Nkind (Obj) = N_Indexed_Component then return Is_Aliased (Etype (Prefix (Obj))); elsif Nkind (Obj) = N_Type_Conversion then return Is_Tagged_Type (Etype (Obj)); elsif Nkind (Obj) = N_Explicit_Dereference then return True; -- more precise test needed??? else return False; end if; end Valid_Aliased_View; -- Start of processing for Analyze_Access begin -- In the case of an access to subprogram, use the name of the -- subprogram itself as the designated type. Type-checking in -- this case compares the signatures of the designated types. if Is_Name (P) and then Is_Overloadable (Entity (P)) then if not Is_Overloaded (P) then Acc_Type := New_Internal_Entity (E_Access_Subprogram_Type, Current_Scope, Sloc (N), "access"); Set_Etype (Acc_Type, Acc_Type); Set_Directly_Designated_Type (Acc_Type, Entity (P)); Set_Etype (N, Acc_Type); else Get_First_Interp (P, Index, It); while Present (It.Nam) loop Acc_Type := New_Internal_Entity (E_Access_Subprogram_Type, Current_Scope, Sloc (N), "access"); Set_Etype (Acc_Type, Acc_Type); Set_Directly_Designated_Type (Acc_Type, It.Nam); Add_One_Interp (N, Acc_Type, Acc_Type); Get_Next_Interp (Index, It); end loop; end if; -- Case of access to object else Acc_Type := New_Internal_Entity (E_Allocator_Type, Current_Scope, Sloc (N), "access"); Set_Etype (Acc_Type, Acc_Type); Set_Directly_Designated_Type (Acc_Type, T); Set_Etype (N, Acc_Type); if not Valid_Aliased_View (P) then Error_Msg_N ("prefix of 'ACCESS must be aliased view", N); end if; end if; end Analyze_Access; --------------------- -- Analyze_Address -- --------------------- procedure Analyze_Address (N : Node_Id) is begin Set_Etype (N, RTE (RE_Address)); end Analyze_Address; ---------------------- -- Analyze_Adjacent -- ---------------------- procedure Analyze_Adjacent (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Adjacent; ----------------- -- Analyze_Aft -- ----------------- procedure Analyze_Aft (N : Node_Id) is begin Check_Fixed_Type (N, Etype (Prefix (N))); Set_Etype (N, Universal_Integer); Unimplemented (N, "attribute"); end Analyze_Aft; ----------------------- -- Analyze_Alignment -- ----------------------- procedure Analyze_Alignment (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Alignment; ------------------ -- Analyze_Base -- ------------------ procedure Analyze_Base (N : Node_Id) is begin Find_Type (Prefix (N)); Set_Etype (N, Base_Type (Entity (Prefix (N)))); end Analyze_Base; ----------------------- -- Analyze_Bit_Order -- ----------------------- procedure Analyze_Bit_Order (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Bit_Order; -------------------------- -- Analyze_Body_Version -- -------------------------- procedure Analyze_Body_Version (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Body_Version; ---------------------- -- Analyze_Callable -- ---------------------- procedure Analyze_Callable (N : Node_Id) is begin -- The semantic processing for 'Callable is identical to 'Terminated Analyze_Terminated (N); end Analyze_Callable; -------------------- -- Analyze_Caller -- -------------------- procedure Analyze_Caller (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Caller; --------------------- -- Analyze_Ceiling -- --------------------- procedure Analyze_Ceiling (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Ceiling; ------------------- -- Analyze_Class -- ------------------- procedure Analyze_Class (N : Node_Id) is begin Find_Type (N); if Present (Expression (N)) then -- in fact, this is a conversion not an attribute : T'Class (X) Rewrite_Substitute_Tree (N, Make_Type_Conversion (Sloc (N), Subtype_Mark => New_Occurrence_Of (Etype (N), Sloc (N)), Expression => New_Copy (Expression (N)))); Analyze (N); end if; end Analyze_Class; ---------------------------- -- Analyze_Component_Size -- ---------------------------- procedure Analyze_Component_Size (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Component_Size; --------------------- -- Analyze_Compose -- --------------------- procedure Analyze_Compose (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Compose; ------------------------- -- Analyze_Constrained -- ------------------------- procedure Analyze_Constrained (N : Node_Id) is begin if Ada_9X then Error_Msg_N ("obsolescent feature: 'Constrained attribute?", N); end if; Set_Etype (N, Standard_Boolean); end Analyze_Constrained; ----------------------- -- Analyze_Copy_Sign -- ----------------------- procedure Analyze_Copy_Sign (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Copy_Sign; ------------------- -- Analyze_Count -- ------------------- procedure Analyze_Count (N : Node_Id) is begin Set_Etype (N, Universal_Integer); Unimplemented_Attribute (N); end Analyze_Count; ------------------- -- Analyze_Delta -- ------------------- procedure Analyze_Delta (N : Node_Id) is begin Check_Fixed_Type (N, Etype (Prefix (N))); Set_Etype (N, Universal_Real); Unimplemented_Attribute (N); end Analyze_Delta; -------------------- -- Analyze_Denorm -- -------------------- procedure Analyze_Denorm (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Denorm; -------------------- -- Analyze_Digits -- -------------------- procedure Analyze_Digits (N : Node_Id) is begin Check_Float_Type (N, Etype (Prefix (N))); Set_Etype (N, Universal_Integer); Unimplemented_Attribute (N); end Analyze_Digits; ------------------ -- Analyze_Emax -- ------------------ procedure Analyze_Emax (N : Node_Id) is begin Check_Float_Type (N, Etype (Prefix (N))); Set_Etype (N, Universal_Integer); Unimplemented_Attribute (N); end Analyze_Emax; --------------------- -- Analyze_Epsilon -- --------------------- procedure Analyze_Epsilon (N : Node_Id) is begin Check_Float_Type (N, Etype (Prefix (N))); Set_Etype (N, Universal_Real); Unimplemented_Attribute (N); end Analyze_Epsilon; ---------------------- -- Analyze_Exponent -- ---------------------- procedure Analyze_Exponent (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Exponent; -------------------------- -- Analyze_External_Tag -- -------------------------- procedure Analyze_External_Tag (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_External_Tag; ------------------- -- Analyze_First -- ------------------- procedure Analyze_First (N : Node_Id) is begin Check_Array_Or_Scalar_Type (N, Etype (Prefix (N))); end Analyze_First; ----------------------- -- Analyze_First_Bit -- ----------------------- procedure Analyze_First_Bit (N : Node_Id) is begin Set_Etype (N, Universal_Integer); Unimplemented_Attribute (N); end Analyze_First_Bit; ------------------- -- Analyze_Floor -- ------------------- procedure Analyze_Floor (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Floor; ------------------ -- Analyze_Fore -- ------------------ procedure Analyze_Fore (N : Node_Id) is begin Check_Fixed_Type (N, Etype (Prefix (N))); Set_Etype (N, Universal_Integer); Unimplemented_Attribute (N); end Analyze_Fore; ---------------------- -- Analyze_Fraction -- ---------------------- procedure Analyze_Fraction (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Fraction; ---------------------- -- Analyze_Identity -- ---------------------- procedure Analyze_Identity (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Identity; ------------------- -- Analyze_Image -- ------------------- procedure Analyze_Image (N : Node_Id) is begin Set_Etype (N, Standard_String); if Is_Real_Type (Etype (Prefix (N))) then if Ada_83 then Error_Msg_N ("Image attribute not allowed for real types in Ada 83", N); end if; else Check_Discrete_Attribute (N); end if; end Analyze_Image; ------------------- -- Analyze_Input -- ------------------- procedure Analyze_Input (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Input; ------------------- -- Analyze_Large -- ------------------- procedure Analyze_Large (N : Node_Id) is begin Check_Real_Type (N, Etype (Prefix (N))); Set_Etype (N, Universal_Real); Unimplemented_Attribute (N); end Analyze_Large; ------------------ -- Analyze_Last -- ------------------ procedure Analyze_Last (N : Node_Id) is begin Check_Array_Or_Scalar_Type (N, Etype (Prefix (N))); end Analyze_Last; ---------------------- -- Analyze_Last_Bit -- ---------------------- procedure Analyze_Last_Bit (N : Node_Id) is begin Set_Etype (N, Universal_Integer); Unimplemented_Attribute (N); end Analyze_Last_Bit; -------------------------- -- Analyze_Leading_Part -- -------------------------- procedure Analyze_Leading_Part (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Leading_Part; -------------------- -- Analyze_Length -- -------------------- procedure Analyze_Length (N : Node_Id) is ok : boolean := Check_Array_Type (N, Etype (Prefix (N))); begin Set_Etype (N, Universal_Integer); end Analyze_Length; --------------------- -- Analyze_Machine -- --------------------- procedure Analyze_Machine (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Machine; -------------------------- -- Analyze_Machine_Emax -- -------------------------- procedure Analyze_Machine_Emax (N : Node_Id) is begin Check_Float_Type (N, Etype (Prefix (N))); Set_Etype (N, Universal_Integer); Unimplemented_Attribute (N); end Analyze_Machine_Emax; -------------------------- -- Analyze_Machine_Emin -- -------------------------- procedure Analyze_Machine_Emin (N : Node_Id) is begin Check_Float_Type (N, Etype (Prefix (N))); Set_Etype (N, Universal_Integer); Unimplemented_Attribute (N); end Analyze_Machine_Emin; ------------------------------ -- Analyze_Machine_Mantissa -- ------------------------------ procedure Analyze_Machine_Mantissa (N : Node_Id) is begin Check_Float_Type (N, Etype (Prefix (N))); Set_Etype (N, Universal_Integer); Unimplemented_Attribute (N); end Analyze_Machine_Mantissa; ------------------------------- -- Analyze_Machine_Overflows -- ------------------------------- procedure Analyze_Machine_Overflows (N : Node_Id) is begin Check_Real_Type (N, Etype (Prefix (N))); Set_Etype (N, Standard_Boolean); Unimplemented_Attribute (N); end Analyze_Machine_Overflows; --------------------------- -- Analyze_Machine_Radix -- --------------------------- procedure Analyze_Machine_Radix (N : Node_Id) is begin Check_Float_Type (N, Etype (Prefix (N))); Set_Etype (N, Universal_Integer); Unimplemented_Attribute (N); end Analyze_Machine_Radix; ---------------------------- -- Analyze_Machine_Rounds -- ---------------------------- procedure Analyze_Machine_Rounds (N : Node_Id) is begin Check_Real_Type (N, Etype (Prefix (N))); Set_Etype (N, Standard_Boolean); Unimplemented_Attribute (N); end Analyze_Machine_Rounds; ---------------------- -- Analyze_Mantissa -- ---------------------- procedure Analyze_Mantissa (N : Node_Id) is begin Check_Real_Type (N, Etype (Prefix (N))); Set_Etype (N, Universal_Integer); Unimplemented_Attribute (N); end Analyze_Mantissa; ----------------- -- Analyze_Max -- ----------------- procedure Analyze_Max (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Max; ------------------------------------------ -- Analyze_Max_Size_In_Storage_Elements -- ------------------------------------------ procedure Analyze_Max_Size_In_Storage_Elements (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Max_Size_In_Storage_Elements; ----------------- -- Analyze_Min -- ----------------- procedure Analyze_Min (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Min; ------------------- -- Analyze_Model -- ------------------- procedure Analyze_Model (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Model; ------------------------ -- Analyze_Model_Emax -- ------------------------ procedure Analyze_Model_Emax (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Model_Emax; ------------------------ -- Analyze_Model_Emin -- ------------------------ procedure Analyze_Model_Emin (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Model_Emin; --------------------------- -- Analyze_Model_Epsilon -- --------------------------- procedure Analyze_Model_Epsilon (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Model_Epsilon; ------------------------- -- Analyze_Model_Large -- ------------------------- procedure Analyze_Model_Large (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Model_Large; ---------------------------- -- Analyze_Model_Mantissa -- ---------------------------- procedure Analyze_Model_Mantissa (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Model_Mantissa; ------------------------- -- Analyze_Model_Small -- ------------------------- procedure Analyze_Model_Small (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Model_Small; -------------------- -- Analyze_Output -- -------------------- procedure Analyze_Output (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Output; ----------------- -- Analyze_Pos -- ----------------- procedure Analyze_Pos (N : Node_Id) is begin Check_Discrete_Attribute (N); Set_Etype (N, Universal_Integer); end Analyze_Pos; ---------------------- -- Analyze_Position -- ---------------------- procedure Analyze_Position (N : Node_Id) is begin Set_Etype (N, Universal_Integer); end Analyze_Position; ------------------ -- Analyze_Pred -- ------------------ procedure Analyze_Pred (N : Node_Id) is begin Check_Discrete_Attribute (N); Set_Etype (N, Etype (Prefix (N))); end Analyze_Pred; ----------------------------- -- Analyze_Range_Attribute -- ----------------------------- procedure Analyze_Range_Attribute (N : Node_Id) is begin Check_Array_Or_Scalar_Type (N, Etype (Prefix (N))); end Analyze_Range_Attribute; ------------------ -- Analyze_Read -- ------------------ procedure Analyze_Read (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Read; ----------------------- -- Analyze_Remainder -- ----------------------- procedure Analyze_Remainder (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Remainder; ------------------- -- Analyze_Round -- ------------------- procedure Analyze_Round (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Round; ---------------------- -- Analyze_Rounding -- ---------------------- procedure Analyze_Rounding (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Rounding; ----------------------- -- Analyze_Safe_Emax -- ----------------------- procedure Analyze_Safe_Emax (N : Node_Id) is begin Check_Float_Type (N, Etype (Prefix (N))); Set_Etype (N, Universal_Integer); Unimplemented_Attribute (N); end Analyze_Safe_Emax; ------------------------ -- Analyze_Safe_First -- ------------------------ procedure Analyze_Safe_First (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Safe_First; ------------------------ -- Analyze_Safe_Large -- ------------------------ procedure Analyze_Safe_Large (N : Node_Id) is begin Check_Real_Type (N, Etype (Prefix (N))); Set_Etype (N, Universal_Real); Unimplemented_Attribute (N); end Analyze_Safe_Large; ----------------------- -- Analyze_Safe_Last -- ----------------------- procedure Analyze_Safe_Last (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Safe_Last; ------------------------ -- Analyze_Safe_Small -- ------------------------ procedure Analyze_Safe_Small (N : Node_Id) is begin Check_Real_Type (N, Etype (Prefix (N))); Set_Etype (N, Universal_Real); Unimplemented_Attribute (N); end Analyze_Safe_Small; ------------------- -- Analyze_Scale -- ------------------- procedure Analyze_Scale (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Scale; -------------------------- -- Analyze_Signed_Zeros -- -------------------------- procedure Analyze_Signed_Zeros (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Signed_Zeros; ------------------ -- Analyze_Size -- ------------------ procedure Analyze_Size (N : Node_Id) is begin Set_Etype (N, Universal_Integer); end Analyze_Size; ------------------- -- Analyze_Small -- ------------------- procedure Analyze_Small (N : Node_Id) is begin Check_Real_Type (N, Etype (Prefix (N))); Set_Etype (N, Universal_Real); Unimplemented_Attribute (N); end Analyze_Small; ----------------------------- -- Analyze_Standard_Access -- ----------------------------- procedure Analyze_Standard_Access (N : Node_Id) is begin Find_Type (Prefix (N)); if Base_Type (Entity (Prefix (N))) /= Standard_String then Error_Msg_N ("only permitted prefix is `String`", Prefix (N)); Set_Etype (N, Any_Type); else Set_Etype (N, Standard_A_String); end if; end Analyze_Standard_Access; -------------------------- -- Analyze_Storage_Pool -- -------------------------- procedure Analyze_Storage_Pool (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Storage_Pool; -------------------------- -- Analyze_Storage_Size -- -------------------------- procedure Analyze_Storage_Size (N : Node_Id) is begin Set_Etype (N, Universal_Integer); Unimplemented_Attribute (N); end Analyze_Storage_Size; ------------------ -- Analyze_Succ -- ------------------ procedure Analyze_Succ (N : Node_Id) is begin Check_Discrete_Attribute (N); Set_Etype (N, Etype (Prefix (N))); end Analyze_Succ; ----------------- -- Analyze_Tag -- ----------------- procedure Analyze_Tag (N : Node_Id) is begin Unimplemented_Attribute (N); Set_Etype (N, RTE (RE_Tag)); end Analyze_Tag; ------------------------ -- Analyze_Terminated -- ------------------------ procedure Analyze_Terminated (N : Node_Id) is P : constant Node_Id := Prefix (N); begin Set_Etype (N, Standard_Boolean); Analyze (P); if Is_Task_Type (Etype (P)) or else (Is_Access_Type (Etype (P)) and then Is_Task_Type (Designated_Type (Etype (P)))) then Resolve_Subexpr (P, Etype (P)); else Error_Msg_N ("prefix of attribute must be a task", N); end if; end Analyze_Terminated; ------------------------ -- Analyze_Truncation -- ------------------------ procedure Analyze_Truncation (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Truncation; ------------------------------- -- Analyze_Unbiased_Rounding -- ------------------------------- procedure Analyze_Unbiased_Rounding (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Unbiased_Rounding; ------------------------------ -- Analyze_Unchecked_Access -- ------------------------------ procedure Analyze_Unchecked_Access (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Unchecked_Access; ----------------- -- Analyze_Val -- ----------------- procedure Analyze_Val (N : Node_Id) is T : constant Entity_Id := Etype (Prefix (N)); E : constant Node_Id := Expression (N); begin Check_Discrete_Type (N, T); if No (E) or else not Is_Integer_Type (Etype (E)) then Error_Msg_N ("expect integer value as argument of attribute", N); else Resolve_Subexpr (E, Etype (E)); end if; Set_Etype (N, T); end Analyze_Val; ------------------- -- Analyze_Valid -- ------------------- procedure Analyze_Valid (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Valid; ------------------- -- Analyze_Value -- ------------------- procedure Analyze_Value (N : Node_Id) is T : constant Entity_Id := Etype (Prefix (N)); E : constant Node_Id := Expression (N); begin Check_Discrete_Type (N, T); if No (E) then Error_Msg_N ("expect string value as argument of attribute", N); else Resolve_Subexpr (E, Standard_String); end if; Set_Etype (N, T); end Analyze_Value; --------------------- -- Analyze_Version -- --------------------- procedure Analyze_Version (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Version; ------------------------ -- Analyze_Wide_Image -- ------------------------ procedure Analyze_Wide_Image (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Wide_Image; ------------------------ -- Analyze_Wide_Value -- ------------------------ procedure Analyze_Wide_Value (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Wide_Value; ------------------- -- Analyze_Width -- ------------------- procedure Analyze_Width (N : Node_Id) is T : constant Entity_Id := Etype (Prefix (N)); begin Check_Discrete_Type (N, T); Set_Etype (N, Universal_Integer); end Analyze_Width; ------------------- -- Analyze_Write -- ------------------- procedure Analyze_Write (N : Node_Id) is begin Unimplemented_Attribute (N); end Analyze_Write; end Sem_Attr; Analyze_Position; ------------------ gnat-1.67-src/src/sem_ch10.ads 444 10015 7640 5107 5506244363 11213 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ C H 1 0 -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Sem_Ch10 is procedure Analyze_Compilation_Unit (N : Node_Id); procedure Analyze_With_Clause (N : Node_Id); procedure Analyze_Subprogram_Body_Stub (N : Node_Id); procedure Analyze_Package_Body_Stub (N : Node_Id); procedure Analyze_Concurrent_Body_Stub (N : Node_Id); procedure Analyze_Protected_Body_Stub (N : Node_Id); procedure Analyze_Subunit (N : Node_Id); procedure Load_Needed_Body (N : Node_Id); -- Load and analyze the body of a context unit that is generic, or -- that contains generic units or inlined units. The body becomes -- part of the semantic dependency set of the unit that needs it. end Sem_Ch10; epr.ads À¹* treepr.adb Ô¹+ treeprs.adtè¹, ttypes.adsoü¹- ttypes.adtr¹. types.ads t$¹/ types.adb; 8¹0 uintp.adse;L¹1 uintp.adb--`¹2 uname.adsTyt¹3 uname.adb--˜¹4(unchecked_conversion.adse (¼¹5(unchecked_conversion.adbin à¹6(unchecked_deallocation.ads ¹7 unixlib.ads$¹8(unchecked_deallocation.adb 8¹9gnat-1.67-src/src/sem_ch10.adb 444 10015 7640 112275 5506244364 11240 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ C H 1 0 -- -- -- -- B o d y -- -- -- -- $Revision: 1.80 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Debug; use Debug; with Einfo; use Einfo; with Errcount; use Errcount; with Errout; use Errout; with Lib; use Lib; with Namet; use Namet; with Nmake; use Nmake; with Opt; use Opt; with Output; use Output; with Sem; use Sem; with Sem_Ch6; use Sem_Ch6; with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; with Sem_Util; use Sem_Util; with Stand; use Stand; with Sinfo; use Sinfo; with Sinfo.Change; use Sinfo.Change; with Snames; use Snames; with Stringt; use Stringt; with Tbuild; use Tbuild; with Uname; use Uname; package body Sem_Ch10 is ----------------------- -- Local Subprograms -- ----------------------- procedure Analyze_Context (N : Node_Id); -- Analyzes items in the context clause of compilation unit function Ancestor (Lib_Unit : Node_Id) return Entity_Id; -- Return the root ancestor of a child unit. procedure Implicit_With_On_Parent (Child_Unit : Node_Id; Item : Node_Id); -- When a child unit appears in a context clause, the implicit withs on -- parents is made explicit, and with clauses are inserted in the context -- clause after that for the child. procedure Insert_Version_Declaration (N : Node_Id); -- This procedure inserts the declaration of Version_S (for a spec) -- or Version_B for a body in the declarative region of the library -- library unit if either of the the db (traceback) or dv (version) -- debug switches are set. One might thing of this as expansion -- activity, but since it is a real variable, the program can reference -- it, and thus it must be put in early. Furthermore, the expander model -- is wrong for this insertion, since it is inserted at the outer level -- and referenced at inner levels, and expansion works inside out. -- The declaration is added to subprogram bodies, package specs, -- package bodies, generic versions of these, and to subunits. procedure Install_Context (N : Node_Id); -- Installs the entities from the context clause of the given compilation -- unit into the visibility chains. This is done before analyzing a unit. procedure Install_Withed_Unit (Unit_Name : Entity_Id); -- This procedure installs the entities of a singled withed unit into the -- visibility chains. The argument is the entity for the unit involved. -- The caller ensures that the unit is not already currently installed. procedure Install_Parents (Lib_Unit : Node_Id); -- This procedure establishes the context for the compilation of a child -- unit. If Lib_Unit is a child library spec then the context of the parent -- is installed, and the parent itself made directly visible, so that -- the child unit is processed in the declarative region of the parent. -- Install_Parents makes a recursive call to itself to ensure that all -- parents are loaded in the nested case. If Lib_Unit is a library body, -- the only effect of Install_Parents is to install the private decls of -- the parents, because the visible parent declarations will have been -- installed as part of the context of the corresponding spec. function Is_Child_Spec (Lib_Unit : Node_Id) return Boolean; -- Lib_Unit is a library unit which may be a spec or a body. Is_Child_Spec -- returns True if Lib_Unit is a library spec which is a child spec, i.e. -- a library spec that has a parent. If the call to Is_Child_Spec returns -- True, then Parent_Spec (Lib_Unit) is non-Empty and points to the -- compilation unit for the parent spec. procedure Remove_Context (N : Node_Id); -- Removes the entities from the context clause of the given compilation -- unit from the visibility chains. This is done on exit from a unit as -- part of cleaning up the visibility chains for the caller. A special -- case is that the call from the Main_Unit can be ignored, since at the -- end of the main unit the visibility table won't be needed in any case. procedure Remove_Parents (Lib_Unit : Node_Id); -- Remove_Parents checks if Lib_Unit is a child spec. If so then the parent -- contexts established by the corresponding call to Install_Parents are -- removed. Remove_Parents contains a recursive call to itself to ensure -- that all parents are removed in the nested case. procedure Remove_Withed_Unit (Unit_Name : Entity_Id); -- This procedure reverses the effects of a previous call to the install -- routine (Install_Withed_Unit). It removes the entities of a single -- withed unit from the visibility chains. The argument is the entity for -- the unit involved. The caller has ensured that the unit is installed. -- Also called to remove the parent of a child unit. procedure Remove_Entity (E : Entity_Id); -- This procedure removes a single entity from the visibility chain. -- The caller has ensured that the entity is on the chain. procedure Analyze_Proper_Body (N : Node_Id); -- Common processing for subprogram stubs and package stubs. Once the -- subunit name is established, load and analyze. ------------------------------ -- Analyze_Compilation_Unit -- ------------------------------ procedure Analyze_Compilation_Unit (N : Node_Id) is Lib_Unit : constant Node_Id := Unit (N); Spec_Id : Node_Id; begin -- If the unit is a subunit whose parent has not been analyzed (which -- indicates that the main unit is a subunit, either the current one or -- one of its descendents) then the subunit is compiled as part of the -- analysis of the parent, which we proceed to do. Basically this gets -- handled from the top down and we don't want to do anything at this -- level (i.e. this subunit will be handled on the way down from the -- parent), so at this level we immediately return. if Nkind (Lib_Unit) = N_Subunit and then not Analyzed (Library_Unit (N)) then Semantics (Library_Unit (N)); return; end if; Insert_Version_Declaration (N); -- Analyze context (this will call Sem recursively for with'ed units) Analyze_Context (N); -- If the unit is a package body, the spec is already loaded -- and must be analyzed first, before we analyze the body. if Nkind (Lib_Unit) = N_Package_Body then Semantics (Library_Unit (N)); Spec_Id := Defining_Unit_Simple_Name (Specification (Unit (Library_Unit (N)))); -- The following check is an error defense, get out if as a result -- of errors we do not have a proper package spec around! if No (Spec_Id) or else (Ekind (Spec_Id) /= E_Package and then Ekind (Spec_Id) /= E_Generic_Package) then return; else Set_Is_Directly_Visible (Spec_Id, True); end if; -- If the unit is a subprogram body, then we similarly need to analyze -- its spec. However, things are a little simpler in this case, because -- here, this analysis is done only for error checking and consistency -- purposes, so there's nothing else to be done. elsif (Nkind (Lib_Unit) = N_Subprogram_Body and then not Acts_As_Spec (N)) then Semantics (Library_Unit (N)); -- If it is a subprogram declaration it does not need an elaboration -- procedure. A renamed package also needs no elaboration procedure. elsif Nkind (Lib_Unit) = N_Subprogram_Declaration or else Nkind (Lib_Unit) = N_Package_Renaming_Declaration then Set_Preelaborable (N, True); end if; -- If it is a child unit, the parent must be elaborated first if Is_Child_Spec (Lib_Unit) then Semantics (Parent_Spec (Lib_Unit)); end if; -- With the analysis done, install the context. Note that we can't -- install the context from the with clauses as we analyze them, -- because each with clause must be analyzed in a clean visibility -- context, so we have to wait and install them all at once. Install_Context (N); -- All components of the context: with-clauses, library unit, ancestors -- if any, (and their context) are analyzed and installed. Now analyze -- the unit itself, which is either a package, subprogram spec or body. Analyze (Lib_Unit); -- Treat compilation unit pragmas that appear after the library unit if List_Present (Following_Pragmas (N)) then declare Prag_Node : Node_Id := First (Following_Pragmas (N)); begin while Present (Prag_Node) loop Analyze (Prag_Node); Prag_Node := Next (Prag_Node); end loop; end; end if; -- Last step is to deinstall the context we just installed -- as well as the unit just compiled, unless it is the main -- unit, or the specification for the main unit. if N /= File.Table (Main_Unit).Cunit then Remove_Context (N); if Nkind (Lib_Unit) = N_Package_Declaration then Remove_Withed_Unit (Defining_Unit_Simple_Name (Specification (Lib_Unit))); elsif Nkind (Lib_Unit) = N_Package_Body or else (Nkind (Lib_Unit) = N_Subprogram_Body and then not Acts_As_Spec (N)) then -- Bodies that are not the main unit are compiled if they -- are generic or contain generic or inlined units. Their -- analysis brings in the context of the corresponding spec -- (unit declaration) which must be removed as well, to -- return the compilation environment to its proper state. Remove_Context (Library_Unit (N)); end if; end if; end Analyze_Compilation_Unit; ---------------------------------- -- Analyze_Concurrent_Body_Stub -- ---------------------------------- procedure Analyze_Concurrent_Body_Stub (N : Node_Id) is begin Unimplemented (N, "Concurrrent body stubs"); end Analyze_Concurrent_Body_Stub; --------------------- -- Analyze_Context -- --------------------- procedure Analyze_Context (N : Node_Id) is Item : Node_Id := First (Context_Items (N)); begin -- Note: we do not analyze use clauses at this time, since we don't -- want to do any installing of use visible entities until we actually -- install the complete context (in Install_Context). Otherwise things -- can get installed in the wrong context. while Present (Item) loop if Nkind (Item) = N_With_Clause or else Nkind (Item) = N_Pragma then Analyze (Item); end if; Item := Next (Item); end loop; end Analyze_Context; ------------------------------- -- Analyze_Package_Body_Stub -- ------------------------------- procedure Analyze_Package_Body_Stub (N : Node_Id) is Id : Entity_Id := Defining_Identifier (N); Nam : Entity_Id; begin -- The package declaration must be in the current declarative part Nam := Current_Entity (Id); if No (Nam) or else Scope (Nam) /= Current_Scope or else (Ekind (Nam) /= E_Package and then Ekind (Nam) /= E_Generic_Package) then Error_Msg_N ("missing specification for package stub", N); else -- Indicate that the body of the package exists. If we are doing -- only semantic analysis, the stub stands for the body. If we are -- generating code, the existence of the body will be confirmed -- when we load the proper body. Set_Has_Completion (Nam); Analyze_Proper_Body (N); end if; end Analyze_Package_Body_Stub; ------------------------- -- Analyze_Proper_Body -- ------------------------- -- If the subunit is already loaded, it means that the main unit -- was a subunit, and that the current unit is one of its parents -- which was being analyzed to provide the needed context for the -- analysis of the subunit. In this case we analyze the subunit -- and then raise Subunit_Found, since we don't need to analyze -- any more of the parent (only the part up to here is relevant -- to the desired analysis of the subunit). procedure Analyze_Proper_Body (N : Node_Id) is Unum : Unit_Number_Type; Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N); begin if Is_Loaded (Subunit_Name) then Unum := Load (Subunit_Name, True, N); -- must work, to set Unum Compiler_State := Analyzing; -- reset after load Analyze_Subunit (File.Table (Unum).Cunit); Set_Library_Unit (N, File.Table (Unum).Cunit); raise Subunit_Found; -- If the main unit is a subunit, then we are just performing semantic -- analysis on that subunit, and any other subunits of any parent unit -- should be ignored. elsif Nkind (Unit (File.Table (Main_Unit).Cunit)) = N_Subunit and then Subunit_Name /= File.table (Main_Unit).Unit_Name then return; -- If the subunit is not already loaded, and we are generating code, -- then this is the case where compilation started from the parent, -- and we are generating code for an entire subunit tree. In that -- case we definitely need to load the subunit. elsif Operating_Mode = Generate_Code then Unum := Load (Subunit_Name, True, N); Compiler_State := Analyzing; -- reset after load if Unum /= No_Unit and then not File.Table (Unum).Fatal_Error then if Debug_Flag_L then Write_Str ("*** Loaded subunit from stub. Analyze"); Write_Eol; end if; Analyze_Subunit (File.Table (Unum).Cunit); Set_Library_Unit (N, File.Table (Unum).Cunit); end if; -- The remaining case is when the subunit is not already loaded and -- we are not generating code. In this case we are just analyzing -- the parent to check it for errors, and we are not interested in -- the subunit, so there is nothing to be done, except enter the -- name if there was no previous declaration. else null; end if; end Analyze_Proper_Body; ---------------------------------- -- Analyze_Protected_Body_Stub -- ---------------------------------- procedure Analyze_Protected_Body_Stub (N : Node_Id) is begin Unimplemented (N, "Protected body stubs"); end Analyze_Protected_Body_Stub; ---------------------------------- -- Analyze_Subprogram_Body_Stub -- ---------------------------------- -- A subprogram body stub can appear with or without a previous -- specification. If there is one, the analysis of the body will -- find it and verify conformance. The formals appearing in the -- specification of the stub play no role, except for requiring -- an additional conformance check. However, if we are performing -- semantic checks only, the stub must be analyzed like a body, -- because it may be the declaration of the subprogram. procedure Analyze_Subprogram_Body_Stub (N : Node_Id) is begin if Operating_Mode /= Generate_Code then Analyze_Subprogram_Body (N); else Analyze_Proper_Body (N); end if; end Analyze_Subprogram_Body_Stub; --------------------- -- Analyze_Subunit -- --------------------- -- A subunit is compiled either by itself (for semantic checking) -- or as part of compiling the parent (for code generation). In -- either case, by the time we actually process the subunit, the -- parent has already been installed and analyzed. The node N is -- a compilation unit, whose context needs to be treated here, -- because we come directly here from the parent without calling -- Analyze_Compilation_Unit. -- The compilation context includes the explicit context of the -- subunit, and the context of the parent, together with the parent -- itself. In order to compile the current context, we remove the -- one inherited from the parent, in order to have a clean visibility -- table. We restore the parent context before analyzing the proper -- body itself. On exit, we remove only the explicit context of the -- subunit. procedure Analyze_Subunit (N : Node_Id) is Lib : constant Node_Id := Library_Unit (N); Lib_Spec : constant Node_Id := Library_Unit (Lib); begin if List_Present (Context_Items (N)) then Remove_Context (Lib); -- If the parent is a package body, remove the context of the spec -- as well. If it is a subprogram body, verify that there is a -- spec for it. if Present (Lib_Spec) then Remove_Context (Lib_Spec); end if; Analyze_Context (N); if Present (Lib_Spec) then Install_Context (Lib_Spec); end if; Install_Context (Lib); Install_Context (N); end if; Analyze (Proper_Body (Unit (N))); Remove_Context (N); end Analyze_Subunit; ------------------------- -- Analyze_With_Clause -- ------------------------- -- Analyze the declaration of a unit in a with clause. At end, -- label the with clause with the defining entity for the unit. procedure Analyze_With_Clause (N : Node_Id) is E_Name : Entity_Id; Unit_Kind : Node_Kind := Nkind (Unit (Library_Unit (N))); begin if Unit_Kind in N_Generic_Declaration then E_Name := Defining_Unit_Simple_Name (Specification (Unit (Library_Unit (N)))); if Operating_Mode = Generate_Code and then not Is_Intrinsic (E_Name) then Load_Needed_Body (Library_Unit (N)); else -- If not generating code, or if the unit is intrinsic -- (for now only Unchecked conversion, which does not need an -- explicit body) analyze the specification only. Semantics (Library_Unit (N)); end if; else Semantics (Library_Unit (N)); if Unit_Kind = N_Package_Instantiation or else Unit_Kind = N_Procedure_Instantiation or else Unit_Kind = N_Function_Instantiation then -- Instantiation node is replaced with body of instance. -- Unit name is defining unit name in corresponding spec. E_Name := Corresponding_Spec (Unit (Library_Unit (N))); elsif Unit_Kind = N_Package_Renaming_Declaration then E_Name := Defining_Unit_Simple_Name (Unit (Library_Unit (N))); else E_Name := Defining_Unit_Simple_Name (Specification (Unit (Library_Unit (N)))); end if; end if; if Nkind (Name (N)) = N_Selected_Component then -- Child unit in a with clause Change_Selected_Component_To_Expanded_Name (Name (N)); end if; Set_Entity_With_Style_Check (Name (N), E_Name); end Analyze_With_Clause; -------------- -- Ancestor -- -------------- function Ancestor (Lib_Unit : Node_Id) return Entity_Id is P : constant Node_Id := Parent_Spec (Lib_Unit); P_Name : Entity_Id; begin P_Name := Defining_Unit_Simple_Name (Specification (Unit (P))); while Scope (P_Name) /= Standard_Standard loop P_Name := Scope (P_Name); end loop; return P_Name; end Ancestor; --------------------- -- Install_Context -- --------------------- procedure Install_Context (N : Node_Id) is Lib_Unit : Node_Id := Unit (N); Item : Node_Id; Unit_Name : Entity_Id; begin -- Loop through context clauses to find the with clauses Item := First (Context_Items (N)); while Present (Item) loop if Nkind (Item) = N_With_Clause and then not Implicit_With (Item) then Unit_Name := Entity (Name (Item)); if not Is_Directly_Visible (Unit_Name) then Install_Withed_Unit (Unit_Name); Set_Context_Installed (Item, True); else -- Unit has already been installed for an earlier context. null; end if; if Is_Child_Spec (Get_Declaration_Node (Unit_Name)) then Implicit_With_On_Parent (Get_Declaration_Node (Unit_Name), Item); end if; elsif Nkind (Item) = N_Use_Package_Clause then Analyze_Use_Package (Item); elsif Nkind (Item) = N_Use_Type_Clause then Analyze_Use_Type (Item); end if; Item := Next (Item); end loop; -- If the unit is a body, the context of the specification must also -- be installed. if Nkind (Lib_Unit) = N_Package_Body or else (Nkind (Lib_Unit) = N_Subprogram_Body and then not Acts_As_Spec (N)) then Install_Context (Library_Unit (N)); -- If the unit is the body of a public child unit, the private -- declarations of the parent must be made visible. If the child -- unit is private, the private declarations have been installed -- already in the call to Install_Parents for the spec. declare Lib_Spec : Node_Id := Unit (Library_Unit (N)); P : Node_Id; P_Name : Entity_Id; begin if Is_Child_Spec (Lib_Spec) and then not Is_Private_Descendant ( Defining_Unit_Simple_Name (Specification (Lib_Spec))) then P := Unit (Parent_Spec (Lib_Spec)); P_Name := Defining_Unit_Simple_Name (Specification (P)); Install_Private_Declarations (P_Name); end if; end; end if; Install_Parents (Lib_Unit); end Install_Context; ----------------------------- -- Implicit_With_On_Parent -- ----------------------------- procedure Implicit_With_On_Parent (Child_Unit : Node_Id; Item : Node_Id) is P : Node_Id := Parent_Spec (Child_Unit); P_Name : Entity_Id := Defining_Unit_Simple_Name (Specification (Unit (P))); Withn : Node_Id := Make_With_Clause (Sloc (Item), Name => New_Reference_To (P_Name, Sloc (Item))); begin Set_Library_Unit (Withn, P); Set_Corresponding_Spec (Withn, P_Name); Set_First_Name (Withn, True); Set_Implicit_With (Withn, True); Insert_After (Item, Withn); Mark_Rewrite_Insertion (Withn); if not Is_Directly_Visible (P_Name) then Install_Withed_Unit (P_Name); Set_Context_Installed (Withn, True); end if; if Is_Child_Spec (Unit (P)) then Implicit_With_On_Parent (Unit (P), Withn); end if; end Implicit_With_On_Parent; -------------------------------- -- Insert_Version_Declaration -- -------------------------------- procedure Insert_Version_Declaration (N : Node_Id) is Unit_Node : Node_Id := Unit (N); Unit_Num : constant Unit_Number_Type := Get_Cunit_Unit_Number (N); Unit_Decls : List_Id; Str : String_Id; Ver_Decl : Node_Id; Loc : constant Source_Ptr := Sloc (Unit_Node); Ver_Ent : Entity_Id; V_Name : Name_Id; begin -- Don't generate version declaration unless either B or V debug -- switch is set and we have not detected any erorrs. if not (Debug_Flag_B or Debug_Flag_V) or else Errors_Detected /= 0 then return; end if; -- Figure out whether to generate spec or body version information if Nkind (Unit_Node) = N_Subunit then Unit_Node := Proper_Body (Unit_Node); end if; if Nkind (Unit_Node) = N_Package_Declaration or else Nkind (Unit_Node) = N_Generic_Package_Declaration then Unit_Decls := Visible_Declarations (Specification (Unit_Node)); V_Name := Name_Version_S; elsif Nkind (Unit_Node) = N_Subprogram_Body or else Nkind (Unit_Node) = N_Package_Body then Unit_Decls := Declarations (Unit_Node); V_Name := Name_Version_B; else return; end if; -- Build string constant for declaration Start_String; Get_Name_String (File.Table (Unit_Num).File_Name); for I in 1 .. Name_Len loop Store_String_Char (Get_Char_Code (Name_Buffer (I))); end loop; -- The version number information is appended only if debug V is -- set and a version number was collected from the source header. if Debug_Flag_V and then File.Table (Unit_Num).Version (1) /= ' ' then Store_String_Char (Get_Char_Code (' ')); for J in Int range 1 .. 6 loop exit when File.Table (Unit_Num).Version (J) = ' '; Store_String_Char (Get_Char_Code (File.Table (Unit_Num).Version (J))); end loop; end if; Store_String_Char (Get_Char_Code (NUL)); Str := End_String; -- Now generate the declaration: -- Version_x : aliased constant String := "file name [version]"; -- where Version_x is Version_S for a spec, Version_B for a body Ver_Ent := Make_Defining_Identifier (Loc, V_Name); Ver_Decl := Make_Object_Declaration (Loc, Defining_Identifier => Ver_Ent, Constant_Present => True, Object_Definition => New_Reference_To (Standard_String, Loc), Expression => Make_String_Literal (Loc, Str)); Prepend (Ver_Decl, Unit_Decls); end Insert_Version_Declaration; ------------------------- -- Install_Withed_Unit -- ------------------------- procedure Install_Withed_Unit (Unit_Name : Entity_Id) is procedure Install_Package (Package_Id : Entity_Id) is Vis_Entity : Entity_Id; Prev_Entity : Entity_Id; begin if Debug_Flag_I then Write_Str ("Relinking package "); Write_Name (Chars (Package_Id)); Write_Eol; end if; Vis_Entity := First_Entity (Package_Id); while Present (Vis_Entity) and then Vis_Entity /= First_Private_Entity (Package_Id) loop if not Is_Internal (Vis_Entity) then Prev_Entity := Current_Entity (Vis_Entity); -- Set Selectively_visible flag. end if; Vis_Entity := Next_Entity (Vis_Entity); end loop; -- Install recursively any packages nested in the visible part -- of the current one. Vis_Entity := First_Entity (Package_Id); while Present (Vis_Entity) and then Vis_Entity /= First_Private_Entity (Package_Id) loop if Ekind (Vis_Entity) = E_Package then Install_Package (Vis_Entity); end if; Vis_Entity := Next_Entity (Vis_Entity); end loop; end Install_Package; -- Start of processing for Install_Withed_Unit begin -- Install the unit entity itself (it's directly visible of course -- so it goes on the front of the chain with no fiddling around) Set_Is_Directly_Visible (Unit_Name); -- For a subprogram, that's all that needs to be done. For a -- package, the entities within the package must be installed. if Ekind (Unit_Name) = E_Package then Install_Package (Unit_Name); end if; if Scope (Unit_Name) /= Standard_Standard then -- The unit is a child unit. Install all parents declare P : Entity_Id := Scope (Unit_Name); begin while P /= Standard_Standard loop Install_Withed_Unit (P); P := Scope (P); end loop; end; end if; end Install_Withed_Unit; ----------------------- -- Load_Needed_Body -- ----------------------- -- N is a generic unit named in a with clause, or else it is -- a unit that contains a generic unit or an inlined function. -- In order to perform an instantiation, the body of the unit -- must be present. If the unit itself is generic, we assume -- that an instantiation follows, and load and analyze the body -- unconditionally. This forces analysis of the spec as well. -- If the unit is not generic, but contains a generic unit, it -- is loaded on demand, at the point of instantiation (see ch12). procedure Load_Needed_Body (N : Node_Id) is Body_Name : Unit_Name_Type; Unum : Unit_Number_Type; begin Body_Name := Get_Body_Name (Get_Unit_Name (Unit (N))); Unum := Load (Body_Name, True, N); Compiler_State := Analyzing; -- reset after load if Unum /= No_Unit and then not File.Table (Unum).Fatal_Error then if Debug_Flag_L then Write_Str ("*** Loaded generic body" ); Write_Eol; end if; Semantics (File.Table (Unum).Cunit); end if; end Load_Needed_Body; ---------------------- -- Install_Parents -- ---------------------- procedure Install_Parents (Lib_Unit : Node_Id) is P : Node_Id; P_Name : Entity_Id; begin if Is_Child_Spec (Lib_Unit) then P := Unit (Parent_Spec (Lib_Unit)); P_Name := Defining_Unit_Simple_Name (Specification (P)); if Ekind (P_Name) = E_Generic_Package and then Nkind (Lib_Unit) /= N_Generic_Subprogram_Declaration and then Nkind (Lib_Unit) /= N_Generic_Package_Declaration then Error_Msg_N ("child of a generic package must be generic unit", Lib_Unit); end if; -- This is the recursive call that ensures all parents are loaded Install_Parents (P); -- Now we can install the context for this parent Install_Context (Parent_Spec (Lib_Unit)); -- The child unit is in the declarative region of the parent. The -- parent must therefore appear in the scope stack and be visible, -- as when compiling the corresponding body. If the child unit is -- private or it is a package body, private declarations must be -- accessible as well. Set_Is_Directly_Visible (P_Name, True); Set_Is_Private_Descendant (Lib_Unit, Is_Private_Descendant (P_Name) or else Private_Present (Parent (Lib_Unit))); New_Scope (P_Name); Install_Visible_Declarations (P_Name); if Private_Present (Parent (Lib_Unit)) then Install_Private_Declarations (P_Name); end if; -- If the unit is not a child unit, or is a body, nothing to do. else null; end if; end Install_Parents; ------------------- -- Is_Child_Spec -- ------------------- function Is_Child_Spec (Lib_Unit : Node_Id) return Boolean is K : constant Node_Kind := Nkind (Lib_Unit); begin return ( K = N_Function_Instantiation or else K = N_Generic_Function_Renaming_Declaration or else K = N_Generic_Package_Declaration or else K = N_Generic_Package_Renaming_Declaration or else K = N_Generic_Procedure_Renaming_Declaration or else K = N_Generic_Subprogram_Declaration or else K = N_Package_Declaration or else K = N_Package_Instantiation or else K = N_Package_Renaming_Declaration or else K = N_Procedure_Instantiation or else K = N_Subprogram_Declaration or else K = N_Subprogram_Renaming_Declaration) and then Present (Parent_Spec (Lib_Unit)); end Is_Child_Spec; -------------------- -- Remove_Parents -- -------------------- procedure Remove_Parents (Lib_Unit : Node_Id) is P : Node_Id; P_Name : Entity_Id; begin if Is_Child_Spec (Lib_Unit) then P := Unit (Parent_Spec (Lib_Unit)); P_Name := Defining_Unit_Simple_Name (Specification (P)); Remove_Context (Parent_Spec (Lib_Unit)); End_Package_Scope (P_Name); Set_Is_Package_Body (P_Name, False); -- This is the recursive call to remove the context of any -- higher level parent. This recursion ensures that all parents -- are removed in the reverse order of their installation. Remove_Parents (P); end if; end Remove_Parents; -------------------- -- Remove_Context -- -------------------- procedure Remove_Context (N : Node_Id) is Lib_Unit : Node_Id := Unit (N); Item : Node_Id; Unit_Name : Entity_Id; begin -- We can skip the removal if this is the main unit, since on exit from -- the main unit no one needs the visibility chains any more, so it -- doesn't matter if they have junk left around on them. if N /= File.Table (Main_Unit).Cunit then -- Otherwise loop through context items looking for with clauses Item := First (Context_Items (N)); while Present (Item) loop -- We are interested only in with clauses which got installed -- on entry, as indicated by their Context_Installed flag set if Nkind (Item) = N_With_Clause and then Context_Installed (Item) then -- Remove items from one with'ed unit Unit_Name := Entity (Name (Item)); Remove_Withed_Unit (Unit_Name); Set_Context_Installed (Item, False); end if; Item := Next (Item); end loop; Remove_Parents (Lib_Unit); end if; end Remove_Context; ------------------------ -- Remove_Withed_Unit -- ------------------------ procedure Remove_Withed_Unit (Unit_Name : Entity_Id) is procedure Remove_Package (Package_Id : Entity_Id) is Vis_Entity : Entity_Id; begin Vis_Entity := First_Entity (Package_Id); while Present (Vis_Entity) and then Vis_Entity /= First_Private_Entity (Package_Id) loop Remove_Entity (Vis_Entity); if Ekind (Vis_Entity) = E_Package then Remove_Package (Vis_Entity); end if; Vis_Entity := Next_Entity (Vis_Entity); end loop; end Remove_Package; -- Start of processing for Remove_Withed_Unit begin -- We definitely must remove the unit entity itself if Debug_Flag_I then Write_Str ("remove withed unit "); Write_Name (Chars (Unit_Name)); Write_Eol; end if; Remove_Entity (Unit_Name); Set_Is_Directly_Visible (Unit_Name, False); Set_In_Use (Unit_Name, False); -- unconditionally. -- For a subprogram, that's all we have to do. For a package, we must -- also remove all the entities within the package that were chained -- and recursively for inner packages. if Ekind (Unit_Name) = E_Package then Remove_Package (Unit_Name); end if; end Remove_Withed_Unit; ------------------- -- Remove_Entity -- ------------------- procedure Remove_Entity (E : Entity_Id) is begin -- Internal entities are never visible if Is_Internal (E) then null; else -- Set selectively_Visible false. null; end if; Set_Is_Use_Visible (E, False); -- unconditionally. end Remove_Entity; end Sem_Ch10; Package then Install_Package (Unit_Name); end if; if Scope (Unit_Name) /= Standard_Standard then -- The unit is a child unit. Install all parents declare P : Entity_Id := Scope (Unit_Name); begin while P /= Standard_Standard loop Ignat-1.67-src/src/sem_ch11.ads 444 10015 7640 4050 5506244364 11211 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ C H 1 1 -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Sem_Ch11 is procedure Analyze_Exception_Declaration (N : Node_Id); procedure Analyze_Handled_Statements (N : Node_Id); procedure Analyze_Raise_Statement (N : Node_Id); end Sem_Ch11;  a-gtran3.c œ¹> a-gtran3.hy°¹?a-misc.chanĹ@a-misc.hn aعA a-namet.h aì¹B a-rtree.h--¹C a-string.hn¹D a-trans3.ch(¹E a-trans3.h <¹F a-trans4.ciP¹G a-trans4.hrd¹H a-trans.c (x¹I a-trans.h Œ¹J a-tree.defy ¹K a-atree.h ´¹L a-types.hanȹMa-uint.c));ܹNa-uint.h ð¹O xeinfo.spte¹Pali.adsgnat-1.67-src/src/sem_ch11.adb 444 10015 7640 15574 5506244365 11226 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ C H 1 1 -- -- -- -- B o d y -- -- -- -- $Revision: 1.27 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Einfo; use Einfo; with Errout; use Errout; with Opt; use Opt; with Sem_Ch5; use Sem_Ch5; with Sem_Ch8; use Sem_Ch8; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Stand; use Stand; package body Sem_Ch11 is ----------------------- -- Local Subprograms -- ----------------------- procedure Analyze_Exception_Handlers (L : List_Id); ----------------------------------- -- Analyze_Exception_Declaration -- ----------------------------------- procedure Analyze_Exception_Declaration (N : Node_Id) is Id : constant Entity_Id := Defining_Identifier (N); begin Enter_Name (Id); Set_Ekind (Id, E_Exception); Set_Etype (Id, Standard_Exception_Type); end Analyze_Exception_Declaration; -------------------------------- -- Analyze_Handled_Statements -- -------------------------------- procedure Analyze_Handled_Statements (N : Node_Id) is Handlers : constant List_Id := Exception_Handlers (N); begin Analyze_Statements (Statements (N)); if List_Present (Handlers) then Analyze_Exception_Handlers (Handlers); end if; end Analyze_Handled_Statements; -------------------------------- -- Analyze_Exception_Handlers -- -------------------------------- procedure Analyze_Exception_Handlers (L : List_Id) is Handler : Node_Id; Id : Node_Id; procedure Check_Duplication (Id : Node_Id); -- Iterate through the identifiers in each handler to find duplicates procedure Check_Duplication (Id : Node_Id) is Handler : Node_Id; Id1 : Node_Id; begin Handler := First (L); while Present (Handler) loop Id1 := First (Exception_Choices (Handler)); while Present (Id1) loop -- Only check against the exception choices which precede -- Id in the handler, since the ones that follow Id have not -- been analyzed yet and will be checked in a subsequent call. if Id = Id1 then return; elsif Nkind (Id1) /= N_Others_Choice and then Entity (Id) = Entity (Id1) and then (Ada_83 or else Handler /= Parent (Id)) then Error_Msg_N ("exception choice& duplicates earlier choice", Id); return; end if; Id1 := Next (Id1); end loop; Handler := Next (Handler); end loop; end Check_Duplication; -- Start processing for Analyze_Exception_Handlers begin Handler := First (L); while Present (Handler) loop Id := First (Exception_Choices (Handler)); while Present (Id) loop if Nkind (Id) = N_Others_Choice then if Present (Next (Id)) or else Present (Next (Handler)) or else Present (Prev (Id)) then Error_Msg_N ("OTHERS must appear alone and last", Id); end if; else Find_Name (Id); if Present (Renamed_Object (Entity (Id))) then Set_Entity (Id, Renamed_Object (Entity (Id))); end if; Check_Duplication (Id); end if; Id := Next (Id); end loop; if Present (Choice_Parameter (Handler)) then Enter_Name (Choice_Parameter (Handler)); -- The type and kind of a choice parameter should -- be defined in System.Exceptions. end if; Analyze_Statements (Statements (Handler)); Handler := Next (Handler); end loop; end Analyze_Exception_Handlers; ----------------------------- -- Analyze_Raise_Statement -- ----------------------------- procedure Analyze_Raise_Statement (N : Node_Id) is Exception_Id : Node_Id := Name (N); Exception_Name : Entity_Id; P : Node_Id; Nkind_P : Node_Kind; begin -- Reraise statement if No (Exception_Id) then P := Parent (N); Nkind_P := Nkind (P); while Nkind_P /= N_Exception_Handler and then Nkind_P /= N_Subprogram_Body and then Nkind_P /= N_Package_Body and then Nkind_P /= N_Task_Body and then Nkind_P /= N_Entry_Body loop P := Parent (P); Nkind_P := Nkind (P); end loop; if Nkind (P) /= N_Exception_Handler then Error_Msg_N ("reraise statement must appear directly in a handler", N); end if; -- Normal case with exception id present else Find_Name (Exception_Id); Exception_Name := Entity (Exception_Id); if Present (Renamed_Object (Exception_Name)) then Set_Entity (Exception_Id, Renamed_Object (Exception_Name)); end if; if Ekind (Exception_Name) /= E_Exception then Error_Msg_N ("exception name expected in raise statement", N); end if; end if; end Analyze_Raise_Statement; end Sem_Ch11; Id := Defining_Identifier (N); begin Enter_Name (Id); Set_Ekind (Id, E_Exception); Set_Etype (Id, Standard_Excgnat-1.67-src/src/sem_ch12.ads 444 10015 7640 6044 5506244365 11220 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ C H 1 2 -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Sem_Ch12 is procedure Analyze_Generic_Package_Declaration (N : Node_Id); procedure Analyze_Generic_Subprogram_Declaration (N : Node_Id); procedure Analyze_Package_Instantiation (N : Node_Id); procedure Analyze_Procedure_Instantiation (N : Node_Id); procedure Analyze_Function_Instantiation (N : Node_Id); procedure Analyze_Generic_Association (N : Node_Id); procedure Analyze_Formal_Object_Declaration (N : Node_Id); procedure Analyze_Formal_Type_Declaration (N : Node_Id); procedure Analyze_Formal_Subprogram (N : Node_Id); procedure Analyze_Formal_Package (N : Node_Id); function Instantiate_Record (Parent_Type, Derived_Type : Entity_Id) return Node_Id; -- The process of record type derivation is identical to that of -- a parameterless generic instantiation: create new instances of -- each entity, and copy an arbitrary tree replacing terminal nodes -- with their instances. This procedure is called for type derivation -- and it reuses the generic instantiation machinery that otherwise -- applies to compilation units. end Sem_Ch12; xrefprov.adb sp,¹j sysid~d.adsD¹k Makefile.os2ds`¹l CreateMiscFiles.cmd|¹m patches-gas138.os2|˜¹n patches-gcc257.os2˜¬¹o sysid.ads.oȹp Makefile.in.diffÈܹqGCC-BASEiffð¹r a-einfo.hSE¹s README.SPARCSE¹t a-sinfo.hRC0¹u nmake.adbo.¹v nmake.adsadde_Id; begin Handler := First (L); while Present (Handler) loop Id1 :=gnat-1.67-src/src/sem_ch12.adb 444 10015 7640 164644 5506244366 11253 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ C H 1 2 -- -- -- -- B o d y -- -- -- -- $Revision: 1.82 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Alloc; use Alloc; with Atree; use Atree; with Comperr; use Comperr; with Debug; use Debug; with Einfo; use Einfo; with Errout; use Errout; with Exp_Util; use Exp_Util; with Lib; use Lib; with Opt; use Opt; with Output; use Output; with Sem; use Sem; with Sem_Ch3; use Sem_Ch3; with Sem_Ch6; use Sem_Ch6; with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; with Sem_Ch10; use Sem_Ch10; with Sem_Ch13; use Sem_Ch13; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Stand; use Stand; with Sinfo; use Sinfo; with Snames; use Snames; with Table; with Tbuild; use Tbuild; package body Sem_Ch12 is use Atree.Unchecked_Access; -- This package performs untyped traversals of the tree, therefore it -- needs direct access to the fields of a node. ---------------------------------------- -- Data Structures For Instance Table -- ---------------------------------------- -- A hash table is used to keep track of the mapping between generic -- tree nodes and their corresponding instantiated tree nodes. type Hash_Entry_Id is new Nat; -- Id of hash table entry is its subscript in the hash table No_Entry : constant Hash_Entry_Id := 0; -- Value used to mark no chain, or end of chain type Hash_Entry is record Next : Hash_Entry_Id; Old_Node : Node_Id; New_Node : Node_Id; end record; Num_Hash_Headers : constant := 512; -- Number of headers in Hash_Headers array Hash_Headers : array (Nat range 0 .. Num_Hash_Headers - 1) of Hash_Entry_Id; -- Table of hash headers, each entry points to chain of entries in the -- hash table whose hash value matches the subscript in the header table. -- The hash code is simply the Node_Id value mod Num_Hash_Headers. package Hash_Instance is new Table ( Component_Type => Hash_Entry, Index_Type => Hash_Entry_Id, Low_Bound => 1, Initial => Alloc_Hash_Sub_Initial, Increment => Alloc_Hash_Sub_Increment, Table_Name => "Hash_Gen"); ----------------------- -- Local subprograms -- ----------------------- procedure Analyze_Formal_Array_Type (T : in out Entity_Id; Def : Node_Id); procedure Analyze_Formal_Decimal_Fixed_Point (T : Entity_Id; Def : Node_Id); procedure Analyze_Formal_Derived_Type (T : Entity_Id; Def : Node_Id); procedure Analyze_Formal_Discrete_Type (T : Entity_Id; Def : Node_Id); procedure Analyze_Formal_Floating_Type (T : Entity_Id; Def : Node_Id); procedure Analyze_Formal_Signed_Integer_Type (T : Entity_Id; Def : Node_Id); procedure Analyze_Formal_Modular_Type (T : Entity_Id; Def : Node_Id); procedure Analyze_Formal_Ordinary_Fixed_Type (T : Entity_Id; Def : Node_Id); procedure Analyze_Formal_Private_Type (T : Entity_Id; Def : Node_Id); procedure Analyze_Generic_Formal_Part (N : Node_Id); procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id); procedure Analyze_Associations (Formals, Actuals : List_Id); procedure Analyze_Subprogram_Instantiation (N : Node_Id; K : Entity_Kind); procedure Build_Instance_Compilation_Unit_Nodes (N : Node_Id; Act_Body, Act_Decl, Gen_Decl, Gen_Body : Node_Id); -- This procedure is used in the case where the generic instance of a -- subprogram body or package body is a library unit. In this case, the -- original library unit node for the generic instantiation must be -- replaced by the resulting generic body, and a link made to a new -- compilation unit node for the generic declaration. The argument N is -- the original generic instantiation. Act_Body and Act_Decl are the body -- and declaration of the instance (either package body and declaration -- nodes or subprogram body and declaration nodes depending on the case). -- Gen_Decl and Gen_Body are the declaration and body of the generic -- (either generic package body and generic package declaration, or generic -- subprogram body and generic subprogram declaration, depending on the -- case.) On return, the node N has been rewritten with the actual body. procedure Instantiate_Entities (Gen_Scope, Act_Scope : Entity_Id); -- Create instances of each entity declared in the generic unit. procedure Set_Instance_Of (Old_Node, New_Node : Node_Id); -- Set New_Node to be the instance of Old_Node. function Get_Instance_Of (Old_Node : Node_Id) return Node_Id; -- Find the instantiation of a node. If the node is a generic entity, -- its instance is created by the previous procedure. It it is a non- -- generic entity, it is its own instance. If the node is not an -- entity, its instance is created by Instantiate_Node. procedure Initialize_Instances; -- Initialize hash table that maps generic nodes to their instances. procedure Complete_Entities (Gen_Scope : Entity_Id); -- After instantiation of the generic tree, make second pass over -- instantiated entities, to set correctly those attributes that are -- themselves nodes, and that are kind-specific. procedure Instantiate_Object (Formal, Actual : Node_Id); procedure Instantiate_Type (Formal, Actual : Node_Id); procedure Instantiate_Formal_Subprogram (Formal, Actual : Node_Id); procedure Instantiate_Formal_Package (Formal, Actual : Node_Id); function Instantiate_Tree (N : Node_Id) return Node_Id; -- Third step of generic instantiation, top-level routine. function Instantiate_Node (N : Node_Id; Parent_Id : Node_Id) return Node_Id; -- Copy node N, and recursively traverse and copy its descendants. function Instantiate_List (L : List_Id; Parent_Id : Node_Id) return List_Id; -- Copy a list of trees. function Instantiate_Elist (E : Elist_Id) return Elist_Id; -- Copy an element list. procedure Load_Parent_Of_Generic (N : Entity_Id; Spec : Node_Id); -- If the generic appears in a separate non-generic library unit, -- load the corresponding body to retrieve the body of the generic. ------------------------------------------- -- Analyze_Generic_Package_Declaration -- ------------------------------------------- procedure Analyze_Generic_Package_Declaration (N : Node_Id) is Id : constant Entity_Id := Defining_Unit_Simple_Name (Specification (N)); begin -- After processing the generic formals, analysis proceeds -- as for a non-generic package. Enter_Name (Id); Set_Ekind (Id, E_Generic_Package); Set_Etype (Id, Standard_Void_Type); New_Scope (Id); Analyze_Generic_Formal_Part (N); Analyze (Specification (N)); End_Package_Scope (Id); end Analyze_Generic_Package_Declaration; --------------------------------------------- -- Analyze_Generic_Subprogram_Declaration -- --------------------------------------------- procedure Analyze_Generic_Subprogram_Declaration (N : Node_Id) is Spec : constant Node_Id := Specification (N); Id : constant Entity_Id := Defining_Unit_Simple_Name (Spec); Formals : constant List_Id := Parameter_Specifications (Spec); begin Enter_Name (Id); if Nkind (Spec) = N_Function_Specification then Set_Ekind (Id, E_Generic_Function); else Set_Ekind (Id, E_Generic_Procedure); Set_Etype (Id, Standard_Void_Type); end if; New_Scope (Id); Analyze_Generic_Formal_Part (N); if List_Present (Formals) then Process_Formals (Id, Formals); end if; if Nkind (Spec) = N_Function_Specification then Find_Type (Subtype_Mark (Spec)); Set_Etype (Id, Entity (Subtype_Mark (Spec))); end if; End_Scope; end Analyze_Generic_Subprogram_Declaration; ---------------------------------- -- Analyze_Generic_Formal_Part -- ---------------------------------- procedure Analyze_Generic_Formal_Part (N : Node_Id) is Gen_Parm_Decl : Node_Id; begin -- The generic formals are processed in the scope of the generic -- unit, where they are directly visible. The scope is installed -- by the caller. Gen_Parm_Decl := First (Generic_Formal_Declarations (N)); while Present (Gen_Parm_Decl) loop Analyze (Gen_Parm_Decl); Gen_Parm_Decl := Next (Gen_Parm_Decl); end loop; end Analyze_Generic_Formal_Part; ----------------------------------- -- Analyze_Package_Instantiation -- ----------------------------------- procedure Analyze_Package_Instantiation (N : Node_Id) is Act_Body : Node_Id; Act_Body_Id : Entity_Id; Act_Decl : Node_Id := New_Node (N_Package_Declaration, Sloc (N)); Act_Decl_Id : Entity_Id := New_Copy (Defining_Unit_Simple_Name (N)); Actuals : List_Id := Generic_Associations (N); Formals : List_Id; Gen_Id : Node_Id := Name (N); Gen_Decl : Node_Id; Gen_Body : Node_Id; Gen_Body_Id : Entity_Id; Gen_Unit : Entity_Id; Spec : Node_Id; begin Initialize_Instances; Enter_Name (Act_Decl_Id); Set_Ekind (Act_Decl_Id, E_Package); Set_Has_Completion (Act_Decl_Id); Set_Etype (Act_Decl_Id, Standard_Void_Type); Find_Name (Gen_Id); Gen_Unit := Entity (Gen_Id); -- Verify that it is the name of a generic package if Etype (Gen_Unit) = Any_Type then return; end if; if Ekind (Gen_Unit) /= E_Generic_Package then Error_Msg_N ("expect name of generic package in instantiation", Gen_Id); else Spec := Parent (Gen_Unit); Gen_Decl := Parent (Spec); Formals := Generic_Formal_Declarations (Gen_Decl); Analyze_Associations (Formals, Actuals); Instantiate_Entities (Gen_Unit, Act_Decl_Id); -- Instantiate package specification, and insert in current -- declarative part , BEFORE the instantiation node, to avoid -- redoing the semantic analysis of the instance. Set_Specification (Act_Decl, Instantiate_Tree (Spec)); Set_Generic_Parent (Specification (Act_Decl), Gen_Unit); -- If present, instantiate package body, and insert after spec. Gen_Body_Id := Corresponding_Body (Parent (Spec)); if No (Gen_Body_Id) and then Operating_Mode = Generate_Code and then Unit_Requires_Body (Gen_Unit) then Load_Parent_Of_Generic (N, Spec); Gen_Body_Id := Corresponding_Body (Parent (Spec)); end if; if Present (Gen_Body_Id) then Act_Body_Id := New_Copy (Gen_Body_Id); Set_Chars (Act_Body_Id, Chars (Act_Decl_Id)); Set_Is_Internal (Act_Body_Id); Set_Ekind (Act_Body_Id, E_Package); -- First, instantiate entities local to the body. Instantiate_Entities (Gen_Body_Id, Act_Body_Id); -- Finally, instantiate tree for package body. Gen_Body := Parent (Gen_Body_Id); Act_Body := Instantiate_Tree (Gen_Body); Set_Corresponding_Body (Act_Decl, Act_Body_Id); Set_Corresponding_Spec (Act_Body, Act_Decl_Id); -- If the instantiation is a library unit, then build -- the resulting compilation unit nodes for the instance if Nkind (Parent (N)) = N_Compilation_Unit then Build_Instance_Compilation_Unit_Nodes (N, Act_Body, Act_Decl, Gen_Decl, Gen_Body); -- Make sure created entities are set as public Set_Is_Public (Act_Body_Id, True); Set_Is_Public (Act_Decl_Id, True); -- If the instantiation is not a library unit, then append -- the entities to the list of implicitly generated entities else Append (Act_Decl, Implicit_Type_List); Append (Act_Body, Implicit_Type_List); end if; Complete_Entities (Gen_Unit); Complete_Entities (Gen_Body_Id); -- Case of package does not need a body else -- If the instantiation of the declaration is a library unit, -- then rewrite the original package instantiation as a package -- declaration in the compilation unit node. if Nkind (Parent (N)) = N_Compilation_Unit then Rewrite_Substitute_Tree (N, Act_Decl); -- If the instantiation is not a library unit, then append the -- entities to the list of implicitly generated entities. else Append (Act_Decl, Implicit_Type_List); end if; Complete_Entities (Gen_Unit); end if; end if; end Analyze_Package_Instantiation; ------------------------------------- -- Analyze_Procedure_Instantiation -- ------------------------------------- procedure Analyze_Procedure_Instantiation (N : Node_Id) is begin Analyze_Subprogram_Instantiation (N, E_Procedure); end Analyze_Procedure_Instantiation; ------------------------------------ -- Analyze_Function_Instantiation -- ------------------------------------ procedure Analyze_Function_Instantiation (N : Node_Id) is begin Analyze_Subprogram_Instantiation (N, E_Function); end Analyze_Function_Instantiation; ------------------------------------ -- Analyze_Subprogram_Instantiation -- ------------------------------------ procedure Analyze_Subprogram_Instantiation (N : Node_Id; K : Entity_Kind) is Act_Decl : Node_Id := New_Node (N_Subprogram_Declaration, Sloc (N)); Act_Decl_Id : Entity_Id := New_Copy (Defining_Unit_Simple_Name (N)); Act_Body : Node_Id; Act_Body_Id : Entity_Id; Actuals : List_Id := Generic_Associations (N); Formals : List_Id; Gen_Id : Node_Id := Name (N); Gen_Unit : Entity_Id; Gen_Body : Node_Id; Gen_Decl : Node_Id; Gen_Body_Id : Entity_Id; Spec : Node_Id; begin Initialize_Instances; Set_Ekind (Act_Decl_Id, K); Set_Has_Completion (Act_Decl_Id); Set_Etype (Act_Decl_Id, Any_Type); Find_Name (Gen_Id); Gen_Unit := Entity (Gen_Id); if Etype (Gen_Unit) = Any_Type then return; end if; -- Verify that it is a generic subprogram of the right kind. if K = E_Procedure and then Ekind (Gen_Unit) /= E_Generic_Procedure then Error_Msg_N ("expect name of generic procedure in instantiation", Gen_Id); elsif K = E_Function and then Ekind (Gen_Unit) /= E_Generic_Function then Error_Msg_N ("expect name of generic function in instantiation", Gen_Id); else Spec := Parent (Gen_Unit); Gen_Decl := Parent (Spec); Formals := Generic_Formal_Declarations (Gen_Decl); Analyze_Associations (Formals, Actuals); -- Instantiate subprogram declaration, Instantiate_Entities (Gen_Unit, Act_Decl_Id); Set_Specification (Act_Decl, Instantiate_Tree (Spec)); Set_Generic_Parent (Specification (Act_Decl), Gen_Unit); Set_Etype (Act_Decl_Id, Get_Instance_Of (Etype (Gen_Unit))); -- Now subprogram is callable New_Overloaded_Entity (Act_Decl_Id); if Chars (Gen_Unit) = Name_Unchecked_Conversion and then Is_Intrinsic (Gen_Unit) then Validate_Unchecked_Conversion (N, Act_Decl_Id); Set_Is_Intrinsic (Act_Decl_Id); return; end if; -- Instantiate subprogram body, and insert before instantiation node Gen_Body_Id := Corresponding_Body (Parent (Spec)); -- If we are generating code, the body of the generic must be -- present. It may be in the body of another non-generic library -- unit, which must be loaded. if No (Gen_Body_Id) and then Operating_Mode = Generate_Code then Load_Parent_Of_Generic (N, Spec); Gen_Body_Id := Corresponding_Body (Parent (Spec)); end if; if Present (Gen_Body_Id) then Act_Body_Id := New_Copy (Gen_Body_Id); Set_Chars (Act_Body_Id, Chars (Act_Decl_Id)); Set_Is_Internal (Act_Body_Id); Set_Ekind (Act_Body_Id, K); Set_Etype (Act_Body_Id, Get_Instance_Of (Etype (Gen_Unit))); Set_Scope (Act_Body_Id, Current_Scope); Instantiate_Entities (Gen_Body_Id, Act_Body_Id); Gen_Body := Parent (Parent (Gen_Body_Id)); Act_Body := Instantiate_Tree (Gen_Body); Set_Defining_Unit_Name (Specification (Act_Body), Act_Body_Id); Set_Corresponding_Body (Act_Decl, Act_Body_Id); Set_Corresponding_Spec (Act_Body, Act_Decl_Id); -- If the instantiation is a library unit, then build the -- resulting compilation unit nodes for the instance if Nkind (Parent (N)) = N_Compilation_Unit then Build_Instance_Compilation_Unit_Nodes (N, Act_Body, Act_Decl, Gen_Decl, Gen_Body); -- Make sure created entities are set as public Set_Is_Public (Act_Body_Id, True); Set_Is_Public (Act_Decl_Id, True); -- If the instantiation is not a library unit, then append -- the entities to the list of implicitly generated entities else Append (Act_Decl, Implicit_Type_List); Append (Act_Body, Implicit_Type_List); end if; Append_Entity (Act_Body_Id, Current_Scope); Complete_Entities (Gen_Body_Id); -- If the body was not required, nothing to do. If it was not -- found, a fatal error was already emitted. else null; end if; Complete_Entities (Gen_Unit); end if; end Analyze_Subprogram_Instantiation; ------------------------ -- Instantiate_Record -- ------------------------ function Instantiate_Record (Parent_Type, Derived_Type : Entity_Id) return Node_Id is Type_Def : Node_Id; begin Initialize_Instances; Instantiate_Entities (Parent_Type, Derived_Type); Type_Def := Instantiate_Tree (Type_Definition (Parent (Parent_Type))); Complete_Entities (Parent_Type); return Type_Def; end Instantiate_Record; ---------------------------- -- Load_Parent_Of_Generic -- ---------------------------- procedure Load_Parent_Of_Generic (N : Entity_Id; Spec : Node_Id) is begin if Get_Sloc_Unit_Number (Sloc (N)) /= Get_Sloc_Unit_Number (Sloc (Spec)) then -- Find body of parent of spec, and analyze it Load_Needed_Body (File.Table (Get_Sloc_Unit_Number (Sloc (Spec))).Cunit); end if; end Load_Parent_Of_Generic; -------------------------- -- Analyze_Associations -- -------------------------- procedure Analyze_Associations (Formals, Actuals : List_Id) is Actual : Node_Id; Formal : Node_Id; Match : Node_Id; Named : Node_Id; First_Named : Node_Id := Empty; Num_Matched : Integer := 0; Num_Actuals : Integer := 0; function Matching_Actual (F : Entity_Id) return Node_Id is Found : Node_Id; begin if No (Actual) then -- End of list of purely positional parameters. Found := Empty; elsif No (Selector_Name (Actual)) then -- Positional parameter corresponds to current formal. Found := Explicit_Generic_Actual_Parameter (Actual); Num_Matched := Num_Matched + 1; Actual := Next (Actual); else -- Scan list of named actuals to find the one with the -- desired name. all remaining actuals have explicit names. Found := Empty; while Present (Actual) loop if Chars (Selector_Name (Actual)) = Chars (F) then Found := Explicit_Generic_Actual_Parameter (Actual); Num_Matched := Num_Matched + 1; exit; end if; Actual := Next (Actual); end loop; -- Reset for subsequent searches. Actual := First_Named; end if; return Found; end Matching_Actual; -- Start processing for Analyze_Associations begin -- If named associations are present, save the first named association -- (it may of course be Empty) to facilitate subsequent name search. if List_Present (Actuals) then First_Named := First (Actuals); while Present (First_Named) and then No (Selector_Name (First_Named)) loop Num_Actuals := Num_Actuals + 1; First_Named := Next (First_Named); end loop; end if; Named := First_Named; while Present (Named) loop if No (Selector_Name (Named)) then Error_Msg_N ("invalid positional actual after named one", Named); -- No point in countinuing with associations. return; end if; Num_Actuals := Num_Actuals + 1; Named := Next (Named); end loop; if List_Present (Formals) then Formal := First (Formals); if List_Present (Actuals) then Actual := First (Actuals); while Present (Actual) loop Analyze (Explicit_Generic_Actual_Parameter (Actual)); Actual := Next (Actual); end loop; Actual := First (Actuals); else -- all formals should have default values Actual := Empty; end if; while Present (Formal) loop case Nkind (Formal) is when N_Formal_Object_Declaration => Instantiate_Object (Defining_Identifier (Formal), Matching_Actual (Defining_Identifier (Formal))); when N_Formal_Type_Declaration => Match := Matching_Actual (Defining_Identifier (Formal)); if No (Match) then Error_Msg_N ("missing actual for generic formal ", List_Parent (Actuals)); Set_Instance_Of (Defining_Identifier (Formal), Any_Type); else Instantiate_Type (Formal, Match); end if; when N_Formal_Subprogram_Declaration => Instantiate_Formal_Subprogram (Formal, Matching_Actual (Defining_Unit_Name ( Specification (Formal)))); when N_Formal_Package_Declaration => Instantiate_Formal_Package (Formal, Matching_Actual (Defining_Identifier (Formal))); when others => null; end case; Formal := Next (Formal); end loop; if Num_Actuals > Num_Matched then Error_Msg_N ("unmatched actuals in instantiation", List_Parent (Actuals)); end if; elsif List_Present (Actuals) then Error_Msg_N ("too many actuals in generic instantiation", List_Parent (Actuals)); end if; end Analyze_Associations; --------------------------------- -- Analyze_Generic_Association -- --------------------------------- procedure Analyze_Generic_Association (N : Node_Id) is begin -- ??? why is this an abort, TBSL? (should be unimplemented?) Compiler_Abort; end Analyze_Generic_Association; --------------------------------------- -- Analyze_Formal_Object_Declaration -- --------------------------------------- procedure Analyze_Formal_Object_Declaration (N : Node_Id) is Id : Node_Id; E : constant Node_Id := Expression (N); K : Entity_Kind; T : Node_Id; begin -- Determine the mode of the formal object if Out_Present (N) then if In_Present (N) then K := E_Generic_In_Out_Parameter; else Error_Msg_N ("formal generic objects cannot have mode OUT", N); K := E_Generic_In_Out_Parameter; end if; else K := E_Generic_In_Parameter; end if; Find_Type (Subtype_Mark (N)); T := Entity (Subtype_Mark (N)); case K is when E_Generic_In_Parameter => if Is_Limited_Type (T) then Error_Msg_N ("generic formal of mode IN must not be of limited type", N); end if; if Present (E) then Analyze (E); Resolve_Complete_Context (E, T); -- if is_deferred_constant(opt_init) then -- errmsg("Deferred constant cannot be default expression", -- " for a generic parameter","7.4.3"); -- end if; end if; when E_Generic_In_Out_Parameter => -- Constraints will be inherited from actual. This is described -- by regarding the subtype of the in out parameter as an extra -- generic parameter, obtained from the actual at instantiation. -- subtype_mark := make_generic_subtype (subtype_mark); if Present (E) then Error_Msg_N ("initialization not allowed for `IN OUT` formals", N); end if; when others => Compiler_Abort; end case; Id := Defining_Identifier (N); Enter_Name (Id); Set_Ekind (Id, K); Set_Etype (Id, T); end Analyze_Formal_Object_Declaration; ------------------------------------- -- Analyze_Formal_Type_Declaration -- ------------------------------------- procedure Analyze_Formal_Type_Declaration (N : Node_Id) is Def : constant Node_Id := Formal_Type_Definition (N); T : Entity_Id := Defining_Identifier (N); begin -- Enter the new name, and branch to specific routine. Enter_Name (T); Set_Is_Generic_Type (T); case Nkind (Def) is when N_Formal_Private_Type_Definition => Analyze_Formal_Private_Type (T, Def); when N_Formal_Derived_Type_Definition => Analyze_Formal_Derived_Type (T, Def); when N_Formal_Discrete_Type_Definition => Analyze_Formal_Discrete_Type (T, Def); when N_Formal_Signed_Integer_Type_Definition => Analyze_Formal_Signed_Integer_Type (T, Def); when N_Formal_Modular_Type_Definition => Analyze_Formal_Modular_Type (T, Def); when N_Formal_Floating_Point_Definition => Analyze_Formal_Floating_Type (T, Def); when N_Formal_Ordinary_Fixed_Point_Definition => Analyze_Formal_Ordinary_Fixed_Type (T, Def); when N_Formal_Decimal_Fixed_Point_Definition => Analyze_Formal_Decimal_Fixed_Point (T, Def); when N_Array_Type_Definition => Analyze_Formal_Array_Type (T, Def); when N_Access_To_Object_Definition => Analyze_Generic_Access_Type (T, Def); when others => Compiler_Abort; end case; end Analyze_Formal_Type_Declaration; --------------------------------- -- Analyze_Formal_Private_Type -- --------------------------------- procedure Analyze_Formal_Private_Type (T : Entity_Id; Def : Node_Id) is begin if Limited_Present (Def) then Set_Ekind (T, E_Limited_Private_Type); else Set_Ekind (T, E_Private_Type); end if; Set_Etype (T, T); -- Process_Discriminants (name, opt_discr); -- Popscope (); if Tagged_Present (Def) then Set_Is_Tagged_Type (T); -- Initialize dispatch_table Make_Class_Type (T); end if; end Analyze_Formal_Private_Type; --------------------------------- -- Analyze_Formal_Derived_Type -- --------------------------------- procedure Analyze_Formal_Derived_Type (T : Entity_Id; Def : Node_Id) is begin Unimplemented (Def, "formal derived types"); end Analyze_Formal_Derived_Type; ---------------------------------- -- Analyze_Formal_Discrete_Type -- ---------------------------------- procedure Analyze_Formal_Discrete_Type (T : Entity_Id; Def : Node_Id) is -- The operations defined for a discrete types are those of an -- enumeration type. The size is set to an arbitrary value, for use -- in analyzing the generic unit. begin Set_Ekind (T, E_Enumeration_Type); Set_Etype (T, T); Set_Esize (T, Esize (Standard_Integer)); end Analyze_Formal_Discrete_Type; ---------------------------------------- -- Analyze_Formal_Signed_Integer_Type -- ---------------------------------------- procedure Analyze_Formal_Signed_Integer_Type (T : Entity_Id; Def : Node_Id) is Base : constant Entity_Id := New_Internal_Entity (E_Integer_Type, Current_Scope, Sloc (Def), "gen"); begin Set_Ekind (T, E_Integer_Subtype); Set_Etype (T, Base); Set_Etype (Base, Base); Set_Is_Generic_Type (Base); Set_Esize (T, Esize (Standard_Integer)); Set_Esize (Base, Esize (Standard_Integer)); Set_Scalar_Range (T, Scalar_Range (Standard_Integer)); Set_Scalar_Range (Base, Scalar_Range (Standard_Integer)); end Analyze_Formal_Signed_Integer_Type; --------------------------------- -- Analyze_Formal_Modular_Type -- --------------------------------- procedure Analyze_Formal_Modular_Type (T : Entity_Id; Def : Node_Id) is begin Unimplemented (Def, "formal modular types"); end Analyze_Formal_Modular_Type; ---------------------------------- -- Analyze_Formal_Floating_Type -- --------------------------------- procedure Analyze_Formal_Floating_Type (T : Entity_Id; Def : Node_Id) is Base : constant Entity_Id := New_Internal_Entity (E_Float_Type, Current_Scope, Sloc (Def), "gen"); begin Set_Ekind (T, E_Float_Subtype); Set_Etype (T, Base); Set_Etype (Base, Base); Set_Is_Generic_Type (Base); Set_Esize (T, Esize (Standard_Float)); Set_Esize (Base, Esize (Standard_Float)); Set_Scalar_Range (T, Scalar_Range (Standard_Float)); Set_Scalar_Range (Base, Scalar_Range (Standard_Float)); end Analyze_Formal_Floating_Type; ---------------------------------------- -- Analyze_Formal_Ordinary_Fixed_Type -- ---------------------------------------- procedure Analyze_Formal_Ordinary_Fixed_Type (T : Entity_Id; Def : Node_Id) is begin Unimplemented (Def, "formal ordinary fixed types"); end Analyze_Formal_Ordinary_Fixed_Type; ---------------------------------------- -- Analyze_Formal_Decimal_Fixed_Point -- ---------------------------------------- procedure Analyze_Formal_Decimal_Fixed_Point (T : Entity_Id; Def : Node_Id) is begin Unimplemented (Def, "formal decimal fixed types"); end Analyze_Formal_Decimal_Fixed_Point; ------------------------------- -- Analyze_Formal_Array_Type -- ------------------------------- procedure Analyze_Formal_Array_Type (T : in out Entity_Id; Def : Node_Id) is I : Node_Id; begin -- Treated like a non-generic array declaration, with -- additional semantic checks. Array_Type_Declaration (T, Def); if Is_Incomplete_Type (Component_Type (T)) and then not Is_Generic_Type (Component_Type (T)) then Error_Msg_N ("premature usage of incomplete type", Def); elsif Is_Internal (Component_Type (T)) then Error_Msg_N ("only a subtype mark is allowed in a formal", Def); end if; I := First_Index (T); while Present (I) loop if Is_Internal (I) then Error_Msg_N ("only a subtype mark is allowed in a formal", Def); end if; I := Next_Index (I); end loop; end Analyze_Formal_Array_Type; --------------------------------- -- Analyze_Generic_Access_Type -- --------------------------------- procedure Analyze_Generic_Access_Type (T : Entity_Id; Def : Node_Id) is begin Access_Type_Declaration (T, Def); if Is_Incomplete_Type (Designated_Type (T)) and then not Is_Generic_Type (Designated_Type (T)) then Error_Msg_N ("premature usage of incomplete type", Def); elsif Is_Internal (Designated_Type (T)) then Error_Msg_N ("only a subtype mark is allowed in a formal", Def); end if; end Analyze_Generic_Access_Type; ------------------------------- -- Analyze_Formal_Subprogram -- ------------------------------- procedure Analyze_Formal_Subprogram (N : Node_Id) is Spec : constant Node_Id := Specification (N); begin -- Default name is resolved at the point of instantiation if Box_Present (N) then null; -- Else default is bound at the point of generic declaration elsif Present (Default_Name (N)) then Find_Name (Default_Name (N)); end if; Analyze_Subprogram_Declaration (N); Set_Has_Completion (Defining_Unit_Name (Spec)); end Analyze_Formal_Subprogram; ---------------------------- -- Analyze_Formal_Package -- ---------------------------- procedure Analyze_Formal_Package (N : Node_Id) is Actuals : List_Id := Generic_Associations (N); Decls : Node_Id; Formal_Id : Entity_Id := Defining_Identifier (N); Formals : List_Id; Gen_Id : Node_Id := Name (N); Gen_Unit : Entity_Id; Spec : Node_Id; begin Enter_Name (Formal_Id); Set_Ekind (Formal_Id, E_Package); Set_Etype (Formal_Id, Standard_Void_Type); Find_Name (Gen_Id); Gen_Unit := Entity (Gen_Id); if Ekind (Gen_Unit) /= E_Generic_Package then Error_Msg_N ("Expect generic package name", Gen_Id); return; end if; -- The formal package is treated like a regular instance, but only -- the specification needs to be instantiated, to make entities visible. -- If there are no generic associations, the generic parameters appear -- as local entities and are instantiated like them. Otherwise the -- associations are analyzed and the parameters matched to the actuals. Set_Generic_Parent (N, Gen_Unit); Spec := Parent (Gen_Unit); Formals := Generic_Formal_Declarations (Parent (Spec)); if not Box_Present (N) then Analyze_Associations (Formals, Actuals); end if; Instantiate_Entities (Gen_Unit, Formal_Id); -- The tree for the declarations has to be instantiated as well, to -- allow the completion of the instantiation of the entities. The tree -- itself is not kept as part of the current generic unit. Decls := Instantiate_Tree (Spec); Complete_Entities (Gen_Unit); end Analyze_Formal_Package; --------------------------------------------- -- Build_Instance_Compilation_Unit_Nodes -- --------------------------------------------- procedure Build_Instance_Compilation_Unit_Nodes (N : Node_Id; Act_Body, Act_Decl, Gen_Decl, Gen_Body : Node_Id) is Decl_Cunit : Node_Id; Body_Cunit : Node_Id; Citem : Node_Id; begin -- A new compilation unit node is built for the instance declaration Decl_Cunit := New_Node (N_Compilation_Unit, Sloc (N)); Set_Context_Items (Decl_Cunit, Empty_List); Set_Unit (Decl_Cunit, Act_Decl); Set_Parent_Spec (Act_Decl, Parent_Spec (N)); Set_Body_Required (Decl_Cunit, True); -- We use the original instantiation compilation unit as the resulting -- compilation unit of the instance, since this is the main unit. Rewrite_Substitute_Tree (N, Act_Body); Body_Cunit := Parent (N); -- The two compilation unit nodes are linked by the Library_Unit field Set_Library_Unit (Decl_Cunit, Body_Cunit); Set_Library_Unit (Body_Cunit, Decl_Cunit); -- The context clause items on the instantiation, which are now -- attached to the body compilation unit (since the body overwrote -- the orginal instantiation node), semantically belong on the spec, -- so copy them there. It's harmless to leave them on the body as well. -- In fact one could argue that they belong in both places. Citem := First (Context_Items (Body_Cunit)); while Present (Citem) loop Append (New_Copy (Citem), Context_Items (Decl_Cunit)); Citem := Next (Citem); end loop; end Build_Instance_Compilation_Unit_Nodes; ------------------------ -- Instantiate_Object -- ------------------------ procedure Instantiate_Object (Formal, Actual : Node_Id) is Act_Type : Entity_Id := Get_Instance_Of (Etype (Formal)); Act_Object : Entity_Id; Decl_Node : Node_Id; begin if Get_Instance_Of (Formal) /= Formal then Error_Msg_N ( "Duplicate instantiation of generic parameter", Actual); end if; if Ekind (Formal) = E_Generic_In_Parameter then -- The instantiation of a generic formal in-parameter is a -- constant declaration.We create an internal constant whose -- initial value is the generic actual, and we establish this -- internal constant as the instance of the generic formal. Decl_Node := New_Node (N_Object_Declaration, Sloc (Formal)); Set_Constant_Present (Decl_Node, True); Analyze (Actual); Resolve_Complete_Context (Actual, Act_Type); Set_Expression (Decl_Node, Instantiate_Tree (Actual)); Set_Object_Definition (Decl_Node, New_Occurrence_Of (Act_Type, Sloc (Formal))); -- If the actual type is unconstrained, the actual derives its -- bound from the initial value. The process here mimics what is -- done for object declarations, and should eventually be -- common code in the expander. if (Act_Type = Standard_String) or else (Is_String_Type (Act_Type) and not Is_Constrained (Act_Type)) then Expand_Subtype_From_Expr (Decl_Node, Act_Type); Act_Type := Process_Subtype (Object_Definition (Decl_Node)); end if; Act_Object := New_Internal_Entity (E_Constant, Current_Scope, Sloc (Formal), "actual_in"); else -- An IN OUT generic actual must be a name. The instantiation -- is equivalent to a renaming declaration. Act_Object := New_Internal_Entity (E_Variable, Current_Scope, Sloc (Formal), "actual_inout"); Decl_Node := New_Node (N_Object_Renaming_Declaration, Sloc (Formal)); Find_Name (Actual); Set_Name (Decl_Node, Actual); Set_Subtype_Mark (Decl_Node, New_Occurrence_Of (Act_Type, Sloc (Formal))); Set_Renamed_Object (Act_Object, Instantiate_Tree (Actual)); end if; Set_Instance_Of (Formal, Act_Object); Set_Etype (Act_Object, Act_Type); Set_Public_Status (Act_Object); Set_Defining_Identifier (Decl_Node, Act_Object); -- The declaration is inserted before the instantiations, because -- it may be used in subsequent subprogram signatures, etc. Append (Decl_Node, Implicit_Type_List); end Instantiate_Object; ---------------------- -- Instantiate_Type -- ---------------------- procedure Instantiate_Type (Formal, Actual : Node_Id) is Gen_T : Entity_Id := Defining_Identifier (Formal); Act_T : Entity_Id; begin if Get_Instance_Of (Gen_T) /= Gen_T then Error_Msg_N ( "Duplicate instantiation of generic type", Actual); else Act_T := Entity (Actual); Set_Instance_Of (Gen_T, Act_T); if not Is_Abstract (Gen_T) and then Is_Abstract (Act_T) then Error_Msg_N ("actual of non-abstract formal cannot be abstract", Actual); end if; if Is_Scalar_Type (Gen_T) then Set_Instance_Of (Etype (Gen_T), Etype (Act_T)); if Is_Integer_Type (Gen_T) and then not Is_Integer_Type (Act_T) then Error_Msg_N ("expect integer type in instantiation", Parent (Actual)); elsif Is_Float_Type (Gen_T) and then not Is_Float_Type (Act_T) then Error_Msg_N ("expect float type in instantiation", Parent (Actual)); elsif Is_Fixed_Type (Gen_T) and then not Is_Fixed_Type (Act_T) then Error_Msg_N ("expect fixed type in instantiation", Parent (Actual)); -- Decimal Types ??? end if; end if; end if; end Instantiate_Type; ----------------------------------- -- Instantiate_Formal_Subprogram -- ----------------------------------- procedure Instantiate_Formal_Subprogram (Formal, Actual : Node_Id) is Formal_Sub : constant Entity_Id := Defining_Unit_Name (Specification (Formal)); begin if Present (Actual) then Find_Name (Actual); Set_Instance_Of (Formal_Sub, Entity (Actual)); if Is_Abstract (Entity (Actual)) then Error_Msg_N ("generic actual subprogram cannot be abstract", Actual); end if; elsif Present (Default_Name (Formal)) then Set_Instance_Of (Formal_Sub, Entity (Default_Name (Formal))); else Unimplemented (Parent (Actual), "default formal subprograms"); end if; end Instantiate_Formal_Subprogram; -------------------------------- -- Instantiate_Formal_Package -- -------------------------------- procedure Instantiate_Formal_Package (Formal, Actual : Node_Id) is Act_Entity : Entity_Id; Gen_Entity : Entity_Id; begin if No (Actual) then Error_Msg_N ("missing actual for generic formal ", Parent (Actual)); Set_Instance_Of (Defining_Identifier (Formal), Any_Id); elsif Ekind (Actual) /= E_Package or else Generic_Parent (Actual) /= Generic_Parent (Formal) then Error_Msg_N ("expect package instance to instantiate formal", Parent (Actual)); else Set_Instance_Of (Defining_Identifier (Formal), Actual); Gen_Entity := First_Entity (Formal); Act_Entity := First_Entity (Actual); -- The entities in the generic formal are instantiated with the -- corresponding entities in the generic actual. while Present (Gen_Entity) loop Set_Instance_Of (Gen_Entity, Act_Entity); Gen_Entity := Next_Entity (Gen_Entity); Act_Entity := Next_Entity (Act_Entity); end loop; end if; end Instantiate_Formal_Package; --------------------------- -- Instantiate_Entities -- --------------------------- -- The second step of generic instantiation is the construction of -- entities in the instance, in one-to-one correspondence with -- entities in the generic unit. We traverse the entity chains in -- order, and build defining occurrences for the actual entities. Each -- generic entity points to its instance. The Etype can be instantiated -- at the same time, because they are not forward references in the -- chain. Other attributes are updated subsequently. All scopes within -- the unit are instantiated recursively. -- On entry, the generic formals have already been matched to the actuals -- If the new entity is a package, then its local declarations -- are visible on exit, and can become use visible. The local entities -- are entered in the visibility table accordingly. At the end, there -- is no need to unlink them, it is sufficient to exit the scope. procedure Instantiate_Entities (Gen_Scope, Act_Scope : Entity_Id) is Gen_Id : Entity_Id := First_Entity (Gen_Scope); New_Id : Entity_Id; begin Set_Instance_Of (Gen_Scope, Act_Scope); -- The new scope contains no entities Set_First_Entity (Act_Scope, Empty); Set_Last_Entity (Act_Scope, Empty); New_Scope (Act_Scope); while Present (Gen_Id) loop if Get_Instance_Of (Gen_Id) = Gen_Id then New_Id := New_Copy (Gen_Id); Set_Instance_Of (Gen_Id, New_Id); Set_Etype (New_Id, Get_Instance_Of (Etype (Gen_Id))); Set_Scope (New_Id, Act_Scope); Set_Public_Status (New_Id); Set_Is_Directly_Visible (New_Id, False); Set_Next_Entity (New_Id, Empty); Set_Homonym (New_Id, Empty); Append_Entity (New_Id, Act_Scope); if Present (First_Entity (Gen_Id)) and then not Is_Array_Type (Gen_Id) then Instantiate_Entities (Gen_Id, New_Id); end if; -- Already instantiated. Entity lives elsewhere else null; end if; Gen_Id := Next_Entity (Gen_Id); end loop; if Ekind (Act_Scope) = E_Package then Set_First_Private_Entity (Act_Scope, Get_Instance_Of (First_Private_Entity (Gen_Scope))); -- Make new local entities visible New_Id := First_Entity (Act_Scope); while Present (New_Id) and then New_Id /= First_Private_Entity (Act_Scope) loop if not Is_Internal (New_Id) then if No (Current_Entity (New_Id)) then Set_Current_Entity (New_Id); else -- Chain at end of homonym chain. declare Prev : Entity_Id := Current_Entity (New_Id); begin while Present (Homonym (Prev)) loop Prev := Homonym (Prev); end loop; Set_Homonym (Prev, New_Id); end; end if; end if; New_Id := Next_Entity (New_Id); end loop; end if; Pop_Scope; end Instantiate_Entities; --------------------- -- Complete_Entities -- --------------------- procedure Complete_Entities (Gen_Scope : Entity_Id) is E : Entity_Id; Act : Entity_Id; begin E := First_Entity (Gen_Scope); while Present (E) loop Act := Get_Instance_Of (E); if Act = E then null; elsif Is_Generic_Type (E) then null; else -- Some semantic attributes involve forward references, and -- are specific to the entity kind. They are established -- now, after entity and tree instantiation. Eventually, these -- should be set automatically by a fuller traversal of the tree. case Ekind (E) is when E_In_Parameter => Set_Default_Value (Act, Get_Instance_Of (Default_Value (E))); when E_Discriminant => Set_Discriminant_Default_Value (Act, Get_Instance_Of (Discriminant_Default_Value (E))); when Scalar_Kind => Set_Scalar_Range (Act, Get_Instance_Of (Scalar_Range (E))); if No (Scalar_Range (Act)) then -- Range of E is not instantiated: E is an implicit -- subtype in an allocator. Set_Scalar_Range (Act, Instantiate_Tree (Scalar_Range (E))); end if; when Array_Kind => Set_Component_Type (Act, Get_Instance_Of (Component_Type (E))); Set_First_Index (Act, Get_Instance_Of (First_Index (E))); if Ekind (E) = E_Slice_Subtype then Set_Slice_Range (Act, Get_Instance_Of (Slice_Range (E))); if No (Slice_Range (Act)) then Set_Slice_Range (Act, Instantiate_Tree (Slice_Range (E))); end if; end if; when Access_Kind => Set_Directly_Designated_Type (Act, Get_Instance_Of (Directly_Designated_Type (E))); when E_Incomplete_Type => Set_Full_Declaration (Act, Get_Instance_Of (Full_Declaration (E))); when others => null; end case; end if; if Present (First_Entity (E)) and then not Is_Array_Type (E) then -- Entity is a scope. Complete its internal entities Complete_Entities (E); end if; E := Next_Entity (E); end loop; end Complete_Entities; ---------------------- -- Instantiate_Tree -- ---------------------- function Instantiate_Tree (N : Node_Id) return Node_Id is Result : Node_Id; begin Result := Instantiate_Node (N, Empty); -- Place result in current declarative part. return Result; end Instantiate_Tree; ---------------------- -- Instantiate_Node -- ---------------------- function Instantiate_Node (N : Node_Id; Parent_Id : Node_Id) return Node_Id is function Instantiate_Descendant (D : Int) return Int; -- This procedure tests the given value of one of the Fields referenced -- by the current node to determine whether to copy it recursively. -- The field may hold a node id, a list id, or an elist id, or a plain -- value (Uint, Char) in which case it need not be copied. New_N : Node_Id; function Instantiate_Descendant (D : Int) return Int is begin if D in Node_Range then if D = Int (Empty) then return Int (D); elsif Nkind (Node_Id (D)) = N_Defining_Identifier then -- Point to the corresponding instance. -- The instantiation of entities does not set their -- parent pointer. This is done now that the rest of the -- tree is constructed. declare Id1 : constant Entity_Id := Node_Id (D); Id2 : constant Entity_Id := Get_Instance_Of (Id1); begin if Present (Id2) then if No (Parent (Id2)) and then Parent (Id1) = N then Set_Parent (Id2, New_N); end if; return Int (Id2); else return Int (Id1); end if; end; else return Int (Instantiate_Node (Node_Id (D), New_N)); end if; elsif D in List_Range then if D = Int (No_List) or else Is_Empty_List (List_Id (D)) then return Int (D); else return Int (Instantiate_List (List_Id (D), New_N)); end if; elsif D in Elist_Range then if D = Int (No_Elist) or else Is_Empty_Elmt_List (Elist_Id (D)) then return Int (D); else return Int (Instantiate_Elist (Elist_Id (D))); end if; else -- Field is not Id of copyable structure: return as is return D; end if; end Instantiate_Descendant; -- Start processing for Instantiate_Node begin if N = Empty then return N; end if; -- If node is already instantiated, return its instance. New_N := Get_Instance_Of (N); if Present (New_N) then return New_N; end if; if Debug_Flag_E then Write_Str (" instantiate node "); Write_Int (Int (N)); Write_String (Node_Kind'Image (Nkind (N))); Write_Eol; end if; New_N := New_Copy (N); Set_Instance_Of (N, New_N); if not Is_List_Member (N) then Set_Parent (New_N, Parent_Id); end if; Set_Field1 (New_N, Instantiate_Descendant (Field1 (N))); Set_Field2 (New_N, Instantiate_Descendant (Field2 (N))); Set_Field3 (New_N, Instantiate_Descendant (Field3 (N))); Set_Field4 (New_N, Instantiate_Descendant (Field4 (N))); Set_Field5 (New_N, Instantiate_Descendant (Field5 (N))); if Has_Extension (N) then -- Currently true only for Defining_Identifier nodes, -- but this may change. Set_Field6 (New_N, Instantiate_Descendant (Field6 (N))); Set_Field7 (New_N, Instantiate_Descendant (Field7 (N))); Set_Field8 (New_N, Instantiate_Descendant (Field8 (N))); Set_Field9 (New_N, Instantiate_Descendant (Field9 (N))); Set_Field10 (New_N, Instantiate_Descendant (Field10 (N))); Set_Field11 (New_N, Instantiate_Descendant (Field11 (N))); Set_Field12 (New_N, Instantiate_Descendant (Field12 (N))); end if; if Is_Name (N) then declare Nam : Entity_Id := Entity (N); begin -- An implicit subtype may be created for an instance of a -- generic IN parameter. The type of any reference to the -- generic formal must carry this type, rather than the instance -- of the type of the formal, which may be unconstrained. if Present (Nam) and then Get_Instance_Of (Nam) /= Nam and then Ekind (Nam) = E_Generic_In_Parameter then Set_Etype (New_N, Etype (Get_Instance_Of (Nam))); end if; end; end if; return New_N; end Instantiate_Node; ---------------------- -- Instantiate_List -- ---------------------- function Instantiate_List (L : List_Id; Parent_Id : Node_Id) return List_Id is N : Node_Id; New_L : List_Id; begin N := First (L); if N = Empty then return L; else New_L := New_List; Set_Parent (New_L, Parent_Id); N := First (L); while Present (N) loop Append (Instantiate_Node (N, Empty), New_L); N := Next (N); end loop; return New_L; end if; end Instantiate_List; ----------------- -- Copy_Elist -- ----------------- function Instantiate_Elist (E : Elist_Id) return Elist_Id is M : Elmt_Id; L : Elist_Id := New_Elmt_List; begin M := First_Elmt (E); while M /= No_Elmt loop Append_Elmt (Instantiate_Node (Id_Of (M), Empty), L); M := Next_Elmt (M); end loop; return L; end Instantiate_Elist; -------------------------- -- Initialize_Instances -- -------------------------- procedure Initialize_Instances is begin for I in Hash_Headers'range loop Hash_Headers (I) := No_Entry; end loop; Hash_Instance.Init; end Initialize_Instances; --------------------- -- Set_Instance_Of -- --------------------- procedure Set_Instance_Of (Old_Node, New_Node : Node_Id) is Hash_Code : Nat := Int (Old_Node) mod Num_Hash_Headers; Index : Hash_Entry_Id := Hash_Headers (Hash_Code); begin Hash_Instance.Increment_Last; Hash_Instance.Table (Hash_Instance.Last).Next := No_Entry; Hash_Instance.Table (Hash_Instance.Last).New_Node := New_Node; Hash_Instance.Table (Hash_Instance.Last).Old_Node := Old_Node; if Index = No_Entry then Hash_Headers (Hash_Code) := Hash_Instance.Last; else while Hash_Instance.Table (Index).Next /= No_Entry loop Index := Hash_Instance.Table (Index).Next; end loop; Hash_Instance.Table (Index).Next := Hash_Instance.Last; end if; if Debug_Flag_E then Write_String ("instantiate entity "); Write_Int (Int (Old_Node)); Write_String (" into "); Write_Int (Int (New_Node)); Write_Eol; end if; end Set_Instance_Of; --------------------- -- Get_Instance_Of -- --------------------- function Get_Instance_Of (Old_Node : Node_Id) return Node_Id is Hash_Code : Nat := Int (Old_Node) mod Num_Hash_Headers; Index : Hash_Entry_Id := Hash_Headers (Hash_Code); begin if Old_Node = Empty then return Empty; else loop if Index = No_Entry then if Nkind (Old_Node) = N_Defining_Identifier then return Old_Node; else return Empty; end if; end if; if Old_Node = Hash_Instance.Table (Index).Old_Node then return Hash_Instance.Table (Index).New_Node; else Index := Hash_Instance.Table (Index).Next; end if; end loop; end if; end Get_Instance_Of; end Sem_Ch12; --------------------- -- Instantiate_Tree -- ---------------------- function Instagnat-1.67-src/src/sem_ch13.ads 444 10015 7640 5752 5506244366 11227 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ C H 1 3 -- -- -- -- S p e c -- -- -- -- $Revision: 1.4 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Sem_Ch13 is procedure Analyze_At_Clause (N : Node_Id); procedure Analyze_Attribute_Definition_Clause (N : Node_Id); procedure Analyze_Enumeration_Representation_Clause (N : Node_Id); procedure Analyze_Record_Representation_Clause (N : Node_Id); procedure Analyze_Component_Clause (N : Node_Id); procedure Analyze_Code_Statement (N : Node_Id); procedure Analyze_Mod_Clause (N : Node_Id); function Freeze_Entity (E : Entity_Id) return List_Id; -- Freeze an entity, and return Freeze nodes, to be inserted at the -- point of call. function Freeze_All return List_Id; -- Before a non-instance body, or at the end of a declarative part -- freeze all entities therein that are not yet frozen. procedure Validate_Unchecked_Conversion (N : Node_Id; Act_Unit : Entity_Id); -- Validate a call to unchecked conversion. N is the node for the actual -- instantiation, which is used only for error messages. Act_Unit is the -- entity for the instantiation, from which the actual types etc for this -- instantiation can be determined. end Sem_Ch13; xrefprov.adbrs ,gnat-1.67-src/src/sem_ch13.adb 444 10015 7640 45064 5506244367 11227 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ C H 1 3 -- -- -- -- B o d y -- -- -- -- $Revision: 1.48 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Einfo; use Einfo; with Errout; use Errout; with Excep; use Excep; with Nmake; use Nmake; with Opt; use Opt; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Ch3; use Sem_Ch3; with Sem_Ch8; use Sem_Ch8; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Stand; use Stand; with Sinfo; use Sinfo; with Snames; use Snames; with Ttypes; use Ttypes; with Uintp; use Uintp; package body Sem_Ch13 is ----------------------------------------- -- Analyze_Attribute_Definition_Clause -- ----------------------------------------- procedure Analyze_Attribute_Definition_Clause (N : Node_Id) is Nam : Node_Id := Name (N); Attr : Name_Id := Chars (Identifier (N)); Expr : Node_Id := Expression (N); Id : Attribute_Id := Get_Attribute_Id (Attr); Typ : Node_Id; Ent : Entity_Id; begin Find_Name (Nam); Ent := Entity (Nam); -- Ignore rep clauses for junk entities if Etype (Nam) = Any_Type then return; -- Case of setting Address attribute elsif Id = Attribute_Address then if Has_Address_Clause (Ent) then Error_Msg_N ("address already given for &", Nam); return; elsif Ekind (Ent) not in Subprogram_Kind and then Ekind (Ent) /= E_Variable and then Ekind (Ent) /= E_Constant then Error_Msg_N ("address cannot be given for &", Nam); end if; Analyze (Expr); Typ := RTE (RE_Address); Resolve_Complete_Context (Expr, Typ); Set_Has_Address_Clause (Ent, True); Set_Is_Delayed (Ent); -- Case of setting Size attribute elsif Id = Attribute_Size then if Has_Size_Clause (Ent) then Error_Msg_N ("size already given for &", Nam); return; elsif not Is_Type (Ent) and then Ekind (Ent) /= E_Variable and then Ekind (Ent) /= E_Constant then Error_Msg_N ("size cannot be given for &", Nam); end if; Analyze (Expr); Resolve_Complete_Context (Expr, Any_Integer); if not Is_Static_Expression (Expr) then Error_Msg_N ("expect static value for size ", Expr); else -- Note that Gigi is in charge of checking that the size we -- are assigning is acceptable, and will generate the error -- message if the size is inappropriate. Set_Esize (Ent, Intval (Expr)); Set_Has_Size_Clause (Ent, True); end if; -- Case of setting Storage_Size attribute elsif Id = Attribute_Storage_Size then if Has_Storage_Size_Clause (Ent) then Error_Msg_N ("storage size already given for &", Nam); return; elsif not Is_Access_Type (Ent) and then Ekind (Ent) /= E_Task_Type then Error_Msg_N ("size cannot be given for &", Nam); end if; Analyze (Expr); Resolve_Complete_Context (Expr, Any_Integer); -- We don't yet implement Storage_Size for access types if Is_Access_Type (Ent) then Unimplemented (N, "storage size for collections"); end if; -- All other attribute definition clauses are rejected else Unimplemented (N, "attribute definition?"); end if; end Analyze_Attribute_Definition_Clause; ----------------------------------------------- -- Analyze_Enumeration_Representation_Clause -- ----------------------------------------------- procedure Analyze_Enumeration_Representation_Clause (N : Node_Id) is begin Unimplemented (N, "representation clause?"); end Analyze_Enumeration_Representation_Clause; ------------------------------------------ -- Analyze_Record_Representation_Clause -- ------------------------------------------ -- For now, the only acceptable record representation clauses are those -- that confirm a pragma Packed, i.e. the fields must be strictly in -- order, each field must take up the number of bits indicated by its -- size, and there must be no gaps. Any other record representation -- clauses are rejected. procedure Analyze_Record_Representation_Clause (N : Node_Id) is Mod_Val : Uint; Next_Pos : Uint; Rectype : Entity_Id; Next_CC : Node_Id; Typedecl : Node_Id; Recdef : Node_Id; -- Local procedure used to check the bit position of the next field. -- CC is a component clause node. Check_Bit_Pos checks that the -- bit position specified by the component clause matches Next_Pos, -- and then updates Next_Pos from the Esize field of the type -- of the field entity given. procedure Check_Bit_Pos (CC : Node_Id; Field : Entity_Id) is Bpos : Uint; Posit : constant Uint := Static_Integer (Position (CC)); Fbit : constant Uint := Static_Integer (First_Bit (CC)); Lbit : constant Uint := Static_Integer (Last_Bit (CC)); Oldpos : constant Uint := Next_Pos; Cnam : constant Node_Id := Component_Name (CC); Maxsiz : constant Uint := UI_From_Int (System_Address_Size); begin if Esize (Etype (Field)) = Uint_0 then Error_Msg_N ("type of component& has unknown size", Cnam); raise Error_Resync; return; else Next_Pos := UI_Sum (Next_Pos, Esize (Etype (Field))); end if; if Posit = No_Uint or else Fbit = No_Uint or else Lbit = No_Uint then raise Error_Resync; elsif Esize (Etype (Field)) = Uint_0 then Error_Msg_N ("type of component& has unknown size", Cnam); raise Error_Resync; elsif UI_Gt (Esize (Etype (Field)), Maxsiz) then Error_Msg_Uint_1 := Maxsiz; Error_Msg_N ("size of component& exceeds maximum permitted (^)", Cnam); raise Error_Resync; elsif UI_Ne ( UI_Quotient (Oldpos, Maxsiz), UI_Quotient (UI_Difference (Next_Pos, Uint_1), Maxsiz)) then Error_Msg_N ("component& crosses word boundary", Cnam); raise Error_Resync; elsif Chars (Cnam) /= Chars (Field) then Error_Msg_Node_2 := Field; Error_Msg_N ("wrong component, found&, expecting&", Cnam); raise Error_Resync; elsif UI_Is_Negative (Posit) then Error_Msg_N ("position cannot be negative", Position (CC)); raise Error_Resync; elsif UI_Is_Negative (Fbit) then Error_Msg_N ("first bit cannot be negative", First_Bit (CC)); raise Error_Resync; elsif not UI_Eq ( Esize (Etype (Field)), UI_Sum (Uint_1, UI_Difference (Lbit, Fbit))) then Error_Msg_N ("wrong number of bits for component&", Cnam); raise Error_Resync; else Bpos := UI_Sum ( UI_Product (UI_From_Int (System_Storage_Unit), Posit), Fbit); if UI_Ne (Bpos, Oldpos) then Error_Msg_N ("component& not in required position", Cnam); raise Error_Resync; end if; end if; end Check_Bit_Pos; -- Local procedure used to check a sequence of fields. The single -- argument is a list of nodes, and each node in the list has a -- Defining_Identifier field. procedure Check_Fields (Lst : List_Id) is Fld : Entity_Id; Nod : Node_Id; begin if Lst = No_List then return; end if; Nod := First (Lst); while Present (Nod) loop Fld := Defining_Identifier (Nod); if Next_CC = Empty then Error_Msg_NE ("missing component clause for field&", N, Fld); raise Error_Resync; else Check_Bit_Pos (Next_CC, Fld); Next_CC := Next (Next_CC); end if; Nod := Next (Nod); end loop; end Check_Fields; -- Local procedure to process a component list. This is a recursive -- procedure that calls itself to process nested variant parts procedure Check_Component_List (CL : Node_Id) is Save_Start : Uint; Max_At_End : Uint; Variant : Node_Id; begin Check_Fields (Component_Declarations (CL)); -- Now we process the variants. We record the current bit position -- and reset it for each variant, and when we are done we reset the -- bit position to be the maximum that it reached for any variant. if Present (Variant_Part (CL)) then Max_At_End := Next_Pos; Save_Start := Next_Pos; Variant := First (Variants (Variant_Part (CL))); while Present (Variant) loop Next_Pos := Save_Start; Check_Component_List (Component_List (Variant)); if UI_Gt (Next_Pos, Max_At_End) then Max_At_End := Next_Pos; end if; Variant := Next (Variant); end loop; Next_Pos := Max_At_End; end if; end Check_Component_List; -- Start of processing for Analyze_Record_Representation_Clause begin if Present (Mod_Clause (N)) then Mod_Val := Static_Integer (Expression (Mod_Clause (N))); Unimplemented (N, "mod clause"); end if; Analyze (Identifier (N)); Rectype := Entity (Identifier (N)); if Ekind (Rectype) /= E_Record_Type then Error_Msg_N ("& is not a record type", Identifier (N)); return; end if; Typedecl := Parent (Rectype); Recdef := Type_Definition (Typedecl); Next_Pos := Uint_0; Next_CC := First (Component_Clauses (N)); -- First check out the discriminants then call the recursive internal -- procedure to check out the component list (this call includes the -- processing for the common components, and for all the variants) Check_Fields (Discriminant_Specifications (Typedecl)); Check_Component_List (Component_List (Recdef)); -- Make sure all component declarations are used up if Next_CC /= Empty then Error_Msg_N ("component& does not exist in record", Component_Name (Next_CC)); -- If everything has checked out (we would not be here if that were -- not the case, since anyone finding an error raised Error_Resync to -- bypass further processing), then we simply set the Is_Packed flag -- on the type, since we have checked that the layout is exactly -- equivalent to the default behavior of pragma packed. else Set_Is_Packed (Rectype, True); end if; -- We use the Error_Resync exception to get out if we detect any -- errors, since otherwise we can get bad cases of cascaded errors exception when Error_Resync => return; end Analyze_Record_Representation_Clause; ------------------------ -- Analyze_Mod_Clause -- ------------------------ procedure Analyze_Mod_Clause (N : Node_Id) is begin Unimplemented (N, "representation clause?"); end Analyze_Mod_Clause; ------------------------------ -- Analyze_Component_Clause -- ------------------------------ procedure Analyze_Component_Clause (N : Node_Id) is begin Unimplemented (N, "representation clause?"); end Analyze_Component_Clause; ----------------------- -- Analyze_At_Clause -- ----------------------- procedure Analyze_At_Clause (N : Node_Id) is begin Rewrite_Substitute_Tree (N, Make_Attribute_Definition_Clause (Sloc (N), Name => Identifier (N), Identifier => Make_Identifier (Sloc (N), Name_Address), Expression => Expression (N))); Analyze (N); end Analyze_At_Clause; ---------------------------- -- Analyze_Code_Statement -- ---------------------------- procedure Analyze_Code_Statement (N : Node_Id) is begin Unimplemented (N, "code statement"); end Analyze_Code_Statement; ------------------- -- Freeze_Entity -- ------------------- function Freeze_Entity (E : Entity_Id) return List_Id is Comp : Entity_Id; Elmt : Elmt_Id; F_Node : Node_Id; Op_List : Elist_Id; Result : List_Id; Subp : Entity_Id; procedure Freeze_It is begin F_Node := New_Node (N_Freeze_Entity, Sloc (E)); Set_Entity (F_Node, E); Append (F_Node, Result); end Freeze_It; begin if not Is_Frozen (E) and then Scope (E) = Current_Scope and then Present (Parent (E)) then Result := New_List; Set_Is_Frozen (E); if Is_Array_Type (E) then Append_List (Freeze_Entity (Component_Type (E)), Result); Freeze_It; elsif Is_Record_Type (E) then Comp := First_Entity (E); while Present (Comp) loop Append_List (Freeze_Entity (Etype (Comp)), Result); Comp := Next_Entity (Comp); end loop; Freeze_It; if Is_Tagged_Type (E) and then Ekind (E) = E_Record_Type and then not Is_Abstract (E) then Op_List := Primitive_Operations (E); -- Verify that no primitive operation of the type is abstract Elmt := First_Elmt (Op_List); while Elmt /= No_Elmt loop Subp := Id_Of (Elmt); if Is_Abstract (Subp) then Error_Msg_Name_1 := Chars (Subp); Error_Msg_N ( "non-abstract type has abstract subprogram%", E); end if; Elmt := Next_Elmt (Elmt); end loop; end if; elsif Is_Task_Type (E) and then Present (Task_Value_Type (E)) then Append_List (Freeze_Entity (Task_Value_Type (E)), Result); elsif Is_Delayed (E) and then Ekind (E) not in Incomplete_Kind then -- Subprogram whose profile includes a private type, -- or subtype of private type, or full declaration of -- private type. Note that the entity in the full declaration -- is currently a copy of the original private entity (it has -- not been swapped back yet) and does not receive a freeze node. Freeze_It; else null; end if; return Result; else return Empty_List; end if; end Freeze_Entity; ----------------- -- Freeze_All -- ----------------- function Freeze_All return List_Id is E : Entity_Id; Result : List_Id := New_List; begin E := First_Entity (Current_Scope); while Present (E) loop if not Is_Frozen (E) then Append_List (Freeze_Entity (E), Result); end if; E := Next_Entity (E); end loop; return Result; end Freeze_All; -------------------------------------- -- Validate_Unchecked_Conversion -- -------------------------------------- procedure Validate_Unchecked_Conversion (N : Node_Id; Act_Unit : Entity_Id) is Source : Entity_Id; Target : Entity_Id; begin -- If we are dealing with private types, then do the check on their -- fully declared counterparts if the full declarations have been -- encountered (they don't have to be visible, but they must exist!) Source := Etype (First_Formal (Act_Unit)); if Ekind (Source) in Private_Kind and then Present (Full_Declaration (Source)) then Source := Full_Declaration (Source); end if; Target := Etype (Act_Unit); if Ekind (Target) in Private_Kind and then Present (Full_Declaration (Target)) then Target := Full_Declaration (Target); end if; if Is_Unconstrained_Type (Source) then Error_Msg_NE ("unconstrained type& not allowed in unchecked conversion", N, Source); return; end if; if Is_Unconstrained_Type (Target) then Error_Msg_NE ("unconstrained type& not allowed in unchecked conversion", N, Target); return; end if; if Esize (Source) /= Uint_0 and then Esize (Target) /= Uint_0 and then UI_Ne (Esize (Source), Esize (Target)) then Error_Msg_N ("types for unchecked conversion have different sizes", N); end if; end Validate_Unchecked_Conversion; end Sem_Ch13; iant_Part (CL)) then Max_At_End := Next_Pos; Save_Start := Next_Pos; Variant := First (Variants (Variant_Part (CL))); while Present (Variant) loop Next_Pos := Save_Start; Check_Component_List (Component_List (Variant)); if UI_Gt (Next_Pos, Max_At_End) then Max_At_End := Next_Pos; end if; Variant := Next (Variant);gnat-1.67-src/src/sem_ch3.ads 444 10015 7640 13177 5506244367 11167 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ C H 3 -- -- -- -- S p e c -- -- -- -- $Revision: 1.14 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Sem_Ch3 is procedure Analyze_Component_Declaration (N : Node_Id); procedure Analyze_Implicit_Type (N : Node_Id); procedure Analyze_Number_Declaration (N : Node_Id); procedure Analyze_Declarations (L : List_Id); procedure Analyze_Incomplete_Type_Decl (N : Node_Id); procedure Analyze_Object_Declaration (N : Node_Id); procedure Analyze_Subtype_Declaration (N : Node_Id); procedure Analyze_Subtype_Indication (N : Node_Id); procedure Analyze_Type_Declaration (N : Node_Id); procedure Analyze_Variant_Part (N : Node_Id); procedure Analyze_Private_Extension_Declaration (N : Node_Id); function Access_Definition (N : Node_Id) return Entity_Id; -- An access definition defines a general access type for a formal -- parameter. The procedure is called when processing formals, when -- the current scope is the subprogram. The Implicit type is placed -- in the enclosing scope, so that the only entities defined in the -- spec are the formals themselves. procedure Array_Type_Declaration (T : in out Entity_Id; Def : Node_Id); -- Process an array type declaration. If the array is constrained, we -- create an implicit parent array type, with the same index types and -- component type. procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id); -- Process an access type declaration procedure Check_Completion; -- At the end of a declarative part, verify that all entities that -- require completion have received one. procedure Install_Implicit_Types (N : Node_Id); -- Insert the list of implicit types where it has to be : -- - before the concerned declaration, or -- - in the anonymous list in a Record Definition function Is_Derived_Type (Type_Id : Entity_Id) return Boolean; -- Determine if given entity is for a derived type function Is_Unconstrained_Type (E : Entity_Id) return Boolean; -- Determines if given entity is for an unconstrained array or -- record type (note that scalar types like Integer, which are -- technically unconstrained are not considered to be so for -- the purpose of this test) procedure Make_Index (I : Node_Id; Related_Id : Entity_Id := Empty; Postfix : Nat := 1); -- Process an index that is given in an array declaration, an entry -- family declaration or a loop iteration. The index is given by an -- index declaration (a 'box'), or by a discrete range. The later can -- be the name of a discrete type, or a subtype indication. procedure Make_Class_Type (T : Entity_Id); -- A Class_Type is created for each tagged type definition. -- The attributes of a class wide type are inherited from -- those of the type T. If T is introduced by a private declaration, -- the corresponding Class_Type is created at the same time, and -- therefore there is a private and a full declaration for the class -- type as well. function Process_Subtype (S : Node_Id; Related_Id : Entity_Id := Empty; Suffix : Str := "") return Entity_Id; -- Process a subtype indication and return corresponding entity. The 2 -- last parameters are used to build the associated Implicit type name. procedure Process_The_Discriminants (N : Node_Id); -- Process discriminants of a type with discriminants function New_Class_Subtype (N : Node_Id; Ctyp : Entity_Id) return Entity_Id; -- Ctype is a Class type. This function defines the implicit type -- corresponding to a new Class Subtype (a constrained class type). -- see Expand_Class_Subtype for further details. end Sem_Ch3; vate type, or full declaration of -- private type. Note that the entity in the full declaration -- is currently a copy of the original private entity (it has -- not been swapped back yet) and does not receive a freeze node. Freeze_It; else null; end if; return Result; else regnat-1.67-src/src/sem_ch3.adb 444 10015 7640 354513 5506244372 11164 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ C H 3 -- -- -- -- B o d y -- -- -- -- $Revision: 1.234 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Comperr; use Comperr; with Debug; use Debug; with Einfo; use Einfo; with Errout; use Errout; with Exp_Util; use Exp_Util; with Namet; use Namet; with Nmake; use Nmake; with Opt; use Opt; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Ch5; use Sem_Ch5; with Sem_Ch6; use Sem_Ch6; with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; with Sem_Ch9; use Sem_Ch9; with Sem_Ch12; use Sem_Ch12; with Sem_Ch13; use Sem_Ch13; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Stand; use Stand; with Sinfo; use Sinfo; with Snames; use Snames; with Tbuild; use Tbuild; with Ttypes; use Ttypes; with Uintp; use Uintp; package body Sem_Ch3 is ----------------------- -- Local Subprograms -- ----------------------- procedure Access_Subprogram_Declaration (T_Name : Entity_Id; T_Def : Node_Id); -- The subprogram specification yields the signature and return type of -- an implicit type. This implicit type is the designated type of the -- declared access type. procedure Build_Derived_Type (N : Node_Id; Parent_Type : Entity_Id; Derived_Type : Entity_Id); -- The attributes of a derived type are a copy of the attributes of -- the parent type. In some cases, additional entities (copies of -- components of the parent type) must also be created. procedure Check_Incomplete (T : Entity_Id); -- Called to verify that an incomplete type is not used prematurely procedure Check_Initialization (T : Entity_Id; Exp : Node_Id); -- Validate the initialization of an object declaration. T is the -- required type, and Exp is the initialization expression. function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id; -- Called upon type derivation and extension. We scan the declarative -- part in which the type appears, and collect subprograms that have -- one subsidiary subtype of the type. These subprograms can only -- appear after the type itself. procedure Constrain_Access (Def_Id : Entity_Id; S : Node_Id); -- Apply a list of constraints to an access type procedure Constrain_Array (Def_Id : in out Entity_Id; SI : Node_Id; Related_Id : Entity_Id; Suffix : Str); -- Apply a list of index constraints to an unconstrained array type -- creating an implicit constrained array subtype. The last two -- parameters are used to build a correct name for the implicit type. procedure Constrain_Enumeration (Def_Id : Node_Id; S : Node_Id); -- Constrain an enumeration type with a range constraint. This is -- identical to Constrain_Integer, but for the Ekind of the subtype. procedure Constrain_Index (Index : Node_Id; S : Node_Id; Related_Id : Entity_Id; Suffix : Str; Postfix : Nat); -- Process an index constraint in a constrained array declaration. -- The constraint can be a subtype name, or a range with or without -- an explicit subtype mark. The index is the corresponding index of the -- unconstrained array. The 3 last parameters are used to build a correct -- name for the implicit type that is created. procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id); -- Build an integer subtype procedure Constrain_Discriminated_Type (Def_Id : Entity_Id; S : Node_Id); -- Process discriminant constraints of composite type. Verify that values -- have been provided for all discriminants, that the original type is -- unconstrained, and that the types of the supplied expressions match -- the discriminant types. procedure Constant_Redeclaration (Id : Entity_Id; N : Node_Id); -- Processes full declaration of deferred constant. Id is the entity for -- the redeclaration, and N is the N_Object_Declaration node. The caller -- has not done an Enter_Name or Set_Ekind on this entity. procedure Derived_Type_Declaration (T : Entity_Id; N : Node_Id); -- Process derived type declaration function Determine_Enum_Size (T : Entity_Id) return Uint; -- Determine the size in bits necessary to store enumeration literals -- of type "T". The sizes are rounded to 8, 16 or 32 bit quantites. -- This determination is made in the absence of representation clauses -- for the enumeration type. procedure Derive_Subprograms (Parent_Type, Derived_Type : Entity_Id); -- To complete type derivation, collect or retrieve the primitive -- operations of the parent type, and replace the subsidiary subtypes -- with the derived type, to build the specs of the inherited ops. procedure Discriminant_Redeclaration (T : Entity_Id; D_List : List_Id); -- Verify conformance of discriminant part on redeclarations of types procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id); -- Insert each literal in symbol table, as an overloadable identifier -- Each enumeration type is mapped into a sequence of integers, and -- each literal is defined as a constant with integer value. If any -- of the literals are character literals, the type is a character -- type, which means that strings are legal aggregates for arrays of -- components of the type. procedure Expand_Others_Choice (Case_Table : Case_Table_Type; Others_Choice : Node_Id; Choice_Type : Entity_Id); -- In the case of a variant part of a record type that has an OTHERS -- choice, this procedure expands the OTHERS into the actual choices -- that it represents. This new list of choice nodes is attached to -- the OTHERS node via the Others_Discrete_Choices field. The Case_Table -- contains all choices that have been given explicitly in the variant. function Find_Type_Name (N : Node_Id) return Entity_Id; -- Enter the identifier in a type definition, or find the entity already -- declared, in the case of the full declaration of an incomplete or -- private type. function Find_Type_Of_Object (Obj_Def : Node_Id) return Entity_Id; -- Get type entity for object referenced by Obj_Def procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id); -- Create a new float, and apply the constraint to obtain subtype of it procedure Freeze_Before (N : Node_Id; T : Entity_Id); -- Freeze T then Insert the generated Freeze nodes before the node N. procedure Inherit_Components (Parent_Type, Derived_Type : Entity_Id); -- Used by derived types and type extensions to copy components of Parent. procedure Integer_Type_Declaration (T : Entity_Id; Def : Node_Id); -- Create a new integer, and apply the constraint to obtain subtype of it procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id); -- Create new modular type. Verify that modulus is in bounds and is -- a power of two (implementation restriction). function In_Visible_Part (Scope_Id : Entity_Id) return Boolean; -- Determine whether a declaration occurs within the visible part of a -- package specification. The package must be on the scope stack, and the -- corresponding private part must not. procedure New_Binary_Operator (Op : Name_Id; Typ : Entity_Id); -- Create an abbreviated declaration for an operator, in order to -- materialize minimally operators on derived types. procedure Record_Extension (Parent_Type, Derived_Type : Entity_Id; Extension : Node_Id; N : Node_Id); -- Documentation needed for this subprogram ??? procedure Record_Type_Declaration (T : Entity_Id; N : Node_Id); -- Process record type declaration procedure Record_Type_Definition (Def : Node_Id; T : Entity_Id); -- Def is a record type definition node. This procedure analyzes the -- components in this record type definition. T is the entity for -- the enclosing type. It is provided so that its Has_Tasks flag -- can be set if any of the component have Has_Tasks set. -------------------------- -- Analyze_Declarations -- -------------------------- procedure Analyze_Declarations (L : List_Id) is D : Node_Id; Next_Node : Node_Id; Frozen : Boolean := False; Clear_Overload_Structures : constant Boolean := (Nkind (List_Parent (L)) /= N_Expression_Actions); -- This flag indicates whether we can clear the overload data structures -- between expressions. Normally we can clear them between declarations -- but the one exception arises when the list of declarations (called -- actions in this context) appears in an expression actions node, in -- which case we can't clear the overload data structures, since they -- may be in use by the outer expression context (the expression that -- contains the expression actions node). begin D := First (L); while Present (D) loop -- Complete analysis of declaration Analyze (D); -- Insert all N_Implicit_Type nodes representing implicit defining -- ids generated for the declaration just analyzed (N) before the -- declaration. (See comments in New_Implicit_Type for details.) -- In the case where we are processing a record declaration, delay -- inserting the N_Implicit_Type nodes until the record has been -- fully processed and then insert them in the Implicit_Types -- field of the N_Record_Definition node. Install_Implicit_Types (D); Next_Node := Next (D); if No (Next_Node) then -- At the end of a declarative part, freeze remaining entities -- declared in it. The end of the visible declarations of a -- package specification is not the end of a declarative part if -- private declarations are present. if not Frozen and then Nkind (List_Parent (L)) /= N_Component_List and then (Nkind (List_Parent (L)) /= N_Package_Specification or else L /= Visible_Declarations (List_Parent (L)) or else not List_Present (Private_Declarations (List_Parent (L)))) then Frozen := True; -- else it will be fluid for ever... Append_List (Freeze_All, L); end if; elsif Nkind (Next_Node) /= N_Subprogram_Body and then Nkind (Next_Node) /= N_Entry_Body and then Nkind (Next_Node) /= N_Package_Body and then Nkind (Next_Node) /= N_Protected_Body and then Nkind (Next_Node) /= N_Task_Body then null; -- Case of internally generated declaration elsif Analyzed (Next_Node) then null; -- A body that is not an instance nor an internally generated, -- freezes all entities so far. else Insert_List_After (D, Freeze_All); end if; D := Next (D); if Clear_Overload_Structures then Init_Interp; end if; end loop; end Analyze_Declarations; ---------------------------- -- Analyze_Implicit_Type -- ---------------------------- -- Nothing to do, since the only descendent is the entity representing -- the type, and this was analyzed when it the type was constructed. procedure Analyze_Implicit_Type (N : Node_Id) is begin null; end Analyze_Implicit_Type; -------------------------------- -- Analyze_Object_Declaration -- -------------------------------- procedure Analyze_Object_Declaration (N : Node_Id) is Id : constant Entity_Id := Defining_Identifier (N); E : constant Node_Id := Expression (N); T : Entity_Id; begin if Constant_Present (N) and then Present (Current_Entity (Id)) and then Scope (Current_Entity (Id)) = Current_Scope then Constant_Redeclaration (Id, N); else -- Enter the identifiers at the start to catch premature usage -- in the initialization. Enter_Name (Id); end if; T := Find_Type_Of_Object (Object_Definition (N)); -- If deferred constant, make sure context is appropriate if Constant_Present (N) and then No (E) then if (Ekind (Current_Scope) /= E_Package and then Ekind (Current_Scope) /= E_Generic_Package) or else In_Private_Part (Current_Scope) then Error_Msg_N ("invalid context for deferred constant declaration", N); Set_Constant_Present (N, False); -- In Ada 83, deferred constant must be of private type elsif Ada_83 then if Ekind (T) /= E_Private_Type and then Ekind (T) /= E_Limited_Private_Type then Error_Msg_N ("deferred constant must be of private type in Ada 83", N); end if; end if; end if; -- Install anonymous types before analyzing the expression -- to avoid mixing them with anonymous types created for this -- expression (for instance in the aggregate case) Install_Implicit_Types (N); -- Process initialization expression if present -- Is this check of Etype still needed? If so why??? if Present (E) then Analyze (E); Check_Initialization (T, E); Apply_Range_Check (E, T); end if; -- Check improper use of unconstrained subtype if Is_Unconstrained_Type (T) then if No (E) or else (Ada_83 and then not Constant_Present (N)) then Error_Msg_N ("unconstrained subtype not allowed", Object_Definition (N)); else -- Constrain the type with the expression size for -- declarations such as S : String := "literal"; -- Same thing has to be done with records and arrays. Expand_Subtype_From_Expr (N, T); T := Find_Type_Of_Object (Object_Definition (N)); end if; elsif Is_Class_Type (T) then if No (E) then Error_Msg_N ("initialization required in class-wide declaration ", N); else -- Define a Class subtype with a size constraint coming -- from the expression T := New_Class_Subtype (N, T); end if; elsif Is_Abstract (T) then Error_Msg_N ("type of object cannot be abstract", N); end if; -- Now establish the proper kind and type of the object. if Constant_Present (N) then Set_Ekind (Id, E_Constant); else Set_Ekind (Id, E_Variable); end if; Set_Etype (Id, T); Set_Is_Aliased (Id, Aliased_Present (N)); -- An object declaration freezes its type. If there are freezing -- actions to perform, analyze the freeze nodes, which are -- placed before the current declaration. if not Constant_Present (N) or else Present (Expression (N)) then Freeze_Before (N, Base_Type (T)); end if; end Analyze_Object_Declaration; ------------------- -- Freeze_Before -- ------------------- procedure Freeze_Before (N : Node_Id; T : Entity_Id) is Freeze_Nodes : constant List_Id := Freeze_Entity (T); F : Node_Id; begin F := First (Freeze_Nodes); if Present (F) then Insert_List_Before (N, Freeze_Nodes); while F /= N loop Analyze (F); F := Next (F); end loop; end if; end Freeze_Before; ---------------------------- -- Constant_Redeclaration -- ---------------------------- procedure Constant_Redeclaration (Id : Entity_Id; N : Node_Id) is E : constant Node_Id := Expression (N); Prev : constant Entity_Id := Current_Entity (Id); T : Entity_Id; begin T := Find_Type_Of_Object (Object_Definition (N)); if Ekind (Prev) /= E_Constant or else Present (Expression (Parent (Prev))) or else Etype (Prev) /= T then Enter_Name (Id); -- error message will follow. else Set_Full_Declaration (Prev, Id); Set_Is_Public (Id, Is_Public (Prev)); Set_Is_Internal (Id); Append_Entity (Id, Current_Scope); if Present (E) and then No (Etype (E)) then Analyze (E); Check_Initialization (T, E); end if; end if; end Constant_Redeclaration; -------------------------------- -- Analyze_Number_Declaration -- -------------------------------- procedure Analyze_Number_Declaration (N : Node_Id) is Id : constant Entity_Id := Defining_Identifier (N); E : constant Node_Id := Expression (N); T : Entity_Id; K : Entity_Kind := E_Constant; begin Analyze (E); -- Verify that the expression is static and universal T := Etype (E); if Is_Integer_Type (T) then K := E_Named_Integer; elsif Is_Real_Type (T) then K := E_Named_Real; else Error_Msg_N ("numeric type required for number declaration", N); T := Any_Type; end if; Resolve_Complete_Context (E, T); if not Is_Static_Expression (E) then Error_Msg_N ("static expression required for number declaration", N); end if; Enter_Name (Id); Set_Etype (Id, T); Set_Ekind (Id, K); end Analyze_Number_Declaration; ---------------------------- -- Install_Implicit_Types -- ---------------------------- procedure Install_Implicit_Types (N : Node_Id) is begin if Is_Empty_List (Implicit_Type_List) or else Nkind (N) = N_Component_Declaration then return; end if; Mark_Implicit_Private_Decls (Implicit_Type_List); -- Install Implicit types at the proper place either in the record -- definition itself or before the declaraction generating them if (Nkind (N) = N_Record_Definition) then Set_Implicit_Types (N, Implicit_Type_List); else Insert_List_Before (N, Implicit_Type_List); end if; Implicit_Type_List := New_List; end Install_Implicit_Types; ------------------------- -- Find_Type_Of_Object -- ------------------------- function Find_Type_Of_Object (Obj_Def : Node_Id) return Entity_Id is T : Entity_Id; begin if Nkind (Obj_Def) = N_Constrained_Array_Definition then -- Case of an anonymous array subtype T := Empty; Array_Type_Declaration (T, Obj_Def); else T := Process_Subtype (Obj_Def, Defining_Identifier (Parent (Obj_Def)), "type"); end if; return T; end Find_Type_Of_Object; -------------------------------- -- Analyze_Subtype_Indication -- -------------------------------- procedure Analyze_Subtype_Indication (N : Node_Id) is T : constant Node_Id := Subtype_Mark (N); R : constant Node_Id := Range_Expression (Constraint (N)); begin Analyze (T); Analyze (R); Set_Etype (N, Etype (R)); end Analyze_Subtype_Indication; -------------------------- -- Check_Initialization -- -------------------------- procedure Check_Initialization (T : Entity_Id; Exp : Node_Id) is begin if Is_Limited_Type (T) then Error_Msg_N ("cannot initialize entities of limited type", Exp); end if; Resolve_Complete_Context (Exp, T); end Check_Initialization; ------------------------------ -- Analyze_Type_Declaration -- ------------------------------ procedure Analyze_Type_Declaration (N : Node_Id) is Def : constant Node_Id := Type_Definition (N); T : Node_Id; begin T := Find_Type_Name (N); -- Elaborate the type definition according to kind, and generate -- susbsidiary (implicit) subtypes where needed. case Nkind (Def) is when N_Access_To_Subprogram_Definition => Access_Subprogram_Declaration (T, Def); when N_Access_To_Object_Definition => Access_Type_Declaration (T, Def); when N_Array_Type_Definition => Array_Type_Declaration (T, Def); when N_Derived_Type_Definition => Derived_Type_Declaration (T, N); when N_Enumeration_Type_Definition => Enumeration_Type_Declaration (T, Def); when N_Floating_Point_Definition => Floating_Point_Type_Declaration (T, Def); when N_Ordinary_Fixed_Point_Definition => Unimplemented (N, "fixed point type declaration"); when N_Signed_Integer_Type_Definition => Integer_Type_Declaration (T, Def); when N_Modular_Type_Definition => Modular_Type_Declaration (T, Def); when N_Record_Definition => Record_Type_Declaration (T, N); when others => Unimplemented (N, "declaration"); end case; Set_Is_Private_Type (T, Has_Private_Component (T)); Set_Is_Delayed (T, Is_Private_Type (T)); -- Install implicit types now to avoid to get mixed with anonymous -- types generated by the expansion of this declaration Install_Implicit_Types (N); end Analyze_Type_Declaration; -------------------- -- Find_Type_Name -- -------------------- function Find_Type_Name (N : Node_Id) return Entity_Id is Id : constant Entity_Id := Defining_Identifier (N); Prev : constant Entity_Id := Current_Entity (Id); New_Id : Entity_Id; begin -- Find incomplete declaration, if some was given. if Present (Prev) and then Scope (Prev) = Current_Scope then -- Previous declaration exists. Error if not incomplete/private case if not Is_Incomplete_Type (Prev) then Error_Msg_Sloc_1 := Sloc (Prev); Error_Msg_N ("invalid redeclaration of& declared on line #", Id); New_Id := Id; -- Case of full declaration of incomplete type elsif Ekind (Prev) = E_Incomplete_Type then -- Indicate that the incomplete declaration has a matching -- full declaration. The defining occurrence of the incomplete -- declaration remains the visible one, and the procedure -- Get_Full_Declaration dereferences it whenever the type is used. Set_Full_Declaration (Prev, Id); Append_Entity (Id, Current_Scope); Set_Is_Public (Id, Is_Public (Prev)); Set_Is_Internal (Id); New_Id := Id; -- Case of full declaration of private type else -- Place all semantic information on the first entity, which -- remains visible. Save private declaration in the new entity, -- to be swapped at the end of the private part. Copy_Node (Prev, Id); Set_Full_Declaration (Id, Prev); Set_Is_Private_Type (Prev, False); Set_Is_Limited_Type (Prev, False); Append_Entity (Id, Current_Scope); New_Id := Prev; if Nkind (Parent (Prev)) = N_Private_Extension_Declaration and then not (Abstract_Present (Parent (Prev))) and then Nkind (N) = N_Full_Type_Declaration and then Abstract_Present (Type_Definition (N)) then Error_Msg_N ("full view of non-abstract extension cannot be abstract", N); end if; end if; -- Verify that full declaration conforms to incomplete one if List_Present (Discriminant_Specifications (N)) and then Is_Incomplete_Type (Prev) then Discriminant_Redeclaration (Prev, Discriminant_Specifications (N)); elsif Is_Incomplete_Type (Prev) and then Has_Discriminants (Prev) then Error_Msg_N ("missing discriminants in full type declaration", N); end if; return New_Id; else -- New type declaration Enter_Name (Id); return Id; end if; end Find_Type_Name; --------------------- -- Process_Subtype -- --------------------- function Process_Subtype (S : Node_Id; Related_Id : Entity_Id := Empty; Suffix : Str := "") return Entity_Id is P : Node_Id; Def_Id : Entity_Id; Subtype_Mark_Id : Entity_Id; begin -- Case of constraint present, so that we have an N_Subtype_Indication -- node (this node is created only if constraints are present). if Nkind (S) = N_Subtype_Indication then Find_Type (Subtype_Mark (S)); P := Parent (S); Subtype_Mark_Id := Entity (Subtype_Mark (S)); if Nkind (P) = N_Subtype_Declaration then Def_Id := Defining_Identifier (P); elsif Nkind (P) = N_Derived_Type_Definition then Def_Id := Defining_Identifier (Parent (P)); else -- In the case of a constraint given on an array type, delay -- generating the implicit array subtype until any other -- implicit types, such as for the index constaint are -- generated. The defining identifier is passed as Empty -- to Constrain_Array and is created towards the end of -- that procedure. if Is_Array_Type (Subtype_Mark_Id) then Def_Id := Empty; else Def_Id := New_Implicit_Type (Sloc (S), Related_Id, Suffix); end if; end if; case Ekind (Subtype_Mark_Id) is -- If the type is a access type, the constraint applies to the -- type being accessed. Create the corresponding subtype of it, -- promote it to an implicit type, and return an access to it. when Access_Kind => Constrain_Access (Def_Id, S); when Array_Kind => Constrain_Array (Def_Id, S, Related_Id, Suffix); when Enumeration_Kind => Constrain_Enumeration (Def_Id, S); when Fixed_Kind => null; -- Constrain_Fixed (Def_Id, S); ??? when Float_Kind => null; -- Constrain_Float (Def_Id, S); ??? when Integer_Kind => Constrain_Integer (Def_Id, S); when Record_Kind | Incomplete_Kind => Constrain_Discriminated_Type (Def_Id, S); when Task_Kind | Protected_Kind => Constrain_Discriminated_Type (Def_Id, S); -- For concurrent types, the record value type carries -- the same discriminants, so when we constrain such a -- type we constrain the value type as well. declare T_Val : constant Entity_Id := Task_Value_Type ( Entity (Subtype_Mark (S))); T_Sub : Entity_Id; begin if Present (T_Val) then T_Sub := New_Implicit_Type (Sloc (S), Related_Id, "val"); Set_Ekind (T_Sub, E_Record_Subtype); Set_Etype (T_Sub, T_Val); Set_Esize (T_Sub, Uint_0); Set_Has_Discriminants (T_Sub, True); Set_Is_Constrained (T_Sub, True); Set_First_Entity (T_Sub, First_Entity (T_Val)); Set_Discriminant_Constraint (T_Sub, Discriminant_Constraint (Def_Id)); Set_Task_Value_Type (Def_Id, T_Sub); end if; end; when others => Error_Msg_N ("invalid subtype mark in subtype indication", S); end case; return Def_Id; -- Case of no constraints present else Find_Type (S); Check_Incomplete (S); return Entity (S); end if; end Process_Subtype; ---------------------- -- Check_Incomplete -- ---------------------- procedure Check_Incomplete (T : Entity_Id) is begin if Ekind (Entity (T)) = E_Incomplete_Type then Error_Msg_N ("invalid use of type before its full declaration", T); end if; end Check_Incomplete; ----------------------- -- Check_Completion -- ----------------------- procedure Check_Completion is E : Entity_Id; begin E := First_Entity (Current_Scope); while Present (E) loop if Is_Internal (E) then null; -- The following situation requires special handling: a child -- unit that appears in the context clause of the body of its -- parent: -- procedure Parent.Child (...); -- -- with Parent.Child; -- package body Parent is -- Here Parent.Child appears as a local entity, but should not -- be flagged as requiring completion, because it is a -- compilation unit. elsif Ekind (E) = E_Function or else Ekind (E) = E_Procedure then if not Has_Completion (E) and then not Is_Abstract (E) and then Nkind (Parent (Get_Declaration_Node (E))) /= N_Compilation_Unit and then Chars (E) /= Name_uSize and then Chars (E) /= Name_uEquality then Error_Msg_N ("missing body for subprogram specification", Parent (E)); end if; elsif Ekind (E) = E_Package then if Unit_Requires_Body (E) and then not Has_Completion (E) and then Nkind (Parent (Get_Declaration_Node (E))) /= N_Compilation_Unit then Error_Msg_N ("missing body for package declaration", Parent (E)); end if; elsif Ekind (E) = E_Incomplete_Type and then No (Full_Declaration (E)) then Error_Msg_N ("missing full declaration for type", Parent (E)); elsif (Ekind (E) = E_Task_Type or else Ekind (E) = E_Protected_Type) and then not Has_Completion (E) and then not Is_Internal (E) then Error_Msg_N ("missing full declaration for type", Parent (E)); elsif Ekind (E) = E_Constant and then Ekind (Etype (E)) = E_Task_Type and then not Has_Completion (Etype (E)) then Error_Msg_N ("missing full declaration for task", Parent (E)); elsif Ekind (E) = E_Protected_Object and then not Has_Completion (Etype (E)) then Error_Msg_N ("missing full declaration for protected object", Parent (E)); end if; E := Next_Entity (E); end loop; end Check_Completion; --------------------------------- -- Analyze_Subtype_Declaration -- --------------------------------- procedure Analyze_Subtype_Declaration (N : Node_Id) is Id : Entity_Id; T : Entity_Id; begin Id := Defining_Identifier (N); Enter_Name (Id); T := Process_Subtype (Subtype_Indication (N), Id, "parent"); Set_Is_Private_Type (Id, Has_Private_Component (Etype (Id))); Set_Is_Limited_Type (Id, Is_Limited_Type (Etype (Id))); Set_Is_Delayed (T, Is_Private_Type (T)); Set_Has_Tasks (Id, Has_Tasks (T)); -- In the case where there is no constraint given in the subtype -- indication, Process_Subtype just returns the Subtype_Mark, -- so its semantic attributes must be established here. if Nkind (Subtype_Indication (N)) /= N_Subtype_Indication then Set_Etype (Id, Base_Type (T)); case Ekind (T) is when Array_Kind => Set_Ekind (Id, E_Array_Subtype); Set_First_Index (Id, First_Index (T)); Set_Component_Type (Id, Component_Type (T)); Set_Is_Constrained (Id, Is_Constrained (T)); Set_Esize (Id, Uint_0); when Enumeration_Kind => Set_Ekind (Id, E_Enumeration_Subtype); Set_Scalar_Range (Id, Scalar_Range (T)); Set_Parent_Subtype (Id, T); Set_Esize (Id, Esize (T)); when Fixed_Kind => null; -- Set_Ekind (Id, E_Fixed_Subtype); ??? when Float_Kind => Set_Ekind (Id, E_Float_Subtype); Set_Scalar_Range (Id, Scalar_Range (T)); Set_Parent_Subtype (Id, T); Set_Esize (Id, Esize (T)); when Signed_Integer_Kind => Set_Ekind (Id, E_Integer_Subtype); Set_Scalar_Range (Id, Scalar_Range (T)); Set_Parent_Subtype (Id, T); Set_Esize (Id, Esize (T)); when Modular_Kind => Set_Ekind (Id, E_Modular_Subtype); Set_Scalar_Range (Id, Scalar_Range (T)); Set_Parent_Subtype (Id, T); Set_Esize (Id, Esize (T)); Set_Modulus (Id, Modulus (T)); when Record_Kind => Set_Ekind (Id, E_Record_Subtype); Set_Esize (Id, Uint_0); Set_Has_Discriminants (Id, Has_Discriminants (T)); Set_Is_Constrained (Id, Is_Constrained (T)); Set_First_Entity (Id, First_Entity (T)); Set_Discriminant_Constraint (Id, Discriminant_Constraint (T)); when Private_Kind => Unimplemented (N, "subtypes of private types"); when Access_Kind => Set_Ekind (Id, E_Access_Subtype); Set_Directly_Designated_Type (Id, Designated_Type (T)); Set_Esize (Id, UI_From_Int (System_Address_Size)); when others => Compiler_Abort; end case; end if; end Analyze_Subtype_Declaration; ----------------------- -- Constrain_Integer -- ----------------------- procedure Constrain_Integer (Def_Id : Node_Id; S : Node_Id) is T : constant Node_Id := Entity (Subtype_Mark (S)); C : constant Node_Id := Constraint (S); R : Node_Id; begin Set_Ekind (Def_Id, E_Integer_Subtype); if Nkind (C) /= N_Range_Constraint then Error_Msg_N ("expect range constraint for integer type", C); Set_Etype (Def_Id, Any_Type); return; end if; R := Range_Expression (C); Analyze (R); Resolve_Complete_Context (R, T); Set_Scalar_Range (Def_Id, R); Set_Etype (Def_Id, Base_Type (T)); Set_Parent_Subtype (Def_Id, T); Set_Esize (Def_Id, Esize (T)); end Constrain_Integer; --------------------------- -- Constrain_Enumeration -- --------------------------- procedure Constrain_Enumeration (Def_Id : Node_Id; S : Node_Id) is T : constant Entity_Id := Entity (Subtype_Mark (S)); C : constant Node_Id := Constraint (S); R : Node_Id; begin Set_Ekind (Def_Id, E_Enumeration_Subtype); if Nkind (C) /= N_Range_Constraint then Error_Msg_N ("expect range constraint for enumeration type", C); Set_Etype (Def_Id, Any_Type); return; end if; R := Range_Expression (C); Analyze (R); Resolve_Complete_Context (R, T); Set_Scalar_Range (Def_Id, R); Set_First_Literal (Def_Id, Entity (Low_Bound (R))); Set_Etype (Def_Id, Base_Type (T)); Set_Esize (Def_Id, Esize (T)); end Constrain_Enumeration; ------------------------------------- -- Floating_Point_Type_Declaration -- ------------------------------------- -- ??? This procedure is incomplete. It does not yet process bounds -- if given, and does not set the bounds in the resulting float type. procedure Floating_Point_Type_Declaration (T : Entity_Id; Def : Node_Id) is Digs : constant Node_Id := Digits_Expression (Def); Digs_Val : Uint; Implicit_Base : constant Entity_Id := New_Implicit_Type (Sloc (T), T, "base"); Base_Type : Entity_Id; -- Find if given digits value allows derivation from specified type function Can_Derive_From (E : Entity_Id) return Boolean is begin return UI_Le (Digs_Val, Expr_Value (Digits_Expression (Type_Definition (Parent (E))))); end Can_Derive_From; -- Start of processing for floattype declaration begin if Present (Real_Range_Specification (Def)) then Unimplemented (Real_Range_Specification (Def), "real range specification"); end if; Analyze (Digs); Resolve_Complete_Context (Digs, Any_Integer); if not (Is_Integer_Type (Etype (Digs))) then Error_Msg_N ("digits expression must be of integer type", Def); elsif not Is_Static_Expression (Digs) then Error_Msg_N ("digits expression must be static", Def); end if; Digs_Val := Expr_Value (Digs); if Can_Derive_From (Standard_Short_Float) then Base_Type := Standard_Short_Float; elsif Can_Derive_From (Standard_Float) then Base_Type := Standard_Float; elsif Can_Derive_From (Standard_Long_Float) then Base_Type := Standard_Long_Float; elsif Can_Derive_From (Standard_Long_Long_Float) then Base_Type := Standard_Long_Long_Float; else Base_Type := Standard_Long_Long_Float; Error_Msg_N ("digits expression out of range", Def); end if; Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Type)); Set_Ekind (Implicit_Base, E_Float_Type); Set_Etype (Implicit_Base, Implicit_Base); Set_Esize (Implicit_Base, Esize (Base_Type)); Set_Ekind (T, E_Float_Subtype); Set_Etype (T, Implicit_Base); Set_Esize (T, Esize (Implicit_Base)); Set_Scalar_Range (T, Scalar_Range (Base_Type)); Set_Parent_Subtype (T, Implicit_Base); end Floating_Point_Type_Declaration; --------------------------- -- Is_Unconstrained_Type -- --------------------------- function Is_Unconstrained_Type (E : Entity_Id) return Boolean is K : constant Entity_Kind := Ekind (E); begin if Is_Constrained (E) then return False; elsif K in Array_Kind then return not Is_Constrained (E); elsif K = E_Record_Type or else (Is_Incomplete_Type (E) and then No (Full_Declaration (E))) then if Has_Discriminants (E) then if No (Discriminant_Default_Value (First_Discriminant (E))) then return True; end if; end if; end if; return False; end Is_Unconstrained_Type; ------------------------------ -- Integer_Type_Declaration -- ------------------------------ procedure Integer_Type_Declaration (T : Entity_Id; Def : Node_Id) is Lo : constant Node_Id := Low_Bound (Def); Hi : constant Node_Id := High_Bound (Def); Implicit_Base : constant Entity_Id := New_Implicit_Type (Sloc (T), T, "base"); Base_Type : Entity_Id; Lo_Val : Uint; Hi_Val : Uint; -- Determine whether given bounds allow derivation from specified type function Can_Derive_From (E : Entity_Id) return Boolean is begin return UI_Ge (Lo_Val, Expr_Value (Type_Low_Bound (E))) and then UI_Le (Hi_Val, Expr_Value (Type_High_Bound (E))); end Can_Derive_From; -- If the bounds are literals, their type is the chosen base type, -- and the not the largest integer type that would otherwise be -- chosen for a literal in a non-specific context. If the bounds -- are constants of some other integer type, convert them explicitly -- to the new type. procedure Set_Type_Bound (Bound : Node_Id) is NewB : Node_Id; begin if Nkind (Bound) = N_Integer_Literal then Set_Etype (Bound, Implicit_Base); else NewB := New_Node (N_Type_Conversion, Sloc (Bound)); Set_Expression (NewB, New_Copy (Bound)); Set_Subtype_Mark (NewB, Implicit_Base); Set_Etype (NewB, Implicit_Base); Set_Unchecked_Conversion (NewB, True); Rewrite_Substitute_Tree (Bound, NewB); Analyze (NewB); end if; end Set_Type_Bound; -- Start of processing for Integer_Type_Declaration begin Analyze (Lo); Analyze (Hi); Resolve_Complete_Context (Lo, Any_Integer); Resolve_Complete_Context (Hi, Any_Integer); -- If a range constraint is used as an integer type definition, each -- bound of the range must be defined by a static expression of some -- integer type, but the two bounds need not have the same integer type. -- (Negative bounds are allowed.) [LRM 3.5.4] if not (Is_Integer_Type (Etype (Lo)) and then Is_Integer_Type (Etype (Hi))) then Error_Msg_N ("integer type definition bounds must be of integer type", Def); elsif not (Is_Static_Expression (Lo) and then Is_Static_Expression (Hi)) then Error_Msg_N ("integer type definition bounds must be static", Def); end if; Lo_Val := Expr_Value (Lo); Hi_Val := Expr_Value (Hi); if Can_Derive_From (Standard_Short_Short_Integer) then Base_Type := Standard_Short_Short_Integer; elsif Can_Derive_From (Standard_Short_Integer) then Base_Type := Standard_Short_Integer; elsif Can_Derive_From (Standard_Integer) then Base_Type := Standard_Integer; elsif Can_Derive_From (Standard_Long_Integer) then Base_Type := Standard_Long_Integer; elsif Can_Derive_From (Standard_Long_Long_Integer) then Base_Type := Standard_Long_Long_Integer; else Base_Type := Standard_Long_Long_Integer; Error_Msg_N ("integer type definition bounds out of range", Def); end if; Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Type)); Set_Ekind (Implicit_Base, E_Integer_Type); Set_Etype (Implicit_Base, Base_Type); Set_Esize (Implicit_Base, Esize (Base_Type)); Set_Ekind (T, E_Integer_Subtype); Set_Etype (T, Implicit_Base); Set_Esize (T, Esize (Implicit_Base)); Set_Scalar_Range (T, Def); Set_Parent_Subtype (T, Implicit_Base); Set_Type_Bound (Lo); Set_Type_Bound (Hi); end Integer_Type_Declaration; ------------------------------ -- Modular_Type_Declaration -- ------------------------------ procedure Modular_Type_Declaration (T : Entity_Id; Def : Node_Id) is Mod_Expr : constant Node_Id := Expression (Def); M_Val : Uint; M : Uint; Bits : Nat; begin Set_Etype (T, T); Set_Ekind (T, E_Modular_Type); Analyze (Mod_Expr); Resolve_Complete_Context (Mod_Expr, Any_Integer); if not Is_Static_Expression (Mod_Expr) then Error_Msg_N ("expression in modular type definition must be static", Mod_Expr); M_Val := UI_Power (System_Max_Binary_Modulus_Power); else M_Val := Expr_Value (Mod_Expr); end if; if UI_Le (M_Val, Uint_1) then Error_Msg_N ("modulus value must be greater than 1", Mod_Expr); M_Val := UI_Power (System_Max_Binary_Modulus_Power); end if; Set_Modulus (T, M_Val); -- Create bounds for the modular type based on the modulus given in -- the type declaration and then analyze and resolve those bounds. Set_Scalar_Range (T, Make_Range (Sloc (Mod_Expr), Low_Bound => Make_Integer_Literal (Sloc (Mod_Expr), Intval => Uint_0), High_Bound => Make_Integer_Literal (Sloc (Mod_Expr), Intval => UI_Difference (M_Val, Uint_1)))); Analyze (Low_Bound (Scalar_Range (T))); Analyze (High_Bound (Scalar_Range (T))); Resolve_Complete_Context (Low_Bound (Scalar_Range (T)), T); Resolve_Complete_Context (High_Bound (Scalar_Range (T)), T); -- Loop through powers of 2 to find number of bits required for Bits in Int range 1 .. System_Max_Binary_Modulus_Power loop -- Binary case if UI_Eq (M_Val, UI_Power (Bits)) then Set_Esize (T, UI_From_Int (Bits)); return; -- Non-binary case elsif UI_Lt (M_Val, UI_Power (Bits)) then if Bits > System_Max_Nonbinary_Modulus_Power then Error_Msg_Uint_1 := UI_From_Int (System_Max_Nonbinary_Modulus_Power); Error_Msg_N ("nonbinary modulus exceeds limit (2'*'*^ - 1)", Mod_Expr); Set_Esize (T, UI_From_Int (System_Max_Binary_Modulus_Power)); return; else -- In the non-binary case, we must have the actual size -- of the object be at least enough to hold the square -- of the modulus. Set_Esize (T, UI_From_Int (Bits * 2)); return; end if; end if; end loop; -- If we fall through, then the size exceed System.Max_Binary_Modulus -- so we just signal an error and set the maximum size. Error_Msg_Uint_1 := UI_From_Int (System_Max_Binary_Modulus_Power); Error_Msg_N ("modulus exceeds limit (2'*'*^)", Mod_Expr); Set_Esize (T, UI_From_Int (System_Max_Binary_Modulus_Power)); end Modular_Type_Declaration; ---------------------------------- -- Enumeration_Type_Declaration -- ---------------------------------- procedure Enumeration_Type_Declaration (T : Entity_Id; Def : Node_Id) is Ev : Uint; L : Node_Id; Int_Lit : Node_Id; R_Node, B_Node : Node_Id; Table_Obj : Entity_Id; Table_Type : Entity_Id; begin -- Create identifier node representing lower bound B_Node := New_Node (N_Identifier, Sloc (Def)); L := First (Literals (Def)); Set_Chars (B_Node, Chars (L)); Set_Entity (B_Node, L); Set_Etype (B_Node, T); Set_Is_Static (B_Node, True); Set_Is_Evaluated (B_Node, True); R_Node := New_Node (N_Range, Sloc (Def)); Set_Low_Bound (R_Node, B_Node); Set_Ekind (T, E_Enumeration_Type); Set_First_Literal (T, L); Set_Etype (T, T); Ev := Uint_0; -- Loop through literals of enumeration type while Present (L) loop Set_Ekind (L, E_Enumeration_Literal); Set_Etype (L, T); Set_Enumeration_Pos (L, Ev); Set_Enumeration_Rep (L, Ev); New_Overloaded_Entity (L); if Nkind (L) = N_Defining_Character_Literal then Set_Ekind (T, E_Character_Type); end if; Ev := UI_Sum (Ev, Uint_1); L := Next (L); end loop; -- Now create a node representing upper bound B_Node := New_Node (N_Identifier, Sloc (Def)); Set_Chars (B_Node, Chars (Last (Literals (Def)))); Set_Entity (B_Node, Last (Literals (Def))); Set_Etype (B_Node, T); Set_Is_Static (B_Node, True); Set_Is_Evaluated (B_Node, True); Set_High_Bound (R_Node, B_Node); Set_Scalar_Range (T, R_Node); Set_Esize (T, Determine_Enum_Size (T)); -- Create two defining occurrences corresponding to a enumeration -- table constaining the literal names and its type. This table is -- used in conjunction with calls to 'Image on enumeration values. -- This table filled in by the back-end. Table_Obj := Make_Defining_Identifier (Sloc (Def), Chars => New_External_Name (Chars (T), "table")); Set_Is_Internal (Table_Obj); Append_Entity (Table_Obj, Current_Scope); Set_Current_Entity (Table_Obj); Table_Type := New_Implicit_Type (Sloc (Def), T, "enum_table"); Set_Ekind (Table_Type, E_Enum_Table_Type); Set_Etype (Table_Obj, Table_Type); Set_Ekind (Table_Obj, E_Variable); Set_Public_Status (Table_Obj); Set_Etype (Table_Type, Table_Type); Set_Public_Status (Table_Type); Set_Component_Type (Table_Type, Standard_A_String); Set_First_Index (Table_Type, First (New_List_1 ( New_Occurrence_Of (Standard_Positive, Sloc (Def))))); Int_Lit := New_Node (N_Integer_Literal, Sloc (Def)); Set_Intval (Int_Lit, Enumeration_Pos (Entity (Type_High_Bound (T)))); Set_Etype (Int_Lit, Standard_Integer); Set_Is_Static (Int_Lit, True); Set_Table_High_Bound (Table_Type, Int_Lit); Set_Lit_Name_Table (T, Table_Obj); end Enumeration_Type_Declaration; ------------------------- -- Determine_Enum_Size -- ------------------------- function Determine_Enum_Size (T : Entity_Id) return Uint is Count : Nat := 0; Lit : Entity_Id; begin Lit := First_Literal (T); while Present (Lit) loop Count := Count + 1; Lit := Next_Literal (Lit); end loop; if Count <= 2 ** 8 then return Uint_8; elsif Count <= 2 ** 16 then return Uint_16; else return Uint_32; end if; end Determine_Enum_Size; ---------------------------- -- Array_Type_Declaration -- ---------------------------- procedure Array_Type_Declaration (T : in out Entity_Id; Def : Node_Id) is Element_Type : Entity_Id; Component_Def : constant Node_Id := Subtype_Indication (Def); Implicit_Base : Entity_Id; Index : Node_Id; Related_Id : Entity_Id := Empty; Nb_Index : Nat; begin if Nkind (Def) = N_Constrained_Array_Definition then Index := First (Discrete_Subtype_Definitions (Def)); -- Find proper names for the implicit types which may be public. -- in case of anonymous arrays we use the name of the first object -- of that type as prefix. if No (T) then Related_Id := Defining_Identifier (Parent (Def)); else Related_Id := T; end if; else Index := First (Subtype_Marks (Def)); end if; Nb_Index := 1; while Present (Index) loop Analyze (Index); Make_Index (Index, Related_Id, Nb_Index); Index := Next_Index (Index); Nb_Index := Nb_Index + 1; end loop; Element_Type := Process_Subtype (Component_Def, Related_Id, "component"); -- Constrained array case if Nkind (Def) = N_Constrained_Array_Definition then -- Establish Implicit_Base as unconstrained base type Implicit_Base := New_Implicit_Type (Sloc (Def), Related_Id, "base"); Set_Ekind (Implicit_Base, E_Array_Type); Set_Esize (Implicit_Base, Uint_0); Set_Etype (Implicit_Base, Implicit_Base); Set_Scope (Implicit_Base, Current_Scope); if No (T) then T := New_Implicit_Type (Sloc (Def), Related_Id); end if; -- The constrained array type is a subtype of the unconstrained one Set_Ekind (T, E_Array_Subtype); Set_Esize (T, Uint_0); Set_Etype (T, Implicit_Base); Set_Scope (T, Current_Scope); Set_Is_Constrained (T, True); Set_First_Index (T, First (Discrete_Subtype_Definitions (Def))); -- Complete setup of implicit base type Set_First_Index (Implicit_Base, First_Index (T)); Set_Component_Type (Implicit_Base, Element_Type); Set_Has_Tasks (Implicit_Base, Has_Tasks (Element_Type)); -- Unconstrained array case else Set_Ekind (T, E_Array_Type); Set_Esize (T, Uint_0); Set_Etype (T, T); Set_Scope (T, Current_Scope); Set_First_Index (T, First (Subtype_Marks (Def))); end if; Set_Component_Type (T, Element_Type); Set_Has_Tasks (T, Has_Tasks (Element_Type)); if Aliased_Present (Def) then Set_Is_Aliased (T); Set_Is_Aliased (Etype (T)); end if; if Number_Dimensions (T) = 1 then New_Binary_Operator (Name_Op_Concat, T); end if; -- In the case of an unconstrained array the parser has already -- verified that all the indices are unconstrained but we still -- need to make sure that the element type is constrained. if Is_Unconstrained_Type (Element_Type) then Error_Msg_N ("unconstrained element type in array declaration ", Component_Def); elsif Is_Abstract (Element_Type) then Error_Msg_N ("The type of a component cannot be abstract ", Component_Def); end if; Set_Is_Limited_Type (T, Is_Limited_Type (Element_Type)); end Array_Type_Declaration; ---------------- -- Make_Index -- ---------------- procedure Make_Index (I : Node_Id; Related_Id : Entity_Id := Empty; Postfix : Nat := 1) is L : Entity_Id; -- Type of low bound of range H : Entity_Id; -- Type of high bound of range R : Node_Id; T : Entity_Id; Def_Id : Entity_Id; begin -- For a discrete range used in a constrained array definition and -- defined by a range, an implicit conversion to the predefined type -- INTEGER is assumed if each bound is either a numeric literal, a named -- number, or an attribute, and the type of both bounds (prior to the -- implicit conversion) is the type universal_integer. Otherwise, both -- bounds must be of the same discrete type, other than universal -- integer; this type must be determinable independently of the -- context, but using the fact that the type must be discrete and that -- both bounds must have the same type. -- Character literals also have a universal type in the absence of -- of additional context, and are resolved to Standard_Character. if Nkind (I) = N_Range then -- The index is given by a range constraint. The bounds are known -- to be of a consistent type. L := Etype (Low_Bound (I)); H := Etype (High_Bound (I)); if L = Universal_Integer and H = Universal_Integer then T := Standard_Integer; elsif L = Universal_Integer then T := H; elsif L = Any_Character and then H = Any_Character then T := Standard_Character; else T := L; end if; R := I; Resolve_Complete_Context (R, T); elsif Nkind (I) = N_Subtype_Indication then -- The index is given by a subtype with a range constraint. T := Base_Type (Entity (Subtype_Mark (I))); R := Range_Expression (Constraint (I)); Resolve_Complete_Context (R, T); elsif Nkind (I) = N_Attribute_Reference then -- The parser guarantees that the attribute is a RANGE attribute Analyze (I); T := Etype (I); Resolve_Complete_Context (I, T); R := I; -- If none of the above, must be a subtype (nothing to do) else if not Is_Name (I) or else not Is_Type (Entity (I)) then Error_Msg_N ("invalid subtype mark in discrete range ", I); Set_Etype (I, Any_Integer); end if; return; end if; if not Is_Discrete_Type (T) then Error_Msg_N ("discrete type required for range", I); Set_Etype (I, Any_Type); return; elsif T = Any_Type then Set_Etype (I, Any_Type); return; end if; Def_Id := New_Implicit_Type (Sloc (I), Related_Id, "index_", Postfix); Set_Etype (Def_Id, Base_Type (T)); if Is_Integer_Type (T) then Set_Ekind (Def_Id, E_Integer_Subtype); else Set_Ekind (Def_Id, E_Enumeration_Subtype); end if; Set_Esize (Def_Id, Esize (T)); Set_Scalar_Range (Def_Id, R); Set_Parent_Subtype (Def_Id, T); Set_Etype (I, Def_Id); end Make_Index; --------------------- -- Constrain_Array -- --------------------- procedure Constrain_Array (Def_Id : in out Entity_Id; SI : Node_Id; Related_Id : Entity_Id; Suffix : Str) is T : Entity_Id; C : constant Node_Id := Constraint (SI); Number_Of_Constraints : Nat := 0; Index : Node_Id; S : Entity_Id; begin if Nkind (C) /= N_Index_Or_Discriminant_Constraint then Error_Msg_N ("incorrect constraint given for array type", C); return; end if; T := Entity (Subtype_Mark (SI)); if Ekind (T) in Access_Kind then T := Designated_Type (T); end if; -- If an index constraint follows a subtype mark in a subtype indication -- then the type or subtype denoted by the subtype mark must not already -- impose an index constraint. The subtype mark must denote either an -- unconstrained array type or an access type whose designated type -- is such an array type... [LRM 3.6.1] if Is_Constrained (T) then Error_Msg_N ("array type is already constrained", Subtype_Mark (SI)); return; end if; S := First (Constraints (C)); while Present (S) loop Number_Of_Constraints := Number_Of_Constraints + 1; S := Next (S); end loop; -- In either case, the index constraint must provide a discrete range -- for each index of the array type and the type of each discrete range -- must be the same as that of the corresponding index. [LRM 3.6.1] if Number_Of_Constraints /= Number_Dimensions (T) then Error_Msg_NE ("incorrect no. of index constraints for type&", C, T); return; end if; S := First (Constraints (C)); Index := First_Index (T); Analyze (Index); -- Apply constraints to each index type for I in 1 .. Number_Of_Constraints loop Constrain_Index (Index, S, Related_Id, Suffix, I); Index := Next (Index); S := Next (S); end loop; if No (Def_Id) then Def_Id := New_Implicit_Type (Sloc (SI), Related_Id, Suffix); end if; Set_Ekind (Def_Id, E_Array_Subtype); Set_Esize (Def_Id, Uint_0); Set_Etype (Def_Id, Base_Type (T)); Set_First_Index (Def_Id, First (Constraints (C))); Set_Component_Type (Def_Id, Component_Type (T)); Set_Has_Tasks (Def_Id, Has_Tasks (T)); Set_Is_Constrained (Def_Id); end Constrain_Array; --------------------- -- Constrain_Index -- --------------------- procedure Constrain_Index (Index : Node_Id; S : Node_Id; Related_Id : Entity_Id; Suffix : Str; Postfix : Nat) is Def_Id : Entity_Id; R : Node_Id; T : constant Entity_Id := Etype (Index); begin if Nkind (S) = N_Range or else Nkind (S) = N_Attribute_Reference then -- A Range attribute will transformed into N_Range by Resolve. Analyze (S); Set_Etype (S, T); R := S; Resolve_Complete_Context (R, T); if not (Covers (T, Etype (Low_Bound (S))) or else Covers (Etype (Low_Bound (S)), T) or else Covers (T, Etype (High_Bound (S))) or else Covers (Etype (High_Bound (S)), T)) then Error_Msg_NE ("invalid index constraint for&", S, Index); end if; elsif Nkind (S) = N_Subtype_Indication then Analyze (Subtype_Mark (S)); R := Range_Expression (Constraint (S)); Analyze (R); if Base_Type (Entity (Subtype_Mark (S))) /= Base_Type (T) then Error_Msg_NE ("invalid index constraint for&", R, Index); Set_Etype (S, Any_Type); return; else Resolve_Complete_Context (R, T); end if; elsif Is_Name (S) then -- Subtype_Mark Analyze (S); if Base_Type (Entity (S)) /= Base_Type (T) then Error_Msg_NE ("invalid index constraint for&", S, Index); end if; -- If the constraint is a subtype mark, there are no anonymous -- subtypes to construct. return; else Error_Msg_N ("invalid index constraint", S); return; end if; Def_Id := New_Implicit_Type (Sloc (S), Related_Id, Suffix, Postfix); Set_Etype (Def_Id, Base_Type (T)); if Is_Integer_Type (T) then Set_Ekind (Def_Id, E_Integer_Subtype); else Set_Ekind (Def_Id, E_Enumeration_Subtype); end if; Set_Esize (Def_Id, Esize (T)); Set_Scalar_Range (Def_Id, R); Set_Parent_Subtype (Def_Id, T); Set_Etype (S, Def_Id); end Constrain_Index; ----------------------------- -- Record_Type_Declaration -- ----------------------------- procedure Record_Type_Declaration (T : Entity_Id; N : Node_Id) is Def : constant Node_Id := Type_Definition (N); begin -- Records constitute a scope for the component declarations within. -- The scope is created prior to the processing of these declarations. -- Discriminants are processed first, so that they are visible when -- processing the other components. The Ekind of the record type itself -- is set to E_Record_Type (subtypes appear as E_Record_Subtype). -- If an incomplete or private type declaration was already given for -- the type, then this scope already exists, and the discriminants have -- been declared within. We must verify that the full declaration -- matches the incomplete one. New_Scope (T); -- Enter record scope Set_Is_Tagged_Type (T, Tagged_Present (Def)); -- Type is abstract if full declaration carries keyword, or if -- previous partial view did. Set_Is_Abstract (T, Is_Abstract (T) or else Abstract_Present (Def)); -- If an incomplete or private type declaration was already given for -- the type, the discriminants have been declared. Else process them now if not Is_Incomplete_Type (T) then if List_Present (Discriminant_Specifications (N)) then Process_The_Discriminants (N); end if; elsif Has_Discriminants (T) then -- Make the discriminants visible to component declarations. declare D : Entity_Id := First_Discriminant (T); Prev : Entity_Id; begin while Present (D) loop Prev := Current_Entity (D); Set_Current_Entity (D); Set_Is_Directly_Visible (D); Set_Homonym (D, Prev); D := Next_Discriminant (D); end loop; end; end if; Set_Ekind (T, E_Record_Type); Set_Etype (T, T); Set_Esize (T, Uint_0); Record_Type_Definition (Def, T); if Tagged_Present (Def) then Make_Class_Type (T); Set_Primitive_Operations (T, New_Elmt_List); end if; End_Scope; -- Exit record scope end Record_Type_Declaration; ------------------------------- -- Process_The_Discriminants -- ------------------------------- procedure Process_The_Discriminants (N : Node_Id) is Id : Node_Id; Discr : Node_Id; Discr_Type : Entity_Id; Default_Present : Boolean := False; Default_Not_Present : Boolean := False; D_Minal : Entity_Id; Elist : Elist_Id; begin -- A composite type other than an array type can have discriminants. -- Discriminants of non-limited types must have a discrete type. -- On entry, the current scope is the composite type. -- The discriminants are initially entered into the scope of the type -- via Enter_Name with the default Ekind of E_Void to prevent premature -- use, as explained at the end of this procedure. Elist := New_Elmt_List; Discr := First (Discriminant_Specifications (N)); while Present (Discr) loop Enter_Name (Defining_Identifier (Discr)); if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then Discr_Type := Access_Definition (Discriminant_Type (Discr)); if Ada_83 then Error_Msg_N ("Access definition not supported in Ada83", Discr); elsif not Is_Limited_Type (Current_Scope) then Error_Msg_N ("Only limited types can have access discriminants", Discr); end if; else Analyze (Discriminant_Type (Discr)); Discr_Type := Etype (Discriminant_Type (Discr)); if not Is_Discrete_Type (Discr_Type) then Error_Msg_N ("discriminants must have a discrete type", Discriminant_Type (Discr)); end if; end if; Set_Etype (Defining_Identifier (Discr), Discr_Type); -- If a discriminant specification includes the assignment compound -- delimiter followed by an expression,the expression is the default -- expression of the discriminant; the default expression must be of -- the type of the discriminant. [LRM 3.7.1] if Present (Expression (Discr)) then Analyze (Expression (Discr)); Resolve_Complete_Context (Expression (Discr), Discr_Type); Default_Present := True; Append_Elmt (Expression (Discr), Elist); -- Tag the defining identifiers for the discriminants with their -- corresponding default expressions from the tree. Set_Discriminant_Default_Value (Defining_Identifier (Discr), Expression (Discr)); else Default_Not_Present := True; end if; Discr := Next (Discr); end loop; -- An element list consisting of the default expressions of the -- discriminants is constructed in the above loop and used to set -- the Discriminant_Constraint attribute for the type. If an object -- is declared of this (record or task) type without any explicit -- discriminant constraint given, this element list will form the -- actual parameters for the corresponding initialization procedure -- for the type. Set_Discriminant_Constraint (Current_Scope, Elist); -- Default expressions must be provided either for all or for none -- of the discriminants of a discriminant part. [LRM 3.7.1] if Default_Present and Default_Not_Present then Error_Msg_N ("incomplete specification of defaults for discriminants", N); end if; -- The use of the name of a discriminant is not allowed in default -- expressions of a discriminant part if the specification of the -- discriminant is itself given in the discriminant part. [LRM 3.7.1] -- To detect this, the discriminant names are entered initially with an -- Ekind of E_Void (which is the default Ekind given by Enter_Name). Any -- attempt to use a void entity (for example in an expression that is -- type-checked) produces the error message: premature usage. Now after -- completing the semantic analysis of the discriminant part, we can set -- the Ekind of all the discriminants appropriately. Discr := First (Discriminant_Specifications (N)); while Present (Discr) loop Id := Defining_Identifier (Discr); Set_Ekind (Id, E_Discriminant); -- Initialize the Original_Record_Component to the entity itself -- the New_Copy call in Build_Derived_Type will automatically -- propagate the right value to descendants Set_Original_Record_Component (Id, Id); -- Create discriminal, that is to say the associated entity -- to be used in initialization procedures for the type, -- in which a discriminal is a formal parameter whose actual -- is the value of the corresponding discriminant constraint. -- Discriminals are not used during semantic analysis, and are -- not fully defined entities until expansion. Thus they are not -- given a scope until intialization procedures are built. D_Minal := Make_Defining_Identifier (Sloc (N), New_Internal_Name ("discriminal")); Set_Ekind (D_Minal, E_In_Parameter); Set_Etype (D_Minal, Etype (Id)); Set_Discriminal (Id, D_Minal); Discr := Next (Discr); end loop; Set_Has_Discriminants (Current_Scope); end Process_The_Discriminants; -------------------------------- -- Discriminant_Redeclaration -- -------------------------------- procedure Discriminant_Redeclaration (T : Entity_Id; D_List : List_Id) is begin null; -- For now ??? end Discriminant_Redeclaration; ---------------------------- -- Record_Type_Definition -- ---------------------------- procedure Record_Type_Definition (Def : Node_Id; T : Entity_Id) is Anon_List : List_Id; Component : Entity_Id; begin if Tagged_Present (Def) then Expand_Tagged_Root (Def); end if; -- If the component list of a record type is defined by the reserved -- word null and there is no discriminant part, then the record type has -- no components and all records of the type are null records. [LRM 3.7] if No (Component_List (Def)) or else Null_Present (Component_List (Def)) then return; end if; Analyze_Declarations (Component_Declarations (Component_List (Def))); if Present (Variant_Part (Component_List (Def))) then Analyze (Variant_Part (Component_List (Def))); end if; Component := First_Entity (Current_Scope); -- After completing the semantic analysis of the record definition, -- then record components are accessible. while Present (Component) loop if Ekind (Component) = E_Void then Set_Ekind (Component, E_Component); end if; if Has_Tasks (Etype (Component)) then Set_Has_Tasks (T, True); end if; Component := Next_Entity (Component); end loop; -- If any implicit subtypes were generated for component declarations -- of this record, set the Implicit_Type field to be the list of the -- N_Implicit_Type nodes (contained in Implicit_Type_List) that were -- generated. See New_Implicit_Type for more details. Install_Implicit_Types (Def); end Record_Type_Definition; ----------------------------------- -- Analyze_Component_Declaration -- ----------------------------------- procedure Analyze_Component_Declaration (N : Node_Id) is Id : constant Entity_Id := Defining_Identifier (N); T : Entity_Id; begin Enter_Name (Defining_Identifier (N)); T := Find_Type_Of_Object (Subtype_Indication (N)); -- If a component declaration includes the assignment compound delimiter -- followed by an expression, the expression is the default expression -- of the record component; the default expression must be of the type -- of the component. Default expressions are not allowed for components -- that are of a limited type. [LRM 3.7 (5)] if Present (Expression (N)) then Analyze (Expression (N)); Check_Initialization (T, Expression (N)); end if; if Is_Unconstrained_Type (T) then Error_Msg_N ("unconstrained subtype in component declaration", Subtype_Indication (N)); elsif Is_Abstract (T) then Error_Msg_N ("The type of a component cannot be abstract", N); end if; if Is_Limited_Type (T) then Set_Is_Limited_Type (Current_Scope); end if; Set_Ekind (Id, E_Component); Set_Etype (Id, T); Set_Is_Aliased (Id, Aliased_Present (N)); -- Initialyze the Original_Record_Component to the entity itself -- the New_Copy call in Build_Derived_Type will automatically -- propagate the right value to descendants Set_Original_Record_Component (Id, Id); end Analyze_Component_Declaration; -------------------------- -- Analyze_Variant_Part -- -------------------------- procedure Analyze_Variant_Part (N : Node_Id) is Case_Table : Case_Table_Type (1 .. Number_Of_Case_Choices (N)); Choice : Node_Id; Choice_Count : Nat := 0; Discr_Name : Node_Id; Discr_Type : Entity_Id; E : Entity_Id; Hi : Node_Id; Invalid_Case : Boolean := False; Kind : Node_Kind; Lo : Node_Id; Others_Present : Boolean := False; Variant : Node_Id; procedure Check_Choice (Lo, Hi : Node_Id; Position : Node_Id); -- Check_Choice checks whether the given bounds of a choice are -- static. If not a message is issued, otherwise the bounds are -- entered into the case table. procedure Check_Choice (Lo, Hi : Node_Id; Position : Node_Id) is begin -- The simple expressions and discrete ranges given as choices -- in a variant part must be static. [LRM 3.7.3] if not (Is_Static_Expression (Lo) and then Is_Static_Expression (Hi)) then Error_Msg_N ("choice given in variant part not static", Position); Invalid_Case := True; else Choice_Count := Choice_Count + 1; Case_Table (Choice_Count).Choice_Lo := Lo; Case_Table (Choice_Count).Choice_Hi := Hi; Case_Table (Choice_Count).Choice_Node := Position; end if; end Check_Choice; -- Start of processing for Analyze_Variant_Part begin Discr_Name := Name (N); Analyze (Discr_Name); if Ekind (Entity (Discr_Name)) /= E_Discriminant then Error_Msg_N ("invalid discriminant name in variant part", Discr_Name); end if; Discr_Type := Etype (Entity (Discr_Name)); -- The type of the discriminant of a variant part must not be a -- generic formal type. [LRM 3.7.3] if Is_Generic_Type (Discr_Type) then Error_Msg_N ("discriminant of variant part cannot be generic", Discr_Name); return; end if; -- Now check each of the case choices against Exp_Base_Type. Variant := First (Variants (N)); while Present (Variant) loop Choice := First (Discrete_Choices (Variant)); while Present (Choice) loop Analyze (Choice); Kind := Nkind (Choice); if Kind = N_Range then Resolve_Complete_Context (Choice, Discr_Type); Check_Choice (Low_Bound (Choice), High_Bound (Choice), Choice); elsif (Kind = N_Identifier or else Kind = N_Selected_Component) and then Is_Type (Entity (Choice)) then E := Entity (Choice); Lo := Type_Low_Bound (E); Hi := Type_High_Bound (E); Check_Choice (Lo, Hi, Choice); elsif Kind = N_Subtype_Indication then Compiler_Abort; -- for now ??? -- The choice others is only allowed for the last variant and as -- its only choice; it stands for all values (possibly none) not -- given in the choices of previous variants. [LRM 3.7.3] elsif Kind = N_Others_Choice then if not (Choice = First (Discrete_Choices (Variant)) and then Choice = Last (Discrete_Choices (Variant)) and then Variant = Last (Variants (N))) then Error_Msg_N ("the choice OTHERS must appear alone and last", Choice); return; end if; Others_Present := True; else -- an expression Resolve_Complete_Context (Choice, Discr_Type); Check_Choice (Choice, Choice, Choice); end if; Choice := Next (Choice); end loop; if not Null_Present (Component_List (Variant)) then Analyze_Declarations (Component_Declarations (Component_List (Variant))); if Present (Variant_Part (Component_List (Variant))) then Analyze (Variant_Part (Component_List (Variant))); end if; end if; Variant := Next (Variant); end loop; if not Invalid_Case and then Case_Table'Length > 0 then Check_Case_Choices (Case_Table, N, Discr_Type, Others_Present); if Others_Present then -- Fill in Others_Discrete_Choices field of the OTHERS choice Choice := Last (Discrete_Choices (Last (Variants (N)))); Expand_Others_Choice (Case_Table, Choice, Discr_Type); end if; end if; end Analyze_Variant_Part; -------------------------- -- Expand_Others_Choice -- -------------------------- procedure Expand_Others_Choice (Case_Table : Case_Table_Type; Others_Choice : Node_Id; Choice_Type : Entity_Id) is Choice : Node_Id; Choice_List : List_Id := New_List; Exp_Lo : Node_Id; Exp_Hi : Node_Id; Hi : Uint; Lo : Uint; Loc : Source_Ptr := Sloc (Others_Choice); Previous_Hi : Uint; function Lit_Of (Value : Uint) return Node_Id; -- Returns the Node_Id for the enumeration literal corresponding to the -- position given by Value within the enumeration type Choice_Type. function Build_Choice (Value1, Value2 : Uint) return Node_Id; -- Builds a node representing the missing choices given by the -- Value1 and Value2. A N_Range node is built if there is more than -- one literal value missing. Otherwise a single N_Integer_Literal, -- N_Identifier or N_Character_Literal is built depending on what -- Choice_Type is. ------------ -- Lit_Of -- ------------ function Lit_Of (Value : Uint) return Node_Id is Lit : Entity_Id; begin -- In the case where the literal is of type Character, there needs -- to be some special handling since there is no explicit chain -- of literals to search. Instead, a N_Character_Literal node -- is created with the appropriate Char_Code and Chars fields. if Base_Type (Choice_Type) = Standard_Character then Name_Buffer (1) := '''; Name_Buffer (2) := Char'Val (UI_To_Int (Value)); Name_Buffer (3) := '''; Name_Len := 3; Lit := New_Node (N_Character_Literal, Loc); Set_Chars (Lit, Name_Find); Set_Char_Literal_Value (Lit, Char_Code (UI_To_Int (Value))); Set_Etype (Lit, Choice_Type); Set_Is_Static (Lit, True); return Lit; -- Otherwise, iterate through the literals list of Choice_Type -- "Value" number of times until the desired literal is reached -- and then return an occurrence of it. else Lit := First_Literal (Choice_Type); for I in 1 .. UI_To_Int (Value) loop Lit := Next_Literal (Lit); end loop; return New_Occurrence_Of (Lit, Loc); end if; end Lit_Of; ------------------ -- Build_Choice -- ------------------ function Build_Choice (Value1, Value2 : Uint) return Node_Id is Lit_Node : Node_Id; Lo, Hi : Node_Id; Lo_Val : Uint; Hi_Val : Uint; begin -- If there is only one choice value missing between Value1 and -- Value2, build an integer or enumeration literal to represent it. if UI_Eq (UI_Difference (Value2, Value1), Uint_1) then if Is_Integer_Type (Choice_Type) then Lit_Node := Make_Integer_Literal (Loc, Value1); Set_Etype (Lit_Node, Choice_Type); else Lit_Node := Lit_Of (Value1); end if; -- Otherwise is more that one choice value that is missing between -- Value1 and Value2, therefore build a N_Range node of either -- integer or enumeration literals. else Hi_Val := UI_Difference (Value2, Uint_1); if Is_Integer_Type (Choice_Type) then Lo := Make_Integer_Literal (Loc, Value1); Set_Etype (Lo, Choice_Type); Hi := Make_Integer_Literal (Loc, Hi_Val); Set_Etype (Hi, Choice_Type); Lit_Node := Make_Range (Loc, Low_Bound => Lo, High_Bound => Hi); else Lit_Node := Make_Range (Loc, Low_Bound => Lit_Of (Value1), High_Bound => Lit_Of (Hi_Val)); end if; end if; return Lit_Node; end Build_Choice; -- Start of processing for Expand_Others_Choice begin -- Establish the bound values for the variant depending upon whether -- the type of the discriminant name is static or not. if Is_Static_Subtype (Choice_Type) then Exp_Lo := Type_Low_Bound (Choice_Type); Exp_Hi := Type_High_Bound (Choice_Type); else Exp_Lo := Type_Low_Bound (Base_Type (Choice_Type)); Exp_Hi := Type_High_Bound (Base_Type (Choice_Type)); end if; Lo := Expr_Value (Case_Table (Case_Table'First).Choice_Lo); Hi := Expr_Value (Case_Table (Case_Table'First).Choice_Hi); Previous_Hi := Expr_Value (Case_Table (Case_Table'First).Choice_Hi); -- Build the node for any missing choices that are smaller than any -- explicit choices given in the variant. if UI_Lt (Expr_Value (Exp_Lo), Lo) then Append (Build_Choice (Expr_Value (Exp_Lo), Lo), Choice_List); end if; -- Build the nodes representing any missing choices that lie between -- the explicit ones given in the variant. for I in Case_Table'First + 1 .. Case_Table'Last loop Lo := Expr_Value (Case_Table (I).Choice_Lo); Hi := Expr_Value (Case_Table (I).Choice_Hi); Choice := Case_Table (I).Choice_Node; if UI_Ne (Lo, UI_Sum (Previous_Hi, Uint_1)) then Append (Build_Choice (UI_Sum (Previous_Hi, Uint_1), Lo), Choice_List); end if; Previous_Hi := Hi; end loop; -- Build the node for any missing choices that are greater than any -- explicit choices given in the variant. if UI_Gt (Expr_Value (Exp_Hi), Hi) then Append (Build_Choice (UI_Sum (Hi, Uint_1), Expr_Value (Exp_Hi)), Choice_List); end if; Set_Others_Discrete_Choices (Others_Choice, Choice_List); end Expand_Others_Choice; ---------------------------------- -- Constrain_Discriminated_Type -- ---------------------------------- procedure Constrain_Discriminated_Type (Def_Id : Entity_Id; S : Node_Id) is T : Node_Id; C : Node_Id; N : Node_Id; Elist : Elist_Id; Id : Entity_Id; Discr : Entity_Id; Number_Discriminants : Nat := 0; begin C := Constraint (S); if Nkind (C) /= N_Index_Or_Discriminant_Constraint then Error_Msg_N ("incorrect constraint given for record type", C); return; end if; -- A discriminant constraint is only allowed in a subtype indication, -- after a subtype mark. This subtype mark must denote either a type -- with discriminants, or an access type whose designated type is a -- type with discriminants. A discriminant constraint specifies the -- values of these discriminants. [LRM 3.7.2 (5)] T := Entity (Subtype_Mark (S)); if Ekind (T) in Access_Kind then T := Designated_Type (T); end if; if Is_Constrained (T) then Error_Msg_N ("record type is already constrained", Subtype_Mark (S)); return; elsif not Has_Discriminants (T) then Error_Msg_N ("invalid constraint: record type has no discriminant", C); Set_Etype (Def_Id, Any_Type); return; end if; -- Count the number of discriminants of the record type so that -- an array of the proper size can be allocated to hold the -- expressions given by the discriminant constraint. Discr := First_Discriminant (T); while Present (Discr) loop Number_Discriminants := Number_Discriminants + 1; Discr := Next_Discriminant (Discr); end loop; declare Discriminant_Expr : array (1 .. Number_Discriminants) of Node_Id; E : Entity_Id; Position : Nat := 1; Id2 : Entity_Id; Not_Found : Boolean; function Pos_Of_Discr (T : Entity_Id; Discr : Entity_Id) return Nat; -- Return the Position number (starting at 1) of a discriminant -- (Discr) within the discriminant list of the record type (T). function Pos_Of_Discr (T : Entity_Id; Discr : Entity_Id) return Nat is I : Nat := 1; D : Entity_Id; begin D := First_Discriminant (T); while Present (D) loop if D = Discr then return I; end if; D := Next_Discriminant (D); I := I + 1; end loop; -- Note: Since this function is called on discriminants that are -- known to belong to the record type, falling through the loop -- with no match signals an internal compiler error. Compiler_Abort; end Pos_Of_Discr; begin for I in Discriminant_Expr'range loop Discriminant_Expr (I) := Empty; end loop; Discr := First_Discriminant (T); N := First (Constraints (C)); -- The following loop will process the positional associations only -- and will exit when a named association is seen. The named -- associations will then be processed by the subsequent loop. while Present (N) loop exit when Nkind (N) = N_Discriminant_Association; -- Named Assoc -- For a positional association, the (single) discriminant is -- implicitly specified by position, in textual order. [LRM 3.7.2] if No (Discr) then Error_Msg_N ("too many constraints given for record", C); return; else Analyze (N); Discriminant_Expr (Position) := N; Resolve_Complete_Context (N, Base_Type (Etype (Discr))); Position := Position + 1; Discr := Next_Discriminant (Discr); end if; N := Next (N); end loop; -- There should only be named associations left on the discriminant -- constraint. Any positional assoication are in error. while Present (N) loop if Nkind (N) = N_Discriminant_Association then E := Empty; Analyze (Expression (N)); -- Search the entity list of the record looking at only the -- discriminants (which always appear first) to see if the -- simple name given in the constraint matches any of them. Id := First (Selector_Names (N)); while Present (Id) loop Not_Found := True; Id2 := First_Entity (T); while Present (Id2) and then Ekind (Id2) = E_Discriminant loop if Chars (Id2) = Chars (Id) then Not_Found := False; exit; end if; Id2 := Next_Entity (Id2); end loop; if Not_Found then Error_Msg_N ("& does not match any discriminant", N); return; end if; Position := Pos_Of_Discr (T, Id2); if No (Discriminant_Expr (Position)) then Discriminant_Expr (Position) := Expression (N); Resolve_Complete_Context (Expression (N), Base_Type (Etype (Id2))); else Error_Msg_N ("duplicate constraint for discriminant&", Id); end if; -- A discriminant association with more than one -- discriminant name is only allowed if the named -- discriminants are all of the same type ... [LRM 3.7.2] if E = Empty then E := Etype (Id2); elsif Etype (Id2) /= E then Error_Msg_N ("all discriminants in an association " & "must have the same type", N); end if; Id := Next (Id); end loop; else -- Positional Association -- Named associations can be given in any order, but if both -- positional and named associations are used in the same -- discriminant constraint, then positional associations must -- occur first, at their normal position. Hence once a named -- association is used, the rest of the discriminant constraint -- must use only named associations. Error_Msg_N ("positional association follows named one", N); return; end if; N := Next (N); end loop; -- Furthermore, for each discriminant association (whether named or -- positional), the expression and the associated discriminants must -- have the same type. A discriminant constraint must provide exactly -- one value for each discriminant of the type. [LRM 3.7.2] -- missing code here??? for I in 1 .. Number_Discriminants loop if No (Discriminant_Expr (I)) then Error_Msg_N ("too few constraints given for record", C); return; end if; end loop; -- Build an element list consisting of the expressions given in the -- discriminant constraint. The list is constructed after resolving -- any named discriminant associations and therefore the expressions -- appear in the textual order of the discriminants. Elist := New_Elmt_List; for I in 1 .. Number_Discriminants loop Append_Elmt (Discriminant_Expr (I), Elist); end loop; end; -- end of declare block if Ekind (T) = E_Record_Type then Set_Ekind (Def_Id, E_Record_Subtype); elsif Ekind (T) = E_Task_Type then Set_Ekind (Def_Id, E_Task_Subtype); elsif Ekind (T) = E_Protected_Type then Set_Ekind (Def_Id, E_Protected_Subtype); else -- incomplete or private type. Set_Ekind (Def_Id, Ekind (T)); end if; Set_Etype (Def_Id, T); Set_Is_Tagged_Type (Def_Id, Is_Tagged_Type (T)); Set_Has_Discriminants (Def_Id); Set_Is_Constrained (Def_Id); Set_First_Entity (Def_Id, First_Entity (T)); Set_Discriminant_Constraint (Def_Id, Elist); Set_Has_Tasks (Def_Id, Has_Tasks (T)); -- Subtypes introduced by component declarations do not need to be -- marked as delayed, and do not get freeze nodes, because the semantics -- verifies that the parents of the subtypes are frozen before the -- enclosing record is frozen. if not Is_Type (Scope (Def_Id)) then Set_Is_Private_Type (Def_Id, Is_Private_Type (T)); Set_Is_Delayed (Def_Id, Is_Delayed (T)); end if; -- ??? This function is awfully long, could use some breaking up ??? end Constrain_Discriminated_Type; ------------------------ -- Check_Discriminant -- ------------------------ -- Within a record type definition the only allowed uses of the name -- of a discriminant of the record type are: in the default expressions -- for record components; in a variant part as the discriminant name; -- and in a component subtype definition, either as a bound in an index -- constraint, or to specify a discriminant value in a discriminant -- constraint. A discriminant name used in these component subtype -- definitions must appear by itself, not as part of a larger expression. -- [LRM 3.7.1] -- Verify that when a discriminant appears in an index constraint or a -- discriminant constraint of a record component, it appears by itself -- and not as part of a larger expression. function Check_Discriminant (Exp_Node : Node_Id) return Boolean is begin return True; end Check_Discriminant; ------------------------------ -- Derived_Type_Declaration -- ------------------------------ procedure Derived_Type_Declaration (T : Entity_Id; N : Node_Id) is Def : constant Node_Id := Type_Definition (N); Indic : constant Node_Id := Subtype_Indication (Def); Extension : constant Node_Id := Record_Extension_Part (Def); Parent_Type : Entity_Id; Parent_Subtype : Entity_Id; begin -- If subtype indication, constraint to be applied later to derived type if Nkind (Indic) = N_Subtype_Indication then Find_Type (Subtype_Mark (Indic)); Parent_Type := Entity (Subtype_Mark (Indic)); -- Else we have subtype mark without a constraint else Find_Type (Indic); Parent_Type := Entity (Indic); end if; -- A derived type defined in a package specification cannot be used for -- further derivation until the end of its visible part. This means that -- derivation in the private part of the package is allowed. if (Is_Derived_Type (Parent_Type) and then Ada_83 and then In_Visible_Part (Scope (Parent_Type))) or else (Is_Incomplete_Type (Parent_Type) and then No (Full_Declaration (Parent_Type))) then Error_Msg_N ("premature derivation of derived or private type", Indic); end if; if Present (Extension) then if not Is_Tagged_Type (Parent_Type) then Error_Msg_N ("parent of type extension must be a tagged type ", Indic); else -- oo-extension Freeze_Before (N, Parent_Type); Expand_Tagged_Extension (Def); Record_Extension (Parent_Type, T, Extension, N); end if; elsif Is_Tagged_Type (Parent_Type) then Error_Msg_N ("a type derived from a tagged type must have an extension", Indic); end if; Build_Derived_Type (N, Parent_Type, T); Derive_Subprograms (Parent_Type, T); if Present (Extension) and then Is_Tagged_Type (Parent_Type) then Make_Class_Type (T); end if; end Derived_Type_Declaration; ------------------------ -- Build_Derived_Type -- ------------------------ procedure Build_Derived_Type (N : Node_Id; Parent_Type : Entity_Id; Derived_Type : Entity_Id) is Indic : constant Node_Id := Subtype_Indication (Type_Definition (N)); Implicit_Base : Entity_Id; T : Entity_Id; begin -- Copy common attributes Set_Ekind (Derived_Type, Ekind (Base_Type (Parent_Type))); Set_Esize (Derived_Type, Esize (Parent_Type)); Set_Etype (Derived_Type, Base_Type (Parent_Type)); Set_Scope (Derived_Type, Current_Scope); case Ekind (Parent_Type) is when Numeric_Kind => -- Process the subtype indication including a validation check on -- the constraint if any. T := Process_Subtype (Indic); -- Introduce an implicit base type for the derived type even if -- there is no constraint attached to it, since this seems closer -- to the Ada semantics. Implicit_Base := New_Implicit_Type (Sloc (N), Derived_Type, "base"); Set_Ekind (Implicit_Base, Ekind (Base_Type (Parent_Type))); Set_Etype (Implicit_Base, Parent_Type); Set_Esize (Implicit_Base, Esize (Parent_Type)); Set_Scalar_Range (Implicit_Base, Scalar_Range (Parent_Type)); -- Make "Derived_Type", which is the defining identifier of the -- derived type declaration, be a subtype of the introduced -- implicit base type. In the case where there is no constraint -- given the Ekind will have to be set here since it is not set -- by Process_Subtype. Set_Etype (Derived_Type, Implicit_Base); Set_Parent_Subtype (Derived_Type, Implicit_Base); if Nkind (Indic) /= N_Subtype_Indication then Set_Ekind (Derived_Type, Subtype_Kind (Ekind (Parent_Type))); Set_Scalar_Range (Derived_Type, Scalar_Range (Parent_Type)); end if; if Ekind (Parent_Type) in Modular_Kind then Set_Modulus (Derived_Type, Modulus (Parent_Type)); end if; when Array_Kind => Set_First_Index (Derived_Type, First_Index (Parent_Type)); Set_Component_Type (Derived_Type, Component_Type (Parent_Type)); Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type)); -- A derived record type has the same fields and types as the parent. -- The declaration may have a discriminant part, in which case they -- must conform to the discriminants of the parent type. We assume -- the discriminant names, types and default values must be the same. -- For untagged types, we generate a copy of the parent record defi- -- nition, using the generic instantiation mechanism as a general -- purpose copy/instantiate facility, and we replace the derived type -- definition with a record type definition. For tagged types we -- only need to duplicate the entities and we treat the parent type -- as a single special component. when Record_Kind => -- Tagged type case if Is_Tagged_Type (Parent_Type) then Inherit_Components (Parent_Type, Derived_Type); Set_Is_Tagged_Type (Derived_Type); Set_Primitive_Operations (Derived_Type, New_Elmt_List); -- Non-tagged type, replace derived type definition else Rewrite_Substitute_Tree (Type_Definition (N), Instantiate_Record (Parent_Type, Derived_Type)); Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type)); Set_Has_Discriminants (Derived_Type, Has_Discriminants (Parent_Type)); end if; -- A derived enumeration type has the literals of its parent, but -- these are marked as derived, to enforce the overloading rules. -- The first literal of the parent is the entity that follows the -- parent in its scope. We cannot use the attribute First_Literal -- because the parent itself may be derived and have no explicit tree when Enumeration_Kind => declare Literal : Entity_Id := Next_Entity (Parent_Type); New_Lit : Entity_Id; begin Unimplemented (N, "derived enumeration types"); while Present (Literal) loop New_Lit := New_Copy (Literal); Set_Etype (New_Lit, Derived_Type); Set_Alias (New_Lit, Literal); New_Overloaded_Entity (New_Lit); Literal := Next_Entity (Literal); end loop; Set_Scalar_Range (Derived_Type, Scalar_Range (Parent_Type)); end; when Access_Kind => Set_Directly_Designated_Type (Derived_Type, Designated_Type (Parent_Type)); when Incomplete_Kind => Set_Full_Declaration (Derived_Type, Full_Declaration (Parent_Type)); Set_Is_Limited_Type (Derived_Type, Is_Limited_Type (Parent_Type)); when others => Compiler_Abort; end case; end Build_Derived_Type; ------------------------ -- Inherit_Components -- ------------------------ procedure Inherit_Components (Parent_Type, Derived_Type : Entity_Id) is Comp : Entity_Id := First_Entity (Parent_Type); New_Comp : Entity_Id; begin while Present (Comp) loop -- The entities in the parent_Type include components and -- implicit types. If those types do not depend on disc- -- riminants, they can be elaborated once and shared by -- both parent and derived type. If the implicit types -- depend on the discriminants, a more complex instantia- -- tion mechanism must be used (TBSL). if (Ekind (Comp) = E_Discriminant or else Ekind (Comp) = E_Component) and then Chars (Comp) /= Name_uParent then New_Comp := New_Copy (Comp); Append_Entity (New_Comp, Derived_Type); end if; Comp := Next_Entity (Comp); end loop; end Inherit_Components; --------------------- -- Is_Derived_Type -- --------------------- function Is_Derived_Type (Type_Id : Entity_Id) return Boolean is begin return Base_Type (Type_Id) /= Root_Type (Type_Id) and not Is_Generic_Type (Type_Id); end Is_Derived_Type; --------------------- -- In_Visible_Part -- --------------------- function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is begin return (Ekind (Scope_Id) = E_Package or Ekind (Scope_Id) = E_Generic_Package) and then In_Open_Scopes (Scope_Id) and then not Is_Package_Body (Scope_Id) and then not In_Private_Part (Scope_Id); end In_Visible_Part; ---------------------------------- -- Collect_Primitive_Operations -- ---------------------------------- function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is Op_List : Elist_Id := New_Elmt_List; Id : Entity_Id := Next_Entity (T); Formal : Entity_Id; Is_Prim : Boolean; begin -- For tagged types, the primitive operations are collected as they -- are declared, and held in an explicit list which is simply returned. if Is_Tagged_Type (T) then return Primitive_Operations (T); end if; while Present (Id) loop if Is_Overloadable (Id) then Is_Prim := False; if Base_Type (Etype (Id)) = Base_Type (T) then Is_Prim := True; else Formal := First_Formal (Id); while Present (Formal) loop if Base_Type (Etype (Formal)) = Base_Type (T) then Is_Prim := True; exit; end if; Formal := Next_Formal (Formal); end loop; end if; if Is_Prim then Append_Elmt (Id, Op_List); end if; end if; Id := Next_Entity (Id); end loop; return Op_List; end Collect_Primitive_Operations; ------------------------ -- Derive_Subprograms -- ------------------------ procedure Derive_Subprograms (Parent_Type, Derived_Type : Entity_Id) is Op_List : Elist_Id := Collect_Primitive_Operations (Parent_Type); Elmt : Elmt_Id; Subp : Entity_Id; New_Subp : Entity_Id; Formal : Entity_Id; New_Formal : Entity_Id; procedure Replace_Type (Id, New_Id : Entity_Id) is begin if Base_Type (Etype (Id)) = Base_Type (Parent_Type) then Set_Etype (New_Id, Derived_Type); else Set_Etype (New_Id, Etype (Id)); end if; end Replace_Type; -- Start of processing for Derive_Subprograms begin Elmt := First_Elmt (Op_List); while Elmt /= No_Elmt loop Subp := Id_Of (Elmt); New_Subp := Extend_Node (New_Node (N_Defining_Identifier, Sloc (Derived_Type))); Set_Ekind (New_Subp, Ekind (Subp)); Set_Chars (New_Subp, Chars (Subp)); Replace_Type (Subp, New_Subp); Formal := First_Formal (Subp); while Present (Formal) loop New_Formal := New_Copy (Formal); Append_Entity (New_Formal, New_Subp); Replace_Type (Formal, New_Formal); Formal := Next_Formal (Formal); end loop; Set_Alias (New_Subp, Subp); New_Overloaded_Entity (New_Subp); -- Indicate that a derived subprogram does not require a body. Set_Has_Completion (New_Subp); -- A derived function with a controlling result is abstract. if Is_Abstract (Subp) or else Etype (New_Subp) = Derived_Type then Set_Is_Abstract (New_Subp); end if; Elmt := Next_Elmt (Elmt); end loop; end Derive_Subprograms; ---------------------- -- Record_Extension -- ---------------------- procedure Record_Extension (Parent_Type, Derived_Type : Entity_Id; Extension : Node_Id; N : Node_Id) is begin -- If parent is a private type, then derived type must be constructed -- as extension of the full declaration, which must be retrieved. Is -- this comment right ??? (appears to cover all incomplete types???) if Is_Incomplete_Type (Parent_Type) then null; -- Otherwise enter scope of derived type to compile new components else New_Scope (Derived_Type); if List_Present (Discriminant_Specifications (N)) then Process_The_Discriminants (N); else Set_Has_Discriminants (Derived_Type, False); end if; Set_Ekind (Derived_Type, Ekind (Parent_Type)); if Has_Discriminants (Derived_Type) then Set_Is_Constrained (Derived_Type, Present (Discriminant_Default_Value ( First_Discriminant (Derived_Type)))); else Set_Is_Constrained (Derived_Type, True); end if; Record_Type_Definition (Extension, Derived_Type); End_Scope; end if; end Record_Extension; ------------------------------------------- -- Analyze_Private_Extension_Declaration -- ------------------------------------------- procedure Analyze_Private_Extension_Declaration (N : Node_Id) is T : constant Entity_Id := Defining_Identifier (N); Indic : constant Node_Id := Subtype_Indication (N); Parent_Type : Entity_Id; begin Enter_Name (T); Set_Is_Tagged_Type (T); Set_Ekind (T, E_Private_Type); Set_Is_Abstract (T, Abstract_Present (N)); Make_Class_Type (T); New_Scope (T); -- The discriminants must be processed first, and made visible, -- because they may be used to constain the discriminants of the -- parent. if List_Present (Discriminant_Specifications (N)) then Process_The_Discriminants (N); end if; Find_Type (Indic); Parent_Type := Entity (Indic); if not Is_Tagged_Type (Parent_Type) then Error_Msg_N ("parent of type extension must be a tagged type ", Indic); return; end if; Inherit_Components (Parent_Type, T); End_Scope; Derive_Subprograms (Parent_Type, T); end Analyze_Private_Extension_Declaration; --------------------- -- Make_Class_Type -- --------------------- procedure Make_Class_Type (T : Entity_Id) is Class_Type : Entity_Id; Prev_Class : Entity_Id; Class_Name : Name_Id; begin Prev_Class := Next_Entity (T); while Present (Prev_Class) and then (not Is_Class_Type (Prev_Class) or else Etype (Prev_Class) /= T) loop Prev_Class := Next_Entity (Prev_Class); end loop; -- If previous private declaration exists (which generated class -- type) then we are all set if Present (Prev_Class) then return; -- Otherwise construct the class type else -- We construct the implicit type node by hand instead of using -- New_Implicit_Type because the new type must be insterted after -- and not before the actual type definition Class_Type := New_External_Entity (E_Void, Scope (T), Sloc (T), T, "class", 0, "ityp"); Set_Public_Status (Class_Type); Insert_After (Parent (T), Make_Implicit_Type (Sloc (T), Class_Type)); Class_Name := Chars (Class_Type); Copy_Node (T, Class_Type); Set_Chars (Class_Type, Class_Name); Set_Primitive_Operations (Class_Type, New_Elmt_List); Set_Ekind (Class_Type, E_Class_Type); -- Entity is currently last one in scope. Set_Next_Entity (Class_Type, Empty); end if; Set_Etype (Class_Type, T); end Make_Class_Type; ---------------------------------- -- Analyze_Incomplete_Type_Decl -- ---------------------------------- procedure Analyze_Incomplete_Type_Decl (N : Node_Id) is T : Node_Id; begin -- Process an incomplete declaration. The identifier must not have been -- declared already in the scope. However, an incomplete declaration may -- appear in the private part of a package, for a private type that has -- already been declared. -- In this case, the discriminants (if any) must match. T := Find_Type_Name (N); Set_Ekind (T, E_Incomplete_Type); Set_Etype (T, T); New_Scope (T); if List_Present (Discriminant_Specifications (N)) then Process_The_Discriminants (N); end if; End_Scope; end Analyze_Incomplete_Type_Decl; ---------------------------- -- Access_Type_Declaration -- ---------------------------- procedure Access_Type_Declaration (T : Entity_Id; Def : Node_Id) is S : constant Node_Id := Subtype_Indication (Def); begin -- Check for permissible use of incomplete type if Nkind (S) /= N_Subtype_Indication then Analyze (S); if Ekind (Entity (S)) = E_Incomplete_Type then Set_Directly_Designated_Type (T, Entity (S)); else Set_Directly_Designated_Type (T, Process_Subtype (S, T, "parent")); end if; else Set_Directly_Designated_Type (T, Process_Subtype (S, T, "parent")); end if; if All_Present (Def) or Constant_Present (Def) then Set_Ekind (T, E_General_Access_Type); else Set_Ekind (T, E_Access_Type); end if; Set_Etype (T, T); Set_Esize (T, UI_From_Int (System_Address_Size)); -- Note that Has_Tasks is always false, since the access type itself -- is not a task type. See Einfo for more description on this point. Set_Has_Tasks (T, False); end Access_Type_Declaration; ----------------------------------- -- Access_Subprogram_Declaration -- ----------------------------------- procedure Access_Subprogram_Declaration (T_Name : Entity_Id; T_Def : Node_Id) is Formals : constant List_Id := Parameter_Specifications (T_Def); Desig_Type : constant Entity_Id := New_Implicit_Type (Sloc (T_Def)); begin Set_Ekind (Desig_Type, E_Subprogram_Type); if Nkind (T_Def) = N_Access_Function_Definition then Find_Name (Subtype_Mark (T_Def)); Set_Etype (Desig_Type, Entity (Subtype_Mark (T_Def))); else Set_Etype (Desig_Type, Standard_Void_Type); end if; if List_Present (Formals) then New_Scope (Desig_Type); Process_Formals (Desig_Type, Formals); End_Scope; end if; Set_Ekind (T_Name, E_Access_Subprogram_Type); Set_Etype (T_Name, T_Name); Set_Directly_Designated_Type (T_Name, Desig_Type); end Access_Subprogram_Declaration; ---------------------- -- Constrain_Access -- ---------------------- procedure Constrain_Access (Def_Id : Entity_Id; S : Node_Id) is T : constant Entity_Id := Entity (Subtype_Mark (S)); Desig_Type : constant Entity_Id := Designated_Type (T); Desig_Subtype : Entity_Id := New_Implicit_Type (Sloc (S)); begin Set_Ekind (Def_Id, E_Access_Subtype); Set_Directly_Designated_Type (Def_Id, Desig_Subtype); if Ekind (Desig_Type) = E_Array_Type or else Ekind (Desig_Type) = E_String_Type then Constrain_Array (Desig_Subtype, S, Def_Id, "parent"); elsif Ekind (Desig_Type) = E_Record_Type or else Ekind (Desig_Type) = E_Task_Type or else Ekind (Desig_Type) = E_Protected_Type then Constrain_Discriminated_Type (Desig_Subtype, S); else Error_Msg_N ("invalid constraint on access type", S); Set_Etype (Def_Id, Any_Type); return; end if; Set_Etype (Def_Id, T); end Constrain_Access; ----------------------- -- Access_Definition -- ----------------------- function Access_Definition (N : Node_Id) return Entity_Id is Anon_Type : constant Entity_Id := New_Implicit_Type (Sloc (N), Scope_Id => Scope (Current_Scope)); begin if (Ekind (Current_Scope) = E_Entry or else Ekind (Current_Scope) = E_Entry_Family) and then Is_Task_Type (Etype (Scope (Current_Scope))) then Error_Msg_N ("Task entries cannot have access parameters", N); end if; Find_Type (Subtype_Mark (N)); Set_Ekind (Anon_Type, E_Anonymous_Access_Type); Set_Etype (Anon_Type, Anon_Type); Set_Directly_Designated_Type (Anon_Type, Entity (Subtype_Mark (N))); return Anon_Type; end Access_Definition; ------------------------- -- New_Binary_Operator -- ------------------------- procedure New_Binary_Operator (Op : Name_Id; Typ : Entity_Id) is Op_Node : Entity_Id; function Make_Op_Formal (Typ : Entity_Id) return Entity_Id; -- Create abbreviated declaration for the formal of a predefined -- Operator (too abbreviated I suspect, the defining identifier -- lacks both a source location and a Chars field. Who provides -- them, no one??? function Make_Op_Formal (Typ : Entity_Id) return Entity_Id is Formal : Entity_Id; begin Formal := Extend_Node (New_Node (N_Defining_Identifier, No_Location)); Set_Ekind (Formal, E_In_Parameter); Set_Etype (Formal, Typ); return Formal; end Make_Op_Formal; -- Start of processing for Make_Op_Formal begin Op_Node := Extend_Node (New_Node (N_Defining_Identifier, Standard_Location)); Set_Ekind (Op_Node, E_Operator); Set_Etype (Op_Node, Typ); Set_Chars (Op_Node, Op); Set_Homonym (Op_Node, Get_Name_Entity_Id (Op)); Set_Name_Entity_Id (Op, Op_Node); Set_Is_Directly_Visible (Op_Node); Append_Entity (Op_Node, Current_Scope); Append_Entity (Make_Op_Formal (Typ), Op_Node); Append_Entity (Make_Op_Formal (Typ), Op_Node); end New_Binary_Operator; ----------------------- -- New_Class_Subtype -- ----------------------- function New_Class_Subtype (N : Node_Id; Ctyp : Entity_Id) return Entity_Id is Class_Subtype : Entity_Id; Class_Subtype_Name : Name_Id; begin pragma Assert (Is_Class_Type (Ctyp), Compiler_Abort (Ctyp)); -- we delay the implicit type node construction till expansion -- because the new type must be insterted after -- and not before the equivalent type definition (See -- Expand_Class_Subtype) Class_Subtype := New_External_Entity (E_Void, Current_Scope, Sloc (Ctyp), Ctyp, "subclass", 0, "ityp"); Set_Public_Status (Class_Subtype); Class_Subtype_Name := Chars (Class_Subtype); Copy_Node (Ctyp, Class_Subtype); Set_Chars (Class_Subtype, Class_Subtype_Name); Set_Ekind (Class_Subtype, E_Class_Subtype); Set_Next_Entity (Class_Subtype, Empty); return Class_Subtype; end New_Class_Subtype; end Sem_Ch3; lass type else -- We construct the implicit type node by hand instead of using -- New_Implicit_Type because the new type must be insterted after gnat-1.67-src/src/sem_ch4.ads 444 10015 7640 7340 5506244373 11140 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ C H 4 -- -- -- -- S p e c -- -- -- -- $Revision: 1.8 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Sem_Ch4 is procedure Analyze_Aggregate (N : Node_Id); procedure Analyze_Allocator (N : Node_Id); procedure Analyze_Arithmetic_Op (N : Node_Id); procedure Analyze_Call (N : Node_Id); procedure Analyze_Comparison_Op (N : Node_Id); procedure Analyze_Concatenation (N : Node_Id); procedure Analyze_Conversion (N : Node_Id); procedure Analyze_Equality_Op (N : Node_Id); procedure Analyze_Explicit_Dereference (N : Node_Id); procedure Analyze_Expression_Actions (N : Node_Id); procedure Analyze_Indexed_Component (N : Node_Id); procedure Analyze_Logical_Op (N : Node_Id); procedure Analyze_Membership_Op (N : Node_Id); procedure Analyze_Negation (N : Node_Id); procedure Analyze_Null (N : Node_Id); procedure Analyze_N_Parenthesized_Expression (N : Node_Id); procedure Analyze_Qualified_Expression (N : Node_Id); procedure Analyze_Range (N : Node_Id); procedure Analyze_Reference (N : Node_Id); procedure Analyze_Selected_Component (N : Node_Id); procedure Analyze_Short_Circuit (N : Node_Id); procedure Analyze_Unary_Op (N : Node_Id); procedure Analyze_Expression (N : Node_Id); -- This is the top-level procedure for analyzing all expressions. -- For expressions that are not names, this is just a call to analyze. -- If the expression is a name, it may be a call to a parameterless -- procedure, and if so must be converted into an explicit call node -- and analyzed as such. end Sem_Ch4; ܹNa-uint.hð¹O xeinfo.spt¹Pali.ads¹Q xsinfo.spto,¹R xtreeprs.sptj@¹S xnmake.sptjT¹T mk-ttypes.cd¹Uali.adbx¹V bcheck.ads…Œ¹W bcheck.adb ¹X binde.ads´¹Y binde.adbÈgnat-1.67-src/src/sem_ch4.adb 444 10015 7640 141051 5506244374 11156 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ C H 4 -- -- -- -- B o d y -- -- -- -- $Revision: 1.164 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Debug; use Debug; with Einfo; use Einfo; with Errout; use Errout; with Exp_Util; use Exp_Util; with Namet; use Namet; with Nmake; use Nmake; with Output; use Output; with Sem; use Sem; with Sem_Ch3; use Sem_Ch3; with Sem_Ch8; use Sem_Ch8; with Sem_Util; use Sem_Util; with Sem_Type; use Sem_Type; with Stand; use Stand; with Sinfo; use Sinfo; with Snames; use Snames; with Tbuild; use Tbuild; package body Sem_Ch4 is ----------------------- -- Local Subprograms -- ----------------------- procedure Analyze_Expanded_Operator (N : Node_Id; Op_Id : Entity_Id); -- Analyze a call of the form P."+", etc. where the prefix of the call -- is an expanded name whose selector is an operator name, and one -- possible interpretation of the name is a predefined operator. procedure Analyze_Overloaded_Indexed_Component (N : Node_Id); -- If the prefix of an indexed component is overloaded, the proper -- interpretation is selected by the index types and the context. procedure Analyze_Overloaded_Selected_Component (N : Node_Id); -- If the prefix of a selected_component is overloaded, the proper -- interpretation that yields a record type with the proper selector -- name must be selected. procedure Analyze_User_Defined_Binary_Op (N : Node_Id; Op_Id : Entity_Id); -- A user-defined operator is resolved like a function, but instead of -- a list of actuals it is presented with the left and right operands -- of an operator node. procedure Analyze_User_Defined_Unary_Op (N : Node_Id; Op_Id : Entity_Id); procedure Insert_Explicit_Dereference (N : Node_Id); -- In a context that requires a composite or subprogram type and -- where a prefix is an access type, insert an explicit dereference. procedure Analyze_One_Call (N : Node_Id; Nam : Entity_Id; Report : Boolean); -- Check one interpretation of an overloaded subprogram name -- for compatibility with the types of the actuals in a call. -- If there is a single interpretation which does not match, -- report error if Report is set to True. procedure Find_Arithmetic_Types (L, R : Node_Id; Op_Id : Entity_Id; N : Node_Id); -- L and R are the operands of an arithmetic operator. Find -- consistent pairs of interpretations for L and R that have a -- numeric type consistent with the semantics of the operator. procedure Find_Comparison_Types (L, R : Node_Id; Op_Id : Entity_Id; N : Node_Id); -- L and R are operands of a comparison operator. Find consistent -- pairs of interpretations for L and R. procedure Find_Concatenation_Types (L, R : Node_Id; Op_Id : Entity_Id; N : Node_Id); -- for the four varieties of concatenation. procedure Find_Equality_Types (L, R : Node_Id; Op_Id : Entity_Id; N : Node_Id); -- Ditto for equality operators. procedure Find_Boolean_Types (L, R : Node_Id; Op_Id : Entity_Id; N : Node_Id); -- Ditto for binary logical operations. procedure Find_Negation_Types (R : Node_Id; Op_Id : Entity_Id; N : Node_Id); -- negation operator. procedure Find_Unary_Types (R : Node_Id; Op_Id : Entity_Id; N : Node_Id); -- Unary arithmetic types: plus, minus, abs. procedure Check_Arithmetic_Pair (T1, T2 : Entity_Id; Op_Id : Entity_Id; N : Node_Id); -- Subsidiary procedure to Find_Arithmetic_Types. T1 and T2 are valid -- types for left and right operand. Determine whether they constitute -- a valid pair for the given operator, and record the corresponding -- interpretation of the operator node. procedure Operator_Check (N : Node_Id); -- Verify that an operator has received some valid interpretation. -- If none was found, determine whether a use clause would make the -- operation legal. procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id); -- If an operator node resolves to a call to a user-defined operator, -- rewrite the node as a function call. ------------------------------ -- Rewrite_Operator_As_Call -- ------------------------------ procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id) is L, R : Node_Id; Actuals : List_Id := New_List; begin if Nkind (N) in N_Binary_Op then Append (Left_Opnd (N), Actuals); end if; Append (Right_Opnd (N), Actuals); Change_Node (N, N_Function_Call); Set_Etype (N, Etype (Nam)); Set_Name (N, New_Occurrence_Of (Nam, Sloc (N))); Set_Parameter_Associations (N, Actuals); end Rewrite_Operator_As_Call; ----------------------- -- Analyze_Aggregate -- ----------------------- -- For the moment, all Analyze_Aggregate does is to set the Etype, since -- all the work is done in Resolve_Aggregate. This is a bit peculiar, and -- should be fixed later to work like the other Analyze/Resolve pairs. procedure Analyze_Aggregate (N : Node_Id) is begin Set_Etype (N, Any_Composite); end Analyze_Aggregate; ----------------------- -- Analyze_Allocator -- ----------------------- procedure Analyze_Allocator (N : Node_Id) is E : constant Node_Id := Expression (N); Acc_Type : Entity_Id; Type_Id : Entity_Id; Loc : constant Source_Ptr := Sloc (N); begin if Nkind (E) = N_Qualified_Expression then Acc_Type := New_Implicit_Type (Loc); Set_Ekind (Acc_Type, E_Allocator_Type); Set_Etype (Acc_Type, Acc_Type); Find_Type (Subtype_Mark (E)); Type_Id := Entity (Subtype_Mark (E)); Set_Directly_Designated_Type (Acc_Type, Type_Id); Analyze (Expression (E)); -- When allocator's form is : new T'Class'(Exp) -- * an Equivalent type if generated (Expand_Class_Subtype) -- * the node is expanded into -- Acc_Type (new Equiv_Type'(Equiv_Type (Exp))) if Is_Class_Type (Type_Id) then Expand_Class_Allocator (N, Acc_Type, New_Class_Subtype (N, Type_Id)); return; end if; else declare Desig_Type : Entity_Id; Subtype_Decl : Node_Id; Def_Id : Entity_Id; New_Alloc : Node_Id; begin -- If the allocator includes a N_Subtype_Indication then a -- constraint is present, otherwise the node is a subtype mark. -- Introduce an explicit subtype declaration into the tree -- defining some anonymous subtype and rewrite the allocator to -- use this subtype rather than the subtype indication. -- Change the allocator node to an N_Expression_Actions, where -- the actions just consist of the subtype declaration just -- introduced and the expression is the rewritten allocator. -- Analyze is then called on the rewritten node for the analysis. -- It is important to introduce the explicit subtype declaration -- so that the bounds of the subtype indication are attached to -- the tree in case the allocator is inside a generic unit. if Nkind (E) = N_Subtype_Indication then Subtype_Decl := New_Node (N_Subtype_Declaration, Loc); Def_Id := Make_Defining_Identifier (Loc, Chars => New_Internal_Name ("subtype")); Set_Defining_Identifier (Subtype_Decl, Def_Id); Set_Subtype_Indication (Subtype_Decl, E); New_Alloc := New_Node (N_Allocator, Loc); Set_Expression (New_Alloc, Make_Identifier (Loc, Chars (Def_Id))); Rewrite_Substitute_Tree (N, Make_Expression_Actions (Loc, Actions => New_List_1 (Subtype_Decl), Expression => New_Alloc)); Analyze (N); return; else Desig_Type := Process_Subtype (E); Acc_Type := New_Implicit_Type (Sloc (N)); Set_Ekind (Acc_Type, E_Allocator_Type); Set_Etype (Acc_Type, Acc_Type); Set_Directly_Designated_Type (Acc_Type, Desig_Type); end if; end; end if; Set_Etype (N, Acc_Type); end Analyze_Allocator; --------------------------- -- Analyze_Arithmetic_Op -- --------------------------- procedure Analyze_Arithmetic_Op (N : Node_Id) is Index : Interp_Index; It : Interp; L : constant Node_Id := Left_Opnd (N); R : constant Node_Id := Right_Opnd (N); Op_Id : Entity_Id; begin Set_Etype (N, Any_Type); Analyze_Expression (L); Analyze_Expression (R); Op_Id := Get_Name_Entity_Id (Chars (N)); while Present (Op_Id) loop if Ekind (Op_Id) = E_Operator and then Present (Next_Entity (First_Entity (Op_Id))) then Find_Arithmetic_Types (L, R, Op_Id, N); else Analyze_User_Defined_Binary_Op (N, Op_Id); end if; Op_Id := Homonym (Op_Id); end loop; Operator_Check (N); end Analyze_Arithmetic_Op; ------------------ -- Analyze_Call -- ------------------ -- Function, procedure, and entry calls are checked here. E is the prefix -- of the call (which may be overloaded). The actuals have been analyzed -- and may themselves be overloaded. On exit from this procedure, the node -- N may have zero, one or more interpretations. In the first case an error -- message is produced. In the last case, the node is flagged as overloaded -- and the interpretations are collected in All_Interp. -- If the prefix is an Access_To_Subprogram, it cannot be overloaded, but -- the type-checking is similar to that of other calls. procedure Analyze_Call (N : Node_Id) is Actuals : constant List_Id := Parameter_Associations (N); E : constant Entity_Id := Name (N); I : Interp_Index; It : Interp; Nam : Entity_Id; Found : Boolean := False; begin -- Initialize the type of the result of the call to -- Universal type, to prevent cascaded errors. Set_Etype (N, Any_Type); if not Is_Overloaded (E) then -- Only one interpretation to check if Ekind (Etype (E)) = E_Subprogram_Type then Nam := Etype (E); elsif Is_Access_Type (Etype (E)) and then Ekind (Designated_Type (Etype (E))) = E_Subprogram_Type then Nam := Designated_Type (Etype (E)); Insert_Explicit_Dereference (E); else Nam := Entity (E); if not Is_Overloadable (Nam) then Error_Msg_N ("invalid prefix in call", E); return; end if; end if; Analyze_One_Call (N, Nam, True); else Get_First_Interp (E, I, It); while Present (It.Nam) loop Nam := It.Nam; Analyze_One_Call (N, Nam, False); Get_Next_Interp (I, It); end loop; if Etype (N) = Any_Type then -- None of the interpretations is compatible with the actuals Error_Msg_N ("invalid parameter list in call", E); elsif not Is_Overloaded (N) then -- Resolution yields a single interpretation. Verify that -- is has the proper capitalization. Set_Entity_With_Style_Check (E, Entity (E)); end if; End_Interp_List; end if; end Analyze_Call; --------------------------- -- Analyze_Comparison_Op -- --------------------------- procedure Analyze_Comparison_Op (N : Node_Id) is L : constant Node_Id := Left_Opnd (N); R : constant Node_Id := Right_Opnd (N); Op_Id : Entity_Id; begin Set_Etype (N, Any_Type); Analyze_Expression (L); Analyze_Expression (R); Op_Id := Get_Name_Entity_Id (Chars (N)); while Present (Op_Id) loop if Ekind (Op_Id) = E_Operator then Find_Comparison_Types (L, R, Op_Id, N); else Analyze_User_Defined_Binary_Op (N, Op_Id); end if; Op_Id := Homonym (Op_Id); end loop; Operator_Check (N); end Analyze_Comparison_Op; --------------------------- -- Analyze_Concatenation -- --------------------------- -- If the only one-dimensional array type in scope is String, -- this is the resulting type of the operation. Otherwise there -- will be a concatenation operation defined for each user-defined -- one-dimensional array. procedure Analyze_Concatenation (N : Node_Id) is L : constant Node_Id := Left_Opnd (N); R : constant Node_Id := Right_Opnd (N); Op_Id : Entity_Id; begin Set_Etype (N, Any_Type); Analyze_Expression (L); Analyze_Expression (R); Op_Id := Get_Name_Entity_Id (Name_Op_Concat); while Present (Op_Id) loop if Ekind (Op_Id) = E_Operator then Find_Concatenation_Types (L, R, Op_Id, N); else Analyze_User_Defined_Binary_Op (N, Op_Id); end if; Op_Id := Homonym (Op_Id); end loop; Operator_Check (N); end Analyze_Concatenation; ------------------------ -- Analyze_Conversion -- ------------------------ procedure Analyze_Conversion (N : Node_Id) is Expr : constant Node_Id := Expression (N); T : Entity_Id; begin Find_Type (Subtype_Mark (N)); T := Entity (Subtype_Mark (N)); Set_Etype (N, T); Analyze_Expression (Expr); -- if it is a tagged type, that's a view conversion if Is_Name (Expr) and then Is_Tagged_Type (T) then Set_Unchecked_Conversion (N, True); end if; if Nkind (Expr) = N_Aggregate or else Nkind (Expr) = N_String_Literal or else (Nkind (Expr) = N_Attribute_Reference and then (Chars (Identifier (Expr)) = Name_Access or else Chars (Identifier (Expr)) = Name_Unchecked_Access)) then Error_Msg_N ("argument of conversion cannot be aggregate, literal or access", N); end if; end Analyze_Conversion; ------------------------- -- Analyze_Equality_Op -- ------------------------- procedure Analyze_Equality_Op (N : Node_Id) is L : constant Node_Id := Left_Opnd (N); R : constant Node_Id := Right_Opnd (N); Op_Id : Entity_Id; Neg : Node_Id; Eq : Node_Id; begin if Chars (N) = Name_Op_Ne then Eq := Make_Op_Eq (Sloc (N), L, R); Neg := Make_Op_Not (Sloc (N), Eq); Analyze (Eq); Set_Etype (Neg, Standard_Boolean); -- Find predefined negation operation. Op_Id := Current_Entity (Neg); while Ekind (Op_Id) /= E_Operator loop Op_Id := Homonym (Op_Id); end loop; Set_Entity (Neg, Op_Id); Rewrite_Substitute_Tree (N, Neg); else Set_Etype (N, Any_Type); Analyze_Expression (L); Analyze_Expression (R); Op_Id := Get_Name_Entity_Id (Chars (N)); while Present (Op_Id) loop if Ekind (Op_Id) = E_Operator then Find_Equality_Types (L, R, Op_Id, N); else Analyze_User_Defined_Binary_Op (N, Op_Id); end if; Op_Id := Homonym (Op_Id); end loop; Operator_Check (N); end if; end Analyze_Equality_Op; ---------------------------------- -- Analyze_Explicit_Dereference -- ---------------------------------- procedure Analyze_Explicit_Dereference (N : Node_Id) is P : constant Node_Id := Prefix (N); T : Entity_Id; I : Interp_Index; It : Interp; begin Analyze_Expression (P); Set_Etype (N, Any_Type); if not Is_Overloaded (P) then T := Etype (P); -- Return if error in prefix if T = Any_Type then return; elsif not Is_Access_Type (T) then Error_Msg_N ("access type required in prefix of explicit dereference", P); else Set_Etype (N, Designated_Type (T)); end if; else New_Interps (N); Get_First_Interp (P, I, It); while Present (It.Nam) loop T := It.Typ; if Is_Access_Type (T) then Add_One_Interp (N, Designated_Type (T), Designated_Type (T)); end if; Get_Next_Interp (I, It); end loop; if Etype (N) = Any_Type then -- No access type was found for prefix Error_Msg_N ("access type required in prefix of explicit dereference", P); Set_Etype (N, Any_Type); end if; end if; end Analyze_Explicit_Dereference; -------------------------------- -- Analyze_Expression_Actions -- -------------------------------- procedure Analyze_Expression_Actions (N : Node_Id) is begin Analyze_Declarations (Actions (N)); Analyze (Expression (N)); Set_Etype (N, Etype (Expression (N))); -- All implicit subtypes that were generated by the expression part -- should be become attached to the actions part so they will be -- processed before the expression. if Is_Non_Empty_List (Implicit_Type_List) then Append_List (Implicit_Type_List, Actions (N)); Implicit_Type_List := New_List; end if; end Analyze_Expression_Actions; ------------------------------- -- Analyze_Indexed_Component -- ------------------------------- procedure Analyze_Indexed_Component (N : Node_Id) is Name : Node_Id := Prefix (N); Expr : Node_Id := First (Expressions (N)); Array_Type : Entity_Id; Index : Node_Id; begin if Is_Overloaded (Name) then Analyze_Overloaded_Indexed_Component (N); else Array_Type := Etype (Name); -- Prefix must be appropriate for an array type. Dereference if -- prefix is an access type. if Is_Access_Type (Array_Type) then Array_Type := Designated_Type (Array_Type); -- Make_Explicit_Dereference (Name); -- TBSL end if; if not Is_Array_Type (Array_Type) then Error_Msg_N ("array type required in indexed component", Name); Set_Etype (N, Any_Type); return; end if; Index := First_Index (Array_Type); while Present (Index) and then Present (Expr) loop if Has_Compatible_Type (Expr, Etype (Index)) then null; else Set_Etype (N, Any_Type); Error_Msg_NE ("invalid index type. Expect &", Expr, Etype (Index)); return; end if; Index := Next_Index (Index); Expr := Next (Expr); end loop; Set_Etype (N, Component_Type (Array_Type)); if No (Index) and No (Expr) then null; else Error_Msg_N ( "incorrect number of indices in indexed component", N); end if; end if; end Analyze_Indexed_Component; ------------------------ -- Analyze_Logical_Op -- ------------------------ procedure Analyze_Logical_Op (N : Node_Id) is L : constant Node_Id := Left_Opnd (N); R : constant Node_Id := Right_Opnd (N); Op_Id : Entity_Id; begin Set_Etype (N, Any_Type); Analyze_Expression (L); Analyze_Expression (R); Op_Id := Get_Name_Entity_Id (Chars (N)); while Present (Op_Id) loop if Ekind (Op_Id) = E_Operator then Find_Boolean_Types (L, R, Op_Id, N); else Analyze_User_Defined_Binary_Op (N, Op_Id); end if; Op_Id := Homonym (Op_Id); end loop; Operator_Check (N); end Analyze_Logical_Op; --------------------------- -- Analyze_Membership_Op -- --------------------------- procedure Analyze_Membership_Op (N : Node_Id) is L : constant Node_Id := Left_Opnd (N); R : constant Node_Id := Right_Opnd (N); Typ : Entity_Id; begin Analyze_Expression (L); if Nkind (R) = N_Range or else (Nkind (R) = N_Attribute_Reference and then Get_Attribute_Id (Chars (Identifier (R))) = Attribute_Range) then Analyze (R); else -- If not a range, it can only be a subtype-mark. Find_Type (R); end if; Typ := Intersect_Types (L, R); Set_Etype (N, Standard_Boolean); end Analyze_Membership_Op; ---------------------- -- Analyze_Negation -- ---------------------- procedure Analyze_Negation (N : Node_Id) is R : constant Node_Id := Right_Opnd (N); Op_Id : Entity_Id; begin Set_Etype (N, Any_Type); Analyze_Expression (R); Op_Id := Get_Name_Entity_Id (Chars (N)); while Present (Op_Id) loop if Ekind (Op_Id) = E_Operator then Find_Negation_Types (R, Op_Id, N); else Analyze_User_Defined_Unary_Op (N, Op_Id); end if; Op_Id := Homonym (Op_Id); end loop; Operator_Check (N); end Analyze_Negation; ------------------- -- Analyze_Null -- ------------------- procedure Analyze_Null (N : Node_Id) is begin Set_Etype (N, Any_Access); end Analyze_Null; ----------------------------------------- -- Analyze_N_Parenthesized_Expression -- ----------------------------------------- procedure Analyze_N_Parenthesized_Expression (N : Node_Id) is begin Analyze_Expression (Expression (N)); Set_Etype (N, Etype (Expression (N))); end Analyze_N_Parenthesized_Expression; ------------------------ -- Analyze_Expression -- ------------------------ procedure Analyze_Expression (N : Node_Id) is Nam : Node_Id; begin Analyze (N); if Is_Name (N) and then Is_Overloadable (Entity (N)) and then (Ekind (Entity (N)) /= E_Enumeration_Literal or else Is_Overloaded (N)) then Nam := New_Copy (N); -- If overloaded, overload set belongs to new copy. if Is_Overloaded (N) then for Index in 0 .. Interp_Map.Last loop if Interp_Map.Table (Index).Node = N then Interp_Map.Table (Index).Node := Nam; exit; end if; end loop; end if; -- Change node to parameterless function call Change_Node (N, N_Function_Call); Set_Name (N, Nam); Set_Sloc (N, Sloc (Nam)); Analyze_Call (N); end if; end Analyze_Expression; ---------------------------------- -- Analyze_Qualified_Expression -- ---------------------------------- procedure Analyze_Qualified_Expression (N : Node_Id) is Mark : constant Entity_Id := Subtype_Mark (N); T : Entity_Id; begin Set_Etype (N, Any_Type); Find_Type (Mark); T := Entity (Mark); if T = Any_Type then return; end if; if Is_Incomplete_Type (T) then Error_Msg_N ("premature use of incomplete type&", T); end if; Analyze_Expression (Expression (N)); Set_Etype (N, T); end Analyze_Qualified_Expression; ------------------- -- Analyze_Range -- ------------------- procedure Analyze_Range (N : Node_Id) is L : Node_Id := Low_Bound (N); H : Node_Id := High_Bound (N); Typ : Entity_Id; begin Analyze_Expression (L); Analyze_Expression (H); Typ := Intersect_Types (L, H); if Typ /= Any_Type and then not Is_Discrete_Type (Typ) then Error_Msg_N ("type& in range is not discrete type", N); Set_Etype (N, Any_Type); else Set_Etype (N, Typ); end if; end Analyze_Range; ----------------------- -- Analyze_Reference -- ----------------------- procedure Analyze_Reference (N : Node_Id) is begin null; -- TBD ??? end Analyze_Reference; -------------------------------- -- Analyze_Selected_Component -- -------------------------------- -- Prefix is a record type or a task or protected type. In the -- later case, the selector must denote a visible entry. procedure Analyze_Selected_Component (N : Node_Id) is Comp : Entity_Id; Name : constant Node_Id := Prefix (N); Sel : constant Node_Id := Selector_Name (N); Prefix_Type : Entity_Id; Expr_Type : Entity_Id; begin Set_Etype (N, Any_Type); if Is_Overloaded (Name) then Analyze_Overloaded_Selected_Component (N); return; elsif Etype (Name) = Any_Type then Set_Entity (Sel, Any_Id); Set_Etype (Sel, Any_Type); return; else Prefix_Type := Etype (Name); end if; if Is_Access_Type (Prefix_Type) then Prefix_Type := Designated_Type (Prefix_Type); end if; Comp := First_Entity (Prefix_Type); if Is_Record_Type (Prefix_Type) then -- Find component with given name while Present (Comp) loop if Chars (Comp) = Chars (Sel) then Set_Entity_With_Style_Check (Sel, Comp); Set_Etype (Sel, Etype (Comp)); Set_Etype (N, Etype (Comp)); return; end if; Comp := Next_Entity (Comp); end loop; else -- Prefix is concurrent type. Find visible operation with given name while Present (Comp) and then Comp /= First_Private_Entity (Prefix_Type) loop if Chars (Comp) = Chars (Sel) then Set_Entity_With_Style_Check (Sel, Comp); Set_Etype (Sel, Etype (Comp)); Set_Etype (N, Etype (Comp)); if Present (Homonym (Comp)) then Collect_Interps (N); end if; return; end if; Comp := Next_Entity (Comp); end loop; end if; -- If we exit, the component is not defined in the type. Error_Msg_NE ("undefined selector for type&", N, Prefix_Type); Set_Entity (Sel, Any_Id); Set_Etype (Sel, Any_Type); end Analyze_Selected_Component; --------------------------- -- Analyze_Short_Circuit -- --------------------------- procedure Analyze_Short_Circuit (N : Node_Id) is L : constant Node_Id := Left_Opnd (N); R : constant Node_Id := Right_Opnd (N); Typ : Entity_Id; begin Analyze_Expression (L); Analyze_Expression (R); Typ := Intersect_Types (L, R); Set_Etype (N, Standard_Boolean); if Is_Boolean_Type (Typ) or else Typ = Any_Type then null; else Error_Msg_N ("expect boolean arguments for operator ", N); end if; end Analyze_Short_Circuit; ---------------------- -- Analyze_Unary_Op -- ---------------------- procedure Analyze_Unary_Op (N : Node_Id) is R : constant Node_Id := Right_Opnd (N); Op_Id : Entity_Id; begin Set_Etype (N, Any_Type); Analyze_Expression (R); Op_Id := Get_Name_Entity_Id (Chars (N)); while Present (Op_Id) loop if Ekind (Op_Id) = E_Operator then if No (Next_Entity (First_Entity (Op_Id))) then Find_Unary_Types (R, Op_Id, N); end if; else Analyze_User_Defined_Unary_Op (N, Op_Id); end if; Op_Id := Homonym (Op_Id); end loop; Operator_Check (N); end Analyze_Unary_Op; ------------------------------------------ -- Analyze_Overloaded_Indexed_Component -- ------------------------------------------ procedure Analyze_Overloaded_Indexed_Component (N : Node_Id) is Name : constant Node_Id := Prefix (N); Expr : Node_Id; I : Interp_Index; It : Interp; Typ : Entity_Id; Index : Node_Id; Found : Boolean; begin Set_Etype (N, Any_Type); New_Interps (N); Get_First_Interp (Name, I, It); while Present (It.Nam) loop Typ := It.Typ; if Is_Access_Type (Typ) then Typ := Designated_Type (Typ); end if; if Is_Array_Type (Typ) then -- Got a candidate: verify that index types are compatible Index := First_Index (Typ); Found := True; Expr := First (Expressions (N)); while Present (Index) and then Present (Expr) loop if Has_Compatible_Type (Expr, Etype (Index)) then null; else Found := False; Remove_Interp (I); exit; end if; Index := Next_Index (Index); Expr := Next (Expr); end loop; if Found and then No (Index) and then No (Expr) then Add_One_Interp (N, Etype (Component_Type (Typ)), Etype (Component_Type (Typ))); end if; end if; Get_Next_Interp (I, It); end loop; if Etype (N) = Any_Type then Error_Msg_N ("no legal interpetation for indexed component", N); Set_Is_Overloaded (N, False); end if; End_Interp_List; end Analyze_Overloaded_Indexed_Component; ------------------------------------------- -- Analyze_Overloaded_Selected_Component -- ------------------------------------------- procedure Analyze_Overloaded_Selected_Component (N : Node_Id) is begin Unimplemented (N, "overloaded prefix in selected component"); end Analyze_Overloaded_Selected_Component; --------------------------------- -- Insert_Explicit_Dereference -- --------------------------------- procedure Insert_Explicit_Dereference (N : Node_Id) is begin Rewrite_Substitute_Tree (N, Make_Explicit_Dereference (Sloc (N), Prefix => New_Copy (N))); Set_Etype (N, Designated_Type (Etype (Prefix (N)))); end Insert_Explicit_Dereference; --------------------------- -- Find_Comparison_Types -- --------------------------- procedure Find_Comparison_Types (L, R : Node_Id; Op_Id : Entity_Id; N : Node_Id) is Index : Interp_Index; It : Interp; Found : Boolean := False; procedure Try_One_Interp (T1 : Entity_Id) is -- The context of the operator plays no role in resolving the -- arguments, so that if there is more than one interpretation -- of the operands that is compatible with comparison, begin if Valid_Comparison_Arg (T1) and then Has_Compatible_Type (R, T1) then if Found then Error_Msg_N ("ambiguous operands for comparison", N); Set_Etype (L, Any_Type); else Found := True; Set_Etype (L, T1); Add_One_Interp (N, Op_Id, Standard_Boolean); end if; end if; end Try_One_Interp; begin if not Is_Overloaded (L) then Try_One_Interp (Etype (L)); else Get_First_Interp (L, Index, It); while Present (It.Typ) loop Try_One_Interp (It.Typ); Get_Next_Interp (Index, It); end loop; end if; end Find_Comparison_Types; ------------------------------ -- Find_Concatenation_Types -- ------------------------------ procedure Find_Concatenation_Types (L, R : Node_Id; Op_Id : Entity_Id; N : Node_Id) is Op_Type : Entity_Id := Etype (Op_Id); begin if (Has_Compatible_Type (L, Op_Type) or else Has_Compatible_Type (L, Component_Type (Op_Type))) and then (Has_Compatible_Type (R, Op_Type) or else Has_Compatible_Type (R, Component_Type (Op_Type))) then Add_One_Interp (N, Op_Id, Op_Type); end if; end Find_Concatenation_Types; ------------------------- -- Find_Equality_Types -- ------------------------- procedure Find_Equality_Types (L, R : Node_Id; Op_Id : Entity_Id; N : Node_Id) is Index : Interp_Index; It : Interp; Found : Boolean := False; procedure Try_One_Interp (T1 : Entity_Id) is -- The context of the operator plays no role in resolving the -- arguments, so that if there is more than one interpretation -- of the operands that is compatible with equality, the construct -- is ambiguous and an error can be emitted now. begin if not Is_Limited_Type (T1) and then Has_Compatible_Type (R, T1) then if Found then Error_Msg_N ("ambiguous operands for equality", N); Set_Etype (L, Any_Type); else Found := True; Set_Etype (L, T1); Add_One_Interp (N, Op_Id, Standard_Boolean); end if; end if; end Try_One_Interp; begin if not Is_Overloaded (L) then Try_One_Interp (Etype (L)); else Get_First_Interp (L, Index, It); while Present (It.Typ) loop Try_One_Interp (It.Typ); Get_Next_Interp (Index, It); end loop; end if; end Find_Equality_Types; ------------------------- -- Find_Boolean_Types -- ------------------------- procedure Find_Boolean_Types (L, R : Node_Id; Op_Id : Entity_Id; N : Node_Id) is Index : Interp_Index; It : Interp; begin if not Is_Overloaded (L) then if Valid_Boolean_Arg (Etype (L)) and then Has_Compatible_Type (R, Etype (L)) then Add_One_Interp (N, Op_Id, Etype (L)); end if; else Get_First_Interp (L, Index, It); while Present (It.Typ) loop if Valid_Boolean_Arg (It.Typ) and then Has_Compatible_Type (R, It.Typ) then Add_One_Interp (N, Op_Id, It.Typ); end if; Get_Next_Interp (Index, It); end loop; end if; end Find_Boolean_Types; ------------------------- -- Find_Negation_Types -- ------------------------- procedure Find_Negation_Types (R : Node_Id; Op_Id : Entity_Id; N : Node_Id) is Index : Interp_Index; It : Interp; begin if not Is_Overloaded (R) then if Valid_Boolean_Arg (Etype (R)) then Add_One_Interp (N, Op_Id, Etype (R)); end if; else Get_First_Interp (R, Index, It); while Present (It.Typ) loop if Valid_Boolean_Arg (It.Typ) then Add_One_Interp (N, Op_Id, It.Typ); end if; Get_Next_Interp (Index, It); end loop; end if; end Find_Negation_Types; ---------------------- -- Find_Unary_Types -- ---------------------- procedure Find_Unary_Types (R : Node_Id; Op_Id : Entity_Id; N : Node_Id) is Index : Interp_Index; It : Interp; begin if not Is_Overloaded (R) then if Is_Numeric_Type (Etype (R)) then Add_One_Interp (N, Op_Id, Etype (R)); end if; else Get_First_Interp (R, Index, It); while Present (It.Typ) loop if Is_Numeric_Type (It.Typ) then Add_One_Interp (N, Op_Id, It.Typ); end if; Get_Next_Interp (Index, It); end loop; end if; end Find_Unary_Types; --------------------------- -- Find_Arithmetic_Types -- --------------------------- procedure Find_Arithmetic_Types (L, R : Node_Id; Op_Id : Entity_Id; N : Node_Id) is Index1, Index2 : Interp_Index; It1, It2 : Interp; procedure Check_Right_Argument (T : Entity_Id) is begin if not Is_Overloaded (R) then Check_Arithmetic_Pair (T, Etype (R), Op_Id, N); else Get_First_Interp (R, Index2, It2); while Present (It2.Typ) loop Check_Arithmetic_Pair (T, It2.Typ, Op_Id, N); Get_Next_Interp (Index2, It2); end loop; end if; end Check_Right_Argument; begin if not Is_Overloaded (L) then Check_Right_Argument (Etype (L)); else Get_First_Interp (L, Index1, It1); while Present (It1.Typ) loop Check_Right_Argument (It1.Typ); Get_Next_Interp (Index1, It1); end loop; end if; end Find_Arithmetic_Types; --------------------------- -- Check_Arithmetic_Pair -- --------------------------- procedure Check_Arithmetic_Pair (T1, T2 : Entity_Id; Op_Id : Entity_Id; N : Node_Id) is Op_Name : Name_Id := Chars (Op_Id); function Specific_Type (T1, T2 : Entity_Id) return Entity_Id is begin if T1 = Universal_Integer or else T1 = Universal_Real then return Base_Type (T2); else return Base_Type (T1); end if; end Specific_Type; begin if Op_Name = Name_Op_Add or else Op_Name = Name_Op_Subtract then if Is_Numeric_Type (T1) and then (Covers (T1, T2) or else Covers (T2, T1)) then Add_One_Interp (N, Op_Id, Specific_Type (T1, T2)); end if; elsif Op_Name = Name_Op_Multiply or else Op_Name = Name_Op_Divide then if Is_Numeric_Type (T1) and then (Covers (T1, T2) or else Covers (T2, T1)) then Add_One_Interp (N, Op_Id, Specific_Type (T1, T2)); elsif (Is_Fixed_Type (T1) or else T1 = Universal_Real) and then Is_Integer_Type (T2) then Add_One_Interp (N, Op_Id, T1); elsif (Is_Fixed_Type (T2) or else T2 = Universal_Real) and then Is_Integer_Type (T1) and then Nkind (N) = N_Op_Multiply then Add_One_Interp (N, Op_Id, T1); end if; elsif (Op_Name = Name_Op_Mod or else Op_Name = Name_Op_Rem) then if Is_Integer_Type (T1) and then (Covers (T1, T2) or else Covers (T2, T1)) then Add_One_Interp (N, Op_Id, Specific_Type (T1, T2)); end if; elsif Op_Name = Name_Op_Expon then if Is_Numeric_Type (T1) and then Is_Integer_Type (T2) then Add_One_Interp (N, Op_Id, Base_Type (T1)); end if; end if; end Check_Arithmetic_Pair; ------------------------------------ -- Analyze_User_Defined_Unary_Op -- ------------------------------------ procedure Analyze_User_Defined_Unary_Op (N : Node_Id; Op_Id : Entity_Id) is F : Entity_Id := First_Formal (Op_Id); begin -- Verify that Op_Id is a visible unary function if Ekind (Op_Id) = E_Function and then No (Next_Formal (F)) and then (Is_Directly_Visible (Op_Id) or else Is_Use_Visible (Op_Id)) and then Has_Compatible_Type (Right_Opnd (N), Etype (F)) then Add_One_Interp (N, Op_Id, Etype (Op_Id)); end if; end Analyze_User_Defined_Unary_Op; ------------------------------------- -- Analyze_User_Defined_Binary_Op -- ------------------------------------- procedure Analyze_User_Defined_Binary_Op (N : Node_Id; Op_Id : Entity_Id) is F1 : Entity_Id := First_Formal (Op_Id); F2 : Entity_Id := Next_Formal (F1); begin -- Verify that Op_Id is a visible binary function if Ekind (Op_Id) = E_Function and then Present (F2) and then (Is_Directly_Visible (Op_Id) or else Is_Use_Visible (Op_Id)) and then Has_Compatible_Type (Left_Opnd (N), Etype (F1)) and then Has_Compatible_Type (Right_Opnd (N), Etype (F2)) then Add_One_Interp (N, Op_Id, Etype (Op_Id)); if Debug_Flag_E then Write_Str ("user defined operator "); Write_Name (Chars (Op_Id)); Write_Str (" on node "); Write_Int (Int (N)); Write_Eol; end if; end if; end Analyze_User_Defined_Binary_Op; ---------------------- -- Analyze_One_Call -- ---------------------- procedure Analyze_One_Call (N : Node_Id; Nam : Entity_Id; Report : Boolean) is Actuals : constant List_Id := Parameter_Associations (N); Formal : Entity_Id; Actual : Node_Id; begin if not Normalize_Actuals (N, Nam, Report) then -- Mismatch in number or names of parameters if Debug_Flag_E then Write_Str (" normalization fails in call "); Write_Int (Int (N)); Write_Str (" with subprogram "); Write_Int (Int (Nam)); Write_Eol; end if; elsif not List_Present (Actuals) then -- If Normalize succeeds, then there are default parameters for -- all formals. Add_One_Interp (N, Nam, Etype (Nam)); -- Set the entity pointer, unless it is an indirect call, in -- which case the prefix is an expression without a unique name. if not Is_Type (Nam) then Set_Entity (Name (N), Nam); end if; if Debug_Flag_E and not Report then Write_Str (" Overloaded call "); Write_Int (Int (N)); Write_Str (" compatible with "); Write_Int (Int (Nam)); Write_Eol; end if; elsif Ekind (Nam) = E_Operator then -- This can occur when the prefix of the call is an expanded name -- whose selector is an operator name. Analyze_Expanded_Operator (N, Nam); else -- Normalize_Actuals has chained the named associations in the -- correct order of the formals. Actual := First_Actual (N); Formal := First_Formal (Nam); while Present (Actual) and then Present (Formal) loop if (Nkind (Parent (Actual)) /= N_Parameter_Association or else Chars (Selector_Name (Parent (Actual))) = Chars (Formal)) then if Has_Compatible_Type (Actual, Etype (Formal)) then Actual := Next_Actual (Actual); Formal := Next_Formal (Formal); else if Debug_Flag_E then Write_Str (" type checking fails in call "); Write_Int (Int (N)); Write_Str (" with formal "); Write_Int (Int (Formal)); Write_Str (" in subprogram "); Write_Int (Int (Nam)); Write_Eol; end if; if Report then Error_Msg_Node_2 := Etype (Actual); Error_Msg_NE ("type& expected, found&", Actual, Etype (Formal)); end if; return; end if; else -- Normalize_Actuals has verified that a default value exists -- for this formal. Current actual names a subsequent formal. Formal := Next_Formal (Formal); end if; end loop; -- On exit, all actuals match. Add_One_Interp (N, Nam, Etype (Nam)); if not Is_Type (Nam) then Set_Entity (Name (N), Nam); end if; if Debug_Flag_E and not Report then Write_Str (" Overloaded call "); Write_Int (Int (N)); Write_Str (" compatible with "); Write_Int (Int (Nam)); Write_Eol; end if; end if; end Analyze_One_Call; -------------------------------- -- Analyze_Expanded_Operator -- -------------------------------- procedure Analyze_Expanded_Operator (N : Node_Id; Op_Id : Entity_Id) is E : Node_Id := Name (N); Op_Name : Name_Id := Chars (Selector_Name (E)); Act1 : Node_Id := First_Actual (N); Act2 : Node_Id := Next_Actual (Act1); begin if Present (Act2) then -- Maybe binary operators if Present (Next_Actual (Act2)) then -- Too many actuals for an operator return; elsif Op_Name = Name_Op_Add or else Op_Name = Name_Op_Subtract or else Op_Name = Name_Op_Multiply or else Op_Name = Name_Op_Divide or else Op_Name = Name_Op_Mod or else Op_Name = Name_Op_Rem or else Op_Name = Name_Op_Expon then Find_Arithmetic_Types (Act1, Act2, Op_Id, N); elsif Op_Name = Name_Op_And or else Op_Name = Name_Op_Or or else Op_Name = Name_Op_Xor then Find_Boolean_Types (Act1, Act2, Op_Id, N); elsif Op_Name = Name_Op_Lt or else Op_Name = Name_Op_Le or else Op_Name = Name_Op_Gt or else Op_Name = Name_Op_Ge or else Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne then Find_Comparison_Types (Act1, Act2, Op_Id, N); elsif Op_Name = Name_Op_Concat then Find_Concatenation_Types (Act1, Act2, Op_Id, N); end if; else -- Unary operators if Op_Name = Name_Op_Subtract or else Op_Name = Name_Op_Add or else Op_Name = Name_Op_Abs then Find_Unary_Types (Act1, Op_Id, N); elsif Op_Name = Name_Op_Not then Find_Negation_Types (Act1, Op_Id, N); end if; end if; end Analyze_Expanded_Operator; -------------------- -- Operator_Check -- -------------------- procedure Operator_Check (N : Node_Id) is begin if Etype (N) = Any_Type then -- Looks bad, but don't complain if either operand has no type, -- since that simply means that we have a propagated error. if Etype (Right_Opnd (N)) = Any_Type or else (Nkind (N) in N_Binary_Op and then Etype (Left_Opnd (N)) = Any_Type) then null; else Error_Msg_N ("invalid operand types for operator&", N); end if; end if; -- TBSL: Indicate whether a use clause would make operator visible. end Operator_Check; end Sem_Ch4; Expon then if Is_Numeric_Type (T1) and then Is_Integer_Type (T2) then Add_One_Interp (N, Op_Id, Base_Type (T1)); end if; end if; end Check_Arithmetic_Pair; ------------------------------------ -- Analyze_User_Defined_Unary_Op -- ------------------------------------ procedure Analyze_User_Defined_Unary_Op (N : Node_Id; Op_Id : Entity_Id) is F : Entity_Ignat-1.67-src/src/sem_ch5.ads 444 10015 7640 7776 5506244374 11157 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ C H 5 -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Sem_Ch5 is procedure Analyze_Statements (L : List_Id); procedure Analyze_Assignment (N : Node_Id); procedure Analyze_If_Statement (N : Node_Id); procedure Analyze_Case_Statement (N : Node_Id); procedure Analyze_Loop_Statement (N : Node_Id); procedure Analyze_Block_Statement (N : Node_Id); procedure Analyze_Exit_Statement (N : Node_Id); procedure Analyze_Return_Statement (N : Node_Id); procedure Analyze_Goto_Statement (N : Node_Id); procedure Analyze_Implicit_Label_Declaration (N : Node_Id); type Case_Bounds is record Choice_Lo : Node_Id; Choice_Hi : Node_Id; Choice_Node : Node_Id; end record; type Case_Table_Type is array (Nat range <>) of Case_Bounds; -- Table type used by Check_Case_Choices procedure procedure Sort_Case_Table (Case_Table : in out Case_Table_Type); -- Sort the Case Table using the Lower Bound of each Choice as the key. -- A simple insertion sort is used since the number of choices in a case -- statement of variant part will usually be small and probably in near -- sorted order. procedure Check_Case_Choices (Case_Table : in out Case_Table_Type; N : Node_Id; Choice_Type : Entity_Id; Others_Present : Boolean); -- This is the procedure which verifies that a set of case choices -- is correct (has no duplicates, and covers the range). Case_Table -- contains the choices, N is the node for the construct, Choice_Type -- is the type of the value used for selection, and Others_Present is -- A flag indicating whether or not an others choice is present. function Number_Of_Case_Choices (N : Node_Id) return Nat; -- Iterates through the choices of a case statement or variant part of -- a record counting all the Choice nodes except for Others. function Is_Variable (N : Node_Id) return Boolean; -- Determines if the tree referenced by N represents a variable end Sem_Ch5; pgnat-1.67-src/src/sem_ch5.adb 444 10015 7640 74272 5506244375 11152 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ C H 5 -- -- -- -- B o d y -- -- -- -- $Revision: 1.92 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Comperr; use Comperr; with Einfo; use Einfo; with Errout; use Errout; with Sem; use Sem; with Sem_Ch3; use Sem_Ch3; with Sem_Ch8; use Sem_Ch8; with Sem_Eval; use Sem_Eval; with Sem_Disp; use Sem_Disp; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sem_Type; use Sem_Type; with Stand; use Stand; with Sinfo; use Sinfo; with Uintp; use Uintp; package body Sem_Ch5 is ----------------------- -- Local Subprograms -- ----------------------- procedure Analyze_Elsif_Parts (L : List_Id); procedure Analyze_Iteration_Scheme (N : Node_Id); ------------------------ -- Analyze_Statements -- ------------------------ procedure Analyze_Statements (L : List_Id) is S : Node_Id; begin -- The labels declared in the statement list are reachable from -- statements in the list. S := First (L); while Present (S) loop if Nkind (S) = N_Label then Find_Name (Identifier (S)); if Ekind (Entity (Identifier (S))) /= E_Label then Error_Msg_N ("label& conflicts with outer declaration ", Identifier (S)); else Set_Reachable (Entity (Identifier (S))); end if; end if; S := Next (S); -- Here is where we reset the data structures for overload resolution -- since no overload data is required to be kept between statements. -- Note that an expression actions node analyzes the actions as a -- sequence of declarations, not as a sequence of statements, so -- there is no problem in that case. Init_Interp; end loop; -- Perform semantic analysis on all statements S := First (L); while Present (S) loop if Nkind (S) /= N_Label then Analyze (S); -- Insert all the N_Implicit_Type nodes representing implicit -- defining ids generated for the statement just analyzed (S). -- Statements which may generate implicit types include the loop -- statement and allocators. (See comments in New_Implicit_Type -- for details.) if Is_Non_Empty_List (Implicit_Type_List) then Insert_List_Before (S, Implicit_Type_List); Implicit_Type_List := New_List; end if; end if; S := Next (S); end loop; -- Make labels unreachable. Visibility is not sufficient, because -- labels in one if-branch for example are not reachable from the -- other branch, even though their declarations are in the enclosing -- declarative part. S := First (L); while Present (S) loop if Nkind (S) = N_Label then Set_Reachable (Entity (Identifier (S)), False); end if; S := Next (S); end loop; end Analyze_Statements; ------------------------ -- Analyze_Assignment -- ------------------------ -- For now, no overloaded left-hand side procedure Analyze_Assignment (N : Node_Id) is Lhs : constant Node_Id := Name (N); Rhs : constant Node_Id := Expression (N); T1, T2 : Entity_Id; begin Analyze (Lhs); T1 := Etype (Lhs); -- In the most general case, both Lhs and Rhs can be overloaded, and we -- must compute the intersection of the possible types on each side. -- (TBSL). if Is_Overloaded (Lhs) then Unimplemented (N, "overloaded lhs in assignment"); end if; Analyze (Rhs); Resolve_Subexpr (Lhs, T1); Resolve_Complete_Context (Rhs, T1); T2 := Etype (Rhs); if Covers (T1, T2) then null; else Error_Msg_Name_2 := Chars (Etype (Rhs)); Error_Msg_NE ("incompatible types on assignment:& :=&", N, Etype (Lhs)); end if; if T1 = Any_Type or else T2 = Any_Type then return; end if; if not Is_Variable (Lhs) and then not Assignment_OK (N) then Error_Msg_N ("left hand side of assignment must be a variable", Lhs); elsif Is_Limited_Type (T1) and then not Assignment_OK (N) then Error_Msg_N ("left hand of assignment must not be limited type", Lhs); end if; if Is_Class_Type (T1) and then Is_Tag_Indeterminate (Rhs) then Propagate_Tag (Lhs, Rhs); end if; Apply_Range_Check (Rhs, Etype (Lhs)); end Analyze_Assignment; -------------------------- -- Analyze_If_Statement -- -------------------------- procedure Analyze_If_Statement (N : Node_Id) is begin Analyze (Condition (N)); Resolve_Complete_Context (Condition (N), Standard_Boolean); -- insert Implicit types generated by the condition before the -- If statement if Is_Non_Empty_List (Implicit_Type_List) then Insert_List_Before (N, Implicit_Type_List); Implicit_Type_List := New_List; end if; Analyze_Statements (Then_Statements (N)); if List_Present (Elsif_Parts (N)) then Analyze_Elsif_Parts (Elsif_Parts (N)); end if; if List_Present (Else_Statements (N)) then Analyze_Statements (Else_Statements (N)); end if; end Analyze_If_Statement; ------------------------- -- Analyze_Elsif_Parts -- ------------------------- procedure Analyze_Elsif_Parts (L : List_Id) is E : Node_Id := First (L); N : Node_Id := List_Parent (L); begin while Present (E) loop Analyze (Condition (E)); Resolve_Complete_Context (Condition (E), Standard_Boolean); -- Insert Implicit types generated by the condition before the -- if statement if Is_Non_Empty_List (Implicit_Type_List) then Insert_List_Before (N, Implicit_Type_List); Implicit_Type_List := New_List; end if; Analyze_Statements (Then_Statements (E)); E := Next (E); end loop; end Analyze_Elsif_Parts; ---------------------------- -- Analyze_Case_Statement -- ---------------------------- procedure Analyze_Case_Statement (N : Node_Id) is Alt : Node_Id; Case_Table : Case_Table_Type (1 .. Number_Of_Case_Choices (N)); Choice : Node_Id; Choice_Count : Nat := 0; E : Entity_Id; Exp : Node_Id; Exp_Base_Type : Entity_Id; Exp_Type : Entity_Id; Hi : Node_Id; Invalid_Case : Boolean := False; Kind : Node_Kind; Lo : Node_Id; Others_Present : Boolean := False; procedure Check_Choice (Lo, Hi : Node_Id; Position : Node_Id); -- Check_Choice checks whether the given bounds of a choice are static. -- If not a message is issued, otherwise the bounds are entered into -- the case table. The simple expressions and discrete ranges given as -- choices in a case statement must be static. [LRM 5.4] procedure Check_Choice (Lo, Hi : Node_Id; Position : Node_Id) is begin if not (Is_Static_Expression (Lo) and then Is_Static_Expression (Hi)) then Error_Msg_N ("choice given in case statement is not static", Position); Invalid_Case := True; else Choice_Count := Choice_Count + 1; Case_Table (Choice_Count).Choice_Lo := Lo; Case_Table (Choice_Count).Choice_Hi := Hi; Case_Table (Choice_Count).Choice_Node := Position; end if; end Check_Choice; -- Start of processing for Analyze_Case_Statement begin -- Check that the case expression is of a discrete type and that its -- range is static, and find the length of the range. Exp := Expression (N); Analyze (Exp); Exp_Type := Etype (Exp); Resolve_Subexpr (Exp, Exp_Type); -- Insert Implicit types generated by the condition before the -- case statement if Is_Non_Empty_List (Implicit_Type_List) then Insert_List_Before (N, Implicit_Type_List); Implicit_Type_List := New_List; end if; if Exp_Type = Universal_Integer then -- literal expression Exp_Base_Type := Standard_Integer; -- force INTEGER else Exp_Base_Type := Base_Type (Exp_Type); end if; -- The expression must be of a discrete type which must be determinable -- independently of the context in which the expression occurs, but -- using the fact that the expression must be of a discrete type. -- Moreover, the type this expression must not be a generic formal type. if not Is_Discrete_Type (Exp_Base_Type) then Error_Msg_N ("case expression not of discrete type", Exp); return; elsif Is_Generic_Type (Exp_Base_Type) then Error_Msg_N ("case expression cannot be of a generic type", Exp); return; end if; -- The simple expressions and discrete ranges given as choices in a case -- statement must be static. [LRM 5.4] -- Now check each of the case choices against exp_base_type, Alt := First (Alternatives (N)); while Present (Alt) loop Choice := First (Discrete_Choices (Alt)); while Present (Choice) loop -- Type check the choice and ensure that it is static, -- that it is in the range for the expression subtype, and -- that it appears no more than once as a value possibility. Analyze (Choice); Kind := Nkind (Choice); if Kind = N_Range then Resolve_Complete_Context (Choice, Exp_Base_Type); Check_Choice (Low_Bound (Choice), High_Bound (Choice), Choice); elsif (Kind = N_Identifier or else Kind = N_Selected_Component) and then Is_Type (Entity (Choice)) then E := Entity (Choice); Lo := Type_Low_Bound (E); Hi := Type_High_Bound (E); Check_Choice (Lo, Hi, Choice); elsif Kind = N_Subtype_Indication then Compiler_Abort; -- for now -- The choice others is only allowed for the last alternative and -- as its only choice; it stands for all values (possibly none) -- not given in the choices of previous statement alternatives. elsif Kind = N_Others_Choice then if not (Choice = First (Discrete_Choices (Alt)) and then Choice = Last (Discrete_Choices (Alt)) and then Alt = Last (Alternatives (N))) then Error_Msg_N ("the choice OTHERS must appear alone and last", Choice); return; end if; Others_Present := True; -- Only other possibility is an expression else Resolve_Complete_Context (Choice, Exp_Base_Type); Check_Choice (Choice, Choice, Choice); end if; Choice := Next (Choice); end loop; Analyze_Statements (Statements (Alt)); Alt := Next (Alt); end loop; if not Invalid_Case and then Case_Table'Length > 0 then Check_Case_Choices (Case_Table, N, Exp_Type, Others_Present); end if; end Analyze_Case_Statement; ----------------------------- -- Number_Of_Case_Choices -- ----------------------------- function Number_Of_Case_Choices (N : Node_Id) return Nat is Alt_or_Var : Node_Id; Choice : Node_Id; Count : Nat := 0; begin -- The iteration uses different access functions depending on whether -- it is processing a case statement or a variant part here. if Nkind (N) = N_Case_Statement then Alt_or_Var := First (Alternatives (N)); else -- N_Variant_Part Alt_or_Var := First (Variants (N)); end if; while Present (Alt_or_Var) loop Choice := First (Discrete_Choices (Alt_or_Var)); while Present (Choice) loop if Nkind (Choice) /= N_Others_Choice then Count := Count + 1; end if; Choice := Next (Choice); end loop; Alt_or_Var := Next (Alt_or_Var); end loop; return Count; end Number_Of_Case_Choices; --------------------- -- Sort_Case_Table -- --------------------- procedure Sort_Case_Table (Case_Table : in out Case_Table_Type) is L : Int := Case_Table'First; U : Int := Case_Table'Last; I : Int; J : Int; T : Case_Bounds; begin I := L; while I /= U loop T := Case_Table (I + 1); J := I + 1; while J /= L and then UI_Gt (Expr_Value (Case_Table (J - 1).Choice_Lo), Expr_Value (T.Choice_Lo)) loop Case_Table (J) := Case_Table (J - 1); J := J - 1; end loop; Case_Table (J) := T; I := I + 1; end loop; end Sort_Case_Table; ------------------------ -- Check_Case_Choices -- ------------------------ procedure Check_Case_Choices (Case_Table : in out Case_Table_Type; N : Node_Id; Choice_Type : Entity_Id; Others_Present : Boolean) is Choice : Node_Id; First_Msg : Boolean := True; Exp_Lo : Node_Id; Exp_Hi : Node_Id; Hi : Uint; Lo : Uint; Msg_Sloc : Source_Ptr; Previous_Hi : Uint; function Image_Of (Value : Uint) return Node_Id; -- Returns the Node_Id for the enumeration literal corresponding to the -- position given by Value, within the enumeration type Choice_Type. procedure Issue_Msg (Value1, Value2 : Uint); -- Issue an error message indicating that there are missing choices, -- followed by the image of the missing choices themselves which lie -- between Value1 and Value2 exclusive. If there is more than one -- choice missing print the first and last of the range. Since this -- can be called several times for the same case statement or variant -- part, make sure to print the error message itself only once per -- case statement or variant part. -------------- -- Image_Of -- -------------- function Image_Of (Value : Uint) return Node_Id is Lit : Entity_Id; begin -- Iterate through the literals list "Value" number of times -- until the desired literal is reached and return its Name_Id. -- Note: since Value is an offset given in terms of the original -- enumeration type use the base type. Lit := First_Literal (Base_Type (Choice_Type)); for I in 1 .. UI_To_Int (Value) loop Lit := Next_Literal (Lit); end loop; return Lit; end Image_Of; --------------- -- Issue_Msg -- --------------- procedure Issue_Msg (Value1, Value2 : Uint) is begin if First_Msg then Msg_Sloc := Sloc (N); First_Msg := False; end if; if UI_Eq (UI_Difference (Value2, Value1), Uint_1) then -- There is only one choice value that is missing between -- Value1 and Value2, so print only that value. if Is_Integer_Type (Choice_Type) then Error_Msg_Uint_1 := UI_Sum (Value1, Uint_1); Error_Msg ("missing case value: ^!", Msg_Sloc); elsif Base_Type (Choice_Type) = Standard_Character or else Root_Type (Choice_Type) = Standard_Character then Error_Msg_Uint_1 := UI_Sum (Value1, Uint_1); Error_Msg ("missing case value: Character''Pos (^)!", Msg_Sloc); else Error_Msg_Node_1 := Image_Of (UI_Sum (Value1, Uint_1)); Error_Msg ("missing case value: &!", Msg_Sloc); end if; else -- There is more that one choice value that is missing between -- Value1 and Value2, so print the range of values between them. if Is_Integer_Type (Choice_Type) then Error_Msg_Uint_1 := UI_Sum (Value1, Uint_1); Error_Msg_Uint_2 := UI_Difference (Value2, Uint_1); Error_Msg ("missing case values: ^ .. ^!", Msg_Sloc); elsif Base_Type (Choice_Type) = Standard_Character or else Root_Type (Choice_Type) = Standard_Character then Error_Msg_Uint_1 := UI_Sum (Value1, Uint_1); Error_Msg_Uint_2 := UI_Difference (Value2, Uint_1); Error_Msg ("missing case values: Character''Pos (^) .. " & "Character''Pos (^)!", Msg_Sloc); else Error_Msg_Node_1 := Image_Of (UI_Sum (Value1, Uint_1)); Error_Msg_Node_2 := Image_Of (UI_Difference (Value2, Uint_1)); Error_Msg ("missing case values: & .. &!", Msg_Sloc); end if; end if; end Issue_Msg; -- Start processing for Check_Case_Choices begin Sort_Case_Table (Case_Table); -- If the subtype of the discriminant is static, then each value of this -- subtype must be represented once and only once in the set of choices -- of the variant part, and no other value is allowed. Otherwise, each -- value of the (base) type of the discriminant must be represented once -- and only once in the set of choices. [LRM 3.7.3] -- If the expression is the name of an object whose subtype is static, -- then each value of this subtype must be represented once and only -- once in the set of choices of the case statement, and no other value -- is allowed. Otherwise, for other forms of expression, each value -- of the (base) type of the expression must be represented once and -- only once in the set of choices, and no other value is allowed. if Is_Static_Subtype (Choice_Type) then Exp_Lo := Type_Low_Bound (Choice_Type); Exp_Hi := Type_High_Bound (Choice_Type); else Exp_Lo := Type_Low_Bound (Base_Type (Choice_Type)); Exp_Hi := Type_High_Bound (Base_Type (Choice_Type)); end if; Lo := Expr_Value (Case_Table (Case_Table'First).Choice_Lo); Hi := Expr_Value (Case_Table (Case_Table'First).Choice_Hi); Previous_Hi := Expr_Value (Case_Table (Case_Table'First).Choice_Hi); if not Others_Present and then UI_Lt (Expr_Value (Exp_Lo), Lo) then Issue_Msg (Expr_Value (Exp_Lo), Lo); end if; for I in Case_Table'First + 1 .. Case_Table'Last loop Lo := Expr_Value (Case_Table (I).Choice_Lo); Hi := Expr_Value (Case_Table (I).Choice_Hi); Choice := Case_Table (I).Choice_Node; if UI_Le (Lo, Previous_Hi) then Error_Msg_Sloc_1 := Sloc (Case_Table (I - 1).Choice_Node); Error_Msg_N ("choice value duplicates that given on line #", Choice); elsif not Others_Present and then UI_Ne (Lo, UI_Sum (Previous_Hi, Uint_1)) then Issue_Msg (Previous_Hi, Lo); end if; Previous_Hi := Hi; end loop; if not Others_Present and then UI_Gt (Expr_Value (Exp_Hi), Hi) then Issue_Msg (Hi, UI_Sum (Expr_Value (Exp_Hi), Uint_1)); end if; end Check_Case_Choices; ----------------- -- Is_Variable -- ----------------- function Is_Variable (N : Node_Id) return Boolean is function Is_Variable_Prefix (N : Node_Id) return Boolean; -- Prefixes can involve implicit dereferences function Is_Variable_Prefix (N : Node_Id) return Boolean is begin return Is_Variable (N) or else Is_Access_Type (Etype (N)); end Is_Variable_Prefix; begin if Is_Name (N) then declare K : Entity_Kind := Ekind (Entity (N)); begin return K = E_Variable or else K = E_Component or else K = E_Out_Parameter or else K = E_In_Out_Parameter or else K = E_Generic_In_Out_Parameter; end; else case Nkind (N) is when N_Indexed_Component | N_Slice => return Is_Variable_Prefix (Prefix (N)); when N_Selected_Component => return Is_Variable_Prefix (Prefix (N)) and then Is_Variable (Selector_Name (N)); when N_Expanded_Name => return Is_Variable (Selector_Name (N)); when N_Explicit_Dereference => -- Still need to check whether the type is access constant return Is_Name (Prefix (N)) or else Is_Variable (Prefix (N)) or else Is_Access_Type (Etype (Prefix (N))) or else (Nkind (Prefix (N)) = N_Function_Call and then Is_Access_Type (Etype (Entity (Name (Prefix (N)))))); when N_Type_Conversion => return Is_Variable (Expression (N)); when others => return False; end case; end if; end Is_Variable; ------------------------------ -- Analyze_Iteration_Scheme -- ------------------------------ procedure Analyze_Iteration_Scheme (N : Node_Id) is begin -- For an infinite loop, there is no iteration scheme if No (N) then return; end if; -- For WHILE loop, verify that the condition is a Boolean expression if Present (Condition (N)) then Analyze (Condition (N)); Resolve_Complete_Context (Condition (N), Any_Boolean); -- Else we have a FOR loop else declare L : constant Node_Id := Loop_Parameter_Specification (N); I : constant Node_Id := Defining_Identifier (L); D : constant Node_Id := Discrete_Subtype_Definition (L); begin Analyze (D); Make_Index (D); Enter_Name (I); Set_Ekind (I, E_Loop_Parameter); Set_Etype (I, Etype (D)); end; end if; end Analyze_Iteration_Scheme; ---------------------------- -- Analyze_Loop_Statement -- ---------------------------- procedure Analyze_Loop_Statement (N : Node_Id) is Id : Node_Id := Identifier (N); begin if Present (Id) then -- Make name visible, e.g. for use in exit statements Find_Name (Id); Id := Entity (Id); -- Check that the loop id does not clash with another use of the id. if Ekind (Id) /= E_Label then Error_Msg_N ("loop name conflicts with outer declaration", Identifier (N)); end if; Set_Ekind (Id, E_Loop); else Id := New_Internal_Entity (E_Loop, Current_Scope, Sloc (N), "loop"); Set_Etype (Id, Standard_Void_Type); end if; New_Scope (Id); Analyze_Iteration_Scheme (Iteration_Scheme (N)); -- Insert any N_Implicit_Type nodes generated by the Iteration Scheme. -- These nodes are inserted before the loop statement. if Is_Non_Empty_List (Implicit_Type_List) then Insert_List_Before (N, Implicit_Type_List); Implicit_Type_List := New_List; end if; Analyze_Statements (Statements (N)); End_Scope; end Analyze_Loop_Statement; ---------------------------- -- Analyze_Exit_Statement -- ---------------------------- -- If the exit includes a name, it must be the name of a currently open -- loop. Otherwise there must be an innermost open loop on the stack, -- to which the statement implicitly refers. procedure Analyze_Exit_Statement (N : Node_Id) is Target : Node_Id := Name (N); Scope_Id : Entity_Id; U_Name : Entity_Id; Kind : Entity_Kind; begin if Present (Target) then Find_Name (Target); U_Name := Entity (Target); if not In_Open_Scopes (U_Name) or else Ekind (U_Name) /= E_Loop then Error_Msg_N ("invalid loop name in exit statement", N); return; else Set_Has_Exit (U_Name); end if; end if; for I in reverse 0 .. Scope_Stack.Last loop Scope_Id := Scope_Stack.Table (I).Entity; Kind := Ekind (Scope_Id); if Kind = E_Loop and (No (Target) or Scope_Id = U_Name) then exit; elsif Kind = E_Block or else Kind = E_Loop then null; else Error_Msg_N ("cannot exit from program unit or accept statement", N); exit; end if; end loop; -- Verify that if present the condition is a Boolean expression. if Present (Condition (N)) then Analyze (Condition (N)); Resolve_Complete_Context (Condition (N), Any_Boolean); end if; end Analyze_Exit_Statement; ----------------------------- -- Analyze_Block_Statement -- ----------------------------- procedure Analyze_Block_Statement (N : Node_Id) is Decls : constant List_Id := Declarations (N); Id : Node_Id; begin Id := Identifier (N); if Present (Id) then Find_Name (Id); Id := Entity (Id); Set_Ekind (Id, E_Block); else Id := New_Internal_Entity (E_Block, Current_Scope, Sloc (N), "block"); end if; Set_Etype (Id, Standard_Void_Type); New_Scope (Id); if List_Present (Decls) then Analyze_Declarations (Decls); end if; Analyze (Handled_Statement_Sequence (N)); End_Use (Decls); End_Scope; end Analyze_Block_Statement; ------------------------------ -- Analyze_Return_Statement -- ------------------------------ procedure Analyze_Return_Statement (N : Node_Id) is Scope_Id : Entity_Id; Kind : Entity_Kind; begin -- Find subprogram or accept statement enclosing the return statement for I in reverse 0 .. Scope_Stack.Last loop Scope_Id := Scope_Stack.Table (I).Entity; exit when Ekind (Scope_Id) /= E_Block and then Ekind (Scope_Id) /= E_Loop; end loop; Kind := Ekind (Scope_Id); if Present (Expression (N)) then if Kind = E_Function or Kind = E_Generic_Function then Analyze (Expression (N)); Resolve_Complete_Context (Expression (N), Etype (Scope_Id)); else Error_Msg_N ("Procedure or accept statement cannot return value", N); end if; else if Kind = E_Function or Kind = E_Generic_Function then Error_Msg_N ("missing expression in return from function", N); end if; end if; end Analyze_Return_Statement; ---------------------------- -- Analyze_Goto_Statement -- ---------------------------- procedure Analyze_Goto_Statement (N : Node_Id) is Label : constant Node_Id := Name (N); Scope_Id : Entity_Id; Label_Scope : Entity_Id; begin Find_Name (Label); if Ekind (Entity (Label)) /= E_Label then Error_Msg_N ("target of goto statement must be a label", Label); elsif not Reachable (Entity (Label)) then Error_Msg_N ("target of goto statement is not reachable", Label); end if; Label_Scope := Scope (Entity (Label)); for I in reverse 0 .. Scope_Stack.Last loop Scope_Id := Scope_Stack.Table (I).Entity; exit when (Label_Scope = Scope_Id) or else (Ekind (Scope_Id) /= E_Block and then Ekind (Scope_Id) /= E_Loop); end loop; if Scope_Id /= Label_Scope then Error_Msg_N ("cannot exit from program unit or accept statement", N); end if; end Analyze_Goto_Statement; ---------------------------------------- -- Analyze_Implicit_Label_Declaration -- ---------------------------------------- -- An implicit label declaration is generated in the innermost -- enclosing declarative part. This is done for labels as well as -- block and loop names. -- TBSL: verify that names are unique over the innermost program -- unit (i.e. different blocks cannot have labels with the same name. procedure Analyze_Implicit_Label_Declaration (N : Node_Id) is Id : Node_Id := Defining_Identifier (N); begin Enter_Name (Id); Set_Ekind (Id, E_Label); Set_Etype (Id, Standard_Void_Type); end Analyze_Implicit_Label_Declaration; end Sem_Ch5; tor_Name (N)); when N_Expanded_Name => return Is_Variable (Selector_Name (N)); when N_Explicit_Dereference => -- Still need to check whether the type is access constant return Is_Name (Prefix (N)) or else Is_Variable (Prefix (N)) gnat-1.67-src/src/sem_ch6.ads 444 10015 7640 7133 5506244375 11144 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ C H 6 -- -- -- -- S p e c -- -- -- -- $Revision: 1.5 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Sem_Ch6 is procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id); procedure Analyze_Function_Call (N : Node_Id); procedure Analyze_Operator_Symbol (N : Node_Id); procedure Analyze_Procedure_Call (N : Node_Id); procedure Analyze_Subprogram_Declaration (N : Node_Id); procedure Analyze_Subprogram_Body (N : Node_Id); function Analyze_Spec (N : Node_Id) return Entity_Id; -- Analyze subprogram specification in both subprogram declarations -- and body declarations. function Find_Corresponding_Spec (N : Node_Id) return Entity_Id; -- Use the subprogram specification in the body to retrieve the previous -- subprogram declaration, if any. function Mode_Conformant (S1, S2 : Entity_Id) return Boolean; -- Determine whether two callable entities (subprograms, entries, -- literals) are mode conformant, i.e. have the same type-result -- profile, and corresponding parameters have the same mode. procedure New_Overloaded_Entity (S : Entity_Id); -- Process new overloaded entity. Overloaded entities are created -- by enumeration type declarations, subprogram specifications, -- entry declarations, and (implicitly) by type derivations. procedure Process_Formals (S : Entity_Id; T : List_Id); -- Enter the formals in the scope of the subprogram or entry, and -- analyze default expressions if any. procedure Set_Formal_Mode (Formal_Id : Entity_Id); -- Set proper Ekind to reflect formal mode (in, out, in out) function Type_Conformant (S1, S2 : Entity_Id) return Boolean; -- Determine whether two callable entities (subprograms, entries, -- literals) are type conformant, i.e. have same type-result profile end Sem_Ch6; end if; end Analyze_Exit_Statement; ----------------------------- -- Analyze_Block_Statement -- ----------------------------- procedure Analyze_Block_Statement (N : Node_Id) is Decls : constant List_Id := Declarations (N); Id : Node_Id; begin Id := Identifier (N); if Present (Id) then Find_Name (Id); Id := Entity (Id); Set_Ekind (Id, E_Blocgnat-1.67-src/src/sem_ch6.adb 444 10015 7640 110771 5506244376 11167 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ C H 6 -- -- -- -- B o d y -- -- -- -- $Revision: 1.99 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Casing; use Casing; with Debug; use Debug; with Einfo; use Einfo; with Errout; use Errout; with Exp_Util; use Exp_Util; with Lib; use Lib; with Namet; use Namet; with Nmake; use Nmake; with Output; use Output; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Ch3; use Sem_Ch3; with Sem_Ch4; use Sem_Ch4; with Sem_Ch8; use Sem_Ch8; with Sem_Ch9; use Sem_Ch9; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sem_Disp; use Sem_Disp; with Stand; use Stand; with Sinfo; use Sinfo; with Sinfo.Change; use Sinfo.Change; with Snames; use Snames; with Stringt; use Stringt; with Tbuild; use Tbuild; package body Sem_Ch6 is ----------------------- -- Local Subprograms -- ----------------------- procedure Analyze_Generic_Subprogram_Body (N : Node_Id; Gen_Id : Entity_Id); -- Analyze a generic subprogram body procedure Check_Conformance (Old_Id, New_Id : Entity_Id); -- Verify that the specifications given in a subprogram declaration -- conforms to that given in the body. procedure Enter_Overloaded_Entity (S : Entity_Id); -- This procedure makes S, a new overloaded entity, into the first -- visible entity with that name. procedure Establish_Traceback_Data (Loc : Source_Ptr; Decls : List_Id); -- Called from Analyze_Subprogram_Body to insert declarations for the -- traceback data (simple name of procedure and traceback names entry -- to reference this name and the name of the enclosing file). Loc is -- the source location for the created declarations, which are inserted -- at the start of Decls. On entry, Name_Buffer contains the subprogram -- name that is to be used. procedure Install_Entity (E : Entity_Id); -- Make single entity visible. Used for generic formals as well. procedure Install_Formals (Id : Entity_Id); -- On entry to a subprogram body, make the formals visible. Note -- that simply placing the subprogram on the scope stack is not -- sufficient: the formals must become the current entities for -- their names. procedure May_Need_Actuals (Fun : Entity_Id); -- Flag functions that can be called without parameters, i.e. those that -- have no parameters, or those for which defaults exist for all parameters procedure Valid_Operator_Definition (Designator : Entity_Id); -- Verify that an operator definition has the proper number of formals --------------------------------------------- -- Analyze_Abstract_Subprogram_Declaration -- --------------------------------------------- procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id) is Designator : constant Entity_Id := Analyze_Spec (Specification (N)); begin New_Overloaded_Entity (Designator); Set_Is_Abstract (Designator); end Analyze_Abstract_Subprogram_Declaration; ---------------------------- -- Analyze_Function_Call -- ---------------------------- procedure Analyze_Function_Call (N : Node_Id) is P : constant Node_Id := Name (N); L : constant List_Id := Parameter_Associations (N); Actual : Node_Id; begin Analyze (P); -- If error analyzing name, then set Any_Type as result type and return if Etype (P) = Any_Type then Set_Etype (N, Any_Type); return; end if; -- Otherwise analyze the parameters if List_Present (L) then Actual := First (L); while Present (Actual) loop Analyze_Expression (Actual); Actual := Next (Actual); end loop; end if; Analyze_Call (N); end Analyze_Function_Call; ------------------------------------- -- Analyze_Generic_Subprogram_Body -- ------------------------------------- procedure Analyze_Generic_Subprogram_Body (N : Node_Id; Gen_Id : Entity_Id) is Spec : constant Node_Id := Specification (N); Kind : constant Entity_Kind := Ekind (Gen_Id); Nam : Entity_Id; First_Generic_Formal : Entity_Id := First_Entity (Gen_Id); Last_Formal : Entity_Id := Last_Entity (Gen_Id); begin -- Within the body of the generic, the subprogram is callable, and -- behaves like the corresponding non-generic unit. Nam := Defining_Unit_Simple_Name (Spec); if Kind = E_Generic_Procedure and then Nkind (Spec) /= N_Procedure_Specification then Error_Msg_N ("invalid body for generic procedure ", Nam); return; elsif Kind = E_Generic_Function and then Nkind (Spec) /= N_Function_Specification then Error_Msg_N ("invalid body for generic function ", Nam); return; end if; Set_Corresponding_Body (Parent (Parent (Gen_Id)), Nam); Set_Corresponding_Spec (N, Gen_Id); Set_Has_Completion (Nam); if Nkind (N) = N_Subprogram_Body_Stub then return; end if; -- Make generic parameters directly visible in the body. They are -- needed to process the formals declarations. Then make formals -- visible in a separate step. declare E : Entity_Id := First_Entity (Gen_Id); begin while Present (E) and then Ekind (E) not in E_In_Parameter .. E_In_Out_Parameter loop Install_Entity (E); E := Next_Entity (E); end loop; -- Now generic formals are visible, and the specification can be -- analyzed, for subsequent conformance check. Nam := Analyze_Spec (Spec); if Present (E) then -- E is the first formal parameter, which must be the first -- entity in the subprogram body. Set_First_Entity (Gen_Id, E); -- Now make formal parameters visible while Present (E) and then Ekind (E) in E_In_Parameter .. E_In_Out_Parameter loop Install_Entity (E); E := Next_Entity (E); end loop; end if; end; Append_Entity (Nam, Current_Scope); -- Visible generic entity is callable within its own body. Set_Ekind (Gen_Id, Ekind (Nam)); New_Scope (Gen_Id); -- Check_Conformance (Gen_Id, Nam); Analyze_Declarations (Declarations (N)); Check_Completion; Analyze (Handled_Statement_Sequence (N)); End_Use (Declarations (N)); -- Prior to exiting the scope, include generic formals again -- in the set of local entities. Set_First_Entity (Gen_Id, First_Generic_Formal); End_Scope; -- Chain local declarations to the id for the body, as for the -- non-generic case. if Present (Last_Formal) then if Present (Last_Entity (Nam)) then Set_Next_Entity (Last_Entity (Nam), Next_Entity (Last_Formal)); else Set_First_Entity (Nam, Next_Entity (Last_Formal)); end if; Set_Next_Entity (Last_Formal, Empty); -- Case of no generic parameters, no formals else Set_First_Entity (Nam, First_Entity (Gen_Id)); Set_First_Entity (Gen_Id, Empty); end if; -- Outside of its body, unit is generic again. Set_Ekind (Gen_Id, Kind); end Analyze_Generic_Subprogram_Body; ----------------------------- -- Analyze_Operator_Symbol -- ----------------------------- -- This procedure only gets called if an operator symbol is analyzed in -- a context (e.g. in an expression) where an operator symbol is not -- semantically permissible. The scanner parses out all strings that are -- of the form of operator symbols as such. It is this routine that is -- in charge of correcting this "mistake" made by the scanner. procedure Analyze_Operator_Symbol (N : Node_Id) is begin Change_Operator_Symbol_To_String_Literal (N); Set_Etype (N, Any_String); end Analyze_Operator_Symbol; ---------------------------- -- Analyze_Procedure_Call -- ---------------------------- procedure Analyze_Procedure_Call (N : Node_Id) is P : constant Node_Id := Name (N); Actuals : constant List_Id := Parameter_Associations (N); Actual : Node_Id; begin -- The syntactic construct : Prefix actual_parameters can denote a -- a procedure call or an entry call. The prefix may denote an -- access to subprogram type, in which case an implicit dereference -- applies. If the prefix is an indexed component (without implicit -- dereference) then the construct denotes a call to a member of an -- entry family. If the prefix is a simple name, it may still denote -- a call to a parameterless member of an entry family. Resolution of -- these various interpretations is delicate. Analyze (P); -- If error analyzing prefix, then set Any_Type as result and return if Etype (P) = Any_Type then Set_Etype (N, Any_Type); return; end if; -- Otherwise analyze the parameters if List_Present (Actuals) then Actual := First (Actuals); while Present (Actual) loop Analyze_Expression (Actual); Actual := Next (Actual); end loop; end if; if Is_Name (P) then Analyze_Call (N); Resolve_Complete_Context (N, Standard_Void_Type); elsif Nkind (P) = N_Explicit_Dereference then if Ekind (Etype (P)) = E_Subprogram_Type then Analyze_Call (N); Resolve_Complete_Context (N, Standard_Void_Type); else Error_Msg_N ("expect access to procedure in call", P); end if; -- Then name can be a selected component or an indexed component -- that yields an access to subprogram. Such a prefix is legal if -- the call has parameter associations. elsif (Is_Access_Type (Etype (P)) and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type) then if List_Present (Actuals) then Analyze_Call (N); Resolve_Complete_Context (N, Standard_Void_Type); else Error_Msg_N ("missing explicit dereference in call ", N); end if; -- If not an access to subprogram, then the prefix must resolve to -- the name of an entry, entry family, or protected operation. elsif Nkind (P) = N_Selected_Component then Analyze_Entry_Call (N); else Error_Msg_N ("Invalid procedure or entry call", N); end if; end Analyze_Procedure_Call; ------------------ -- Analyze_Spec -- ------------------ function Analyze_Spec (N : Node_Id) return Entity_Id is Designator : constant Entity_Id := Defining_Unit_Simple_Name (N); Formals : constant List_Id := Parameter_Specifications (N); begin if Nkind (N) = N_Function_Specification then Set_Ekind (Designator, E_Function); Find_Type (Subtype_Mark (N)); Set_Etype (Designator, Entity (Subtype_Mark (N))); else Set_Ekind (Designator, E_Procedure); Set_Etype (Designator, Standard_Void_Type); end if; if List_Present (Formals) then Set_Scope (Designator, Current_Scope); New_Scope (Designator); Process_Formals (Designator, Formals); End_Scope; end if; if Nkind (N) = N_Function_Specification then if Nkind (Designator) = N_Defining_Operator_Symbol then Valid_Operator_Definition (Designator); end if; May_Need_Actuals (Designator); if Is_Abstract (Etype (Designator)) and then Nkind (Parent (N)) /= N_Abstract_Subprogram_Declaration then Error_Msg_N ("function that returns abstract type must be abstract", N); end if; end if; return Designator; end Analyze_Spec; ----------------------------- -- Analyze_Subprogram_Body -- ----------------------------- -- This procedure is called for regular subprogram bodies, generic bodies, -- and for subprogram stubs of both kinds. In the case of stubs, only the -- specification matters, and is used to create a proper declaration for -- the subprogram, or to perform conformance checks. procedure Analyze_Subprogram_Body (N : Node_Id) is Spec : constant Node_Id := Specification (N); Nam : constant Entity_Id := Defining_Unit_Simple_Name (Spec); Gen_Id : constant Entity_Id := Current_Entity (Nam); Decls : constant List_Id := Declarations (N); Loc : Source_Ptr; Subp : Entity_Id; Prev : Entity_Id; Last_Formal : Entity_Id; Vsn_Name : Name_Id; begin Trace_Scope (N, Nam, " Analyze subprogram"); Set_Ekind (Nam, E_Subprogram_Body); -- Generic subprograms are handled separately. They always have a -- generic specification. if Present (Gen_Id) and then (Ekind (Gen_Id) = E_Generic_Procedure or else Ekind (Gen_Id) = E_Generic_Function) then Analyze_Generic_Subprogram_Body (N, Gen_Id); return; -- Non-generic case, find the subprogram declaration, if one was -- seen, or enter new overloaded entity in the current scope. else Subp := Analyze_Spec (Spec); Prev := Find_Corresponding_Spec (N); end if; if Debug_Flag_B then if Is_Empty_List (Decls) then Loc := Sloc (N); else Loc := Sloc (First (Decls)); end if; Get_Name_String (Chars (Nam)); Establish_Traceback_Data (Loc, Decls); end if; -- Place subprogram on scope stack, and make formals visible. If there -- is a spec, the visible entity remains that of the spec. The defining -- entity for the body is entered in the chain of entities in that case, -- to insure that it is instantiated if it appears in a generic unit. if Present (Prev) then Check_Conformance (Prev, Subp); if Nkind (N) /= N_Subprogram_Body_Stub then Set_Corresponding_Spec (N, Prev); end if; Set_Corresponding_Body (Get_Declaration_Node (Prev), Subp); Install_Formals (Prev); Append_Entity (Subp, Current_Scope); Last_Formal := Last_Entity (Prev); New_Scope (Prev); else New_Overloaded_Entity (Subp); Install_Formals (Subp); New_Scope (Subp); end if; Set_Has_Completion (Subp); if Nkind (N) = N_Subprogram_Body_Stub then End_Scope; -- nothing else to process else Analyze_Declarations (Declarations (N)); Check_Completion; -- Add traceback call to start of statements in statement -- sequence if the traceback flag is set. This is done at -- this point (rather than in N_Expand_Subprogram_Body) so -- that Version_B is properly visible for a library subprogram. if Debug_Flag_B then Traceback_Store (First (Statements (Handled_Statement_Sequence (N))), False); end if; Analyze (Handled_Statement_Sequence (N)); End_Use (Declarations (N)); End_Scope; if Present (Prev) then -- Chain the declared entities on the id for the body. -- The id for the spec only holds the formals. if Present (Last_Formal) then Set_Next_Entity (Last_Entity (Subp), Next_Entity (Last_Formal)); Set_Next_Entity (Last_Formal, Empty); else Set_First_Entity (Subp, First_Entity (Prev)); Set_First_Entity (Prev, Empty); end if; end if; end if; end Analyze_Subprogram_Body; ------------------------------------ -- Analyze_Subprogram_Declaration -- ------------------------------------ procedure Analyze_Subprogram_Declaration (N : Node_Id) is Designator : constant Entity_Id := Analyze_Spec (Specification (N)); F : Entity_Id; begin Trace_Scope (N, Defining_Unit_Simple_Name (Specification (N)), " Analyze subprogram spec. "); New_Overloaded_Entity (Designator); -- If a type in the profile depends on a private type without a full -- declaration, indicate that the subprogram is delayed. if Has_Private_Component (Etype (Designator)) then Set_Is_Delayed (Designator); else F := First_Formal (Designator); while Present (F) loop if Has_Private_Component (Etype (F)) then Set_Is_Delayed (Designator); exit; end if; F := Next_Formal (F); end loop; end if; end Analyze_Subprogram_Declaration; ----------------------- -- Check_Conformance -- ----------------------- procedure Check_Conformance (Old_Id, New_Id : Entity_Id) is Old_Spec : constant List_Id := Parameter_Specifications (Specification (Get_Declaration_Node (Old_Id))); New_Spec : constant List_Id := Parameter_Specifications (Specification (Get_Declaration_Node (New_Id))); Old_Param_Spec : Node_Id; New_Param_Spec : Node_Id; Old_Formal : Entity_Id; New_Formal : Entity_Id; procedure Conformance_Error is begin Error_Msg_Sloc_1 := Sloc (Old_Id); Error_Msg_N ("no conformance with line #", New_Id); end Conformance_Error; -- Start of processing for Check_Conformance begin if not List_Present (Old_Spec) then if not List_Present (New_Spec) then return; else Conformance_Error; end if; else Old_Param_Spec := First (Old_Spec); New_Param_Spec := First (New_Spec); while Present (Old_Param_Spec) and then Present (New_Param_Spec) loop Old_Formal := Defining_Identifier (Old_Param_Spec); New_Formal := Defining_Identifier (New_Param_Spec); if Chars (Old_Formal) = Chars (New_Formal) and then Ekind (Old_Formal) = Ekind (New_Formal) and then (Etype (Old_Formal) = Etype (New_Formal) or else Full_Declaration (Etype (Old_Formal)) = Etype (New_Formal) or else (Ekind (Etype (Old_Formal)) = E_Anonymous_Access_Type and then Ekind (Etype (New_Formal)) = E_Anonymous_Access_Type and then Directly_Designated_Type (Etype (Old_Formal)) = Directly_Designated_Type (Etype (New_Formal)))) then null; else Conformance_Error; return; end if; -- Here is where we check the More_Ids and Prev_Ids flags to -- make sure they match. This catches a misconformance like -- A,B : Integer -- A : Integer; B : Integer -- which are represented identically in the tree except for the -- setting of these flags. if More_Ids (Old_Param_Spec) /= More_Ids (New_Param_Spec) or else Prev_Ids (Old_Param_Spec) /= Prev_Ids (New_Param_Spec) then Conformance_Error; end if; Old_Param_Spec := Next (Old_Param_Spec); New_Param_Spec := Next (New_Param_Spec); end loop; end if; end Check_Conformance; ----------------------------- -- Enter_Overloaded_Entity -- ----------------------------- procedure Enter_Overloaded_Entity (S : Entity_Id) is E : Entity_Id; begin E := Current_Entity (S); Set_Is_Directly_Visible (S); Set_Current_Entity (S); Set_Homonym (S, E); if Present (E) and then Scope (E) = Current_Scope then Set_Has_Homonym (E); Set_Has_Homonym (S); end if; Append_Entity (S, Current_Scope); Check_Dispatching_Operation (S); Set_Public_Status (S); if Debug_Flag_E then Write_Str ("New overloaded entity chain: "); Write_Name (Chars (S)); E := S; while Present (E) loop Write_Str (" "); Write_Int (Int (E)); E := Homonym (E); end loop; Write_Eol; end if; end Enter_Overloaded_Entity; ------------------------------ -- Establish_Traceback_Data -- ------------------------------ -- If the debug B flag is set then establish the traceback data -- _TB_Snam : aliased constant String := "subprogram name" & NUL; -- This declaration is placed at the start of the subprogram declarations. procedure Establish_Traceback_Data (Loc : Source_Ptr; Decls : List_Id) is Unit_Num : constant Unit_Number_Type := Get_Sloc_Unit_Number (Loc); Unit_Node : Node_Id; Str : String_Id; Vsn_Name : Name_Id; begin -- Nothing to do if not in main unit (no point in generating calls -- for other than the main unit, since we won't generate code anyway) if Unit_Num /= Main_Unit then return; end if; -- Build string constant for _TB_Snam declaration Set_Casing (File.Table (Unit_Num).Identifier_Casing, Mixed_Case); Start_String; for I in 1 .. Name_Len loop Store_String_Char (Get_Char_Code (Name_Buffer (I))); end loop; Store_String_Char (Get_Char_Code (NUL)); Str := End_String; -- Insert declaration of _TB_Snam Prepend_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uTB_Snam), Aliased_Present => True, Constant_Present => True, Object_Definition => New_Reference_To (Standard_String, Loc), Expression => Make_String_Literal (Loc, Str))); end Establish_Traceback_Data; ----------------------------- -- Find_Corresponding_Spec -- ----------------------------- function Find_Corresponding_Spec (N : Node_Id) return Entity_Id is Spec : constant Node_Id := Specification (N); Designator : constant Entity_Id := Defining_Unit_Simple_Name (Spec); E : Entity_Id; begin E := Current_Entity (Designator); while Present (E) loop if Scope (E) = Current_Scope and then Type_Conformant (E, Designator) then if not Has_Completion (E) then if Nkind (N) /= N_Subprogram_Body_Stub then Set_Corresponding_Spec (N, E); end if; Set_Has_Completion (E); return E; -- If body already exists, this is an error unless the -- previous declaration is the implicit declaration of -- a derived subprogram. elsif No (Alias (E)) then Error_Msg_N ("duplicate subprogram body", N); end if; end if; E := Homonym (E); end loop; -- On exit, we know that no previous declaration of subprogram exists return Empty; end Find_Corresponding_Spec; -------------------- -- Install_Entity -- -------------------- procedure Install_Entity (E : Entity_Id) is Prev : constant Entity_Id := Current_Entity (E); begin Set_Is_Directly_Visible (E); Set_Current_Entity (E); Set_Homonym (E, Prev); end Install_Entity; --------------------- -- Install_Formals -- --------------------- procedure Install_Formals (Id : Entity_Id) is F : Entity_Id; begin F := First_Formal (Id); while Present (F) loop Install_Entity (F); F := Next_Formal (F); end loop; end Install_Formals; ---------------------- -- May_Need_Actuals -- ---------------------- procedure May_Need_Actuals (Fun : Entity_Id) is F : Entity_Id; B : Boolean; begin F := First_Formal (Fun); B := True; while Present (F) loop if No (Default_Value (F)) then B := False; exit; end if; F := Next_Formal (F); end loop; Set_Needs_No_Actuals (Fun, B); end May_Need_Actuals; --------------------- -- Mode_Conformant -- --------------------- function Mode_Conformant (S1, S2 : Entity_Id) return Boolean is P1 : Entity_Id; P2 : Entity_Id; function Same_Type (T1 : Entity_Id; T2 : Entity_Id) return Boolean; -- Check whether T1 and T2 are the same type (for conformance purposes) function Same_Type (T1 : Entity_Id; T2 : Entity_Id) return Boolean is begin -- For a general access type, the designated subtypes must -- match statically. return Base_Type (T1) = Base_Type (T2) or else (Ekind (T1) = E_Anonymous_Access_Type and then Ekind (T2) = E_Anonymous_Access_Type and then Directly_Designated_Type (T1) = Directly_Designated_Type (T2)); end Same_Type; -- Start of processing for Mode_Conformant begin P1 := First_Formal (S1); P2 := First_Formal (S2); if not Same_Type (Etype (S1), Etype (S2)) then return False; else while Present (P1) and then Present (P2) loop if not Same_Type (Etype (P1), Etype (P2)) or else Ekind (P1) /= Ekind (P2) then return False; end if; P1 := Next_Formal (P1); P2 := Next_Formal (P2); end loop; -- Both must be empty on exit from list to return True return P1 = P2; end if; end Mode_Conformant; --------------------------- -- New_Overloaded_Entity -- --------------------------- procedure New_Overloaded_Entity (S : Entity_Id) is E : Entity_Id := Current_Entity (S); Prev_Vis : Entity_Id := Empty; begin if No (E) or else Scope (E) /= Current_Scope then Enter_Overloaded_Entity (S); elsif not Is_Overloadable (E) then Error_Msg_N ("duplicate identifier:&", S); else -- E exists and is overloadable. Determine whether S is the body -- of E, a new overloaded entity with a different signature, or -- an error altogether. while Present (E) and then Scope (E) = Current_Scope loop if Type_Conformant (E, S) then -- If the old and new entities have the same profile and -- one is not the body of the other, then this is an error, -- unless one of them is implicitly declared. if Present (Alias (S)) or else (Is_Internal (S) and then Chars (S) = Name_Op_Eq) then -- S is a derived operation, which remains hidden by -- an existing declaration. return; elsif Present (Alias (E)) or else (Is_Internal (E) and then Chars (E) = Name_Op_Eq) then -- E is a derived operation which is being overridden. -- Remove E from further visibility. Furthermore, if -- E is a dispatching operation, it must be replaced in -- the list of primitive operations of its type. declare Prev : Entity_Id; begin Prev := First_Entity (Current_Scope); while Next_Entity (Prev) /= E loop Prev := Next_Entity (Prev); end loop; -- E must be removed both from the entity_list of the -- current scope, and from the visibility chain if Debug_Flag_E then Write_Str ("Override implicit operation "); Write_Int (Int (E)); Write_Eol; end if; if Prev_Vis /= Empty then Set_Homonym (Prev_Vis, Homonym (E)); -- Skip E in the visibility chain else Set_Name_Entity_Id (Chars (E), Homonym (E)); end if; Set_Next_Entity (Prev, Next_Entity (E)); if No (Next_Entity (Prev)) then Set_Last_Entity (Current_Scope, Prev); end if; Enter_Overloaded_Entity (S); if Is_Dispatching_Operation (E) then Override_Dispatching_Operation (E, S); end if; return; end; else Error_Msg_Sloc_1 := Sloc (E); Error_Msg_NE ("declaration of& conflicts with line #", S, S); return; end if; else null; end if; Prev_Vis := E; E := Homonym (E); end loop; -- On exit, we know that S is a new entity Enter_Overloaded_Entity (S); end if; end New_Overloaded_Entity; --------------------- -- Process_Formals -- --------------------- procedure Process_Formals (S : Entity_Id; T : List_Id) is Param_Spec : Node_Id; Formal : Entity_Id; Formal_Type : Entity_Id; Default : Node_Id; begin -- In order to prevent premature use of the formals in the same formal -- part, the Ekind is left undefined until all default expressions are -- analyzed. The Ekind is established in a separate loop at the end. Param_Spec := First (T); while Present (Param_Spec) loop if Nkind (Parameter_Type (Param_Spec)) /= N_Access_Definition then -- Ordinary parameters Find_Type (Parameter_Type (Param_Spec)); Formal_Type := Entity (Parameter_Type (Param_Spec)); if Ekind (Formal_Type) = E_Incomplete_Type then Error_Msg_N ("invalid use of incomplete type&", Parameter_Type (Param_Spec)); end if; else -- An access formal type Formal_Type := Access_Definition (Parameter_Type (Param_Spec)); end if; Formal := Defining_Identifier (Param_Spec); Enter_Name (Formal); Set_Etype (Formal, Formal_Type); Default := Expression (Param_Spec); if Present (Default) then Analyze_Expression (Default); Resolve_Complete_Context (Default, Formal_Type); if Out_Present (Param_Spec) then Error_Msg_N ("default initialization only allowed for IN parameters", Param_Spec); end if; end if; Param_Spec := Next (Param_Spec); end loop; -- Now set the kind (mode) of each formal Param_Spec := First (T); while Present (Param_Spec) loop Formal := Defining_Identifier (Param_Spec); Set_Formal_Mode (Formal); if Ekind (Formal) = E_In_Parameter then Set_Default_Value (Formal, Expression (Param_Spec)); end if; Param_Spec := Next (Param_Spec); end loop; end Process_Formals; --------------------- -- Set_Formal_Mode -- --------------------- procedure Set_Formal_Mode (Formal_Id : Entity_Id) is Spec : constant Node_Id := Parent (Formal_Id); begin if Out_Present (Spec) then if Ekind (Scope (Formal_Id)) = E_Function or else Ekind (Scope (Formal_Id)) = E_Generic_Function then Error_Msg_N ( "functions can only have IN parameters ", Spec); Set_Ekind (Formal_Id, E_In_Parameter); elsif In_Present (Spec) then Set_Ekind (Formal_Id, E_In_Out_Parameter); else Set_Ekind (Formal_Id, E_Out_Parameter); end if; else Set_Ekind (Formal_Id, E_In_Parameter); end if; end Set_Formal_Mode; --------------------- -- Type_Conformant -- --------------------- function Type_Conformant (S1, S2 : Entity_Id) return Boolean is P1 : Entity_Id; P2 : Entity_Id; function Same_Type (T1, T2 : Entity_Id) return Boolean; -- If the specification of the subprogram includes private types, -- the body may appear where the full declaration is visible. Both -- views of the type are still conformant. function Same_Type (T1, T2 : Entity_Id) return Boolean is begin return Base_Type (T1) = Base_Type (T2) or else (Ekind (T1) = E_Anonymous_Access_Type and then Ekind (T2) = E_Anonymous_Access_Type and then Same_Type (Directly_Designated_Type (T1), Directly_Designated_Type (T2))); end Same_Type; -- Start of processing for Type_Conformant begin if not Same_Type (Etype (S1), Etype (S2)) then return False; else P1 := First_Formal (S1); P2 := First_Formal (S2); while Present (P1) and then Present (P2) loop if not Same_Type (Etype (P1), Etype (P2)) then return False; end if; P1 := Next_Formal (P1); P2 := Next_Formal (P2); end loop; -- Both must be empty on exit from list to return True return (P1 = P2); end if; end Type_Conformant; ------------------------------- -- Valid_Operator_Definition -- ------------------------------- procedure Valid_Operator_Definition (Designator : Entity_Id) is N : Integer := 0; F : Entity_Id; Id : constant Name_Id := Chars (Designator); N_OK : Boolean; begin F := First_Formal (Designator); while Present (F) loop N := N + 1; if Present (Default_Value (F)) then Error_Msg_N ("default values not allowed for operator parameters", Parent (F)); end if; F := Next_Formal (F); end loop; -- Verify that user-defined operators have proper number of arguments -- First case of operators which can only be unary if Id = Name_Op_Not or else Id = Name_Op_Abs then N_OK := (N = 1); -- Case of operators which can be unary or binary elsif Id = Name_Op_Add or Id = Name_Op_Subtract then N_OK := (N in 1 .. 2); -- All other operators can only be binary else N_OK := (N = 2); end if; if not N_OK then Error_Msg_N ("incorrect number of arguments for operator", Designator); end if; -- TBSL: no explicit definition of inequality can return Boolean ??? end Valid_Operator_Definition; end Sem_Ch6; ains hignat-1.67-src/src/sem_ch7.ads 444 10015 7640 10316 5506244376 11163 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ C H 7 -- -- -- -- S p e c -- -- -- -- $Revision: 1.8 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Sem_Ch7 is procedure Analyze_Package_Body (N : Node_Id); procedure Analyze_Package_Declaration (N : Node_Id); procedure Analyze_Package_Specification (N : Node_Id); procedure Analyze_Private_Type_Declaration (N : Node_Id); procedure End_Package_Scope (P : Entity_Id); -- At the end of a package declaration or body, declarations in the -- visible part are no longer directly visible, and declarations in -- the private part are not visible at all. For inner packages, place -- visible entities at the end of their homonym chains. For compilation -- units, make all entities invisible. In both cases, exchange private -- and visible declarations to restore order of elaboration. procedure Install_Visible_Declarations (P : Entity_Id); procedure Install_Private_Declarations (P : Entity_Id); -- On entrance to a package body, make declarations in package spec -- directly visible, and place them at the beginning of their -- homonym chains. This is done both for internal packages and for -- library packages. In the case of internal packages, the local -- entities are already on visibility chains, behind all directly -- visible declarations, and the previous entries must be removed -- from the chain. -- When compiling the body of a package, both routines are called in -- succession. When compiling the body of a child package, the call -- to Install_Private_Declaration is immediate for private children, -- but is deffered until the compilation of the private part of the -- child for public child packages. procedure Install_Package_Entity (Id : Entity_Id); -- Basic procedure for the previous two. Places one entity on its -- visibility chain, and recurses on the visible part if the entity -- is an inner package. function Unit_Requires_Body (P : Entity_Id) return Boolean; -- Check if a unit requires a body. A specification requires a body -- if it contains declarations that require completion in a body. function Is_Fully_Visible (Type_Id : Entity_Id) return Boolean; -- Indicates whether the Full Declaration of a private type is visible. procedure Mark_Implicit_Private_Decls (Impl_List : List_Id); -- Iterate through the list of implicit types and set the Is_Private -- flag for those that depend on private types. end Sem_Ch7; en Error_Msg_N ("invalid use of incomplete type&", Parameter_Type (Param_Spec)); end if; else -- An access formal type Formal_Type := Access_Definition (Parameter_Type (Param_Specgnat-1.67-src/src/sem_ch7.adb 444 10015 7640 46522 5506244377 11153 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M . C H 7 -- -- -- -- B o d y -- -- -- -- $Revision: 1.77 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Debug; use Debug; with Einfo; use Einfo; with Errout; use Errout; with Lib; use Lib; with Namet; use Namet; with Opt; use Opt; with Output; use Output; with Sem; use Sem; with Sem_Ch3; use Sem_Ch3; with Sem_Ch8; use Sem_Ch8; with Sem_Ch13; use Sem_Ch13; with Sem_Util; use Sem_Util; with Stand; use Stand; with Sinfo; use Sinfo; package body Sem_Ch7 is -- This package contains the routines to process package specifications and -- bodies. The most important semantic aspects of package processing are the -- handling of private and full declarations, and the construction of -- dispatch tables for tagged types. ----------------------------------- -- Handling private declarations -- ----------------------------------- -- The principle that each entity has a single defining occurrence clashes -- with the presence of two separate definitions for private types: the first -- is the private type declaration, and the second is the full type -- declaration. It is important that all references to the type point to the -- same defining occurence, namely the first one. To enforce the two separate -- views of the entity, the corresponding information is swapped between the -- two declarations. Outside of the package, the defining occurence only -- contains the private declaration information, while in the private part -- and the body of the package the defining occurrence contains the full -- declaration. To simplify the swap, the defining occurrence that currently -- holds the private declaration points to the full declaration. During -- semantic processing the defining occurence also points to a list of -- private dependents, that is to say access types or composite types whose -- designated types or component types are subtypes or derived types of the -- private type in question. After the full declaration has been seen, the -- private dependents are updated to indicate that they have full definitions. ----------------------- -- Local Subprograms -- ----------------------- procedure Analyze_Private_Part (Decls : List_Id; N : Entity_Id); procedure Exchange_Declarations (Id : Entity_Id); -- Exchange private and full declaration on entry/exit from a package -- declaration or body. The semantic links of the respective nodes -- are preserved in the exchange. --------------------------------- -- Analyze_Package_Declaration -- --------------------------------- procedure Analyze_Package_Declaration (N : Node_Id) is Id : constant Node_Id := Defining_Unit_Simple_Name (Specification (N)); begin Enter_Name (Id); Set_Ekind (Id, E_Package); Set_Etype (Id, Standard_Void_Type); New_Scope (Id); if Debug_Flag_C then Write_Str ("======== Compiling package spec "); Write_Name (Chars (Id)); Write_Eol; end if; Analyze (Specification (N)); End_Package_Scope (Id); -- For a compilation unit, indicate whether it needs a body. if Nkind (Parent (N)) = N_Compilation_Unit then Set_Body_Required (Parent (N), Unit_Requires_Body (Id)); end if; end Analyze_Package_Declaration; ----------------------------------- -- Analyze_Package_Specification -- ----------------------------------- procedure Analyze_Package_Specification (N : Node_Id) is E : Entity_Id; Id : constant Entity_Id := Defining_Unit_Simple_Name (N); Vis_Decls : List_Id := Visible_Declarations (N); Priv_Decls : List_Id := Private_Declarations (N); begin if List_Present (Vis_Decls) then Analyze_Declarations (Vis_Decls); end if; -- Verify that incomplete types have received full declarations. E := First_Entity (Id); while Present (E) loop if Ekind (E) = E_Incomplete_Type and then No (Full_Declaration (E)) then Error_Msg_NE ("incomplete type& has no full declaration in visible part", E, E); end if; E := Next_Entity (E); end loop; -- If package is a public child unit, then make the private -- declarations of the parent visible. if Present (Parent_Spec ( Parent (N))) and then not Is_Private_Descendant (Id) then declare Par : Entity_Id := Scope (Id); begin while Par /= Standard_Standard loop Install_Private_Declarations (Par); Par := Scope (Par); end loop; end; end if; if List_Present (Priv_Decls) then Analyze_Private_Part (Priv_Decls, Id); end if; End_Use (Vis_Decls); End_Use (Priv_Decls); if List_Present (Priv_Decls) then Append_List (Freeze_All, Priv_Decls); elsif List_Present (Vis_Decls) then Append_List (Freeze_All, Vis_Decls); end if; end Analyze_Package_Specification; ----------------------- -- End_Package_Scope -- ----------------------- procedure End_Package_Scope (P : Entity_Id) is Id : Entity_Id := First_Entity (P); begin while Present (Id) and then Id /= First_Private_Entity (P) loop if Debug_Flag_E then Write_Str ("unlinking visible entity "); Write_Int (Int (Id)); Write_Eol; end if; Set_Is_Use_Visible (Id, In_Use (P)); Set_Is_Directly_Visible (Id, False); if Ekind (Id) in E_Private_Type .. E_Limited_Private_Type and then No (Full_Declaration (Id)) and then not Is_Generic_Type (Id) and then not Is_Derived_Type (Id) then Error_Msg_N ("missing full declaration for private type", Id); end if; Id := Next_Entity (Id); end loop; -- Make private entities invisible by removing them from their -- homonym chains, and exchange full and private declarations -- for private types. while Present (Id) loop if Debug_Flag_E then Write_Str ("unlinking private entity "); Write_Int (Int (Id)); Write_Eol; end if; Set_Is_Directly_Visible (Id, False); if Ekind (Id) in E_Private_Type .. E_Limited_Private_Type then -- The entry in the private part points to the full declaration, -- which is currently visible. Exchange them so only the private -- type declaration remains accessible, and link private and -- full declaration in the opposite direction. Before the actual -- exchange, we make sure that the Size is copied back into the -- private declaration. This is the one attribute of the full -- type that must be available for the private type too. -- Are there other attributes that should be treated the same, -- for example Eaddress? TBSL. Set_Esize (Id, Esize (Full_Declaration (Id))); Set_Is_Use_Visible (Id, In_Use (P)); Exchange_Declarations (Id); else Set_Is_Private (Id); Set_Is_Use_Visible (Id, False); end if; Id := Next_Entity (Id); end loop; Pop_Scope; end End_Package_Scope; --------------------------- -- Exchange_Declarations -- --------------------------- procedure Exchange_Declarations (Id : Entity_Id) is Full_Id : constant Entity_Id := Full_Declaration (Id); Next1 : Entity_Id := Next_Entity (Id); Next2 : Entity_Id; begin -- If missing full declaration for type, nothing to exchange if No (Full_Id) then return; end if; Next2 := Next_Entity (Full_Id); Exchange_Nodes (Id, Full_Id); Set_Full_Declaration (Full_Id, Id); Set_Next_Entity (Id, Next1); Set_Next_Entity (Full_Id, Next2); end Exchange_Declarations; -------------------------------------- -- Analyze_Private_Type_Declaration -- -------------------------------------- procedure Analyze_Private_Type_Declaration (N : Node_Id) is Id : Node_Id := Defining_Identifier (N); begin Enter_Name (Id); if Limited_Present (N) then Set_Ekind (Id, E_Limited_Private_Type); Set_Is_Limited_Type (Id); else Set_Ekind (Id, E_Private_Type); end if; Set_Is_Tagged_Type (Id, Tagged_Present (N)); Set_Etype (Id, Id); Set_Is_Private_Type (Id); Set_Is_Delayed (Id); if Ekind (Current_Scope) /= E_Package and Ekind (Current_Scope) /= E_Generic_Package then Error_Msg_N ("invalid context for private declaration", N); end if; New_Scope (Id); if List_Present (Discriminant_Specifications (N)) then Process_The_Discriminants (N); end if; End_Scope; -- Initialize dispatch_table in tagged case if Tagged_Present (N) then Make_Class_Type (Id); Set_Primitive_Operations (Id, New_Elmt_List); Set_Is_Abstract (Id, Abstract_Present (N)); elsif Abstract_Present (N) then Error_Msg_N ("only a tagged type can be abstract", N); end if; end Analyze_Private_Type_Declaration; -------------------------- -- Analyze_Package_Body -- -------------------------- procedure Analyze_Package_Body (N : Node_Id) is Body_Id : constant Entity_Id := Defining_Unit_Simple_Name (N); Stat_Seq : constant Node_Id := Handled_Statement_Sequence (N); Spec_Id : Entity_Id; Last_Spec_Entity : Entity_Id; Pack_Decl : Node_Id; begin -- Find corresponding package specification, and establish the -- current scope. The visible defining entity for the package is the -- defining occurrence in the spec. On exit from the package body, all -- body declarations are attached to the defining entity for the body, -- but the later is never used for name resolution. In this fashion -- there is only one visible entity that denotes the package. if Debug_Flag_C then Write_Str ("===== Compiling package body "); Write_Name (Chars (Body_Id)); Write_Eol; end if; Set_Ekind (Body_Id, E_Package_Body); Spec_Id := Current_Entity (Body_Id); while Present (Spec_Id) loop exit when Scope (Spec_Id) = Current_Scope and then (Ekind (Spec_Id) = E_Package or else Ekind (Spec_Id) = E_Generic_Package); Spec_Id := Homonym (Spec_Id); end loop; if No (Spec_Id) then Error_Msg_N ("missing specification for package body", Body_Id); return; else Pack_Decl := Get_Declaration_Node (Spec_Id); if Present (Corresponding_Body (Pack_Decl)) then Error_Msg_N ("redefinition of package body", Body_Id); return; end if; end if; if Ekind (Spec_Id) = E_Package and then Current_Scope = Standard_Standard and then Parent (N) = File.Table (Main_Unit).Cunit and then not Unit_Requires_Body (Spec_Id) then if Ada_83 then Error_Msg_N ("optional package body (not allowed in Ada9X)?", N); else Error_Msg_N ("spec of this package does not allow a body", N); end if; end if; -- defining name for the package body is not a visible entity: Only -- the defining name for the declaration is visible. Set_Ekind (Body_Id, Ekind (Spec_Id)); Set_Etype (Body_Id, Standard_Void_Type); Set_Scope (Body_Id, Current_Scope); Set_Corresponding_Spec (N, Spec_Id); Set_Corresponding_Body (Pack_Decl, Body_Id); -- Indicate that we are currently compiling the body of the package. Set_Is_Package_Body (Spec_Id); Set_Has_Completion (Spec_Id); Last_Spec_Entity := Last_Entity (Spec_Id); New_Scope (Spec_Id); Install_Visible_Declarations (Spec_Id); Install_Private_Declarations (Spec_Id); Set_Use (Visible_Declarations (Specification (Pack_Decl))); Set_Use (Private_Declarations (Specification (Pack_Decl))); if List_Present (Declarations (N)) then Analyze_Declarations (Declarations (N)); end if; if Present (Stat_Seq) then Analyze (Stat_Seq); end if; End_Use (Declarations (N)); End_Use (Private_Declarations (Specification (Pack_Decl))); End_Use (Visible_Declarations (Specification (Pack_Decl))); Check_Completion; if Ekind (Spec_Id) = E_Package then End_Package_Scope (Spec_Id); else -- The local declarations of a generic package are not visible End_Scope; end if; -- Chain the body declarations to the defining occurrence in the package if Present (Last_Spec_Entity) then Set_First_Entity (Body_Id, Next_Entity (Last_Spec_Entity)); Set_Next_Entity (Last_Spec_Entity, Empty); else Set_First_Entity (Body_Id, First_Entity (Spec_Id)); Set_First_Entity (Spec_Id, Empty); end if; Set_Is_Package_Body (Spec_Id, False); end Analyze_Package_Body; ---------------------------------- -- Install_Visible_Declarations -- ---------------------------------- procedure Install_Visible_Declarations (P : Entity_Id) is Id : Entity_Id; begin Id := First_Entity (P); while Present (Id) and then Id /= First_Private_Entity (P) loop Install_Package_Entity (Id); Id := Next_Entity (Id); end loop; end Install_Visible_Declarations; ---------------------------------- -- Install_Private_Declarations -- ---------------------------------- procedure Install_Private_Declarations (P : Entity_Id) is Id : Entity_Id; begin -- First exchange declarations for private types, so that the -- full declaration is visible. Id := First_Entity (P); while Present (Id) and then Id /= First_Private_Entity (P) loop if Ekind (Id) in E_Private_Type .. E_Limited_Private_Type then Exchange_Declarations (Id); Set_Is_Directly_Visible (Id); end if; Id := Next_Entity (Id); end loop; -- Next make other declarations in the private part visible as well. Id := First_Private_Entity (P); while Present (Id) loop Install_Package_Entity (Id); Id := Next_Entity (Id); end loop; end Install_Private_Declarations; ----------------------------- -- Install_Package_Entity -- ----------------------------- procedure Install_Package_Entity (Id : Entity_Id) is begin if not Is_Internal (Id) then if Debug_Flag_E then Write_Str ("Install: "); Write_Name (Chars (Id)); Write_Eol; end if; Set_Is_Directly_Visible (Id); end if; end Install_Package_Entity; -------------------------- -- Analyze_Private_Part -- -------------------------- procedure Analyze_Private_Part (Decls : List_Id; N : Entity_Id) is L : Entity_Id := Last_Entity (N); begin Set_In_Private_Part (N); Analyze_Declarations (Decls); -- The first private entity is the immediate follower of the last -- visible entity, if there was one. if Present (L) then Set_First_Private_Entity (N, Next_Entity (L)); else Set_First_Private_Entity (N, First_Entity (N)); end if; Set_In_Private_Part (N, False); end Analyze_Private_Part; ------------------------ -- Unit_Requires_Body -- ------------------------ function Unit_Requires_Body (P : Entity_Id) return Boolean is E : Entity_Id := First_Entity (P); begin while Present (E) loop if (Is_Overloadable (E) and then Ekind (E) /= E_Enumeration_Literal and then Ekind (E) /= E_Operator and then not Has_Completion (E)) or else (Ekind (E) = E_Package and then E /= P and then not Has_Completion (E) and then Unit_Requires_Body (E)) or else (Ekind (E) = E_Incomplete_Type and then No (Full_Declaration (E))) or else (((Ekind (E) = E_Task_Type) or else Ekind (E) = E_Protected_Type) and then not Has_Completion (E)) then return True; else null; end if; E := Next_Entity (E); end loop; return False; end Unit_Requires_Body; ---------------------- -- Is_Fully_Visible -- ---------------------- -- The full declaration of a private type is visible in the private -- part of the package declaration, and in the package body, at which -- point the full declaration must have been given. function Is_Fully_Visible (Type_Id : Entity_Id) return Boolean is S : Entity_Id := Scope (Type_Id); begin if Is_Generic_Type (Type_Id) then return false; elsif In_Private_Part (S) then return Present (Full_Declaration (Type_Id)); else return Is_Package_Body (S); end if; end Is_Fully_Visible; --------------------------------- -- Mark_Implicit_Private_Decls -- --------------------------------- procedure Mark_Implicit_Private_Decls (Impl_List : List_Id) is N : Node_Id := First (Impl_List); Type_Id : Entity_Id; begin while Present (N) loop if Nkind (N) = N_Implicit_Type then Type_Id := Defining_Identifier (N); Set_Is_Private_Type (Type_Id, Has_Private_Component (Type_Id)); end if; N := Next (N); end loop; end Mark_Implicit_Private_Decls; end Sem_Ch7; Find corresponding package specification, and establish the -- current scope. The visible defining entity for the package is the -- defining occurrence in the gnat-1.67-src/src/sem_ch8.ads 444 10015 7640 14106 5506244377 11166 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ C H 8 -- -- -- -- B o d y -- -- -- -- $Revision: 1.6 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Sem_Ch8 is procedure Analyze_Object_Renaming (N : Node_Id); procedure Analyze_Exception_Renaming (N : Node_Id); procedure Analyze_Package_Renaming (N : Node_Id); procedure Analyze_Subprogram_Renaming (N : Node_Id); procedure Analyze_Use_Package (N : Node_Id); procedure Analyze_Use_Type (N : Node_Id); procedure End_Scope; -- Called at end of scope. On exit On exit from blocks and bodies -- (subprogram, package, task, and protected bodies), the name of the -- current scope must be removed from the scope stack, and the local -- entities must be removed from their homonym chains. On exit from -- record declarations, from package specifications, and from tasks -- and protected type specifications, more specialized procedures -- are invoked. procedure End_Use (L : List_Id); -- Find use clauses that are declarative items, and reset -- the direct visibility flags of the imported entities. -- procedure Establish_Transient_Scope; -- If no transient scope is active, then a new transient scope is -- established and pushed onto the top of the scope stack. See section -- "Handling of Transient Data" in package body for details. procedure Find_Expanded_Name (N : Node_Id); -- Selected component is known to be expanded name. Verify legality -- of selector given the scope denoted by prefix. procedure Find_Name (N : Node_Id); -- Top level routine for name resolution. procedure Find_Selected_Component (N : Node_Id); -- Resolve various cases of selected components,recognize expanded -- names. procedure Find_Simple_Name (N : Node_Id); -- Scan the homonym chain, starting from the names table, to find the -- current entity that corresponds to this name. In most cases it will -- be the innermost entity with that name, defined in the current scope. -- However, entities in packages may appear on the chain without being -- directly visible, and we have to skip past then and scan the homonym -- homonym chain until a directly visible entity is found. procedure Find_Type (N : Node_Id); -- Perform name resolution, and verify that the name found is that of a -- type. If it is an incomplete type whose full declaration has been -- senn, return the entity in the full declaration. Similarly, if the -- type type is private, it has receivd a full declaration, and we are -- in the private part or body of the package, return the full -- declaration as well. Special processing for Class types as well. function Has_Implicit_Operator (N : Node_Id) return Boolean; -- N is an expanded name whose selector is an operator name (eg P."+"). -- A declarative part contains an implicit declaration of an operator -- if it has a declaration of a type to which one of the predefined -- operators apply. The existence of this routine is an artifact of -- our implementation: a more straightforward but more space-consuming -- choice would be to make all inherited operators explicit in the -- symbol table. function In_Open_Scopes (S : Entity_Id) return Boolean; -- S is the entity of a scope. This function determines if this scope -- is currently open (i.e. it appears somewhere in the scope stack). function Is_Appropriate_For_Record (T : Entity_Id) return Boolean; -- Prefix is appropriate for record if it is of a record type, or -- an access to such. function Is_Appropriate_For_Entry_Prefix (T : Entity_Id) return Boolean; -- True if it is of a task type, a protected type, or else -- an access to such. procedure New_Scope (S : Entity_Id); -- Make new scope stack entry, pushing S, the entity for a scope -- onto the top of the scope table. The current setting of the scope -- suppress flags is saved for restoration on exit. procedure Pop_Scope; -- Remove top entry from scope stack, restoring the saved setting -- of the scope suppress flags. procedure Set_Use (L : List_Id); -- Find use clauses that are declarative items in a package -- declaration, and set the use-visible flags of imported entities -- before analyzing corresponding package body. end Sem_Ch8; -- -- $Revision: 1.6 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under gnat-1.67-src/src/sem_ch8.adb 444 10015 7640 201410 5506244401 11145 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M . C H 8 -- -- -- -- B o d y -- -- -- -- $Revision: 1.120 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Comperr; use Comperr; with Debug; use Debug; with Einfo; use Einfo; with Errout; use Errout; with Namet; use Namet; with Nmake; use Nmake; with Opt; use Opt; with Output; use Output; with Sem; use Sem; with Sem_Attr; use Sem_Attr; with Sem_Ch3; use Sem_Ch3; with Sem_Ch4; use Sem_Ch4; with Sem_Ch5; use Sem_Ch5; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sem_Type; use Sem_Type; with Stand; use Stand; with Sinfo; use Sinfo; with Sinfo.Change; use Sinfo.Change; with Snames; use Snames; with Tbuild; use Tbuild; package body Sem_Ch8 is ------------------------------------ -- Visibility and Name Resolution -- ------------------------------------ -- This package handles name resolution and the collection of -- interpretations for overloaded names, prior to overload resolution. -- Name resolution is the process that establishes a mapping between source -- identifiers and the entities they denote at each point in the program. -- Each entity is represented by a defining occurrence. Each identifier -- that denotes an entity points to the corresponding defining occurrence. -- This is the entity of the applied occurrence. Each occurrence holds -- an index into the names table, where source identifiers are stored. -- Each entry in the names table for an identifier or designator uses the -- Info pointer to hold a link to the currently visible entity that has -- this name (see subprograms Get_Name_Entity_Id and Set_Name_Entity_Id -- in package Einfo). The visibility is initialized at the beginning of -- semantic rocessing to make entities in package Standard directly -- visible. The visibility table is used in a more subtle way when -- compiling subunits (see below). -- Entities that have the same name (i.e. homonyms) are chained. In the -- case of overloaded entities, this chain holds all the possible meanings -- of a given identifier. The process of overload resolution uses type -- information to select from this chain the unique meaning of a given -- identifier. -- Entities are also chained in their scope, through the Next_Entity link. -- As a consequence, the name space is organized as a sparse matrix, where -- each row corresponds to a scope, and each column to a source identifier. -- Open scopes, that is to say scopes currently being compiled, have their -- corresponding rows of entities in order, innermost scope first. -- The scopes of packages that are mentioned in context clauses appear in -- no particular order, interspersed among open scopes. This is because -- in the course of analyzing the context of a compilation, a package -- declaration is first an open scope, and subsequently an element of the -- context. If subunits or child units are present, a parent unit may -- appear under various guises at various times in the compilation. -- -- When the compilation of the innermost scope is complete, the entities -- defined therein are no longer visible. If the scope is not a package -- declaration, these entities are never visible subsequently, and can be -- removed from visibility chains. If the scope is a package declaration, -- its visible declarations may still be accessible. Therefore the entities -- defined in such a scope are left on the visibility chains, and only -- their visibility (directly-visible or use-visible) is affected. The -- name resolution routines rely on the fact that directly visible entities -- are ordered on their chains, but cannot assume any relative ordering -- among entities made accessible by context clauses. In particular, the -- entities defined in the current scope are not necessarily the first ones -- on their chain, because a package entity may have been inserted first. -- When compiling a child unit, entities in the parent scope are directly -- visible. When compiling the body of a child unit, private entities in -- the parent must also be made visible. There are separate routine to -- make the visible and private declarations directly visible at various -- times (see sem_ch7). -- -- +--------+ +-----+ -- | In use |-------->| EU1 |--------------------------> -- +--------+ +-----+ -- | | -- +--------+ +-----+ +-----+ -- | Stand. |---------------->| ES1 |--------------->| ES2 |---> -- +--------+ +-----+ +-----+ -- | | -- +---------+ | +-----+ -- | with'ed |------------------------------>| EW2 |---> -- +---------+ | +-----+ -- | | -- +--------+ +-----+ +-----+ -- | Scope2 |---------------->| E12 |--------------->| E22 |---> -- +--------+ +-----+ +-----+ -- | | -- +--------+ +-----+ +-----+ -- | Scope1 |---------------->| E11 |--------------->| E12 |---> -- +--------+ +-----+ +-----+ -- ^ | | -- | | | -- | +---------+ | | -- | | with'ed |-----------------------------------------> -- | +---------+ | | -- | | | -- Scope stack | | -- (innermost first) | | -- +----------------------------+ -- Names table => | Id1 | | | | Id2 | -- +----------------------------+ -- Name resolution must deal with several syntactic forms: simple names, -- qualified names, indexed names, and various forms of calls. -- Each identifier points to an entry in the names table. The resolution -- of a simple name consists in traversing the homonym chain, starting -- from the names table. If an entry is directly visible, it is the one -- designated by the identifier. If only use-visible entities are on the -- chain, we must verify that they do not hide each other. If the entity -- we find is overloadable, we collect all other overloadable entities on -- the chain as long as they are not hidden. -- -- To resolve expanded names, we must find the entity at the intersection -- of the entity chain for the scope (the prefix) and the homonym chain -- for the selector. In general, homonym chains will be much shorter than -- entity chains, so it is preferable to start from the names table as -- well. If the entity found is overloadable, we must collect all other -- interpretations that are defined in the scope denoted by the prefix. -- For records, protected types, and tasks, their local entities are -- removed from visibility chains on exit from the corresponding scope. -- From the outside, these entities are always accessed by selected -- notation, and the entity chain for the record type, protected type, -- etc. is traversed sequentially in order to find the designated entity. -- The discriminants of a type and the operations of a protected type or -- task are unchained on exit from the first view of the type, (such as -- a private or incomplete type declaration, or a protected type speci- -- fication) and rechained when compiling the second view. -- In the case of operators, we do not make operators on derived types -- explicit. As a result, the notation P."+" may denote either a user- -- defined function with name "+", or else an implicit declaration of the -- operator "+" in package P. The resolution of expanded names always -- tries to resolve an operator name as such an implicitly defined entity, -- in addition to looking for explicit declarations. -- All forms of names that denote entities (simple names, expanded names, -- character literals in some cases) have a Entity attribute, which -- identifies the entity denoted by the name. --------------------- -- The Scope Stack -- --------------------- -- The Scope stack keeps track of the scopes currently been compiled. -- Every entity that contains declarations (including records) is placed -- on the scope stack while it is being processed, and removed at the end. -- Whenever a non-package scope is exited, the entities defined therein -- are removed from the visibility table, so that entities in outer scopes -- become visible (see previous description). On entry to Sem, the scope -- stack only contains the package Standard. As usual, subunits complicate -- this picture ever so slightly. ------------------------ -- Compiling subunits -- ------------------------ -- Subunits must be compiled in the environment of the corresponding -- stub, that is to say with the same visibility into the parent (and its -- context) that is available at the point of the stub declaration, but -- with the additional visibility provided by the context clause of the -- subunit itself. As a result, compilation of a subunit forces compilation -- of the parent (see description in lib-). At the point of the stub -- declaration, Analyze is called recursively to compile the proper body -- of the subunit, but without reinitializing the names table, nor the -- scope stack (i.e. standard is not pushed on the stack). In this fashion -- the context of the subunit is added to the context of the parent, and -- the subunit is compiled in the correct environment. Note that in the -- course of processing the context of a subunit, Standard will appear -- twice on the scope stack: once for the parent of the subunit, and -- once for the unit in the context clause being compiled. However, the -- two sets of entities are not linked by homonym chains, so that the -- compilation of any context unit happens in a fresh visibility -- environment. ------------------------------- -- Processing of USE Clauses -- ------------------------------- -- Every defining occurrence has a flag to indicate whether it is directly -- visible. Resolution of simple names examines this flag. The processing -- of use clauses consists in setting this flag on all visible entities -- defined in the corresponding package. On exit from the scope of the use -- clause, the corresponding flag must be reset. However, a package may -- appear in several nested use clauses (pathological but legal, alas!) -- which forces us to use a slightly more involved scheme: -- a) The defining occurrence for a package hold a flag -In_Use- to -- indicate that it is currently in the scope of a use clause. If a -- redundant use clause is encountered, then the corresponding occurence -- of the package name is flagged -Redundant_Use-. -- b) On exit from a scope, the use clauses in its declarative part are -- scanned. The visibility flag is reset in all entities declared in -- package named in a use clause, as long as the package is not flagged -- as being in a redundant use clause (in which case the outer use -- clause is still in effect, and the direct visibility of its entities -- must be retained). -- Note that entities are not removed from their homonym chains on exit -- from the package specification. A subsequent use clause does not need -- to rechain the visible entities, but only to establish their direct -- visibility. ----------------------------------- -- Handling private declarations -- ----------------------------------- -- The principle that each entity has a single defining occurrence clashes -- with the presence of two separate definitions for private types: the -- first is the private type declaration, and second is the full type -- declaration. It is important that all references to the type point to -- the same defining occurence, namely the first one. To enforce the two -- separate views of the entity, the corresponding information is swapped -- between the two declarations. Outside of the package, the defining -- occurence only contains the private declaration information, while in -- the private part and the body of the package the defining occurrence -- contains the full declaration. To simplify the swap, the defining -- occurrence that currently holds the private declaration points to the -- full declaration. During semantic processing the defining occurence -- also points to a list of private dependents, that is to say access -- types or composite types whose designated types or component types are -- subtypes or derived types of the private type in question. After the -- full declaration has been seen, the private dependents are updated to -- indicate that they have full definitions. ----------------------- -- Local Subprograms -- ----------------------- procedure Attribute_Renaming (N : Node_Id); -- Analyze renaming of attribute as function. function Entity_Matches_Spec (Old_S, New_S : Entity_Id) return Boolean; -- Used to resolve subprogram renaming. Old_S is a possible interpretation -- of the entity being renamed, New_S has an explicit signature. If Old_S -- is a subprogram, type conformance is required. procedure Find_Function_Call (N : Node_Id); -- Prefix in index_component is an overloadable entity: the node -- is a function call. Reformat it as such. Procedure calls are -- statements syntactically, and are handled elsewhere. procedure Find_Index_Or_Call (N : Node_Id); -- An indexed name can denote one of the following constructs: -- a) An indexed component of an array -- b) A function call -- c) A conversion -- d) A slice -- The resolution of the construct requires some semantic information -- on the prefix and the indices. procedure Find_Index_Or_Slice (N : Node_Id); -- An indexed component with a single index may designate a slice if -- the index is a subtype mark. Resolution of the index is required -- for disambiguation. procedure Find_Slice (N : Node_Id); -- Analyze subtype indication and prefix of a slice, and verify that -- prefix is a one-dimensional array. procedure Find_Explicit_Dereference (N : Node_Id); -- Analyze prefix of an explicit dereference, and verify that it is -- an access object. function Get_Full_Declaration (T_Name : Entity_Id) return Entity_Id; -- If T_Name is an incomplete type and the full declaration has been -- seen, or is the name of a private type and the current context is -- one in which the full declaration is visible, return the full -- declaration. procedure Use_One_Package (P : Entity_Id); -- Make visible entities declarated in package P use-visible in -- the current context. ------------------------------- -- Dump Semantic Information -- ------------------------------- procedure Write_Info; -- Write information on entities declared in current scope --------------- -- New_Scope -- --------------- procedure New_Scope (S : Entity_Id) is begin Scope_Stack.Increment_Last; Scope_Stack.Table (Scope_Stack.Last).Entity := S; Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress := Scope_Suppress; Scope_Stack.Table (Scope_Stack.Last).Save_Entity_Suppress := Entity_Suppress.Last; end New_Scope; --------------- -- Pop_Scope -- --------------- procedure Pop_Scope is E : Entity_Id; begin if Debug_Flag_E then Write_Info; end if; Scope_Suppress := Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress; while Entity_Suppress.Last > Scope_Stack.Table (Scope_Stack.Last).Save_Entity_Suppress loop E := Entity_Suppress.Table (Entity_Suppress.Last).Entity; case Entity_Suppress.Table (Entity_Suppress.Last).Check is when Access_Check => Set_Suppress_Access_Checks (E, False); when Accessibility_Check => Set_Suppress_Accessibility_Checks (E, False); when Discriminant_Check => Set_Suppress_Discriminant_Checks (E, False); when Division_Check => Set_Suppress_Division_Checks (E, False); when Elaboration_Check => Set_Suppress_Elaboration_Checks (E, False); when Index_Check => Set_Suppress_Index_Checks (E, False); when Length_Check => Set_Suppress_Length_Checks (E, False); when Overflow_Check => Set_Suppress_Overflow_Checks (E, False); when Range_Check => Set_Suppress_Range_Checks (E, False); when Storage_Check => Set_Suppress_Storage_Checks (E, False); when Tag_Check => Set_Suppress_Tag_Checks (E, False); -- All_Checks should not appear here (since it is entered as a -- series of its separate checks). Bomb if it is encountered when All_Checks => Compiler_Abort; end case; Entity_Suppress.Decrement_Last; end loop; Scope_Stack.Decrement_Last; end Pop_Scope; -------------------- -- In_Open_Scopes -- -------------------- function In_Open_Scopes (S : Entity_Id) return Boolean is begin -- Since there are several scope stacks maintained by Scope_Stack each -- delineated by Standard (see comments by definition of Scope_Stack) -- it is necessary to end the search when Standard is reached. for I in reverse 0 .. Scope_Stack.Last loop if Scope_Stack.Table (I).Entity = S then return True; end if; exit when Scope_Stack.Table (I).Entity = Standard_Standard; end loop; return False; end In_Open_Scopes; --------------- -- Find_Name -- --------------- procedure Find_Name (N : Node_Id) is begin case Nkind (N) is when N_Identifier | N_String_Literal | N_Operator_Symbol | N_Defining_Identifier => Find_Simple_Name (N); when N_Selected_Component => Find_Selected_Component (N); when N_Expanded_Name => Find_Selected_Component (N); when N_Indexed_Component => Find_Index_Or_Call (N); when N_Slice => Find_Slice (N); when N_Attribute_Reference => Analyze_Attribute (N); when N_Explicit_Dereference => Find_Explicit_Dereference (N); when N_Type_Conversion => Analyze_Conversion (N); when N_Function_Call => null; -- Find_Name should only be called on appropriate nodes when others => Compiler_Abort; end case; end Find_Name; ---------------------- -- Find_Simple_Name -- ---------------------- procedure Find_Simple_Name (N : Node_Id) is begin -- If the entity pointer is already set, this is an internal node, or -- a node that is analyzed more than once, after a tree modification. -- In such a case there is no resolution to perform, just set the type. if Present (Entity (N)) then if Is_Type (Entity (N)) then Set_Etype (N, Entity (N)); else Set_Etype (N, Etype (Entity (N))); end if; return; end if; -- Here if Entity pointer was not set, we need full visibility analysis declare E : Entity_Id := Current_Entity (N); Outer : Entity_Id; Found : Boolean := False; function Inner (E1, E2 : Entity_Id) return Boolean is begin for I in reverse 0 .. Scope_Stack.Last loop if Scope_Stack.Table (I).Entity = Scope (E2) then return False; elsif Scope_Stack.Table (I).Entity = Scope (E1) then return True; end if; exit when Scope_Stack.Table (I).Entity = Standard_Standard; end loop; end Inner; function Find_Innermost (E : Entity_Id) return Entity_Id is E1 : Entity_Id := Homonym (E); Result : Entity_Id := E; begin while Present (E1) loop if Is_Directly_Visible (E1) and Inner (E1, E) then Result := E1; end if; E1 := Homonym (E1); end loop; return Result; end Find_Innermost; begin -- Set the defaults in case of error Set_Entity (N, Any_Id); Set_Etype (N, Any_Type); if Debug_Flag_E then Write_Str ("Looking for "); Write_Name (Chars (N)); Write_Eol; end if; while Present (E) loop if Is_Directly_Visible (E) then E := Find_Innermost (E); Found := True; -- found current entity with given name exit; elsif Is_Use_Visible (E) then Found := True; -- Verify that it is not hidden by other use-visible entities Outer := Homonym (E); while Present (Outer) loop if Is_Use_Visible (Outer) and then (Is_Overloadable (Outer) /= Is_Overloadable (E) or else not Is_Overloadable (E)) then if Debug_Flag_E then Write_Str ("ambiguity between the following"); Write_Eol; Write_Entity_Info (E, " "); Write_Entity_Info (Outer, " "); end if; Found := False; E := Homonym (Outer); -- these use-visible entities hide each other, but -- another use- or directly-visible entity may be -- present on the chain. exit; elsif Is_Directly_Visible (Outer) then E := Find_Innermost (Outer); Found := True; exit; end if; Outer := Homonym (Outer); end loop; exit when Found; else E := Homonym (E); end if; end loop; if Found then Set_Entity (N, E); if Is_Type (E) then Set_Etype (N, E); else Set_Etype (N, Get_Full_Declaration (Etype (E))); end if; if Debug_Flag_E then Write_Str (" found "); Write_Entity_Info (E, " "); end if; if Ekind (E) = E_Void then Error_Msg_N ("premature usage of&!", N); -- If the entity is overloadable, collect all interpretations -- of the name for subsequent overload resolution. elsif Is_Overloadable (E) and then Present (Homonym (E)) then Collect_Interps (N); else Set_Entity_With_Style_Check (N, E); end if; elsif No (Current_Entity (N)) then Error_Msg_N ("& is undefined!", N); -- Make entry with this name in standard (avoid cascaded errors) declare Id : Entity_Id := Extend_Node (New_Node (N_Defining_Identifier, Sloc (N))); begin Set_Chars (Id, Chars (N)); Set_Ekind (Id, E_Variable); Set_Etype (Id, Any_Type); Set_Is_Directly_Visible (Id); Set_Current_Entity (Id); Append_Entity (Id, Standard_Standard); Set_Entity (N, Id); Set_Etype (N, Any_Type); end; else if Is_Use_Visible (Current_Entity (N)) then Error_Msg_N ("& is ambiguous (several use-visible meanings)!", N); else Error_Msg_N ("& is not directly visible (needs USE clause)!", N); end if; end if; end; end Find_Simple_Name; ----------------------------- -- Find_Selected_Component -- ----------------------------- procedure Find_Selected_Component (N : Node_Id) is P : Node_Id := Prefix (N); P_Name : Entity_Id; -- Entity denoted by prefix P_Type : Entity_Id; -- and its type begin Find_Name (P); if Nkind (P) = N_Error then return; elsif Is_Name (P) then P_Name := Entity (P); P_Type := Etype (P); if Debug_Flag_E then Write_Str ("Found prefix type to be "); Write_Entity_Info (P_Type, " "); Write_Eol; end if; if Is_Appropriate_For_Record (P_Type) then -- Selected component of record. Type checking will validate -- name of selector. Analyze_Selected_Component (N); elsif Is_Appropriate_For_Entry_Prefix (P_Type) and then not In_Open_Scopes (P_Name) then -- Call to protected operation or entry. Type checking is -- needed on the prefix. Analyze_Selected_Component (N); elsif In_Open_Scopes (P_Name) and then (Ekind (P_Name) /= E_Void and then not Is_Overloadable (P_Name)) then -- Prefix denotes an enclosing loop, block, or task, i.e. an -- enclosing construct that is not a subprogram or accept. Find_Expanded_Name (N); elsif Ekind (P_Name) = E_Package then Find_Expanded_Name (N); elsif Is_Overloadable (P_Name) then -- Prefix can be an enclosing subprogram or accept statement. -- it can also be a call to a parameterless function that yields -- a record value. if In_Open_Scopes (P_Name) then if In_Open_Scopes (Homonym (P_Name)) then Error_Msg_N ("ambiguous expanded name&", P); Set_Entity (N, Any_Id); Set_Etype (N, Any_Type); else Find_Expanded_Name (N); end if; else -- If no interpretation as an expanded name is possible, it -- must be a selected component of a record returned by a -- function call. Reformat tree as a function call, the rest -- is done by type resolution. Find_Expanded_Name (N); end if; -- Remaining cases generate various error messages else -- Format node as expanded name, to avoid cascaded errors Change_Node (N, N_Expanded_Name); Set_Prefix (N, P); -- Set_Selector_Name (N, Empty); ???? Set_Entity (N, Any_Id); Set_Etype (N, Any_Type); if P_Name = Any_Id then null; -- object was undeclared (error message emitted already) elsif Ekind (P_Name) = E_Void then Error_Msg_N ("premature usage of&", P); else Error_Msg_N ( "invalid prefix in selected component&", P); end if; end if; -- prefix is simple or expanded name. else -- If prefix is not the name of an entity, it must be an expression, -- whose type is appropriate for a record. This is determined by -- type resolution. Analyze_Selected_Component (N); end if; end Find_Selected_Component; ------------------------------- -- Is_Appropriate_For_Record -- ------------------------------- function Is_Appropriate_For_Record (T : Entity_Id) return Boolean is begin return Present (T) and then (Is_Record_Type (T) or else (Is_Access_Type (T) and then Is_Record_Type (Designated_Type (T)))); end Is_Appropriate_For_Record; ------------------------------------- -- Is_Appropriate_For_Entry_Prefix -- ------------------------------------- function Is_Appropriate_For_Entry_Prefix (T : Entity_Id) return Boolean is P_Type : Entity_Id := T; begin if Is_Access_Type (P_Type) then P_Type := Designated_Type (P_Type); end if; return Is_Task_Type (P_Type) or else Is_Protected_Type (P_Type); end Is_Appropriate_For_Entry_Prefix; ------------------------ -- Find_Expanded_Name -- ------------------------ procedure Find_Expanded_Name (N : Node_Id) is P_Name : Entity_Id := Entity (Prefix (N)); Selector : Node_Id := Selector_Name (N); Id : Entity_Id; begin -- We search the homonym chain of the entity until we find an entity -- declared in the scope denoted by the prefix. If the entity is -- private, it may nevertheless be directly visible, if we are in the -- scope of its declaration. -- If the prefix is a renamed package, look for the entity in the -- original package. if Ekind (P_Name) = E_Package and then Present (Renamed_Object (P_Name)) then P_Name := Renamed_Object (P_Name); end if; Id := Current_Entity (Selector); while Present (Id) loop exit when Scope (Id) = P_Name and then (not Is_Private (Id) or else Is_Directly_Visible (Id)); Id := Homonym (Id); end loop; if No (Id) or else Chars (Id) /= Chars (Selector) then if (Nkind (Selector) = N_Operator_Symbol and then Has_Implicit_Operator (N)) then -- There is an implicit instance of the predefined operator -- in the given scope. Find the predefined operator in scope -- Standard. Id := Current_Entity (Selector); while Present (Id) and then Scope (Id) /= Standard_Standard loop Id := Homonym (Id); end loop; else Error_Msg_Node_2 := P_Name; Error_Msg_NE ("& not declared in&", N, Selector); Id := Any_Id; end if; end if; Change_Selected_Component_To_Expanded_Name (N); Set_Entity_With_Style_Check (N, Id); if Is_Type (Id) then Set_Etype (N, Id); else Set_Etype (N, Get_Full_Declaration (Etype (Id))); end if; if Is_Overloadable (Id) and then Present (Homonym (Id)) and then Scope (Id) = Scope (Homonym (Id)) then Collect_Interps (N); end if; if (Nkind (Selector_Name (N)) = N_Operator_Symbol and then Has_Implicit_Operator (N) and then Scope (Id) /= Standard_Standard) then -- In addition to user-defined operators in the given scope, -- there is also an implicit instance of the predefined -- operator. Find the predefined operator in scope -- Standard, and add it as well to the interpretations. -- Procedure Add_One_Interp will determine which hides which. Id := Current_Entity (Selector); while Present (Id) and then Scope (Id) /= Standard_Standard loop Id := Homonym (Id); end loop; Add_One_Interp (N, Id, Etype (Id)); end if; -- If the expanded name represents a named number replace it with -- an the appropriate literal node. if Is_Named_Number (Id) then Rewrite_Named_Number (N, Etype (N)); end if; end Find_Expanded_Name; ------------------------ -- Find_Index_Or_Call -- ------------------------ procedure Find_Index_Or_Call (N : Node_Id) is P : Node_Id := Prefix (N); E : Node_Id; U_N : Entity_Id; begin Find_Name (P); -- name of array, function, or type. if List_Present (Expressions (N)) then E := First (Expressions (N)); while Present (E) loop Analyze_Expression (E); -- array indices, or actuals in call E := Next (E); end loop; end if; if Is_Name (P) then U_N := Entity (P); if Ekind (U_N) in Type_Kind then -- Reformat node as a type conversion. E := Remove_Head ( Expressions (N)); if Present (First (Expressions (N))) then Error_Msg_N ("argument of type conversion must be single expression", N); end if; Change_Node (N, N_Type_Conversion); Set_Subtype_Mark (N, P); Set_Etype (N, U_N); Set_Expression (N, E); Analyze_Conversion (N); elsif Is_Overloadable (U_N) then Find_Function_Call (N); elsif Ekind (Etype (P)) = E_Subprogram_Type or else (Ekind (Etype (P)) = E_Access_Subprogram_Type and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type) then -- Call to access_to-subprogram with possible implicit dereference Find_Function_Call (N); else Find_Index_Or_Slice (N); end if; -- If not an entity name, prefix is an expression that may denote -- an array or an access-to-subprogram. else if (Ekind (Etype (P)) = E_Subprogram_Type) or else (Ekind (Etype (P)) = E_Access_Subprogram_Type and then Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type) then Find_Function_Call (N); else Find_Index_Or_Slice (N); end if; end if; end Find_Index_Or_Call; ------------------------ -- Find_Function_Call -- ------------------------ procedure Find_Function_Call (N : Node_Id) is P : constant Node_Id := Prefix (N); E : constant List_Id := Expressions (N); S : constant Source_Ptr := Sloc (N); begin if Is_Name (P) and then Is_Overloadable (Entity (P)) and then Needs_No_Actuals (Entity (P)) then -- An amusing syntactic ambiguity appears if parameterless -- functions that return an array type appear in a call. In -- this case the expression must be parsed eventually as an -- indexing on the result of the function call. If both -- parameterless and parametered functions are present, then the -- tree itself is ambiguous, and both parsings must be carried, to -- be resolved by overload resolution. ??? TBSL null; end if; Change_Node (N, N_Function_Call); Set_Name (N, P); Set_Parameter_Associations (N, E); Set_Sloc (N, S); Analyze_Call (N); end Find_Function_Call; ------------------------- -- Find_Index_Or_Slice -- ------------------------- procedure Find_Index_Or_Slice (N : Node_Id) is P : constant Node_Id := Prefix (N); E : constant Node_Id := First (Expressions (N)); begin -- If more than one index is present, this is an indexed component -- of a multidimensional array. if Present (Next (E)) then Analyze_Indexed_Component (N); elsif Is_Name (E) and then Ekind (Entity (E)) in Type_Kind then -- The node denotes a slice if E is a subtype mark or a discrete -- range. The discrete range already appears syntactically as a -- N_Slice node, so we only need to consider the case of a -- subtype mark here. Change_Node (N, N_Slice); Set_Prefix (N, P); Set_Discrete_Range (N, E); else -- Single expression indexes a one-dimensional array. Analyze_Indexed_Component (N); end if; end Find_Index_Or_Slice; ---------------- -- Find_Slice -- ---------------- procedure Find_Slice (N : Node_Id) is P : Node_Id := Prefix (N); D : Node_Id := Discrete_Range (N); Array_Type : Entity_Id; begin if No (Etype (P)) then -- The caller may have analyzed the prefix already Analyze (P); end if; Analyze (D); Array_Type := Etype (P); Set_Etype (N, Any_Type); if Is_Access_Type (Array_Type) then Array_Type := Designated_Type (Array_Type); end if; if not Is_Array_Type (Array_Type) then Error_Msg_N ("prefix of slice must be appropriate for array", P); elsif Number_Dimensions (Array_Type) /= 1 then Error_Msg_N ("type is not one-dimensional array in slice prefix", N); elsif not Has_Compatible_Type (D, Etype (First_Index (Array_Type))) then Error_Msg_N ("invalid index type in slice ", N); else Set_Etype (N, Array_Type); end if; end Find_Slice; ------------------------------- -- Find_Explicit_Dereference -- ------------------------------- procedure Find_Explicit_Dereference (N : Node_Id) is P : Node_Id := Prefix (N); begin Find_Name (P); if Is_Access_Type (Etype (P)) then if Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type and then Nkind (Parent (N)) /= N_Indexed_Component then -- Name is a function call with no actuals. Change_Node (N, N_Function_Call); Set_Name (N, P); Set_Parameter_Associations (N, New_List); Analyze_Call (N); else Set_Etype (N, Designated_Type (Etype (P))); end if; else Error_Msg_N ("attempt to dereference non-access type&", N); Set_Etype (N, Any_Type); end if; end Find_Explicit_Dereference; --------------- -- Find_Type -- --------------- procedure Find_Type (N : Node_Id) is C : Entity_Id; T : Entity_Id; T_Name : Entity_Id; begin if Nkind (N) = N_Attribute_Reference then if Chars (Identifier (N)) = Name_Class then Find_Type (Prefix (N)); T := Base_Type (Entity (Prefix (N))); if not Is_Tagged_Type (T) then if Ekind (T) = E_Incomplete_Type then -- It is legal to denote the class type of an incomplete -- type. The full type will have to be tagged, of course. Set_Is_Tagged_Type (T); Make_Class_Type (T); Set_Entity (N, Last_Entity (Current_Scope)); Set_Etype (N, Last_Entity (Current_Scope)); else Error_Msg_N ("type& is not a tagged type", Prefix (N)); Set_Entity (N, Any_Type); end if; else C := Classwide_Type (T); Set_Entity_With_Style_Check (N, C); Set_Etype (N, C); end if; else Error_Msg_N ("invalid attribute in subtype mark", N); end if; else Find_Name (N); T_Name := Entity (N); if T_Name = Any_Id or else Etype (N) = Any_Type then -- Undefined id. Make it into a valid type Set_Entity (N, Any_Type); elsif not Is_Type (T_Name) and then T_Name /= Standard_Void_Type then Error_Msg_N ("subtype mark required in this context", N); Set_Entity (N, Any_Type); else Set_Entity (N, Get_Full_Declaration (T_Name)); if In_Open_Scopes (T_Name) then if Ekind (Base_Type (T_Name)) = E_Task_Type then Error_Msg_N ("task type cannot be used as type mark " & "within its own body", N); else Error_Msg_N ("Type declaration cannot refer to itself", N); end if; end if; end if; end if; end Find_Type; -------------------------- -- Get_Full_Declaration -- -------------------------- function Get_Full_Declaration (T_Name : Entity_Id) return Entity_Id is begin if (Ekind (T_Name) = E_Incomplete_Type and then Present (Full_Declaration (T_Name))) then return Full_Declaration (T_Name); elsif Is_Class_Type (T_Name) and then Ekind (Etype (T_Name)) = E_Incomplete_Type and then Present (Full_Declaration (Etype (T_Name))) then return Classwide_Type (Full_Declaration (Etype (T_Name))); else return T_Name; end if; end Get_Full_Declaration; --------------------------- -- Has_Implicit_Operator -- --------------------------- function Has_Implicit_Operator (N : Node_Id) return Boolean is Op_Id : constant Name_Id := Chars (Selector_Name (N)); P : constant Entity_Id := Entity (Prefix (N)); Id : Entity_Id; begin Id := First_Entity (P); -- Boolean operators: implicit declaration exists if scope contains -- declaration for derived boolean type, or for array of boolean type. if Op_Id = Name_Op_And or else Op_Id = Name_Op_Not or else Op_Id = Name_Op_Or or else Op_Id = Name_Op_Xor then while Present (Id) loop if Valid_Boolean_Arg (Id) then return true; end if; Id := Next_Entity (Id); end loop; -- Equality: look for any non-limited type. elsif Op_Id = Name_Op_Eq or else Op_Id = Name_Op_Ne then while Present (Id) loop if Is_Type (Id) and not Is_Limited_Type (Id) then return true; end if; Id := Next_Entity (Id); end loop; -- Comparison operators: scalar type, or array of scalar. elsif Op_Id = Name_Op_Lt or else Op_Id = Name_Op_Le or else Op_Id = Name_Op_Gt or else Op_Id = Name_Op_Ge then while Present (Id) loop if Is_Scalar_Type (Id) or else (Is_Array_Type (Id) and then Is_Scalar_Type (Component_Type (Id))) then return true; end if; Id := Next_Entity (Id); end loop; -- Arithmetic operators: any numeric type elsif Op_Id = Name_Op_Abs or else Op_Id = Name_Op_Add or else Op_Id = Name_Op_Mod or else Op_Id = Name_Op_Rem or else Op_Id = Name_Op_Subtract or else Op_Id = Name_Op_Multiply or else Op_Id = Name_Op_Divide or else Op_Id = Name_Op_Expon then while Present (Id) loop if Is_Numeric_Type (Id) then return True; end if; Id := Next_Entity (Id); end loop; -- Concatenation: any one-dimensional array type elsif Op_Id = Name_Op_Concat then while Present (Id) loop if Is_Array_Type (Id) and then Number_Dimensions (Id) = 1 then return true; end if; Id := Next_Entity (Id); end loop; else return False; end if; end Has_Implicit_Operator; --------------- -- End_Scope -- --------------- procedure End_Scope is Id : Entity_Id; Prev : Entity_Id; Outer : Entity_Id; begin Id := First_Entity (Current_Scope); while Present (Id) loop -- An entity in the current scope is not necessarily the first one -- on its homonym chain. Find its predecessor if any, -- If it is an internal entity, it will not be in the visibility -- chain altogether, and there is nothing to unchain. if Id /= Current_Entity (Id) then Prev := Current_Entity (Id); while Present (Prev) and then Present (Homonym (Prev)) and then Homonym (Prev) /= Id loop Prev := Homonym (Prev); end loop; if No (Prev) or else Homonym (Prev) /= Id then -- Id is not in the visibility chain. goto Next_Ent; end if; else Prev := Empty; end if; Outer := Homonym (Id); while Present (Outer) and then Scope (Outer) = Current_Scope loop Outer := Homonym (Outer); end loop; if No (Prev) then Set_Name_Entity_Id (Chars (Id), Outer); else Set_Homonym (Prev, Outer); end if; <> Id := Next_Entity (Id); end loop; Pop_Scope; end End_Scope; ------------------------- -- Analyze_Use_Package -- ------------------------- -- Resolve the package names in the use clause, and make all the visible -- entities defined in the package use-visible. If the package is -- already in use because of a previous use clause, its visible entities -- are already use-visible. In that case, mark the occurrence as a -- redundant use. If the package is an open scope, i.e. if the use -- clause occurs within the package itself, ignore it. procedure Analyze_Use_Package (N : Node_Id) is Pack_Name : Node_Id; Pack : Entity_Id; -- Internal function used to scan the context clause to find the -- previous occurence of package name in with-clause, or report error. function Find_Package_Unit return Entity_Id is Item : Node_Id := First (Context_Items (Parent (N))); begin while Present (Item) and then Item /= N loop if Nkind (Item) = N_With_Clause and then Same_Name (Name (Item), Pack_Name) then return Entity (Name (Item)); end if; Item := Next (Item); end loop; Error_Msg_N ("unknown package in USE clause", N); return Standard_Standard; end Find_Package_Unit; -- Start processing for Use_Package_Clause begin -- Loop through package names to identify referenced packages Pack_Name := First (Names (N)); while Present (Pack_Name) loop -- If this use clause appears in the context clause of a compilation -- unit, then we have to find the corresponding with clause to -- identify the referenced package. if Nkind (Parent (N)) = N_Compilation_Unit then Pack := Find_Package_Unit; if Nkind (Pack_Name) = N_Selected_Component then Change_Selected_Component_To_Expanded_Name (Pack_Name); end if; Set_Entity (Pack_Name, Pack); -- If the use clause is appearing in a normal declaration context, -- then it references a package name that is visible by normal rules. else Find_Name (Pack_Name); end if; Pack_Name := Next (Pack_Name); end loop; -- Loop through package names to mark all entities as use visible Pack_Name := First (Names (N)); while Present (Pack_Name) loop Pack := Entity (Pack_Name); if Ekind (Pack) /= E_Package and then Etype (Pack) /= Any_Type then Error_Msg_N ("& is not a usable package", Pack_Name); else if In_Open_Scopes (Pack) then null; elsif not In_Use (Pack) or else Nkind (Parent (N)) = N_Compilation_Unit then Use_One_Package (Pack); else Set_Redundant_Use (Pack_Name, True); end if; end if; Pack_Name := Next (Pack_Name); end loop; end Analyze_Use_Package; --------------------- -- Use_One_Package -- --------------------- procedure Use_One_Package (P : Entity_Id) is Id : Entity_Id; Prev : Entity_Id; begin Set_In_Use (P); -- If unit is a package renaming, indicate that the renamed -- package is also in use (the flags on both entities must -- remain consistent). if Present (Renamed_Object (P)) then Set_In_Use (Renamed_Object (P)); end if; -- Loop through entities in one package making them use visible Id := First_Entity (P); while Present (Id) and then Id /= First_Private_Entity (P) loop Prev := Current_Entity (Id); while Present (Prev) loop if Is_Directly_Visible (Prev) and then (not Is_Overloadable (Prev) or else not Is_Overloadable (Id) or else (Type_Conformant (Id, Prev))) then -- use-visible entity remains hidden goto Next_Usable_Entity; end if; Prev := Homonym (Prev); end loop; -- On exit, we know entity is not hidden. Set_Is_Use_Visible (Id); <> Id := Next_Entity (Id); end loop; end Use_One_Package; ---------------------- -- Analyze_Use_Type -- ---------------------- procedure Analyze_Use_Type (N : Node_Id) is Id : Entity_Id; begin Id := First (Subtype_Marks (N)); while Present (Id) loop Find_Type (Id); if Entity (Id) /= Any_Type then Set_Is_Use_Visible (Entity (Id)); -- If the base type is anonymous this indicates that the entity -- is really a first named subtype and we need to make the -- base type of the entity "use type" visible as well. Otherwise, -- operators which are defined on the type, and which the user -- wanted to make directly visible by means of this use clause, -- would in fact not become visible. if Is_Internal (Base_Type (Entity (Id))) then Set_Is_Use_Visible (Base_Type (Entity (Id))); end if; end if; Id := Next (Id); end loop; end Analyze_Use_Type; ------------- -- End_Use -- ------------- procedure End_Use (L : List_Id) is Decl : Node_Id; Pack_Name : Node_Id; Pack : Entity_Id; Id : Entity_Id; begin if List_Present (L) then Decl := First (L); while Present (Decl) loop if Nkind (Decl) = N_Use_Package_Clause then Pack_Name := First (Names (Decl)); while Present (Pack_Name) loop Pack := Entity (Pack_Name); if Ekind (Pack) = E_Package then if not Redundant_Use (Pack_Name) then Set_In_Use (Pack, False); Id := First_Entity (Pack); while Present (Id) loop Set_Is_Use_Visible (Id, False); Id := Next_Entity (Id); end loop; end if; if Present (Renamed_Object (Pack)) then Set_In_Use (Renamed_Object (Pack), False); end if; -- TBSL : this may be a redundant use of the renamed -- package! end if; Pack_Name := Next (Pack_Name); end loop; elsif Nkind (Decl) = N_Use_Type_Clause then Id := First (Names (Decl)); while Present (Id) loop Find_Type (Id); if Entity (Id) /= Any_Type then Set_Is_Use_Visible (Entity (Id), False); end if; Id := Next (Id); end loop; end if; Decl := Next (Decl); end loop; end if; end End_Use; ------------- -- Set_Use -- ------------- procedure Set_Use (L : List_Id) is Decl : Node_Id; Pack_Name : Node_Id; Pack : Entity_Id; Id : Entity_Id; begin if List_Present (L) then Decl := First (L); while Present (Decl) loop if Nkind (Decl) = N_Use_Package_Clause then Pack_Name := First (Names (Decl)); while Present (Pack_Name) loop Pack := Entity (Pack_Name); if Ekind (Pack) = E_Package then if not In_Use (Pack) then Use_One_Package (Pack); else Set_Redundant_Use (Pack_Name, True); end if; end if; Pack_Name := Next (Pack_Name); end loop; elsif Nkind (Decl) = N_Use_Type_Clause then Id := First (Names (Decl)); while Present (Id) loop if Entity (Id) /= Any_Type then Set_Is_Use_Visible (Entity (Id), True); end if; Id := Next (Id); end loop; end if; Decl := Next (Decl); end loop; end if; end Set_Use; ----------------------------- -- Analyze_Object_Renaming -- ----------------------------- procedure Analyze_Object_Renaming (N : Node_Id) is Id : constant Entity_Id := Defining_Identifier (N); Nam : constant Node_Id := Name (N); S : constant Entity_Id := Subtype_Mark (N); T : Entity_Id; T2 : Entity_Id; begin Enter_Name (Id); Find_Name (Nam); T2 := Etype (Nam); Find_Type (S); T := Entity (S); Resolve_Complete_Context (Nam, T); Set_Ekind (Id, E_Variable); if T = Any_Type or else Etype (Nam) = Any_Type then return; elsif not Is_Constrained (T) then -- The constraints are inherited from the renamed object, they -- are not affected by the given subtype mark. Set_Etype (Id, T2); else Set_Etype (Id, T); end if; if not Is_Variable (Nam) then Set_Ekind (Id, E_Constant); end if; Set_Renamed_Object (Id, Nam); end Analyze_Object_Renaming; -------------------------------- -- Analyze_Exception_Renaming -- -------------------------------- -- The language only allows a single identifier, but the tree holds -- an identifier list. The parser has already issued an error message -- if there is more than one element in the list. procedure Analyze_Exception_Renaming (N : Node_Id) is Id : constant Node_Id := Defining_Identifier (N); Nam : constant Node_Id := Name (N); begin Enter_Name (Id); Set_Ekind (Id, E_Exception); Set_Etype (Id, Standard_Exception_Type); Find_Name (Nam); if Ekind (Entity (Nam)) /= E_Exception then Error_Msg_N ("invalid exception name in renaming", Nam); else Set_Renamed_Object (Id, Entity (Nam)); end if; end Analyze_Exception_Renaming; ------------------------------ -- Analyze_Package_renaming -- ------------------------------ procedure Analyze_Package_Renaming (N : Node_Id) is New_P : Entity_Id := Defining_Unit_Simple_Name (N); Old_P : Entity_Id; begin Find_Name (Name (N)); Old_P := Entity (Name (N)); if Etype (Old_P) = Any_Type then null; elsif Ekind (Old_P) /= E_Package then Error_Msg_N ("invalid package name", Name (N)); else -- Entities in the old package are accessible through the -- renaming entity. The simplest implementation is to have -- both packages share the entity list. Enter_Name (New_P); Set_Ekind (New_P, E_Package); Set_Etype (New_P, Standard_Void_Type); Set_Renamed_Object (New_P, Old_P); Set_Has_Completion (New_P); Set_First_Entity (New_P, First_Entity (Old_P)); Set_Last_Entity (New_P, Last_Entity (Old_P)); Set_First_Private_Entity (New_P, First_Private_Entity (Old_P)); end if; end Analyze_Package_Renaming; --------------------------------- -- Analyze_Subprogram_Renaming -- --------------------------------- procedure Analyze_Subprogram_Renaming (N : Node_Id) is Nam : Node_Id := Name (N); Spec : Node_Id := Specification (N); New_S : Entity_Id := Defining_Unit_Simple_Name (Spec); Old_S : Entity_Id; Prev : Entity_Id; I : Interp_Index; It : Interp; begin -- The renaming defines a new overloaded entity, which is analyzed -- like a subprogram declaration. New_S := Analyze_Spec (Spec); Prev := Find_Corresponding_Spec (N); if Present (Prev) then -- Renaming_As_Body. Renaming declaration is the completion of -- the declaration of Prev. if not Type_Conformant (Prev, New_S) then Error_Msg_N ("renamed entity not type conformant with declaration", N); elsif Ada_83 then Error_Msg_N ("in Ada83 a renaming cannot serve as a body", N); end if; New_S := Prev; else New_Overloaded_Entity (New_S); Set_Has_Completion (New_S); end if; Find_Name (Nam); if Etype (Nam) = Any_Type then null; elsif Nkind (Nam) = N_Attribute_Reference then Attribute_Renaming (N); elsif not Is_Overloadable (Entity (Nam)) then Error_Msg_N ("expect valid subprogram name in renaming", N); else -- Now we must resolve the subprogram renaming Old_S := Any_Id; if not Is_Overloaded (Name (N)) then if Entity_Matches_Spec (Entity (Name (N)), New_S) then Old_S := Entity (Name (N)); end if; else Get_First_Interp (Name (N), I, It); while Present (It.Nam) loop if Entity_Matches_Spec (It.Nam, New_S) then if Old_S /= Any_Id then Old_S := Disambiguate (It.Nam, Old_S, Etype (Old_S)); if Old_S = Any_Id then Error_Msg_N ("ambiguous renaming", N); exit; end if; else Old_S := It.Nam; end if; end if; Get_Next_Interp (I, It); end loop; end if; if Old_S /= Any_Id then -- The subprogram being renamed must be mode conformant -- with the given specification. if Ekind (Old_S) /= E_Operator then if not Mode_Conformant (New_S, Old_S) then Error_Msg_N ("renamed entity not mode conformant with declaration", N); end if; end if; if Present (Prev) then -- Rewrite renaming declaration as a subprogram body, whose -- single statement is a call to Old_S. declare Actuals : List_Id := New_List; Call_Node : Node_Id; Body_Node : Node_Id; Formal : Entity_Id; Loc : Source_Ptr := Sloc (N); begin -- Reset completion flag, so this body is seen as the -- proper completion. Set_Has_Completion (New_S, False); Formal := First_Formal (New_S); while Present (Formal) loop Append (New_Reference_To (Formal, Loc), Actuals); Formal := Next_Formal (Formal); end loop; if Ekind (Old_S) = E_Function then Call_Node := Make_Return_Statement (Loc, Expression => Make_Function_Call (Loc, Name => New_Reference_To (Old_S, Loc), Parameter_Associations => Actuals)); else Call_Node := Make_Procedure_Call_Statement (Loc, Name => New_Reference_To (Old_S, Loc), Parameter_Associations => Actuals); end if; Body_Node := Make_Subprogram_Body (Loc, Specification => Spec, Declarations => New_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List_1 (Call_Node))); Analyze (Body_Node); Rewrite_Substitute_Tree (N, Body_Node); end; else Set_Alias (New_S, Old_S); end if; else Error_Msg_N ("No visible subprogram matches this specification", Spec); end if; end if; end Analyze_Subprogram_Renaming; ------------------------- -- Entity_Matches_Spec -- ------------------------- function Entity_Matches_Spec (Old_S, New_S : Entity_Id) return Boolean is begin -- Simple case: same entity kinds, type conformance is required. -- A parameterless function can also rename a literal. if Ekind (Old_S) = Ekind (New_S) or else (Ekind (New_S) = E_Function and then Ekind (Old_S) = E_Enumeration_Literal) then return Type_Conformant (Old_S, New_S); elsif Ekind (New_S) = E_Function and then Ekind (Old_S) = E_Operator then return Operator_Matches_Spec (Old_S, New_S); elsif Ekind (New_S) = E_Procedure and then Ekind (Old_S) = E_Entry then Unimplemented (Old_S, "entries renamed as procedures"); return False; else return False; end if; end Entity_Matches_Spec; ------------------------ -- Attribute_Renaming -- ------------------------ procedure Attribute_Renaming (N : Node_Id) is begin Unimplemented (N, "Attribute renaming"); end Attribute_Renaming; ---------------- -- Write_Info -- ---------------- procedure Write_Info is Id : Entity_Id := First_Entity (Current_Scope); begin if Current_Scope = Standard_Standard then -- No point in dumping standard entities. return; end if; Write_Str ("========================================================"); Write_Eol; Write_Str (" Defined Entities in "); Write_Name (Chars (Current_Scope)); Write_Eol; Write_Str ("========================================================"); Write_Eol; if No (Id) then Write_Str ("-- none --"); Write_Eol; else while Present (Id) loop Write_Entity_Info (Id, " "); Id := Next_Entity (Id); end loop; end if; if Scope (Current_Scope) = Standard_Standard then -- Print information on the current unit itself Write_Entity_Info (Current_Scope, " "); end if; Write_Eol; end Write_Info; end Sem_Ch8; ption_Renaming; ------------------------------ -- Analyze_Package_renaming -- ------------------------------ procedure Analyze_Package_Renaming (N : Node_Id) is New_P : Entity_Id := Defining_Unit_Simple_Name (N); Old_P : Egnat-1.67-src/src/sem_ch9.ads 444 10015 7640 7426 5506244401 11142 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ C H 9 -- -- -- -- S p e c -- -- -- -- $Revision: 1.4 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Sem_Ch9 is procedure Analyze_Task_Type (N : Node_Id); procedure Analyze_Single_Task (N : Node_Id); procedure Analyze_Task_Definition (N : Node_Id); procedure Analyze_Task_Body (N : Node_Id); procedure Analyze_Protected_Type (N : Node_Id); procedure Analyze_Single_Protected (N : Node_Id); procedure Analyze_Protected_Definition (N : Node_Id); procedure Analyze_Protected_Body (N : Node_Id); procedure Analyze_Entry_Declaration (N : Node_Id); procedure Analyze_Entry_Call (N : Node_Id); procedure Analyze_Entry_Body (N : Node_Id); procedure Analyze_Entry_Body_Formal_Part (N : Node_Id); procedure Analyze_Entry_Index_Specification (N : Node_Id); procedure Analyze_Accept_Statement (N : Node_Id); procedure Analyze_Requeue (N : Node_Id); procedure Analyze_Delay_Until (N : Node_Id); procedure Analyze_Delay_Relative (N : Node_Id); procedure Analyze_Selective_Accept (N : Node_Id); procedure Analyze_Accept_Alternative (N : Node_Id); procedure Analyze_Delay_Alternative (N : Node_Id); procedure Analyze_Terminate_Alternative (N : Node_Id); procedure Analyze_Conditional_Entry_Call (N : Node_Id); procedure Analyze_Entry_Call_Alternative (N : Node_Id); procedure Analyze_Timed_Entry_Call (N : Node_Id); procedure Analyze_Asynchronous_Select (N : Node_Id); procedure Analyze_Triggering_Alternative (N : Node_Id); procedure Analyze_Abortable_Part (N : Node_Id); procedure Analyze_Abort_Statement (N : Node_Id); end Sem_Ch9; gin -- The renaming defines a new overloaded entity, which is analyzed -- like a subprogram declaration. New_S := Analyze_Spec (Spec); Prev := Find_Corresponding_Spec (N); if Present (Prev) then gnat-1.67-src/src/sem_ch9.adb 444 10015 7640 57141 5506244402 11141 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ C H 9 -- -- -- -- B o d y -- -- -- -- $Revision: 1.47 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Debug; use Debug; with Einfo; use Einfo; with Errout; use Errout; with Opt; use Opt; with Sem; use Sem; with Sem_Ch3; use Sem_Ch3; with Sem_Ch4; use Sem_Ch4; with Sem_Ch5; use Sem_Ch5; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Stand; use Stand; with Sinfo; use Sinfo; with Tbuild; use Tbuild; with Ttypes; use Ttypes; with Uintp; use Uintp; package body Sem_Ch9 is ----------------------- -- Local Subprograms -- ----------------------- procedure Install_Declarations (Spec : Entity_Id); -- Utility to make visible in corresponding body the entities defined -- in task, protected type declaration, or entry declaration. ----------------------- -- Analyze_Task_Type -- ----------------------- procedure Analyze_Task_Type (N : Node_Id) is Id : Node_Id := Defining_Identifier (N); begin Enter_Name (Id); Set_Ekind (Id, E_Task_Type); Set_Has_Tasks (Id, True); Set_Esize (Id, UI_From_Int (System_Address_Size)); Set_Etype (Id, Id); Set_Is_Limited_Type (Id); New_Scope (Id); if List_Present (Discriminant_Specifications (N)) then if Ada_83 then Error_Msg_N ("task discriminants not supported in Ada83", N); end if; Process_The_Discriminants (N); end if; if Present (Task_Definition (N)) then Analyze_Task_Definition (Task_Definition (N)); end if; End_Scope; end Analyze_Task_Type; ------------------------- -- Analyze_Single_Task -- ------------------------- procedure Analyze_Single_Task (N : Node_Id) is Id : constant Node_Id := Defining_Identifier (N); T : constant Entity_Id := New_Implicit_Type (Sloc (N), Id, "task_type"); begin -- The anonymous task type is implicitly declared before the -- current declaration. Install_Implicit_Types (N); Enter_Name (Id); Set_Ekind (Id, E_Constant); Set_Ekind (T, E_Task_Type); Set_Etype (T, T); Set_Esize (T, UI_From_Int (System_Address_Size)); Set_Is_Limited_Type (T); Set_Etype (Id, T); Set_Has_Tasks (T, True); if Present (Task_Definition (N)) then New_Scope (T); Analyze_Task_Definition (Task_Definition (N)); End_Scope; end if; end Analyze_Single_Task; ----------------------------- -- Analyze_Task_Definition -- ----------------------------- procedure Analyze_Task_Definition (N : Node_Id) is L : Entity_Id; E_Index : Uint := Uint_1; begin if List_Present (Visible_Declarations (N)) then Analyze_Declarations (Visible_Declarations (N)); end if; if List_Present (Private_Declarations (N)) then L := Last_Entity (Current_Scope); Analyze_Declarations (Private_Declarations (N)); if Present (L) then Set_First_Private_Entity (Current_Scope, Next_Entity (L)); else Set_First_Private_Entity (Current_Scope, First_Entity (Current_Scope)); end if; end if; -- Assign consecutive Entry_Index values to single entries. L := First_Entity (Current_Scope); while Present (L) loop if Ekind (L) = E_Entry then Set_Entry_Index (L, E_Index); E_Index := UI_Sum (E_Index, Uint_1); end if; L := Next_Entity (L); end loop; -- The entry index of entry families is one greater than that of -- the last single entry. L := First_Entity (Current_Scope); while Present (L) loop if Ekind (L) = E_Entry_Family then Set_Entry_Index (L, E_Index); end if; L := Next_Entity (L); end loop; end Analyze_Task_Definition; ----------------------- -- Analyze_Task_Body -- ----------------------- procedure Analyze_Task_Body (N : Node_Id) is Body_Id : Entity_Id := Defining_Identifier (N); Spec_Id : Entity_Id := Current_Entity (Body_Id); begin Set_Ekind (Body_Id, E_Task_Body); if No (Spec_Id) or else Scope (Spec_Id) /= Current_Scope or else Ekind (Etype (Spec_Id)) /= E_Task_Type then Error_Msg_N ("missing specification for task body", Body_Id); return; end if; if Ekind (Spec_Id) = E_Constant then -- The declarations are attached to the type (in the case of a -- single task, to the implicit type of the task). I do not -- understand this comment in this context (RBKD -- TBSL) Spec_Id := Etype (Spec_Id); end if; New_Scope (Spec_Id); Set_Corresponding_Spec (N, Spec_Id); Set_Has_Completion (Spec_Id); Install_Declarations (Spec_Id); Analyze_Declarations (Declarations (N)); Analyze (Handled_Statement_Sequence (N)); End_Use (Declarations (N)); End_Scope; end Analyze_Task_Body; ---------------------------- -- Analyze_Protected_Type -- ---------------------------- procedure Analyze_Protected_Type (N : Node_Id) is Id : Node_Id := Defining_Identifier (N); begin Enter_Name (Id); Set_Ekind (Id, E_Protected_Type); Set_Etype (Id, Id); Set_Is_Limited_Type (Id); New_Scope (Id); if List_Present (Discriminant_Specifications (N)) then Process_The_Discriminants (N); end if; Analyze (Protected_Definition (N)); End_Scope; end Analyze_Protected_Type; ------------------------------ -- Analyze_Single_Protected -- ------------------------------ procedure Analyze_Single_Protected (N : Node_Id) is Id : constant Node_Id := Defining_Identifier (N); T : constant Entity_Id := New_Implicit_Type (Sloc (N), Id, "protected_type"); begin -- The anonymous protected type is implicitly declared before the -- current declaration. Install_Implicit_Types (N); Enter_Name (Id); Set_Ekind (Id, E_Protected_Object); Set_Ekind (T, E_Protected_Type); Set_Etype (T, T); Set_Is_Limited_Type (T); Set_Etype (Id, T); New_Scope (T); Analyze (Protected_Definition (N)); End_Scope; end Analyze_Single_Protected; ---------------------------------- -- Analyze_Protected_Definition -- ---------------------------------- procedure Analyze_Protected_Definition (N : Node_Id) is L : Entity_Id; begin Analyze_Declarations (Visible_Declarations (N)); if List_Present (Private_Declarations (N)) then L := Last_Entity (Current_Scope); Analyze_Declarations (Private_Declarations (N)); Set_First_Private_Entity (Current_Scope, Next_Entity (L)); end if; end Analyze_Protected_Definition; ---------------------------- -- Analyze_Protected_Body -- ---------------------------- procedure Analyze_Protected_Body (N : Node_Id) is Body_Id : Entity_Id := Defining_Identifier (N); Spec_Id : Entity_Id := Current_Entity (Body_Id); begin Set_Ekind (Body_Id, E_Protected_Body); if No (Spec_Id) or else Scope (Spec_Id) /= Current_Scope or else Ekind (Etype (Spec_Id)) /= E_Protected_Type then Error_Msg_N ("missing specification for protected body", Body_Id); return; end if; -- The declarations are always attached to the type if Ekind (Spec_Id) = E_Protected_Object then Spec_Id := Etype (Spec_Id); end if; New_Scope (Spec_Id); Set_Has_Completion (Spec_Id); Install_Declarations (Spec_Id); Analyze_Declarations (Declarations (N)); End_Scope; end Analyze_Protected_Body; ------------------------------- -- Analyze_Entry_Declaration -- ------------------------------- procedure Analyze_Entry_Declaration (N : Node_Id) is Id : Entity_Id := Defining_Identifier (N); D_Sdef : Node_Id := Discrete_Subtype_Definition (N); Formals : List_Id := Parameter_Specifications (N); begin if No (D_Sdef) then Set_Ekind (Id, E_Entry); else Enter_Name (Id); Set_Ekind (Id, E_Entry_Family); Analyze (D_Sdef); Make_Index (D_Sdef, Id); end if; Set_Etype (Id, Standard_Void_Type); if List_Present (Formals) then New_Scope (Id); Process_Formals (Id, Formals); End_Scope; end if; if Ekind (Id) = E_Entry then New_Overloaded_Entity (Id); end if; end Analyze_Entry_Declaration; ------------------------ -- Analyze_Entry_Call -- ------------------------ procedure Analyze_Entry_Call (N : Node_Id) is Actuals : constant List_Id := Parameter_Associations (N); Nam : constant Node_Id := Name (N); Entry_Name : Entity_Id; begin -- The parser only builds procedure calls. After analyzing the prefix -- we know that this is an entry call. Rebuild the node accordingly. -- Resolve possible syntactic ambiguities between calls to single -- entries, and calls to parameterless entry families. if Nkind (Nam) = N_Selected_Component then Entry_Name := Entity (Selector_Name (Nam)); elsif Nkind (Nam) = N_Indexed_Component then Unimplemented (N, "entry family calls"); return; else -- TBSL, the following is a junk error message! Unimplemented (N, "this call"); return; end if; Set_Name (N, New_Occurrence_Of (Entry_Name, Sloc (N))); Analyze_Call (N); Resolve_Complete_Context (N, Standard_Void_Type); Change_Node (N, N_Entry_Call_Statement); Set_Name (N, Nam); Set_Parameter_Associations (N, Actuals); -- The prefix denotes a task or protected object that contains -- the entry. Both the entry and the prefix may be overloaded. -- If this is an external call, then after resolving the entry, -- use the type of its scope to complete the resolution of its -- prefix. (TBD). end Analyze_Entry_Call; ------------------------ -- Analyze_Entry_Body -- ------------------------ procedure Analyze_Entry_Body (N : Node_Id) is Id : constant Entity_Id := Defining_Identifier (N); Decls : constant List_Id := Declarations (N); Stats : constant Node_Id := Handled_Statement_Sequence (N); Cond : constant Node_Id := Condition (N); Entry_Name : Entity_Id; E : Entity_Id; begin -- Entry_Name is initialized to Any_Id. It should get reset to the -- matching entry entity. An error is signalled if it is not reset Entry_Name := Any_Id; Analyze (Entry_Body_Formal_Part (N)); if Present (Entry_Index_Specification (Entry_Body_Formal_Part (N))) then Set_Ekind (Id, E_Entry_Family); else Set_Ekind (Id, E_Entry); end if; Set_Etype (Id, Standard_Void_Type); E := First_Entity (Current_Scope); while Present (E) loop if Chars (E) = Chars (Id) and then (Ekind (E) = Ekind (Id)) and then Type_Conformant (E, Id) then Entry_Name := E; exit; end if; E := Next_Entity (E); end loop; if Entry_Name = Any_Id then Error_Msg_N ("no entry declaration matches entry body", N); return; else Set_Has_Completion (Entry_Name); end if; if Present (Cond) then Analyze (Cond); Resolve_Complete_Context (Cond, Any_Boolean); end if; New_Scope (Entry_Name); if List_Present (Decls) then Install_Declarations (Entry_Name); Analyze_Declarations (Decls); end if; if Present (Stats) then Analyze (Stats); end if; End_Scope; end Analyze_Entry_Body; ------------------------ -- Analyze_Entry_Body -- ------------------------ procedure Analyze_Entry_Body_Formal_Part (N : Node_Id) is Id : constant Entity_Id := Defining_Identifier (Parent (N)); Index : constant Node_Id := Entry_Index_Specification (N); Formals : constant List_Id := Parameter_Specifications (N); begin if Present (Index) then Analyze (Index); end if; if List_Present (Formals) then New_Scope (Id); Process_Formals (Id, Formals); End_Scope; end if; end Analyze_Entry_Body_Formal_Part; --------------------------------------- -- Analyze_Entry_Index_Specification -- --------------------------------------- procedure Analyze_Entry_Index_Specification (N : Node_Id) is begin Unimplemented (N, "entry index specification"); end Analyze_Entry_Index_Specification; ------------------------------ -- Analyze_Accept_Statement -- ------------------------------ procedure Analyze_Accept_Statement (N : Node_Id) is Ityp : Entity_Id; Entry_Name : Entity_Id; E : Entity_Id; Kind : Entity_Kind; Task_Name : Entity_Id; Nam : constant Entity_Id := Accept_Name (N); Formals : constant List_Id := Parameter_Specifications (N); Index : constant Node_Id := Entry_Index (N); Stats : constant Node_Id := Handled_Statement_Sequence (N); begin -- Entry name is initialized to Any_Id. It should get reset to the -- matching entry entity. An error is signalled if it is not reset. Entry_Name := Any_Id; for I in reverse 0 .. Scope_Stack.Last loop Task_Name := Scope_Stack.Table (I).Entity; exit when Ekind (Etype (Task_Name)) = E_Task_Type; Kind := Ekind (Task_Name); if Kind /= E_Block and then Kind /= E_Loop and then Kind /= E_Entry and then Kind /= E_Entry_Family then Error_Msg_N ("enclosing body of accept must be a task", N); return; end if; end loop; if Ekind (Etype (Task_Name)) /= E_Task_Type then Error_Msg_N ("invalid context for accept statement", N); return; end if; -- In order to process the parameters, we create a defining -- identifier that can be used as the name of the scope. The -- name of the accept statement itself is not a defining identifier. if Present (Index) then Ityp := New_Internal_Entity (E_Entry_Family, Current_Scope, Sloc (N), "entry"); else Ityp := New_Internal_Entity (E_Entry, Current_Scope, Sloc (N), "entry"); end if; Set_Etype (Ityp, Standard_Void_Type); if List_Present (Formals) then New_Scope (Ityp); Process_Formals (Ityp, Formals); End_Scope; end if; E := First_Entity (Etype (Task_Name)); while Present (E) loop if Chars (E) = Chars (Nam) and then (Ekind (E) = Ekind (Ityp)) and then Type_Conformant (E, Ityp) then Entry_Name := E; exit; end if; E := Next_Entity (E); end loop; if Entry_Name = Any_Id then Error_Msg_N ("no entry declaration matches accept statement", N); return; else Set_Entity (Nam, Entry_Name); end if; for I in reverse 0 .. Scope_Stack.Last loop exit when Task_Name = Scope_Stack.Table (I).Entity; if Entry_Name = Scope_Stack.Table (I).Entity then Error_Msg_N ("accept statement cannot appear with an accept" & " statement for the same entry", N); end if; end loop; if Ekind (E) = E_Entry_Family then if No (Index) then Error_Msg_N ("missing entry index in accept for entry family", N); else Analyze (Index); end if; elsif Present (Index) then Error_Msg_N ("invalid entry index in accept for simple entry", N); end if; if Present (Stats) then New_Scope (Entry_Name); Install_Declarations (Entry_Name); Analyze (Stats); End_Scope; end if; end Analyze_Accept_Statement; ------------------- -- Analyze_Requeue -- --------------------- procedure Analyze_Requeue (N : Node_Id) is begin Unimplemented (N, "Requeue"); end Analyze_Requeue; ------------------------- -- Analyze_Delay_Until -- ------------------------- procedure Analyze_Delay_Until (N : Node_Id) is begin Unimplemented (N, "Delay statements"); end Analyze_Delay_Until; ---------------------------- -- Analyze_Delay_Relative -- ---------------------------- procedure Analyze_Delay_Relative (N : Node_Id) is begin Unimplemented (N, "Delay statements"); end Analyze_Delay_relative; ------------------------------ -- Analyze_Selective_Accept -- ------------------------------ procedure Analyze_Selective_Accept (N : Node_Id) is Alts : List_Id := Selective_Accept_Alternatives (N); Alt : Node_Id; Accept_Present : Boolean := False; Terminate_Present : Boolean := False; Delay_Present : Boolean := False; begin Alt := First (Alts); while Present (Alt) loop Analyze (Alt); if Nkind (Alt) = N_Delay_Alternative then Delay_Present := True; elsif Nkind (Alt) = N_Terminate_Alternative then if Terminate_Present then Error_Msg_N ("Only one terminate alternative allowed", N); else Terminate_Present := True; end if; else Accept_Present := True; end if; Alt := Next (Alt); end loop; if Terminate_Present and then Delay_Present then Error_Msg_N ("at most one of terminate or delay alternative", N); elsif not Accept_Present then Error_Msg_N ("select must contain at least one accept alternative", N); end if; if List_Present (Else_Statements (N)) then if Terminate_Present or else Delay_Present then Error_Msg_N ("else part not allowed with other alternatives", N); end if; Analyze_Statements (Else_Statements (N)); end if; end Analyze_Selective_Accept; --------------------------------- -- Analyze_Accept_Alternative -- --------------------------------- procedure Analyze_Accept_Alternative (N : Node_Id) is begin Analyze (Accept_Statement (N)); if Present (Condition (N)) then Analyze (Condition (N)); Resolve_Complete_Context (Condition (N), Any_Boolean); end if; if List_Present (Statements (N)) then Analyze_Statements (Statements (N)); end if; end Analyze_Accept_Alternative; -------------------------------- -- Analyze_Delay_alternative -- -------------------------------- procedure Analyze_Delay_Alternative (N : Node_Id) is begin Analyze (Delay_Statement (N)); if Present (Condition (N)) then Analyze (Condition (N)); Resolve_Complete_Context (Condition (N), Any_Boolean); end if; if List_Present (Statements (N)) then Analyze_Statements (Statements (N)); end if; end Analyze_Delay_Alternative; ----------------------------------- -- Analyze_Terminate_Alternative -- ----------------------------------- procedure Analyze_Terminate_Alternative (N : Node_Id) is begin if Present (Condition (N)) then Analyze (Condition (N)); Resolve_Complete_Context (Condition (N), Any_Boolean); end if; if List_Present (Statements (N)) then Analyze_Statements (Statements (N)); end if; end Analyze_Terminate_Alternative; ------------------------------------ -- Analyze_Conditional_Entry_Call -- ------------------------------------ procedure Analyze_Conditional_Entry_Call (N : Node_Id) is begin Unimplemented (N, "conditional entry call"); end Analyze_Conditional_Entry_Call; ------------------------------------ -- Analyze_Entry_Call_Alternative -- ------------------------------------ procedure Analyze_Entry_Call_Alternative (N : Node_Id) is begin Unimplemented (N, "entry call alternative"); end Analyze_Entry_Call_Alternative; ------------------------------ -- Analyze_Timed_Entry_Call -- ------------------------------ procedure Analyze_Timed_Entry_Call (N : Node_Id) is begin Unimplemented (N, "timed entry call"); end Analyze_Timed_Entry_Call; --------------------------------- -- Analyze_Asynchronous_Select -- --------------------------------- procedure Analyze_Asynchronous_Select (N : Node_Id) is begin Unimplemented (N, "asynchronous select"); end Analyze_Asynchronous_Select; ------------------------------------ -- Analyze_Triggering_Alternative -- ------------------------------------ procedure Analyze_Triggering_Alternative (N : Node_Id) is begin Unimplemented (N, "triggering alternative"); end Analyze_Triggering_Alternative; ---------------------------- -- Analyze_Abortable_Part -- ---------------------------- procedure Analyze_Abortable_Part (N : Node_Id) is begin Unimplemented (N, "abortable part"); end Analyze_Abortable_Part; ----------------------------- -- Analyze_Abort_Statement -- ----------------------------- procedure Analyze_Abort_Statement (N : Node_Id) is begin Unimplemented (N, "abort"); end Analyze_Abort_Statement; -------------------------- -- Install_Declarations -- -------------------------- procedure Install_Declarations (Spec : Entity_Id) is E : Entity_Id; Prev : Entity_Id; begin E := First_Entity (Spec); while Present (E) loop Prev := Current_Entity (E); Set_Current_Entity (E); Set_Homonym (E, Prev); E := Next_Entity (E); end loop; end Install_Declarations; begin null; end Sem_Ch9; body of accept must be a task", N); return; end if; end loop; if Ekind (Etype (Task_Name)) /= E_Task_Type then Error_Msg_N ("invalid context for accept statement", N); return; end if; -- In order to process the parameters, we create a defining -- identifier that can be used as the name of the scope. The -- name of the accept statemegnat-1.67-src/src/sem_eval.ads 444 10015 7640 5254 5506244402 11404 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ E V A L -- -- -- -- S p e c -- -- -- -- $Revision: 1.4 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This package contains various subprograms involved in compile time -- evaluation of expressions and checks for staticness of expressions -- and types. with Types; use Types; package Sem_Eval is procedure Static_Evaluation (N : Node_Id); -- Performs compile time evaluation of a given expression. function Is_Static_Expression (N : Node_Id) return Boolean; -- Determines whether an expression fits the definition of an Ada static -- expression as given in LRM 4.9. function Is_Static_Subtype (Typ : Entity_Id) return Boolean; -- Determines whether a subtype fits the definition of an Ada static -- subtype as given in LRM 4.9. function Expr_Value (N : Node_Id) return Uint; -- Returns the folded value of the expression. This function is called -- in instances which it has already been determined that the expression -- has been constant folded. end Sem_Eval; ¹l CreateMiscFiles.cmd|¹m patches-gas138.os2˜¹n patches-gcc257.os2¬¹o sysid.adsȹp Makefile.in.diffܹqGCC-BASEð¹r a-einfo.h¹s README.SPARC¹t a-sinfo.h0¹u nmake.adb¹v nmake.ads, N); elsif not Accept_Present then gnat-1.67-src/src/sem_eval.adb 444 10015 7640 122200 5506244403 11413 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ E V A L -- -- -- -- B o d y -- -- -- -- $Revision: 1.34 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Comperr; use Comperr; with Debug; use Debug; with Debug_Sem; use Debug_Sem; with Einfo; use Einfo; with Errout; use Errout; with Excep; use Excep; with Namet; use Namet; with Output; use Output; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Sinput; use Sinput; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; with Tbuild; use Tbuild; with Uintp; use Uintp; package body Sem_Eval is ---------------- -- Local Data -- ---------------- Pragma_Preelaborable_Enabled : Boolean := False; -- This flag is used to enable checking for pragma Preelaborate, but this -- circuit is not enabled yet, so there is no way for this to get set True Recursive_Call_To_Eval : Boolean := False; -- Eval is not supposed to call itself recursively, directly or indirectly. -- A pragma Assert is used to check for such a recursive call. Is_Static_Result : Boolean; -- Global flag to record if current expression is static. Note that it is -- OK for this to be a global precisely because Eval is non-recursive. ----------------------- -- Local Subprograms -- ----------------------- function Can_Fold_Attribute (N : Node_Id) return Boolean; -- Determine if Attribute is foldable. Only attributes of static subtypes -- are static. All others are dealt with in subsequent compiler phases. function Can_Fold_Expr (N : Node_Id) return Boolean; -- Determine if an expression can be folded (but don't do folding yet) procedure Check_Int_Literal (N : Node_Id); -- Check that the N_Integer_Literal node N has a value that is in range -- of the type. If not, a warning message is raised. procedure Check_Preevaluate (N : Node_Id); -- If the pragma Preelaborate switch is set, this subprogram checks for -- a violation of preelaborate rules and generates an appropriate message procedure Create_Str_Value_Node (N : Node_Id; Str_Id : String_Id); -- Create an N_String_Literal node for the result of compile time -- evaluation of the "&" operation on string literals, character literals -- or constants. Use of Rewrite_Substitute_Tree ensures that the original -- expression tree can be retrieved. procedure Eval_Expr (N : Node_Id); -- Perform evaluation of operators or attributes. Does not do any -- bounds checking for the results of the arithmetic operations. procedure Fold_Expr (N : Node_Id); -- Do constant folding on an expression for which Can_Fold_Expr is true procedure Fold_String (N : Node_Id); -- Used to fold a string value (concatenation or string/character literal) function Fold_Uint (N : Node_Id) return Uint; -- Compute the result of a foldable expression of either an Integer -- or Enumeration type, returning the result as a universal integer. function Fold_Uint_Attribute (N : Node_Id) return Uint; -- Compute result of a foldable attribute, returning the result as a -- universal integer. function Is_Foldable_Subtype (Typ : Entity_Id) return Boolean; -- Determine if a subtype is foldable function Test (Cond : Boolean) return Uint; -- This function simply returns the appropriate Boolean'Pos value -- corresponding to the value of Cond as a universal integer. It is -- used for producing the result of the static evaluation of the -- logical operators -------------------------- -- Is_Static_Expression -- -------------------------- -- If the expression was previously evaluated the Is_Static flag has -- been properly set and just needs to be queried. Otherwise attempt to -- evaluate the expression now and check the result of the evaluation. function Is_Static_Expression (N : Node_Id) return Boolean is begin if not Is_Evaluated (N) then Static_Evaluation (N); end if; return Is_Static (N); end Is_Static_Expression; ----------------------- -- Is_Static_Subtype -- ----------------------- -- A static subtype is either a scalar base type, other than a generic -- formal type; or a scalar subtype formed by imposing on a static -- subtype either a static range constraint, or a floating or fixed -- point constraint whose range constraint, if any, is static. [LRM 4.9] function Is_Static_Subtype (Typ : Entity_Id) return Boolean is Base_T : Entity_Id := Base_Type (Typ); begin if Is_Generic_Type (Base_T) or else not Is_Scalar_Type (Base_T) then return False; elsif Base_T = Typ then return True; else Static_Evaluation (Type_Low_Bound (Typ)); Static_Evaluation (Type_High_Bound (Typ)); return Is_Static_Subtype (Base_T) and then Is_Static (Type_Low_Bound (Typ)) and then Is_Static (Type_High_Bound (Typ)); end if; end Is_Static_Subtype; ------------------------- -- Is_Foldable_Subtype -- ------------------------- function Is_Foldable_Subtype (Typ : Entity_Id) return Boolean is Base_T : Entity_Id := Base_Type (Typ); begin if Is_Generic_Type (Base_T) or not Is_Scalar_Type (Base_T) then return False; elsif Base_T = Typ then return True; else return Is_Foldable_Subtype (Base_T) and then Can_Fold_Expr (Type_Low_Bound (Typ)) and then Can_Fold_Expr (Type_High_Bound (Typ)); end if; end Is_Foldable_Subtype; ----------------------- -- Static_Evaluation -- ----------------------- -- This procedure is called to perform compile time evaluation of an -- expression. The Is_Evaluated flag is first checked to see if the -- expression was previously evaluated. Note that there are two types -- of expressions that can be evaluated at compile time, those that the -- Ada definition considers static and the more general category of -- expressions that do not need run-time support. For example the -- expression (True and then True) can be evaluated at compile time -- but is not considered static by Ada 83 since "and then" is not an -- operator (Ada 9X considers this static). All expressions that can -- be evaluated without run-time support are folded by this procedure. -- The result of the evaluation creates only one additional node which -- holds the result of the evaluation. In the case where folding has -- been sucessful the resulting node is one of the following: -- N_Integer_Literal, N_Identifier, N_String_Literal. -- Rewrite_Substitute_Tree is used to replace the original expression -- with the node containing the result of the evaluation. The original -- expression tree can still be retrieved (for purposes of conformance -- checking, source recreation, and ASIS compliance) by using the -- function Original_Node. -- If the expression evaluation shows that the expression would raise -- Constraint_Error during run-time (e.g. divide by zero), a special -- N_Expression_Actions node is created to raise Constraint_Error -- (see Create_Constraint_Error). -- Identifiers representing user-defined constants which are static are -- not replaced by other nodes but are just marked as being static. -- The Is_Static flag on the result node is set to True only if it is -- Ada static. So the N_Identifier node created for "True and then True", -- (in Ada 83 mode) has Is_Static set to False. -- If the Is_Evaluation flag is False, static evaluation is attempted -- and the Is_Static flag is then set appropriately. -- Evaluation works in a two pass manner. The first pass determines -- whether the expression can be folded, while the second pass actually -- computes the result. If the root of the tree cannot be folded an -- attempt is then made to fold the left and right operands of the -- expression and in case of failure their descendents in turn. -- For the arithmetic results no overflow checking is done here (i.e. -- the exact result is stored as a Uint). Overflow checking will be -- performed as part of the expander pass. -- An expression of a scalar type is said to be static if and only if -- every primary is one of those listed in (a) through (h) below, every -- operator denotes a predefined operator, and the evaluation of the -- expression delivers a value (that is, it does not raise an exception): -- [LRM 4.9] procedure Static_Evaluation (N : Node_Id) is Def_Id : Entity_Id; procedure Debug_Set_Recursion_Flag (B : Boolean) is begin Recursive_Call_To_Eval := B; end Debug_Set_Recursion_Flag; -- Start of processing for Static_Evaluation begin pragma Debug (Debug_A_Entry ("evaluating ", N)); -- If already evaluated, then the subexpression has already been folded -- if folding was possible, and Is_Static (N) is appropriately set. if Is_Evaluated (N) then pragma Debug (Debug_A_Exit ("evaluating ", N, " (already evaluated)")); return; end if; -- Debugging code to make sure there is no recursive call to this -- procedure (which should never occur, because we handle the required -- recursion directly in the code). pragma Assert (not Recursive_Call_To_Eval); pragma Debug (Debug_Set_Recursion_Flag (True)); -- Different cases of static expressions case Nkind (N) is when N_Identifier | N_Expanded_Name => Def_Id := Entity (N); -- An enumeration literal (including a character literal) if Ekind (Def_Id) = E_Enumeration_Literal then Set_Is_Static (N, True); -- A constant explicitly declared by a constant declaration with -- a static subtype, and initialized with a static expression. elsif Ekind (Def_Id) = E_Constant and then Is_Scalar_Type (Etype (Def_Id)) and then -- The expression value given for a constant is evaluated -- when the object declaration is processed. So here we -- can just test its Is_Static field. Is_Static (Constant_Value (Def_Id)) then Set_Is_Static (N, True); else Set_Is_Static (N, False); end if; -- A numeric literal when N_Integer_Literal => Check_Int_Literal (N); Set_Is_Static (N, True); when N_Real_Literal => Set_Is_Static (N, True); -- A string literal when N_String_Literal => Set_Is_Static (N, False); -- An enumeration literal (including a character literal) when N_Character_Literal => Set_Is_Static (N, True); -- A function call whose function name is an operator symbol -- that denotes a predefined operator, including a function -- name that is an expanded name; each actual parameter must -- also be a static expression. when N_Op | N_Attribute_Reference => Eval_Expr (N); when N_Range => Eval_Expr (Low_Bound (N)); Eval_Expr (High_Bound (N)); when others => null; end case; pragma Debug (Debug_Set_Recursion_Flag (False)); pragma Debug (Debug_A_Exit ("evaluating ", N, " (done)")); -- Final step is to mark node as evaluated Set_Is_Evaluated (N, True); end Static_Evaluation; --------------- -- Eval_Expr -- --------------- procedure Eval_Expr (N : Node_Id) is Left : Node_Id; Right : Node_Id; begin if Nkind (N) in N_Entity_Name and then Ekind (Entity (N)) = E_Enumeration_Literal then Set_Is_Static (N, True); elsif Nkind (N) = N_Integer_Literal then Set_Is_Static (N, True); Check_Int_Literal (N); elsif Nkind (N) in N_Unary_Op then if Can_Fold_Expr (Right_Opnd (N)) then Fold_Expr (N); end if; elsif Nkind (N) = N_Op_Concat then if Can_Fold_Expr (Left_Opnd (N)) and then Can_Fold_Expr (Right_Opnd (N)) then Fold_Expr (N); else Error_Msg_N ("dynamic string concatenation not implemented", N); end if; elsif Nkind (N) in N_Binary_Op then Left := Left_Opnd (N); Right := Right_Opnd (N); if Can_Fold_Expr (Left) then if Can_Fold_Expr (Right) then Fold_Expr (N); else Fold_Expr (Left); end if; elsif Can_Fold_Expr (Right) then Fold_Expr (Right); end if; elsif Nkind (N) = N_Attribute_Reference then if Can_Fold_Expr (N) then Fold_Expr (N); end if; end if; end Eval_Expr; ------------------- -- Can_Fold_Expr -- ------------------- function Can_Fold_Expr (N : Node_Id) return Boolean is begin if Is_Generic_Type (Etype (N)) then return false; end if; case Nkind (N) is when N_Binary_Op => return Can_Fold_Expr (Left_Opnd (N)) and then Can_Fold_Expr (Right_Opnd (N)); when N_Unary_Op => return Can_Fold_Expr (Right_Opnd (N)); when N_Identifier | N_Expanded_Name => declare Def_Id : Entity_Id := Entity (N); begin -- An enumeration literal if Ekind (Def_Id) = E_Enumeration_Literal then return True; -- A user defined static constant elsif Ekind (Def_Id) = E_Constant then return Is_Scalar_Type (Etype (Def_Id)) and then Can_Fold_Expr (Constant_Value (Def_Id)); -- A static type or subtype elsif Is_Type (Def_Id) then return Is_Foldable_Subtype (Def_Id); else return False; end if; end; -- An integer literal that was either in the source or created as -- a result of static evaluation. when N_Integer_Literal => return True; -- A string literal that was either in the source or created as a -- result of static evaluation or a character literal. when N_String_Literal | N_Character_Literal => return True; when N_Attribute_Reference => return Can_Fold_Attribute (N); when others => return False; end case; end Can_Fold_Expr; --------------- -- Fold_Expr -- --------------- procedure Fold_Expr (N : Node_Id) is Kind : Node_Kind; Lit : Entity_Id; Pos : Int; Val : Uint; begin Is_Static_Result := True; Kind := Nkind (N); if Kind = N_Identifier or else Kind = N_Expanded_Name or else Kind = N_Character_Literal then return; elsif Kind = N_Integer_Literal then Check_Int_Literal (N); return; -- Attempt to constant fold concatenation between combinations of -- string_literal, character_literals and static user defined -- constants. One pass (Can_Fold_Expr) determines whether the whole -- subtree can be folded and if so, the second pass (Fold_String) -- actually allocates an entry in the strings table and enters the -- new resulting string. No intermediate nodes are created. elsif Kind = N_Op_Concat then Start_String; Fold_String (N); Create_Str_Value_Node (N, End_String); elsif Is_Integer_Type (Etype (N)) then -- Substitute an N_Integer_Literal node for the result of the -- compile time evaluation of an operation on an integer literal or -- constant (i.e. results of arithmetic operators or attributes). Val := Fold_Uint (N); Set_Is_Static (N, Is_Static_Result); Rewrite_Int_Literal (N, Val); Check_Int_Literal (N); elsif Is_Enumeration_Type (Etype (N)) then -- Substitute an N_Identifier or N_Character_Literal node for -- the result of the compile time evaluation of an operation on -- an enumeration literal or constant (i.e. results of logical -- operators or attributes). -- In the case where the literal is of type Character, there needs -- to be some special handling since there is no explicit chain of -- literals to search. Instead, a N_Character_Literal node is -- created with the appropriate Char_Code and Chars fields. if Base_Type (Etype (N)) = Standard_Character then Pos := UI_To_Int (Fold_Uint (N)); Name_Buffer (1) := '''; Name_Buffer (2) := Char'Val (Pos); Name_Buffer (3) := '''; Name_Len := 3; Lit := New_Node (N_Character_Literal, Sloc (N)); Set_Chars (Lit, Name_Find); Set_Char_Literal_Value (Lit, Char_Code (Pos)); Set_Etype (Lit, Etype (N)); Set_Is_Evaluated (Lit, True); Set_Is_Static (Lit, Is_Static_Result); Rewrite_Substitute_Tree (N, Lit); else -- Interate through the literals list until the one in the -- desired position in the chain is found. Note that since -- this offset is relative to the original enumeration type -- start at the first literal of the base type. Pos := UI_To_Int (Fold_Uint (N)) - 1; Lit := First_Literal (Base_Type (Etype (N))); for I in 0 .. Pos loop Lit := Next_Literal (Lit); end loop; Set_Is_Static (N, Is_Static_Result); Rewrite_Enum_Literal (N, Lit); end if; end if; exception when Compile_Time_Constraint_Error => -- Handled when evaluation of an expression indicates a constraint -- violation (e.g. division by zero). A special N_Expression_Actions -- node is inserted which consists of a raise statement for -- Constraint_Error. A warning message has already been issued at -- the point of the expression which violated the constraint. Create_Raise_Expression (N, Standard_Entity (S_Constraint_Error)); end Fold_Expr; ----------------------- -- Check_Int_Literal -- ----------------------- procedure Check_Int_Literal (N : Node_Id) is Typ : constant Entity_Id := Etype (N); begin -- For now, only worry about signed types if Ekind (Typ) in Integer_Kind and then Typ /= Any_Type and then Typ /= Universal_Integer and then Nkind (Type_Low_Bound (Typ)) = N_Integer_Literal and then Nkind (Type_High_Bound (Typ)) = N_Integer_Literal then if UI_Lt (Intval (N), Intval (Type_Low_Bound (Typ))) or else UI_Gt (Intval (N), Intval (Type_High_Bound (Typ))) then Error_Msg_NE ("?literal out of range of type&", N, Typ); end if; end if; end Check_Int_Literal; -------------- -- Fold_Uint -- -------------- function Fold_Uint (N : Node_Id) return Uint is Def_Id : Entity_Id; Kind : Node_Kind; Left_Int : Uint; Right_Int : Uint; begin Kind := Nkind (N); if Kind in N_Binary_Op then Left_Int := Fold_Uint (Left_Opnd (N)); if Kind = N_Op_In then Def_Id := Entity (Right_Opnd (N)); return Test (UI_Le (Expr_Value (Type_Low_Bound (Def_Id)), Left_Int) and then UI_Ge (Expr_Value (Type_High_Bound (Def_Id)), Left_Int)); elsif Kind = N_Op_Not_In then Def_Id := Entity (Right_Opnd (N)); return Test (UI_Gt (Expr_Value (Type_Low_Bound (Def_Id)), Left_Int) or else UI_Lt (Expr_Value (Type_High_Bound (Def_Id)), Left_Int)); else Right_Int := Fold_Uint (Right_Opnd (N)); end if; elsif Kind in N_Unary_Op then Right_Int := Fold_Uint (Right_Opnd (N)); end if; case Kind is -- An integer literal that was either in the source or created as -- a result of static evaluation. An enumeration literal that was -- either in the source or created as a result of static evaluation. when N_Attribute_Reference => return Fold_Uint_Attribute (N); when N_Concat_Multiple => Compiler_Abort; when N_Identifier | N_Expanded_Name | N_Integer_Literal | N_Character_Literal => return Expr_Value (N); when N_Op_And => return Test (not (UI_Is_Zero (Left_Int) or else UI_Is_Zero (Right_Int))); when N_Op_And_Then => Is_Static_Result := False; Check_Preevaluate (N); return Test (not (UI_Is_Zero (Left_Int) or else UI_Is_Zero (Right_Int))); when N_Op_Or => return Test (not (UI_Is_Zero (Left_Int) and then UI_Is_Zero (Right_Int))); when N_Op_Or_Else => Is_Static_Result := False; Check_Preevaluate (N); return Test (not (UI_Is_Zero (Left_Int) and then UI_Is_Zero (Right_Int))); when N_Op_Xor => return Test (UI_Eq (Left_Int, Right_Int)); when N_Op_Eq => return Test (UI_Eq (Left_Int, Right_Int)); when N_Op_Ne => return Test (UI_Ne (Left_Int, Right_Int)); when N_Op_Lt => return Test (UI_Lt (Left_Int, Right_Int)); when N_Op_Le => return Test (UI_Le (Left_Int, Right_Int)); when N_Op_Gt => return Test (UI_Gt (Left_Int, Right_Int)); when N_Op_Ge => return Test (UI_Ge (Left_Int, Right_Int)); when N_Op_Add => return UI_Sum (Left_Int, Right_Int); when N_Op_Subtract => return UI_Difference (Left_Int, Right_Int); -- Concatenation is already handled separately by Fold_String -- so it would be an internal error if we reached this point. when N_Op_Concat => Compiler_Abort; when N_Op_Multiply => return UI_Product (Left_Int, Right_Int); when N_Op_Divide => -- The exception Constraint_Error is raised by integer division, -- rem and mod if the right operand is zero. if UI_Is_Zero (Right_Int) then Raise_Warning (N, Standard_Entity (S_Constraint_Error), "division by zero?!"); raise Compile_Time_Constraint_Error; else return UI_Quotient (Left_Int, Right_Int); end if; when N_Op_Mod => -- The exception Constraint_Error is raised by integer division, -- rem and mod if the right operand is zero. [LRM 4.5.4] if UI_Is_Zero (Right_Int) then Raise_Warning (N, Standard_Entity (S_Constraint_Error), "mod with zero right operand?!"); raise Compile_Time_Constraint_Error; else return UI_Mod (Left_Int, Right_Int); end if; when N_Op_Rem => -- The exception Constraint_Error is raised by integer division, -- rem and mod if the right operand is zero. [LRM 4.5.4] if UI_Is_Zero (Right_Int) then Raise_Warning (N, Standard_Entity (S_Constraint_Error), "rem with zero right operand?!"); raise Compile_Time_Constraint_Error; else return UI_Rem (Left_Int, Right_Int); end if; when N_Op_Expon => -- Exponentiation of an integer raises the exception -- Constraint_Error for a negative exponent. [LRM 4.5.6] if UI_Is_Negative (Right_Int) then Raise_Warning (N, Standard_Entity (S_Constraint_Error), "negative exponent for integer base?!"); raise Compile_Time_Constraint_Error; else return UI_Exponentiate (Left_Int, Right_Int); end if; when N_Op_Plus => -- The "+" can be ignored if it is used as a unary operator return Right_Int; when N_Op_Minus => return UI_Negate (Right_Int); when N_Op_Abs => return UI_Abs (Right_Int); when N_Op_Not => return Test (not UI_Is_Zero (Right_Int)); when N_Parenthesized_Expression => return Right_Int; when others => Compiler_Abort; end case; end Fold_Uint; ----------------- -- Fold_String -- ----------------- procedure Fold_String (N : Node_Id) is Operation : Node_Kind := Nkind (N); begin if Operation = N_Op_Concat then Fold_String (Left_Opnd (N)); Fold_String (Right_Opnd (N)); elsif Operation = N_String_Literal then for I in 1 .. String_Length (Strval (N)) loop Store_String_Char (Get_String_Char (Strval (N), I)); end loop; elsif Operation = N_Character_Literal then Store_String_Char (Char_Literal_Value (N)); -- User defined constants that are static appear here in the category -- of N_Entity_Name. Fold_String is only called if all the arguments -- of the concatenation are static. elsif Operation in N_Entity_Name then Store_String_Char (Char_Code (UI_To_Int (Expr_Value (N)))); else null; end if; end Fold_String; ------------------------ -- Can_Fold_Attribute -- ------------------------ function Can_Fold_Attribute (N : Node_Id) return Boolean is Id : Attribute_Id := Get_Attribute_Id (Chars (Identifier (N))); P : Node_Id := Prefix (N); E : Node_Id := Expression (N); Typ : Entity_Id; begin case Id is when Attribute_First | Attribute_Last | Attribute_Pos | Attribute_Pred | Attribute_Size | Attribute_Succ | Attribute_Val => null; when others => return False; end case; if Etype (P) = Any_Type or else (Present (E) and then Etype (E) = Any_Type) then return False; end if; if Nkind (P) in N_Entity_Name then Typ := Entity (P); -- The attribute 'BASE must be treated specially. elsif Nkind (P) = N_Attribute_Reference and then Attribute_Base = Get_Attribute_Id (Chars (Identifier (P))) then Typ := Etype (P); else return False; end if; if not Is_Type (Typ) or else not Is_Foldable_Subtype (Typ) then return False; elsif Present (E) and then not Can_Fold_Expr (E) then return False; else return True; end if; end Can_Fold_Attribute; ------------------------- -- Fold_Uint_Attribute -- ------------------------- function Fold_Uint_Attribute (N : Node_Id) return Uint is Id : Attribute_Id := Get_Attribute_Id (Chars (Identifier (N))); P : Node_Id := Prefix (N); E : Node_Id := Expression (N); Expr_Uint : Uint; Typ : Entity_Id; begin if Nkind (P) in N_Entity_Name then Typ := Entity (P); -- The attribute 'BASE must be treated specially. elsif (Nkind (P) = N_Attribute_Reference and then Attribute_Base = Get_Attribute_Id (Chars (Identifier (P)))) then Typ := Etype (P); end if; if Present (E) then Expr_Uint := Fold_Uint (E); end if; -- Remaining processing depends on particular attribute case Id is -- Processing for 'First attribute. For any scalar type T or for -- any subtype T of a scalar type, T'First yields the upper bound of -- T. The value of this attribute has the same type as T. [LRM 3.5] when Attribute_First => return Expr_Value (Type_Low_Bound (Typ)); -- Processing for 'Last attribute. For any scalar type T or for -- any subtype T of a scalar type, T'First yields the upper bound of -- T. The value of this attribute has the same type as T. [LRM 3.5] when Attribute_Last => return Expr_Value (Type_High_Bound (Typ)); -- Pos attribute. The result is the position number of the value -- of the parameter. [LRM 3.5.5] when Attribute_Pos => return Expr_Uint; -- For T'PRED (X) The parameter X must be a value of the base type -- of T. The result type is the base type of T. The result is the -- value whose position number is one less than that of X. The -- exception CONSTRAINT_ERROR is raised if X equals T'BASE'FIRST. when Attribute_Pred => if UI_Eq (Expr_Uint, Expr_Value (Type_Low_Bound (Base_Type (Typ)))) then Raise_Warning (N, Standard_Entity (S_Constraint_Error), "Pred of type'First?!"); raise Compile_Time_Constraint_Error; else return UI_Difference (Expr_Uint, Uint_1); end if; -- For T'SUCC (X) The parameter X must be a value of the base type -- of T. The result type is the base type of T. The result is the -- value whose position number is one greater than that of X. The -- exception CONSTRAINT_ERROR is raised if X equals T'BASE'LAST. when Attribute_Succ => if UI_Eq (Expr_Uint, Expr_Value (Type_High_Bound (Base_Type (Typ)))) then Raise_Warning (N, Standard_Entity (S_Constraint_Error), "Succ of type'Last?!"); raise Compile_Time_Constraint_Error; else return UI_Sum (Expr_Uint, Uint_1); end if; -- For T'VAL (X) This attribute is a special function with a single -- parameter which can be of any integer type. The result type is -- the base type of T. The result is the value whose position number -- is the universal_integer value corresponding to X. The exception -- CONSTRAINT_ERROR is raised if the universal_integer value -- corresponding to X is not in the range T'POS(T'BASE'FIRST) -- .. T'POS(T'BASE'LAST). when Attribute_Val => if UI_Lt (Expr_Uint, Expr_Value (Type_Low_Bound (Base_Type (Typ)))) or else UI_Gt (Expr_Uint, Expr_Value (Type_High_Bound (Base_Type (Typ)))) then Raise_Warning (N, Standard_Entity (S_Constraint_Error), "pos out of range?!"); raise Compile_Time_Constraint_Error; else return Expr_Uint; end if; -- Size attribute just returns the size (note that we could only -- be called for size applied to an appropriate type to yield -- a static type, see Can_Fold_Attribute function) when Attribute_Size => return Esize (Typ); -- Remaining attributes cannot be folded when Attribute_Access => null; when Attribute_Address => null; when Attribute_Adjacent => null; when Attribute_Aft => null; when Attribute_Alignment => null; when Attribute_Base => null; when Attribute_Bit_Order => null; when Attribute_Body_Version => null; when Attribute_Callable => null; when Attribute_Caller => null; when Attribute_Ceiling => null; when Attribute_Class => null; when Attribute_Component_Size => null; when Attribute_Compose => null; when Attribute_Constrained => null; when Attribute_Copy_Sign => null; when Attribute_Count => null; when Attribute_Delta => null; when Attribute_Denorm => null; when Attribute_Digits => null; when Attribute_Emax => null; when Attribute_Epsilon => null; when Attribute_Exponent => null; when Attribute_External_Tag => null; when Attribute_First_Bit => null; when Attribute_Floor => null; when Attribute_Fore => null; when Attribute_Fraction => null; when Attribute_Identity => null; when Attribute_Image => null; when Attribute_Input => null; when Attribute_Large => null; when Attribute_Last_Bit => null; when Attribute_Leading_Part => null; when Attribute_Length => null; when Attribute_Machine => null; when Attribute_Machine_Emax => null; when Attribute_Machine_Emin => null; when Attribute_Machine_Mantissa => null; when Attribute_Machine_Overflows => null; when Attribute_Machine_Radix => null; when Attribute_Machine_Rounds => null; when Attribute_Mantissa => null; when Attribute_Max => null; when Attribute_Max_Size_In_Storage_Elements => null; when Attribute_Min => null; when Attribute_Model => null; when Attribute_Model_Emax => null; when Attribute_Model_Emin => null; when Attribute_Model_Epsilon => null; when Attribute_Model_Large => null; when Attribute_Model_Mantissa => null; when Attribute_Model_Small => null; when Attribute_Output => null; when Attribute_Position => null; when Attribute_Range => null; when Attribute_Read => null; when Attribute_Remainder => null; when Attribute_Round => null; when Attribute_Rounding => null; when Attribute_Safe_Emax => null; when Attribute_Safe_First => null; when Attribute_Safe_Large => null; when Attribute_Safe_Last => null; when Attribute_Safe_Small => null; when Attribute_Scale => null; when Attribute_Signed_Zeros => null; when Attribute_Small => null; when Attribute_Standard_Access => null; when Attribute_Storage_Pool => null; when Attribute_Storage_Size => null; when Attribute_Tag => null; when Attribute_Terminated => null; when Attribute_Truncation => null; when Attribute_Unbiased_Rounding => null; when Attribute_Unchecked_Access => null; when Attribute_Valid => null; when Attribute_Value => null; when Attribute_Version => null; when Attribute_Wide_Image => null; when Attribute_Wide_Value => null; when Attribute_Width => null; when Attribute_Write => null; end case; end Fold_Uint_Attribute; --------------------------- -- Create_Str_Value_Node -- --------------------------- procedure Create_Str_Value_Node (N : Node_Id; Str_Id : String_Id) is Str_Literal_Node : Node_Id; Subtype_Id : Entity_Id; begin Str_Literal_Node := New_Node (N_String_Literal, Sloc (N)); Set_Strval (Str_Literal_Node, Str_Id); Set_Is_Evaluated (Str_Literal_Node, True); Set_Is_Static (Str_Literal_Node, False); -- Create a special subtype for the N_String_Literal node which -- becomes its Etype. Subtype_Id := New_Implicit_Type (Sloc (N), Scope_Id => Scope (Etype (N))); Set_Ekind (Subtype_Id, E_String_Literal_Subtype); Set_Etype (Subtype_Id, Etype (N)); Set_Component_Type (Subtype_Id, Component_Type (Etype (N))); Set_String_Literal_Length (Subtype_Id, UI_From_Int (String_Length (Str_Id))); Set_Etype (Str_Literal_Node, Subtype_Id); Rewrite_Substitute_Tree (N, Str_Literal_Node); end Create_Str_Value_Node; ----------------------- -- Check_Preevaluate -- ----------------------- procedure Check_Preevaluate (N : Node_Id) is begin if Pragma_Preelaborable_Enabled then Error_Msg_N ("Evaluation of this expression is not preevaluable", N); end if; end Check_Preevaluate; ---------- -- Test -- ---------- function Test (Cond : Boolean) return Uint is begin if Cond then return Uint_1; else return Uint_0; end if; end Test; ---------------- -- Expr_Value -- ---------------- function Expr_Value (N : Node_Id) return Uint is Def_Id : Entity_Id; Kind : Node_Kind; begin Kind := Nkind (N); if Kind = N_Identifier or else Kind = N_Expanded_Name then Def_Id := Entity (N); -- An enumeration literal that was either in the source or -- created as a result of static evaluation. if Ekind (Def_Id) = E_Enumeration_Literal then return Enumeration_Pos (Def_Id); -- A user defined static constant elsif Ekind (Def_Id) = E_Constant then return Expr_Value (Constant_Value (Def_Id)); end if; -- An integer literal that was either in the source or created as -- a result of static evaluation. elsif Kind = N_Integer_Literal then return Intval (N); elsif Kind = N_Character_Literal then -- Since Character literals of type Standard.Character don't -- have any defining character literals built for them, they -- do not have their Entity set, so just use their Char -- code. Otherwise for user-defined character literals use -- their Pos value as usual. if No (Entity (N)) then return UI_From_Int (Int (Char_Literal_Value (N))); else return Enumeration_Pos (Entity (N)); end if; else Compiler_Abort; end if; end Expr_Value; end Sem_Eval; => null; when Attribute_Address => null; when Attribute_Adjacent => null; when Attribute_Aft => null; when Attribute_Alignment => null; when Attribute_Base => null; when Attribute_Bit_Order gnat-1.67-src/src/sem_prag.ads 444 10015 7640 3754 5506244403 11412 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ P R A G -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Pragma handling is isolated in a separate package -- (logically this processing belongs in chapter 4) with Types; use Types; package Sem_Prag is procedure Analyze_Pragma (N : Node_Id); end Sem_Prag;  xtreeprs.spt.gnat-1.67-src/src/sem_prag.adb 444 10015 7640 137446 5506244404 11440 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ P R A G -- -- -- -- B o d y -- -- -- -- $Revision: 1.60 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This unit contains the semantic processing for all pragmas, both language -- and implementation defined. To add a new pragma, see packages Par.Prag, -- and Sem_Prag. A certain amount of syntax checking has been done in each -- case by the routines in Par.Prag. This procedure carries out the remaining -- semantic checks. with Atree; use Atree; with Einfo; use Einfo; with Errout; use Errout; with Nmake; use Nmake; with Opt; use Opt; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Ch8; use Sem_Ch8; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Stand; use Stand; with Sinfo; use Sinfo; with Snames; use Snames; with Tbuild; use Tbuild; package body Sem_Prag is -------------------- -- Analyze_Pragma -- -------------------- procedure Analyze_Pragma (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); function Arg1 return Node_Id; function Arg2 return Node_Id; function Arg3 return Node_Id; -- Obtain specified Pragma_Argument_Association procedure Error_Pragma (Msg : Str); -- Outputs error message for current pragma. The message contains an & -- that will be replaced with the pragma name, and the flag is placed -- on the pragma itself. procedure Error_Pragma_Argument (Msg : Str; Arg : Node_Id); -- Outputs error message for current pragma. The message contains an & -- that will be replaced with the pragma name, and the flag is placed -- on the pragma argument specified by the Arg operand. procedure Find_Program_Unit_Name (Id : Node_Id); -- If the pragma is a compilation unit pragma, the id must denote the -- compilation unit in the same compilation, and the pragma must appear -- in the list of preceding or trailing pragmas. If it is a program -- unit pragma that is not a compilation unit pragma, then the -- identifier must be visible. procedure Pragma_Misplaced; -- Issue fatal error message for misplaced pragma procedure Pragma_Not_Implemented; -- Issue warning message for unimplemented pragma function Valid_Unit_Pragma (Is_Library_Unit : Boolean := True) return Boolean; -- Common legality checks for program and library unit pragmas. Nargs : Int; -- Number of pragma argument associations -------------- -- Arg1,2,3 -- -------------- function Arg1 return Node_Id is begin return First (Pragma_Argument_Associations (N)); end Arg1; function Arg2 return Node_Id is begin return Next (Arg1); end Arg2; function Arg3 return Node_Id is begin return Next (Arg2); end Arg3; ------------------ -- Error_Pragma -- ------------------ procedure Error_Pragma (Msg : Str) is begin Error_Msg_Node_1 := Identifier (N); Error_Msg (Msg, Loc); end Error_Pragma; --------------------------- -- Error_Pragma_Argument -- --------------------------- procedure Error_Pragma_Argument (Msg : Str; Arg : Node_Id) is begin Error_Msg_Node_1 := Identifier (N); Error_Msg (Msg, Sloc (Arg)); end Error_Pragma_Argument; ---------------------------- -- Find_Program_Unit_Name -- ---------------------------- procedure Find_Program_Unit_Name (Id : Node_Id) is Unit_Name : Entity_Id; Unit_Kind : Node_Kind; P : constant Node_Id := Parent (N); begin if Nkind (P) = N_Compilation_Unit then Unit_Kind := Nkind (Unit (P)); if Unit_Kind = N_Subprogram_Declaration or else Unit_Kind = N_Package_Declaration or else Unit_Kind in N_Generic_Declaration then Unit_Name := Defining_Unit_Simple_Name (Specification (Unit (P))); if Chars (Id) = Chars (Unit_Name) then Set_Entity (Id, Unit_Name); Set_Etype (Id, Etype (Unit_Name)); else Error_Pragma ("cannot find program unit referenced by pragma&"); Set_Etype (Id, Any_Type); end if; else Error_Pragma ("pragma& inapplicable to this unit"); Set_Etype (Id, Any_Type); end if; else Find_Name (Id); end if; end Find_Program_Unit_Name; ---------------------- -- Pragma_Misplaced -- ---------------------- procedure Pragma_Misplaced is begin Error_Pragma ("incorrect placement of pragma&"); end Pragma_Misplaced; ---------------------------- -- Pragma_Not_Implemented -- ---------------------------- procedure Pragma_Not_Implemented is begin Error_Pragma ("pragma& not implemented?"); end Pragma_Not_Implemented; ----------------------- -- Valid_Unit_Pragma -- ----------------------- function Valid_Unit_Pragma (Is_Library_Unit : Boolean := True) return Boolean is Decl : Node_Id; Plist : List_Id; Parent_Node : Node_Id; Unit_Name : Entity_Id; Valid : Boolean := True; begin if not Is_List_Member (N) then Pragma_Misplaced; Valid := False; else Plist := List_Containing (N); Parent_Node := List_Parent (Plist); if Parent_Node = Empty then Pragma_Misplaced; Valid := False; elsif Nkind (Parent_Node) = N_Compilation_Unit then -- Pragma must appear after a compilation_unit, and must have -- an argument with the right name. if Plist /= Following_Pragmas (Parent_Node) then Pragma_Misplaced; Valid := False; elsif Nargs > 0 then if not Same_Name (Expression (Arg1), Defining_Unit_Name (Specification (Unit (Parent_Node)))) then Error_Pragma_Argument ("pragma& argument is not current unit name", Arg1); Valid := False; end if; else Error_Msg_N ("missing argument in unit pragma", N); Valid := False; end if; elsif N = First (Plist) then -- Name is optional, pragma applies to enclosing unit. if Nargs > 0 then Find_Name (Expression (Arg1)); if Entity (Expression (Arg1)) /= Current_Scope then Error_Msg_N ("argument of unit pragma must be enclosing unit", N); Valid := False; end if; end if; -- This is always illegal for library unit pragmas, because the -- name, if any, will denote a local unit. elsif Is_Library_Unit then Error_Msg_N ("invalid context for library unit pragma", N); -- If not first in declarative part, name is required. elsif Nargs > 0 then Find_Name (Expression (Arg1)); Unit_Name := Entity (Expression (Arg1)); if Scope (Unit_Name) /= Current_Scope then Error_Msg_N ("argument of pragma must be in current scope", Arg1); Valid := False; else Decl := Get_Declaration_Node (Unit_Name); if Nkind (Decl) /= N_Package_Declaration and then Nkind (Decl) not in N_Generic_Instantiation and then Nkind (Decl) /= N_Generic_Subprogram_Declaration and then Nkind (Decl) /= N_Subprogram_Declaration then Error_Msg_N ("invalid name in unit pragma", N); Valid := False; end if; end if; else Error_Msg_N ("missing argument in unit pragma", N); Valid := False; end if; end if; return Valid; end Valid_Unit_Pragma; -------------------------------------------- -- Start of processing for Analyze_Pragma -- -------------------------------------------- begin -- Count number of arguments declare Arg_Node : Node_Id; begin Nargs := 0; if List_Present (Pragma_Argument_Associations (N)) then Arg_Node := Arg1; while Arg_Node /= Empty loop Nargs := Nargs + 1; Arg_Node := Next (Arg_Node); end loop; end if; end; -- An enumeration type defines the pragmas that are supported by the -- implementation. Get_Pragma_Id (in package Prag) transorms a name -- into the corresponding enumeration value for the following case. case Get_Pragma_Id (Chars (Identifier (N))) is ----------------- -- Abort_Defer -- ----------------- when Pragma_Abort_Defer => Abort_Defer : begin -- The only required semantic processing is to check the -- placement. This pragma must appear at the start of the -- statement sequence of a handled sequence of statements. if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements or else N /= First (Statements (Parent (N))) then Pragma_Misplaced; end if; end Abort_Defer; ------------ -- Ada_83 -- ------------ when Pragma_Ada_83 => Ada_83 := True; Ada_9X := False; ------------ -- Ada_9X -- ------------ when Pragma_Ada_9X => Ada_83 := False; Ada_9X := True; ---------------------- -- All_Calls_Remote -- ---------------------- when Pragma_All_Calls_Remote => Pragma_Not_Implemented; ------------ -- Assert -- ------------ when Pragma_Assert => Assert : begin -- If we are not in debug mode then rewrite the pragma with -- a null statement and do not even analyze the pragma. if not Assertions_Enabled then Rewrite_Substitute_Tree (N, Make_Null_Statement (Loc)); -- If we are in debug mode, then rewrite the pragma with its -- corresponding if statement, and then analyze the statement -- The expansion transforms: -- pragma Assert (condition [,procedure_call]); -- into -- if not condition then -- [procedure_call;] -- raise System.Assertions.Assert_Failure; -- end if; else declare Stmts : List_Id; begin if Nargs = 2 then Stmts := New_List_1 (New_Copy (Debug_Statement (N))); else Stmts := New_List; end if; Append_To (Stmts, Make_Raise_Statement (Loc, Name => New_Reference_To (RTE (RE_Assert_Failure), Loc))); Rewrite_Substitute_Tree (N, Make_If_Statement (Loc, Condition => Make_Op_Not (Loc, Right_Opnd => Expression (Arg1)), Then_Statements => Stmts)); Analyze (N); end; end if; end Assert; ------------------ -- Asynchronous -- ------------------ when Pragma_Asynchronous => Pragma_Not_Implemented; ------------ -- Atomic -- ------------ when Pragma_Atomic => Pragma_Not_Implemented; ----------------------- -- Atomic_Components -- ----------------------- when Pragma_Atomic_Components => Pragma_Not_Implemented; -------------------- -- Attach_Handler -- -------------------- when Pragma_Attach_Handler => Pragma_Not_Implemented; ---------------- -- Controlled -- ---------------- when Pragma_Controlled => Pragma_Not_Implemented; ---------------- -- Convention -- ---------------- when Pragma_Convention => Convention : begin declare Id : Node_Id; Proc_Def_Id : Entity_Id; begin if Chars ( Expression (Arg1)) = Name_Intrinsic then Id := Expression (Arg2); Find_Program_Unit_Name (Id); -- Remaining processing is needed only if we found the name. if Etype (Id) /= Any_Type then Proc_Def_Id := Entity (Id); if Ekind (Proc_Def_Id) /= E_Procedure and then Ekind (Proc_Def_Id) /= E_Function and then Ekind (Proc_Def_Id) /= E_Generic_Procedure and then Ekind (Proc_Def_Id) /= E_Generic_Function then Error_Pragma_Argument ("second argument of pragma& must be a subprogram", Id); elsif Scope (Proc_Def_Id) /= Current_Scope then Error_Pragma_Argument ("pragma& must be in same declarative part", Id); else while Present (Proc_Def_Id) and then Scope (Proc_Def_Id) = Current_Scope loop Set_Is_Intrinsic (Proc_Def_Id); Proc_Def_Id := Homonym (Proc_Def_Id); end loop; end if; end if; else Pragma_Not_Implemented; end if; end; end Convention; ----------- -- Debug -- ----------- when Pragma_Debug => Debug : begin -- If we are not in debug mode then rewrite the pragma with -- a null statement and do not even analyze the pragma. if not Assertions_Enabled then Rewrite_Substitute_Tree (N, Make_Null_Statement (Loc)); -- If we are in debug mode, then rewrite the pragma with its -- corresponding procedure call, and then analyze the call. else Rewrite_Substitute_Tree (N, New_Copy (Debug_Statement (N))); Analyze (N); Resolve_Complete_Context (N, Standard_Void_Type); end if; end Debug; --------------- -- Elaborate -- --------------- when Pragma_Elaborate => Elaborate : begin declare Plist : List_Id; Parent_Node : Node_Id; Arg : Node_Id; Temp_Node : Node_Id; begin -- Pragma must be in context items list of a compilation unit if not Is_List_Member (N) then Pragma_Misplaced; return; else Plist := List_Containing (N); Parent_Node := List_Parent (Plist); if Parent_Node = Empty or else Nkind (Parent_Node) /= N_Compilation_Unit or else Context_Items (Parent_Node) /= Plist then Pragma_Misplaced; return; end if; end if; -- There can be no items following it on the list except -- other pragmas (it cannot appear before a with or use clause) Temp_Node := Next (N); while Present (Temp_Node) loop if Nkind (Temp_Node) /= N_Pragma then Pragma_Misplaced; return; end if; Temp_Node := Next (Temp_Node); end loop; -- Finally, the arguments must all be units mentioned in a with -- clause in the same context clause. Note we already checked -- (in Par.Prag) that the arguments are either identifiers or Arg := Arg1; Outer : while Present (Arg) loop Temp_Node := First (Plist); Inner : while Temp_Node /= N loop if Nkind (Temp_Node) = N_With_Clause and then Same_Name (Name (Temp_Node), Expression (Arg)) then Set_Elaborate_Present (Temp_Node, True); exit Inner; end if; Temp_Node := Next (Temp_Node); end loop Inner; if Temp_Node = N then Error_Pragma_Argument ("Argument of pragma& is not with'ed unit", Arg); end if; Arg := Next (Arg); end loop Outer; end; end Elaborate; ------------------- -- Elaborate_All -- ------------------- when Pragma_Elaborate_All => Elaborate_All : begin declare Plist : List_Id; Parent_Node : Node_Id; Arg : Node_Id; Temp_Node : Node_Id; begin -- Pragma must be in context items list of a compilation unit if not Is_List_Member (N) then Pragma_Misplaced; return; else Plist := List_Containing (N); Parent_Node := List_Parent (Plist); if Parent_Node = Empty or else Nkind (Parent_Node) /= N_Compilation_Unit or else Context_Items (Parent_Node) /= Plist then Pragma_Misplaced; return; end if; end if; -- Note: unlike pragma Elaborate, pragma Elaborate_All does not -- have to appear at the end of the context clause, but may -- appear mixed in with other items. -- Final check: the arguments must all be units mentioned in -- a with clause in the same context clause. Note that we -- already checked (in Par.Prag) that all the arguments are -- either identifiers or selected components. Arg := Arg1; Outr : while Present (Arg) loop Temp_Node := First (Plist); Innr : while Temp_Node /= N loop if Nkind (Temp_Node) = N_With_Clause and then Same_Name (Name (Temp_Node), Expression (Arg)) then Set_Elaborate_All_Present (Temp_Node, True); exit Innr; end if; Temp_Node := Next (Temp_Node); end loop Innr; if Temp_Node = N then Error_Pragma_Argument ("Argument of pragma& is not with'ed unit", Arg); end if; Arg := Next (Arg); end loop Outr; end; end Elaborate_All; -------------------- -- Elaborate_Body -- -------------------- when Pragma_Elaborate_Body => Elaborate_Body : begin declare Plist : List_Id; Cunit_Node : Node_Id; begin if Valid_Unit_Pragma then Plist := List_Containing (N); Cunit_Node := List_Parent (Plist); -- Case of pragma appearing in declarative part. Only -- legal if it is in a package specification. if Nkind (Cunit_Node) /= N_Compilation_Unit then if Nkind (Cunit_Node) = N_Package_Specification then Cunit_Node := Parent (Parent (Cunit_Node)); else Pragma_Misplaced; return; end if; end if; Set_Elaborate_Body_Present (Cunit_Node, True); Set_Body_Required (Cunit_Node, True); end if; end; end Elaborate_Body; ------------ -- Export -- ------------ when Pragma_Export => Pragma_Not_Implemented; ------------ -- Import -- ------------ -- The parser has verified that the first argument is a valid -- language convention name, and for the moment, the only such -- defined name is Convention_C, so we just assume that we are -- talking about C. All that needs to be done it to set a flag in -- the defining occurence of the subprogram to indicate that it is -- interfaced (and thus needs no body). when Pragma_Import => Import : begin declare Id : Node_Id; Proc_Def_Id : Entity_Id; begin Id := Expression (Arg2); Find_Program_Unit_Name (Id); -- Remaining processing is needed only if we found the name if Etype (Id) /= Any_Type then Proc_Def_Id := Entity (Id); if not Is_Subprogram (Proc_Def_Id) then Error_Pragma_Argument ("second argument of pragma& must be a subprogram", Id); else -- If name is overloaded, pragma applies to all the -- denoted entities in the same declarative part. -- Ignore inherited subprograms, because the pragma will -- apply to the parent operation which is the one called. while Present (Proc_Def_Id) loop if Present (Alias (Proc_Def_Id)) then null; elsif Parent (Get_Declaration_Node (Proc_Def_Id)) /= Parent (N) then exit; else Set_Is_Imported (Proc_Def_Id); -- If convention intrinsic, set instrinsic flag if Chars (Expression (Arg1)) = Name_Intrinsic then Set_Is_Intrinsic (Proc_Def_Id); end if; -- All interfaced procedures need an external -- symbol created for them since they are -- always referenced from another object file. Set_Is_Public (Proc_Def_Id); Set_Has_Completion (Proc_Def_Id); if Nargs = 3 then Set_Interface_Name (Proc_Def_Id, Expression (Arg3)); end if; end if; Proc_Def_Id := Homonym (Proc_Def_Id); end loop; end if; end if; end; end Import; ------------- -- Improve -- ------------- -- We don't do anything with this pragma, except to make sure it -- is of the right form (this is for nice Alsys compatibility). -- Maybe we should later at least check that the second argument is -- a record type name. when Pragma_Improve => null; ------------ -- Inline -- ------------ when Pragma_Inline => Inline : begin declare Assoc : Node_Id := Arg1; Decl : Node_Id; Subp_Id : Node_Id; Subp : Entity_Id; procedure Make_Inline (Subp : Entity_Id); -- Subp is the defining unit name of the subprogram -- declaration. Set the flag, as well as the flag in the -- corresponding boy, if there is one present. procedure Make_Inline (Subp : Entity_Id) is Kind : Entity_Kind := Ekind (Subp); begin if Etype (Subp) = Any_Type then return; elsif Present (Scope (Subp)) and then Scope (Subp) /= Current_Scope then Pragma_Misplaced; return; end if; if Kind = E_Procedure or else Kind = E_Function then Set_Is_Inlined (Subp, True); Decl := Parent (Parent (Subp)); if Nkind (Decl) = N_Subprogram_Declaration and then Present (Corresponding_Body (Decl)) then Set_Is_Inlined (Corresponding_Body (Decl), True); end if; elsif Kind = E_Generic_Procedure or else Kind = E_Generic_Function then Set_Is_Inlined (Subp, True); Decl := Parent (Parent (Parent (Subp))); if Present (Corresponding_Body (Decl)) then Set_Is_Inlined (Corresponding_Body (Decl), True); end if; else Error_Pragma ("expect subprogram name for pragma&"); end if; end Make_Inline; begin while Present (Assoc) loop Subp_Id := Expression (Assoc); Find_Name (Subp_Id); Subp := Entity (Subp_Id); if Subp = Any_Id then null; else Make_Inline (Subp); while Present (Homonym (Subp)) and then Scope (Homonym (Subp)) = Current_Scope loop Make_Inline (Homonym (Subp)); Subp := Homonym (Subp); end loop; end if; Assoc := Next (Assoc); end loop; end; end Inline; ---------------------- -- Inspection_Point -- ---------------------- when Pragma_Inspection_Point => Pragma_Not_Implemented; --------------- -- Interface -- --------------- -- The parser has verified that the first argument is a valid -- language convention name, and for the moment, the only such -- defined name is Convention_C, so we just assume that we are -- talking about C. All that needs to be done it to set a flag in -- the defining occurence of the subprogram to indicate that it is -- interfaced (and thus needs no body). when Pragma_Interface => Interface : begin declare Id : Node_Id; Proc_Def_Id : Entity_Id; begin Id := Expression (Arg2); Find_Program_Unit_Name (Id); -- Remaining processing is needed only if we found the name if Etype (Id) /= Any_Type then Proc_Def_Id := Entity (Id); if not Is_Subprogram (Proc_Def_Id) then Error_Pragma_Argument ("second argument of pragma& must be a subprogram", Id); else while Present (Proc_Def_Id) loop if Present (Alias (Proc_Def_Id)) then null; elsif Parent (Get_Declaration_Node (Proc_Def_Id)) /= Parent (N) then exit; else Set_Is_Imported (Proc_Def_Id); Set_Is_Public (Proc_Def_Id); Set_Has_Completion (Proc_Def_Id); end if; Proc_Def_Id := Homonym (Proc_Def_Id); end loop; end if; end if; end; end Interface; -------------------- -- Interface_Name -- -------------------- when Pragma_Interface_Name => Interface_Name : begin declare Id : constant Node_Id := Expression (Arg1); Link_Name : constant Node_Id := Expression (Arg2); Proc_Def_Id : Entity_Id; begin Find_Name (Id); -- Remaining processing is needed only if we found the name. -- Check that name represents a subprogram for which a pragma -- Interface has been given. Then associate the defining -- identifier with the N_String_Literal (the external name) -- given in the pragma. if Etype (Id) /= Any_Type then Proc_Def_Id := Entity (Id); if not Is_Subprogram (Proc_Def_Id) then Error_Pragma_Argument ("argument of pragma& is not subprogram", Id); elsif not Is_Imported (Proc_Def_Id) then Error_Pragma_Argument ("argument of pragma& is not imported subprogram", Id); else Set_Interface_Name (Proc_Def_Id, Link_Name); end if; end if; end; end Interface_Name; ----------------------- -- Interrupt_Handler -- ----------------------- when Pragma_Interrupt_Handler => Pragma_Not_Implemented; ------------------------ -- Interrupt_Priority -- ------------------------ when Pragma_Interrupt_Priority => Interrupt_Priority : begin declare P : constant Node_Id := Parent (N); begin if Nargs /= 0 then Analyze (Expression (Arg1)); Resolve_Complete_Context (Expression (Arg1), RTE (RE_Priority)); end if; if Nkind (P) /= N_Task_Definition and then Nkind (P) /= N_Protected_Definition then Pragma_Misplaced; return; elsif Has_Priority_Pragma (P) then Error_Pragma ("duplicate pragma& not allowed"); else Set_Has_Priority_Pragma (P, True); end if; end; end Interrupt_Priority; ---------- -- List -- ---------- -- There is nothing to do here, since we did all the processing -- for this pragma in Par.Prag (so that it works properly even in -- syntax only mode) when Pragma_List => null; -------------------- -- Locking_Policy -- -------------------- when Pragma_Locking_Policy => Pragma_Not_Implemented; ----------------- -- Memory_Size -- ----------------- when Pragma_Memory_Size => Pragma_Not_Implemented; ----------------------- -- Normalize_Scalars -- ----------------------- when Pragma_Normalize_Scalars => Pragma_Not_Implemented; -------------- -- Optimize -- -------------- -- Nothing to do, since all checks done in Par.Prag and we don't -- actually pay any attention to this pragma (does anyone?) when Pragma_Optimize => null; ---------- -- Pack -- ---------- when Pragma_Pack => Pack : begin declare Assoc : Node_Id := Arg1; Type_Id : Node_Id := Expression (Assoc); Typ : Entity_Id; begin Find_Type (Type_Id); Typ := Entity (Type_Id); if Typ = Any_Type then return; elsif not Is_Composite_Type (Typ) then Error_Pragma ("pragma& does not specify composite type"); elsif Scope (Typ) /= Current_Scope then Error_Pragma ("pragma& does not specify type in same declarative part"); else if Is_Array_Type (Typ) then Error_Pragma ("?pragma& not implemented yet for array types"); end if; Set_Is_Packed (Typ); end if; end; end Pack; ---------- -- Page -- ---------- -- There is nothing to do here, since we did all the processing -- for this pragma in Par.Prag (so that it works properly even in -- syntax only mode) when Pragma_Page => null; ------------------ -- Preelaborate -- ------------------ when Pragma_Preelaborate => Preelaborate : begin if Valid_Unit_Pragma then Pragma_Not_Implemented; end if; end Preelaborate; -------------- -- Priority -- -------------- when Pragma_Priority => Priority : begin declare P : constant Node_Id := Parent (N); begin Analyze (Expression (Arg1)); Resolve_Complete_Context (Expression (Arg1), RTE (RE_Any_Priority)); if Nkind (P) /= N_Task_Definition and then Nkind (P) /= N_Protected_Definition and then Nkind (P) /= N_Subprogram_Body then Pragma_Misplaced; return; else if Nkind (P) = N_Subprogram_Body and then not Is_Static_Expression (Expression (Arg1)) then Error_Pragma ("static expression required " & "for pragma& in subprogram body"); end if; if Has_Priority_Pragma (P) then Error_Pragma ("duplicate pragma& not allowed"); else Set_Has_Priority_Pragma (P, True); end if; end if; end; end Priority; ---------- -- Pure -- ---------- when Pragma_Pure => Pure : begin if Valid_Unit_Pragma then Pragma_Not_Implemented; end if; end Pure; -------------------- -- Queuing_Policy -- -------------------- when Pragma_Queuing_Policy => Pragma_Not_Implemented; --------------------------- -- Remote_Call_Interface -- --------------------------- when Pragma_Remote_Call_Interface => Pragma_Not_Implemented; ------------------ -- Remote_Types -- ------------------ when Pragma_Remote_Types => Pragma_Not_Implemented; ------------------ -- Restrictions -- ------------------ when Pragma_Restrictions => Pragma_Not_Implemented; ---------------- -- Reviewable -- ---------------- when Pragma_Reviewable => Pragma_Not_Implemented; ------------ -- Shared -- ------------ when Pragma_Shared => Pragma_Not_Implemented; -------------------- -- Shared_Passive -- -------------------- when Pragma_Shared_Passive => Pragma_Not_Implemented; ------------------ -- Storage_Unit -- ------------------ -- Nothing to do here, since this pragma was completely -- handled in Par when Pragma_Storage_Unit => null; -------------- -- Suppress -- -------------- when Pragma_Suppress => Suppress : begin declare C : constant Check_Id := Get_Check_Id (Chars (Expression (Arg1))); begin if Nargs = 1 then case C is when Access_Check => Scope_Suppress.Access_Checks := True; when Accessibility_Check => Scope_Suppress.Accessibility_Checks := True; when Discriminant_Check => Scope_Suppress.Discriminant_Checks := True; when Division_Check => Scope_Suppress.Division_Checks := True; when Elaboration_Check => Scope_Suppress.Elaboration_Checks := True; when Index_Check => Scope_Suppress.Index_Checks := True; when Length_Check => Scope_Suppress.Length_Checks := True; when Overflow_Check => Scope_Suppress.Overflow_Checks := True; when Range_Check => Scope_Suppress.Range_Checks := True; when Storage_Check => Scope_Suppress.Storage_Checks := True; when Tag_Check => Scope_Suppress.Tag_Checks := True; when All_Checks => Scope_Suppress := (others => True); end case; -- Case of two arguments present, where the check is -- suppressed for a specified entity (given as the second -- argument of the pragma) else declare E_Id : Node_Id; E : Entity_Id; Effective : Boolean; procedure Suppress_Echeck (E : Entity_Id; C : Check_Id); -- Used to suppress a single check on the given entity procedure Suppress_Echeck (E : Entity_Id; C : Check_Id) is begin -- First set appropriate suppress flags in the entity case C is when Access_Check => Effective := Suppress_Access_Checks (E); Set_Suppress_Access_Checks (E, True); when Accessibility_Check => Effective := Suppress_Accessibility_Checks (E); Set_Suppress_Accessibility_Checks (E, True); when Discriminant_Check => Effective := Suppress_Discriminant_Checks (E); Set_Suppress_Discriminant_Checks (E, True); when Division_Check => Effective := Suppress_Division_Checks (E); Set_Suppress_Division_Checks (E, True); when Elaboration_Check => Effective := Suppress_Elaboration_Checks (E); Set_Suppress_Elaboration_Checks (E, True); when Index_Check => Effective := Suppress_Index_Checks (E); Set_Suppress_Index_Checks (E, True); when Length_Check => Effective := Suppress_Length_Checks (E); Set_Suppress_Length_Checks (E, True); when Overflow_Check => Effective := Suppress_Overflow_Checks (E); Set_Suppress_Overflow_Checks (E, True); when Range_Check => Effective := Suppress_Range_Checks (E); Set_Suppress_Range_Checks (E, True); when Storage_Check => Effective := Suppress_Storage_Checks (E); Set_Suppress_Storage_Checks (E, True); when Tag_Check => Effective := Suppress_Tag_Checks (E); Set_Suppress_Tag_Checks (E, True); when All_Checks => Suppress_Echeck (E, Access_Check); Suppress_Echeck (E, Accessibility_Check); Suppress_Echeck (E, Discriminant_Check); Suppress_Echeck (E, Division_Check); Suppress_Echeck (E, Elaboration_Check); Suppress_Echeck (E, Index_Check); Suppress_Echeck (E, Length_Check); Suppress_Echeck (E, Overflow_Check); Suppress_Echeck (E, Range_Check); Suppress_Echeck (E, Storage_Check); Suppress_Echeck (E, Tag_Check); end case; -- If the entity is not declared in the current -- scope, then we make an entry in the -- Entity_Suppress table so that the flag will be -- removed on exit. This entry is only made if the -- suppress did something (i.e. the flag was not -- already set). if Effective and then Scope (E) /= Current_Scope then Entity_Suppress.Increment_Last; Entity_Suppress.Table (Entity_Suppress.Last).Entity := E; Entity_Suppress.Table (Entity_Suppress.Last).Check := C; end if; end Suppress_Echeck; -- Start of processing for two argument pragma Suppress case begin E_Id := Expression (Arg2); Find_Name (E_Id); E := Entity (E_Id); if E = Any_Id then return; else Suppress_Echeck (E, C); while Present (Homonym (E)) loop E := Homonym (E); Suppress_Echeck (E, C); end loop; end if; end; end if; end; end Suppress; ----------------- -- System_Name -- ----------------- -- Nothing to do here, since this pragma was completely -- handled in Par when Pragma_System_Name => null; ----------------------------- -- Task_Dispatching_Policy -- ----------------------------- when Pragma_Task_Dispatching_Policy => Pragma_Not_Implemented; --------------------- -- Task_Stack_Size -- --------------------- when Pragma_Task_Stack_Size => Task_Stack_Size : begin declare P : constant Node_Id := Parent (N); begin Analyze (Expression (Arg1)); Resolve_Complete_Context (Expression (Arg1), RTE (RE_Size_Type)); if Nkind (P) /= N_Task_Definition then Pragma_Misplaced; return; else if Has_Task_Stack_Size_Pragma (P) then Error_Pragma ("duplicate pragma& not allowed"); else Set_Has_Task_Stack_Size_Pragma (P, True); end if; end if; end; end Task_Stack_Size; -------------- -- Volatile -- -------------- when Pragma_Volatile => Pragma_Not_Implemented; ------------------------- -- Volatile_Components -- ------------------------- when Pragma_Volatile_Components => Pragma_Not_Implemented; end case; end Analyze_Pragma; end Sem_Prag; se C is when Access_Check => Scope_Suppress.Access_Checks := True; when Accessibility_Check => Scope_Suppress.Accessibility_Chegnat-1.67-src/src/sem_util.ads 444 10015 7640 30102 5506244405 11443 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ U T I L -- -- -- -- S p e c -- -- -- -- $Revision: 1.20 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Package containing utility procedures used throughout the semantics with Einfo; use Einfo; with Types; use Types; package Sem_Util is function Access_Checks_Suppressed (E : Entity_Id) return Boolean; function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean; function Discriminant_Checks_Suppressed (E : Entity_Id) return Boolean; function Division_Checks_Suppressed (E : Entity_Id) return Boolean; function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean; function Index_Checks_Suppressed (E : Entity_Id) return Boolean; function Length_Checks_Suppressed (E : Entity_Id) return Boolean; function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean; function Range_Checks_Suppressed (E : Entity_Id) return Boolean; function Storage_Checks_Suppressed (E : Entity_Id) return Boolean; function Tag_Checks_Suppressed (E : Entity_Id) return Boolean; -- These functions check to see if the named check is suppressed, -- either by an active scope suppress setting, or because the check -- has been specifically suppressed for the given entity. If no entity -- is relevant for the current check, then Empty is used as an argument. -- Note: the reason we insist on specifying Empty is to force the -- caller to think about whether there is any relevant entity that -- should be checked. pragma Inline (Access_Checks_Suppressed); pragma Inline (Accessibility_Checks_Suppressed); pragma Inline (Discriminant_Checks_Suppressed); pragma Inline (Division_Checks_Suppressed); pragma Inline (Elaboration_Checks_Suppressed); pragma Inline (Index_Checks_Suppressed); pragma Inline (Length_Checks_Suppressed); pragma Inline (Overflow_Checks_Suppressed); pragma Inline (Range_Checks_Suppressed); pragma Inline (Storage_Checks_Suppressed); pragma Inline (Tag_Checks_Suppressed); procedure Apply_Access_Check (N : Node_Id; Typ : Entity_Id); -- Determines whether an expression node should be flagged as needing -- a runtime access check. If the node requires such a check, the -- Do_Access_Check flag is turned on. procedure Apply_Discriminant_Check (N : Node_Id; Typ : Entity_Id); -- Determines whether an expression node should be flagged as needing -- a runtime discriminant check. If the node requires such a check, -- the Do_Discriminant_Check flag is turned on. procedure Apply_Range_Check (N : Node_Id; Target_Type : Entity_Id); -- Determines whether an expression node should be flagged as needing -- a runtime range check. If the node requires such a check, the -- Do_Range_Check flag is turned on. function Current_Entity (N : Node_Id) return Entity_Id; pragma Inline (Current_Entity); -- Find the currently visible definition for a given identifier function Current_Scope return Entity_Id; -- Get entity representing current scope function Defining_Unit_Simple_Name (N : Node_Id) return Entity_Id; -- N is the declaration of a program unit (compilation or otherwise). -- If the unit is a child unit, return the final defining identifier; -- Otherwise, the program unit name itself. procedure Enter_Name (Def_Id : Node_Id); -- Insert new name in symbol table of current scope with check for -- duplications (error message is issued if a conflict is found) procedure Get_Index_Bounds (I : Node_Id; L, H : out Node_Id); -- This procedure assigns to L and H respectively the values of the -- low and high bounds of node I, which must be a range, subtype -- indication, or the name of a scalar subtype. function Get_Declaration_Node (Unit_Id : Entity_Id) return Node_Id; -- Unit_Id is the simple name of a unit, this function returns the -- corresponding _Declaration node for the entity, or the subprogram -- body node for it. -- The unit may be a child unit with any number of ancestors. function Has_Private_Component (Type_Id : Entity_Id) return Boolean; -- Check if a type has a (sub)component of a private type that has not -- yet received a full declaration. function Has_Tagged_Component (Typ : Entity_Id) return Boolean; -- Typ must be a composite type (array or record). This function is used -- to check if '=' has to be expanded into a bunch component comparaisons. function In_Subrange_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean; -- Checks whether the range of values for type T1 is always in the range -- given for type T2. function Is_Name (N : Node_Id) return Boolean; pragma Inline (Is_Name); -- Test if the node kind of N is either N_Identifier or N_Expanded_Name, -- i.e. the name of an entity that has a defined unique name. function New_External_Entity (Kind : Entity_Kind; Scope_Id : Entity_Id; Sloc_Value : Source_Ptr; Related_Id : Entity_Id; Suffix : Str; Index : Nat := 0; Prefix : Str := "") return Entity_Id; -- New_Internal_Id creates an N_Defining_Identifier node for an internal -- created entity, such as an implicit type or subtype, or a record -- initialization procedure. The entity name is constructed with a call -- to New_External_Name (Related_Id, Suffix, Index, Prefix), so that -- the generated name may be referenced as a public entry. function New_Implicit_Type (Sloc_Value : Source_Ptr; Related_Id : Entity_Id := Empty; Suffix : Str := ""; Index : Nat := 0; Scope_Id : Entity_Id := Current_Scope) return Entity_Id; -- This is used in cases where there is a new underlying type or subtype -- introduced implicitly. Examples include: -- a. the implicit unconstrained array type type introduced by a -- constrained array type declaration. -- b. the implicit subtype introduced by a subtype indication given as -- "Integer range 1 .. 2". -- For each implicit type or subtype that is created we also create -- an N_Implicit_Type node which is inserted in the declaration list -- to reflect the present of the created type. The only information -- it contains is a pointer to the created entity for the type. -- (which is in the Defining_Identifier field). This list is collected -- for all such implicit entities generated for a given declaration -- and is inserted before the declaration in Analyze_Declarations. -- Related_Id is present only if the implicit type name may be referenced -- as a public symbol, and thus needs a unique external name. The name -- has the form: -- "ityp__" & Related_Id_Name & "___" & Suffix & Postfix'Image. -- where Postfix'Image is present only if Postfix is non-zero, i.e. the -- name is created by a call to: -- New_External_Name (Chars (Related_Id), Suffix, Index, "ityp) -- If the implicit type does not need an external name, the last -- three parameters are omitted. In this case, the created name of -- the implicit type has the form: -- "ityp__" & a_serial_number -- i.e. the name is created by a call to New_Internal_Name ("ityp") -- Note that in all cases, the name starts with "ityp__". This is used -- to identify implicit types in the error message handling circuits. function New_Internal_Entity (Kind : Entity_Kind; Scope_Id : Entity_Id; Sloc_Value : Source_Ptr; Id_Str : Str) return Entity_Id; -- New_Internal_Entity is similar to New_External_Entity, except that -- the name is constructed by New_Internal_Name (Id_Str). This is used -- when the resulting entity does not have to be referenced as a -- public entity. function Normalize_Actuals (N : Node_Id; S : Entity_Id; Report : Boolean) return Boolean; -- Reorders lists of actuals according to names of formals, returned -- value indicates sucess of reordering. For more details, see body. -- Errors are reported only if Report is set to True. procedure Rewrite_Named_Number (N : Node_Id; Typ : Entity_Id); -- Replace an identifier or expanded name that is a named number by -- an appropriate literal node representing its value, and emit a -- constraint check if needed. The appropriate tree Rewrite procedures -- are used so that the original reference to the named number is -- preserved for debugging purposes, etc. function Same_Name (N1, N2 : Node_Id) return Boolean; -- Determine if two (possibly expanded) names are the same name procedure Set_Current_Entity (E : Entity_Id); pragma Inline (Set_Current_Entity); -- Establish the entity E as the currently visible definition of its -- associated name (i.e. the Node_Id associated with its name) procedure Set_Entity_With_Style_Check (N : Node_Id; Val : Node_Id); -- This procedure has the same calling sequence as Set_Entity, -- but it performs the additional check if Gnat_Style_Check is on -- that if the defining entity and reference are both user declared -- identifiers, then the spelling (capitalization) must match. procedure Set_Public_Status (Id : Entity_Id); -- If an entity (visible or otherwise) is defined in a library -- package, or a package that is itself public, then this subprogram -- labels the entity public as well. function Static_Integer (N : Node_Id) return Uint; -- This function analyzes the given expression node and then resolves it -- as any integer type. If the result is static, then the value of the -- universal expression is returned, otherwise an error message is output -- and a value of No_Uint is returned. procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : Str); -- Print debugging information on entry to each unit being analyzed. procedure Unimplemented (N : Node_Id; Feature : Str); -- An indication that here and there we are not finished yet. Prints out -- a message on the given node indicating that the feature described by -- the given string is not implemented yet. end Sem_Util; e definition for a given identifier function Current_Scope return Entity_Id; -- Get entity representing current scope function Defining_Unit_Simple_Name (N : Node_Id) return Entity_Id; -- N is the declaration of a program unit (compilation or otherwise). -- If the unit is a child unit, return the final defining identifier; -- Otherwise, the program unit name itself. procedure Enter_Name (Def_Id : Node_Id); -- Ignat-1.67-src/src/sem_res.adb 444 10015 7640 407374 5506244410 11275 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ R E S -- -- -- -- B o d y -- -- -- -- $Revision: 1.67 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Comperr; use Comperr; with Debug; use Debug; with Debug_Sem; use Debug_Sem; with Einfo; use Einfo; with Errout; use Errout; with Expand; with Nmake; use Nmake; with Opt; use Opt; with Output; use Output; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Attr; use Sem_Attr; with Sem_Ch3; use Sem_Ch3; with Sem_Ch4; use Sem_Ch4; with Sem_Ch5; use Sem_Ch5; with Sem_Disp; use Sem_Disp; with Sem_Eval; use Sem_Eval; with Sem_Util; use Sem_Util; with Sem_Type; use Sem_Type; with Sinput; use Sinput; with Stand; use Stand; with Sinfo; use Sinfo; with Snames; use Snames; with Stringt; use Stringt; with Tbuild; use Tbuild; with Uintp; use Uintp; package body Sem_Res is ----------------------- -- Local Subprograms -- ----------------------- -- Second pass (top-down) type checking and overload resolution procedures -- Typ is the type required by context. These procedures propagate the -- type information recursively to the descendants of N. If the node -- is not overloaded, its Etype is established in the first pass. If -- overloaded, the Resolve routines set the correct type. For arith. -- operators, the Etype is the base type of the context. -- Note that Resolve_Attribute is separated off in Sem_Attr procedure Resolve_Aggregate (N : Node_Id; Typ : Entity_Id); procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id); procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id); procedure Resolve_Array_Aggregate (N : Node_Id; Typ : Entity_Id); procedure Resolve_Call (N : Node_Id; Typ : Entity_Id); procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id); procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id); procedure Resolve_Conversion (N : Node_Id; Typ : Entity_Id); procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id); procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id); procedure Resolve_Extension_Aggregate (N : Node_Id; Typ : Entity_Id); procedure Resolve_Expression_Actions (N : Node_Id; Typ : Entity_Id); procedure Resolve_Identifier (N : Node_Id; Typ : Entity_Id); procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id); procedure Resolve_Integer_Literal (N : Node_Id; Typ : Entity_Id); procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id); procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id); procedure Resolve_Null (N : Node_Id; Typ : Entity_Id); procedure Resolve_Operator_Symbol (N : Node_Id; Typ : Entity_Id); procedure Resolve_Op_Concat (N : Node_Id; Typ : Entity_Id); procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id); procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id); procedure Resolve_Parenthesized_Expression (N : Node_Id; Typ : Entity_Id); procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id); procedure Resolve_Range (N : Node_Id; Typ : Entity_Id); procedure Resolve_Record_Aggregate (N : Node_Id; Typ : Entity_Id); procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id); procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id); procedure Resolve_Selected_Component (N : Node_Id; Typ : Entity_Id); procedure Resolve_Slice (N : Node_Id; Typ : Entity_Id); procedure Resolve_Short_Circuit (N : Node_Id; Typ : Entity_Id); procedure Resolve_String_Literal (N : Node_Id; Typ : Entity_Id); procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id); procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id); -- If an operator node resolves to a call to a user-defined operator, -- rewrite the node as a function call. procedure Make_Call_Into_Operator (N : Node_Id); -- Inverse transformation: if an operator is given in functional notation, -- then after resolving the node, transform into an operator node, so -- that operands are resolved properly. Recall that predefined operators -- do not have a full signature and special resolution rules apply. function Valid_Conversion (N : Node_Id) return Boolean; -- Verify legality rules given in 4.6 (8-23) ------------------------------ -- Resolve_Complete_Context -- ------------------------------ procedure Resolve_Complete_Context (N : Node_Id; Typ : Entity_Id) is begin Resolve_Subexpr (N, Typ); -- Note: we used to reset the overload data structures at this point -- with a call to Init_Interp, but that's wrong, because in the case -- of expression actions, it is possible for complete contexts to be -- properly nested in a recursive sense, and destroying the overloading -- structures after completing analysis of the inner complete context -- would sabotage overload resolution for the outer context. Now we -- clear the data structures between statement and declaration -- boundaries (in the case of declarations, being careful to do it -- only if we are not processing expression actions). -- Now we do static evaluation on the result Static_Evaluation (N); end Resolve_Complete_Context; --------------------- -- Resolve_Subexpr -- --------------------- procedure Resolve_Subexpr (N : Node_Id; Typ : Entity_Id) is I : Interp_Index; It : Interp; Found : Boolean := False; Nam : Node_Id; Seen : Entity_Id; Ctx_Type : Entity_Id := Typ; Expr_Type : Entity_Id; begin pragma Debug (Debug_A_Entry ("resolving ", N)); -- Return if already analyzed if Analyzed (N) then pragma Debug (Debug_A_Exit ("resolving ", N, " (done, already analyzed)")); return; -- Return if type = Any_Type (previous error encountered) elsif Etype (N) = Any_Type then pragma Debug (Debug_A_Exit ("resolving ", N, " (done, Etype = Any_Type)")); return; end if; -- First deal with a parameterless function call, where the node must -- be rebuilt to be a function call (just looked like a name till now) if Is_Name (N) and then Is_Overloadable (Entity (N)) and then (Ekind (Entity (N)) /= E_Enumeration_Literal or else Is_Overloaded (N)) then Nam := New_Copy (N); -- If overloaded, overload set belongs to new copy. if Is_Overloaded (N) then for Index in 0 .. Interp_Map.Last loop if Interp_Map.Table (Index).Node = N then Interp_Map.Table (Index).Node := Nam; exit; end if; end loop; end if; -- Change node to parameterless function call (note that the -- Parameter_Associations associations field is left set to Empty, -- its normal default value since there are no parameters) Change_Node (N, N_Function_Call); Set_Name (N, Nam); Set_Sloc (N, Sloc (Nam)); Analyze_Call (N); end if; -- If not overloaded, then we know the type, and all that needs doing -- is to check that this type is compatible with the context. if not Is_Overloaded (N) then Found := Covers (Typ, Etype (N)); Expr_Type := Etype (N); -- In the overloaded case, we must select the interpretation that -- is compatible with the context (i.e. the type passed to Resolve) else Get_First_Interp (N, I, It); while Present (It.Typ) loop if Covers (Typ, It.Typ) then if Found then -- Could be a tag-indeterminate call which resolves -- statically to the operation on the root of the class. -- Keep the interpretation that is closest to the root type. if Is_Dispatching_Operation (It.Nam) and then Root_Type (Find_Dispatching_Type (It.Nam)) = Root_Type (Find_Dispatching_Type (Seen)) then declare T1 : Entity_Id := Find_Dispatching_Type (It.Nam); T2 : Entity_Id := Find_Dispatching_Type (Seen); R : Entity_Id := Root_Type (T1); begin while T1 /= R and then T2 /= R loop T1 := Etype (T1); T2 := Etype (T2); end loop; if T1 = R then Seen := It.Nam; end if; end; else -- More than one interpretation. Use preference -- rules, and check operator visibility and hiding. Error_Msg_Sloc_1 := Sloc (Seen); Seen := Disambiguate (It.Nam, Seen, Typ); if Seen = Any_Id then Error_Msg_Sloc_2 := Sloc (It.Nam); Error_Msg_N ( " ambiguity: homographs declared at lines #, and #", N); exit; end if; end if; else -- This is the first interpretation. Found := True; Seen := It.Nam; Expr_Type := It.Typ; end if; if Nkind (N) not in N_Op and then Nkind (N) /= N_Explicit_Dereference and then Nkind (N) /= N_Attribute_Reference then Set_Etype (Name (N), Expr_Type); -- If procedure or function, set entity pointer for prefix if Nkind (N) = N_Procedure_Call_Statement or else Nkind (N) = N_Function_Call then Set_Entity (Name (N), Seen); end if; elsif Nkind (N) in N_Op then -- For operators, set only the name. Each resolve routine -- sets the type. Set_Entity (N, Seen); else -- Dereferences, indexed expressions, selected components -- or attributes with overloaded prefixes. null; end if; end if; Get_Next_Interp (I, It); end loop; end if; -- At this stage Found indicates whether or not an acceptable -- interpretation exists. If not, then we have an error, except -- that if the context is Any_Type as a result of some other error, -- then we suppress the error report. if not Found then if Typ /= Any_Type then -- If type we are looking for is Void, then this is the -- procedure call case, and the error is simply that what -- we gave is not a procedure name (we think of procedure -- calls as expressions with types internally, but the user -- doesn't think of them this way! if Typ = Standard_Void_Type then Error_Msg_N ("expect procedure name in procedure call", N); -- Otherwise we do have a subexpression with the wrong type else -- Check for the case of an allocator which uses an access -- type instead of the designated type. This is a common -- error and we would like a nice error message if Nkind (N) = N_Allocator and then Ekind (Typ) in Access_Kind and then Ekind (Etype (N)) in Access_Kind and then Designated_Type (Etype (N)) = Typ then -- This is the special case, and we post the error on -- the operand of the allocator, complaining that we -- expected the designated type of the allocator Error_Msg_Node_2 := Etype (Expression (N)); Error_Msg_NE ("type& expected, found&", Expression (N), Designated_Type (Typ)); -- Case of Class-wide types elsif Is_Class_Type (Typ) then Error_Msg_NE ("expression not in `&''Class`", N, Etype (Typ)); -- Normal case of looking for Typ, found Etype (N) else Error_Msg_Node_2 := Etype (N); Error_Msg_NE ("type& expected, found&", N, Typ); end if; end if; end if; -- Make believe it was right, to avoid cascaded errors. Set_Etype (N, Typ); pragma Debug (Debug_A_Exit ("resolving ", N, " (done, resolution failed)")); Set_Analyzed (N, True); return; -- Here we have an acceptable interpretation for the context else -- A user-defined operator is tranformed into a function call -- at this point, so that further processing knows that operators -- are really operators (i.e. are predefined operators) if Nkind (N) in N_Op and then Present (Entity (N)) and then Ekind (Entity (N)) /= E_Operator then Rewrite_Operator_As_Call (N, Entity (N)); end if; -- Propagate type information and normalize tree for various -- predefined operations. If the context only imposes a class of -- types, rather than a specific type, propagate the actual type -- downward. if Typ = Any_Integer or else Typ = Any_Boolean then Ctx_Type := Expr_Type; end if; case N_Subexpr'(Nkind (N)) is when N_Aggregate => Resolve_Aggregate (N, Ctx_Type); when N_Allocator => Resolve_Allocator (N, Ctx_Type); when N_Attribute_Reference => Resolve_Attribute (N, Ctx_Type); when N_Character_Literal => Resolve_Character_Literal (N, Ctx_Type); when N_Concat_Multiple => Compiler_Error; when N_Extension_Aggregate => Resolve_Extension_Aggregate (N, Ctx_Type); when N_Explicit_Dereference => Resolve_Explicit_Dereference (N, Ctx_Type); when N_Expression_Actions => Resolve_Expression_Actions (N, Ctx_Type); when N_Function_Call | N_Procedure_Call_Statement => Resolve_Call (N, Ctx_Type); when N_Identifier | N_Expanded_Name => Resolve_Identifier (N, Ctx_Type); when N_Indexed_Component => Resolve_Indexed_Component (N, Ctx_Type); when N_Integer_Literal => Resolve_Integer_Literal (N, Ctx_Type); when N_Null => Resolve_Null (N, Ctx_Type); when N_Op_And_Then | N_Op_Or_Else => Resolve_Short_Circuit (N, Ctx_Type); when N_Op_And | N_Op_Or | N_Op_Xor => Resolve_Logical_Op (N, Ctx_Type); when N_Op_In | N_Op_Not_In => Resolve_Membership_Op (N, Ctx_Type); when N_Op_Eq | N_Op_Ne => Resolve_Equality_Op (N, Ctx_Type); when N_Op_Lt | N_Op_Le | N_Op_Gt | N_Op_Ge => Resolve_Comparison_Op (N, Ctx_Type); when N_Op_Not => Resolve_Op_Not (N, Ctx_Type); when N_Op_Add | N_Op_Subtract | N_Op_Multiply | N_Op_Divide | N_Op_Mod | N_Op_Rem => Resolve_Arithmetic_Op (N, Ctx_Type); when N_Op_Concat => Resolve_Op_Concat (N, Ctx_Type); when N_Op_Expon => Resolve_Op_Expon (N, Ctx_Type); when N_Op_Plus | N_Op_Minus | N_Op_Abs => Resolve_Unary_Op (N, Ctx_Type); when N_Operator_Symbol => Resolve_Operator_Symbol (N, Ctx_Type); when N_Parenthesized_Expression => Resolve_Parenthesized_Expression (N, Ctx_Type); when N_Qualified_Expression => Resolve_Qualified_Expression (N, Ctx_Type); when N_Range => Resolve_Range (N, Ctx_Type); when N_Real_Literal => Resolve_Real_Literal (N, Ctx_Type); when N_Reference => Resolve_Reference (N, Ctx_Type); when N_Selected_Component => Resolve_Selected_Component (N, Ctx_Type); when N_Slice => Resolve_Slice (N, Ctx_Type); when N_String_Literal => Resolve_String_Literal (N, Ctx_Type); when N_Type_Conversion => Resolve_Conversion (N, Ctx_Type); end case; -- Now that the resolution of the type of the node is complete, -- and we did not detect an error, we can expand this node and -- mark the analysis of the node as completed. pragma Debug (Debug_A_Exit ("resolving ", N, " (done)")); Expand (N); Set_Analyzed (N, True); end if; end Resolve_Subexpr; ----------------------- -- Resolve_Aggregate -- ----------------------- procedure Resolve_Aggregate (N : Node_Id; Typ : Entity_Id) is begin if Is_Array_Type (Typ) then Resolve_Array_Aggregate (N, Typ); elsif Is_Record_Type (Typ) then -- If Typ is a derived type, we look for the Root_Type of Typ because -- the tree of the record, with all the components and specially -- the ones in variant cases, is not copied and linked to Typ. if Is_Derived_Type (Typ) then Resolve_Record_Aggregate (N, Root_Type (Typ)); else Resolve_Record_Aggregate (N, Typ); end if; else Error_Msg_N ("illegal context for aggregate", N); end if; -- If the node N_Aggregate has been rewritten and replaced by an -- Expression_Actions node then we do not want to override the Etype -- of this node. So, only when the original N_Aggregate node has been -- rewritten with another N_Aggregate node, we set the Etype to be Typ. if Nkind (N) = N_Aggregate then Set_Etype (N, Typ); end if; end Resolve_Aggregate; ----------------------- -- Resolve_Allocator -- ----------------------- procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id) is E : constant Node_Id := Expression (N); begin -- Replace general access with specific type if Ekind (Etype (N)) = E_Allocator_Type then Set_Etype (N, Typ); end if; if Is_Abstract (Typ) then Error_Msg_N ("type of allocator cannot be abstract", N); end if; -- For qualified expression, resolve the expression using the -- given subtype (nothing to do for type mark, subtype indication) if Nkind (E) = N_Qualified_Expression then Resolve_Subexpr (Expression (E), Entity (Subtype_Mark (E))); end if; end Resolve_Allocator; --------------------------- -- Resolve_Arithmetic_Op -- --------------------------- -- Used for resolving all arithmetic operators except exponentiation procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id) is L : Node_Id := Left_Opnd (N); R : Node_Id := Right_Opnd (N); T : Entity_Id; B_Typ : constant Entity_Id := Base_Type (Typ); -- We do the resolution using the base type, because intermediate values -- in expressions always are of the base type, not a subtype of it. begin Resolve_Subexpr (L, B_Typ); Resolve_Subexpr (R, B_Typ); -- If one of the arguments was resolved to a non-universal type. -- label the result of the operation itself with the same type. T := Intersect_Types (L, R); Set_Etype (N, Base_Type (T)); end Resolve_Arithmetic_Op; ----------------------------- -- Resolve_Array_Aggregate -- ----------------------------- -- This procedure is the top-level procedure of the resolution -- of array aggregates. -- First, it calls the procedure Resolve_Multi_Array_Aggregate which does -- the semantic analysis on the aggregate. Some flags are modified by this -- procedure to determine which algorithm for the expansion of the -- aggregate will be called. There are two algorithms : -- The first one represented by the function Rewrite_Array_Aggregate is -- called only in very special cases : the array type should be constrained -- the indices of the array should be static, in the case of a named -- aggregate the choices should be all static and when there is an Others -- statements the number of values which are represented by Others should -- be less then a threshold fixed to 1024 values. -- The original tree of the aggregate is replaced by an other aggregate -- which contains only positional associations : -- (1, 2, 3, 4, 5) => (1, 2, 3, 4, 5); -- (1, 2, 3, others => 4) => (1, 2, 3, 4, 4); -- (2 .. 3 | 5 => 1, 1 | 4 => 2) => (2, 1, 1, 2, 1); -- (2 .. 3 | 5 => 1, others => 2) => (2, 1, 1, 2, 1); -- The second algorithm used in all other cases builds an expression -- actions node containing the declaration of a temporary array whose type -- is the type of the aggregate and containing the necessary loops or/and -- assignments to fill the temporary with the values specified in the -- aggregate. The expression of the node expression actions is the -- temporary filled previously. The declaration of the temporary is not -- necessary in all cases but it's simpler to create one each time. -- the original node is replaced by this expression actions node : -- (M .. N => Val) => { -- Tmp : Array_Type; -- for I in M .. N loop -- Tmp (I) := Val; -- end loop; -- -- Tmp;} -- This algorithm is used specially when the bound of the indices of the -- array are dynamic or when the array is an unconstrained array. -- When the semantic analysis has been able to determine that a run time -- Constraint Error will be raised then the aggregate is modified by : -- in the first algorithm, we build a node expression actions containing -- raise constraint_error for its actions and a correct aggregate (needed -- by the back end) whose values are arbitrary (in fact the first -- expression of the original aggregate is choosen) fills the expression -- field. -- (1, 2, 4, 5) => { raise Constraint_Error; -- (1, 1, 1, 1, 1);} -- in the second algorithm, we build a node expression actions containing -- a declaration of a temporary and the statememt raise constraint error -- for its actions and the temporary for its expression. -- (1 .. 2 => 1, 3 .. 6 => 2) => { -- Tmp : Array_Type; -- raise Constraint_Error; -- -- Tmp;} -- The expansion of the aggregate is called only if we are in a code -- generating phase. procedure Resolve_Array_Aggregate (N : Node_Id; Typ : Entity_Id) is Sloc_N : Source_Ptr := Sloc (N); Actions_List : List_Id := New_List; New_Aggr : Node_Id := New_Node (N_Aggregate, Sloc_N); Expr_Actions : Node_Id; Action : Node_Id; Tmp : Node_Id; Index : Entity_Id; Max_Val : Uint := UI_From_Int (1024); Error_Found : Boolean := False; Full_Others : Boolean := False; Static_Choices : Boolean := True; Raise_C : Boolean := False; Static_Indices : Boolean := True; Others_In_Threshold : Boolean := True; procedure Resolve_Multi_Array_Aggregate (N : Node_Id; Typ, Ind : Entity_Id); -- This procedure does the semantic checking on the aggregate. -- First, the procedure deals with a named aggregate and specially if -- there is an Others statement, then with a positional aggregate. -- At the end, some run time checks are done to warn the user that -- a Constraint Error will be raised at the execution. -- This procedure is recursive in the case of multi-dimensional -- aggregates. -- The N node always represents a node N_Aggregate, the Typ entity -- represents the type of the entire aggregate and the Ind entity -- represents the index correspoonding to the aggregate or subaggregate -- passed in the parameter N. function Rewrite_Array_Aggregate (N : Node_Id; Typ, Ind : Entity_Id) return Node_Id; -- This procedure builds a new node N_Aggregate which contains only -- positional components. -- This procedure is called only if the indices of the array type are -- static and if all the choices, in the case of a named aggregate, -- are static and in the case of an aggregate with an Others statement -- if the number of values covered by Others is less than the threshold. -- The tree transformation is the following : -- type Ary is array (1..6) of integer; -- for a positional aggregate : -- A : Ary := (1, 2, 3, 4, others => 5); -- => A : Ary := (1, 2, 3, 4, 5, 5); -- for a named aggregate : -- A : Ary := (2..3 | 6 => 1, 4 => 4, Others => 0); -- => A : Ary := (0, 1, 1, 0, 4, 0, 1); -- If a constraint Error has been detected during the semantic -- analysis, then the aggregate created is a positional aggregate -- whose values are the value given to the first association of -- the examined aggregate. -- This procedure is called recursively in the case of a -- multi-dimentional aggregate so that each subaggregate becomes -- a positonal subaggregate. -- This procedure is called in Resolve_Array_Aggregate after the -- semantic analysis of the aggregate. -- The N node is always a node N_Aggregate which represents the -- aggregate or subaggregate to be transformed. The Typ entity -- represents the type of the aggregate. The Ind entity represents -- the index corresponding to the aggregate or subaggregate. -- The node_Id returned is a node N_Aggregate corresponding to the -- transformation of the aggregate or subaggregate. function Build_Loop (N : Node_Id; Ind : Entity_Id; L : List_Id) return List_Id; -- This procedure builds a list which contains the loops and assignments -- that are needed for the expansion of the aggregate. It's part -- of the second algorithm of expansion of the aggregate. -- First, we look if there's an Others statement in the aggregate which -- is represented by the node N. If it's the case, we build the code -- corresponding to : -- for I in Index_Low_Bound .. Index_High_Bound loop -- If we deal with a multi dimensional aggregate, we call recursively -- Build_Loop on the expression represented by Others. Else, we build -- the code corresponding to the assignment of the expression : -- Tmp (List_Of_Indices, L) := Expression; -- Then, we deal with the other named associations if they exist : -- if the choice of the named association is a range choice then we -- build a loop corresponding to the code : -- for I in Choice_Low_Bound .. Choice_High_Bound loop -- If the aggregate is multi dimensional we call recursively Build_Loop -- else we create the code correponding to the assignment : -- Tmp (List_Of_Indices_Known, I) := Choice_Expression; -- If the choice is a simple choice : if the aggregate is a multi -- dimensionla aggregtae we call recursively Build_loop else we create -- the code corresponding to the assignment : -- Tmp (List_Of_Indices_Know, Choice) := Choice_Expression; -- If the aggregate contains positional associations instead of named -- associations, we need to generate two sort of code considering the -- case of the index Ind corresponding to the aggregate N is an -- enumeration type or not. It this is the case, the code created is: -- X : Index := Index'First; -- For each positional association, an assignement is created and the -- value of X is updated to the next enumeration type in the range -- Index'first .. Index'last. The code created is: -- X := X'succ; -- Tmp (List_Of_Indices_Known, X) := Positional; -- If the index is not an enumeration type then the code is simpler: -- Tmp (List_Of_Indices_Known, Index'First+Position) := Positional; -- where Position represents the position (- 1) of the positional -- association in the aggregate (the position of the first positional -- is zero). the value of Index'first + Position is computed when -- analyze is called on this subtree. -- The N node correspond to ther aggregate or subaggregate that needs -- to be expanded, Ind corresponds to the index in the array of this -- subaggregate and L corresponds to the list of known identifiers -- at this level of the aggregate : this is necessary for the case -- of created nested loops to create the correct list of indices in -- the built assignments. In the description given here, it corresponds -- to List_Of_Indices_Known for the code created. function Fill_Index (N : Node_Id; Ind : Entity_Id) return List_Id; -- This function is used only in case of an unconstrained array type -- for the aggregate. In this precise case we need to create a temporary -- whose type is the correct constrained type : So the purpose of this -- function is to create the code necessary to constrained the array by -- generating the range needed for each index knowing the number of -- associations existing in the aggregate. We remind the reader that in -- this precise case there is no Others statement possible. -- First we deal with trhe case of named associations by looking for -- the low and high bound of the choices existing in the aggregate and -- we generate the code that will be added to the list of indices of -- the array type of the temporary: -- Choice_Low_Bound .. Choice_High_Bound -- In the case where the choices are not static then we are sure that -- there's only one association so we just copy its bounds. -- For positional associations the bounds are compute by taking -- Index'first and calculating the numebr of associations. The code -- created is: -- Index_Low_Bound .. Index_Low_Bound + Nb_positional - 1 -- If the type of the indexx is an enumeration type the code created -- is different : we need to know which enumeration literal will be -- the high bound so we create the code: -- Index_Low_Bound .. -- Enum'Val (Enum'Pos (Index_Low_Bound) + Nb_Positional - 1) -- The N node represents the aggregate examined and Ind the index -- corresponding to this N aggregate. -- This function is recursive for multi dimensional aggregate. procedure Resolve_Multi_Array_Aggregate (N : Node_Id; Typ, Ind : Entity_Id) is Posit_List : constant List_Id := Expressions (N); Assoc_List : constant List_Id := Component_Associations (N); Posit : Node_Id; Assoc : Node_Id; Choice : Node_Id; Lb_Ch : Node_Id; Hb_Ch : Node_Id; Ind_Lo : Entity_Id; Ind_Hi : Entity_Id; Nb_Posit : Uint := Uint_0; Nb_Values_Choices : Uint := Uint_0; Ind_Lo_Val : Uint; Ind_Hi_Val : Uint; Agg_Lo_Val : Uint; Agg_Hi_Val : Uint; Static_Index : Boolean := False; Others_Passed : Boolean := False; Others_Only : Boolean := True; Others_Alone : Boolean := True; Nb_Choices : Nat := 0; -- Variable indicating the number of choices in the component -- associations in the current aggregate or sub-aggregate. -- Used to instanciate a table in Get_Choices_Bounds. procedure Complete_Component (N : Node_Id; Typ, Ind : Entity_Id); -- The N node represents a N_Aggregate node or a node corresponding -- to the value given of the array component. The Typ entity is -- the type of the aggregate and the Ind entity is the index -- corresponding to the N subaggregate. Ind is Empty when the N node -- represents a value given to a component of the array. -- First, Call Analyze on the N node. -- If Ind is not empty, we still deal with the same -- multi-dimensional aggregate, so we call recursively the -- procedure Resolve_Multi_Array_Aggregate. -- Else, we have reached the component and we call -- Resolve_Complete_Context. procedure Get_Choices_Bounds (A : List_Id; L, H : out Uint); -- This procedure examines the A list of component associations -- of the aggregate being examined. -- The different choices of the association are stored in a table -- with the value corresponding to the low and high bound of the -- choice (this value are the same when that's not a range). -- Then, this table is sorted. We examine the resulting table -- looking for missing or duplicated choices. -- The nodes L and H are set respectively to the low and high -- bound of the values represented in the choices od the aggregate. -- This procedure is part of the processing of the analysis which -- looks for constraint errors at run time. This procedure is -- called only if the component associations does not have an Others -- choice and all the choices are static. procedure Complete_Component (N : Node_Id; Typ, Ind : Entity_Id) is begin Analyze (N); if Present (Ind) then if Nkind (N) /= N_Aggregate then Error_Msg_N ("invalid expression for component" & "of multidimensional aggregate", N); Error_Found := True; else Resolve_Multi_Array_Aggregate (N, Typ, Ind); end if; else Resolve_Complete_Context (N, Component_Type (Typ)); end if; end Complete_Component; procedure Get_Choices_Bounds (A : List_Id; L, H : out Uint) is Assoc : Node_Id := First (A); Choice : Node_Id; Table : Case_Table_Type (1 .. Nb_Choices); I : Nat := 1; begin while Present (Assoc) loop Choice := First (Choices (Assoc)); while Present (Choice) and then I <= Nb_Choices loop if Nkind (Choice) = N_Range then Table (I).Choice_Lo := Low_Bound (Choice); Table (I).Choice_Hi := High_Bound (Choice); else Table (I).Choice_Lo := Choice; Table (I).Choice_Hi := Choice; end if; Table (I).Choice_Node := Expression (Assoc); Choice := Next (Choice); I := I + 1; end loop; Assoc := Next (Assoc); end loop; Sort_Case_Table (Table); for I in Table'First .. Table'Last - 1 loop if UI_Ge (Expr_Value (Table (I).Choice_Hi), Expr_Value (Table (I + 1).Choice_Lo)) then Error_Msg_N ("a choice is not allowed to be specified" & " more than once", Table (I).Choice_Hi); Error_Found := True; elsif UI_Gt (UI_Difference ( Expr_Value (Table (I + 1).Choice_Lo), Expr_Value (Table (I).Choice_Hi)), Uint_1) then Error_Msg_N ("missing association in the aggregate", N); Error_Found := True; end if; exit when Error_Found; end loop; L := Expr_Value (Table (Table'First).Choice_Lo); H := Expr_Value (Table (Table'Last).Choice_Hi); end Get_Choices_Bounds; -- Start of processing for Resolve_Multi_Array_Aggregate begin -- Look for the low and the high bound of the index and -- if they are static, store these values. Get_Index_Bounds (Ind, Ind_Lo, Ind_Hi); if Is_Static_Expression (Ind_Lo) and then Is_Static_Expression (Ind_Hi) then Static_Index := True; Ind_Lo_Val := Expr_Value (Ind_Lo); Ind_Hi_Val := Expr_Value (Ind_Hi); else Static_Indices := False; end if; -- Named choices in component associations if List_Present (Assoc_List) then Assoc := First (Assoc_List); BCL : while Present (Assoc) loop if Others_Passed then Error_Msg_N ("OTHERS must be the last aggregate component", Assoc); Error_Found := True; exit BCL; end if; Choice := First (Choices (Assoc)); Others_Alone := True; while Present (Choice) loop Analyze (Choice); -- Others statement if Nkind (Choice) = N_Others_Choice then if not Others_Alone then Error_Msg_N ("OTHERS must appear as a single choice", Choice); Error_Found := True; exit BCL; elsif not Is_Constrained (Typ) then Error_Msg_N ("OTHERS choice is not allowed in this context", Choice); Error_Found := True; exit BCL; elsif Ada_83 and then not Static_Index and then (not Others_Only or else Present (Posit)) then Error_Msg_N ("OTHERS choice is not allowed in this" & " context (4.3.2 Ada 83)", Choice); Error_Found := True; exit BCL; else Others_Passed := True; end if; else -- Range choice in component association -- Look for the bounds, call resolve and look if they -- are static, compute the number of values covered -- by the range for the check of the number of values -- covered by others if Nkind (Choice) = N_Range then Lb_Ch := Low_Bound (Choice); Hb_Ch := High_Bound (Choice); Resolve_Subexpr (Lb_Ch, Etype (Ind)); Resolve_Subexpr (Hb_Ch, Etype (Ind)); if Is_Static_Expression (Lb_Ch) and then Is_Static_Expression (Hb_Ch) then if UI_Gt (Expr_Value (Lb_Ch), Expr_Value (Hb_Ch)) then if not Others_Only then Error_Msg_N ("a null range in an array" & " aggregate must be the only choice", Choice); Error_Found := True; exit BCL; end if; else Nb_Values_Choices := UI_Sum (Nb_Values_Choices, UI_Difference ( UI_Sum (Expr_Value (Hb_Ch), Uint_1), Expr_Value (Lb_Ch))); end if; else if not Others_Only then Error_Msg_N ("non static choice in array" & " aggregate must be the only choice", Choice); Error_Found := True; exit BCL; else Static_Choices := False; end if; end if; -- Simple choice in component association -- Call resolve and look if it's static, add one to -- the number of values covered by the choices. else Resolve_Subexpr (Choice, Etype (Ind)); if not Is_Static_Expression (Choice) then if not Others_Only then Error_Msg_N ("non static choice in array" & " aggregate must be the only choice", Choice); Error_Found := True; exit BCL; else Static_Choices := False; end if; else Nb_Values_Choices := UI_Sum (Nb_Values_Choices, Uint_1); end if; end if; Others_Only := False; Others_Alone := False; Nb_Choices := Nb_Choices + 1; end if; Choice := Next (Choice); end loop; Complete_Component (Expression (Assoc), Typ, Next_Index (Ind)); Assoc := Next (Assoc); end loop BCL; end if; -- Positional associations -- Calculate the number of positional associations if not Error_Found and then List_Present (Posit_List) then Posit := First (Posit_List); while Present (Posit) loop Complete_Component (Posit, Typ, Next_Index (Ind)); Nb_Posit := UI_Sum (Nb_Posit, Uint_1); Posit := Next (Posit); end loop; end if; -- Check that either positional or named associations -- are present in the aggregate, apart from OTHERS. if not Error_Found and then List_Present (Posit_List) and then not Others_Only then Error_Msg_N ("apart from OTHERS, associations must be all " & "positional or all named", N); Error_Found := True; -- Check the valid context of an OTHERS choice (Ada 83) elsif not Error_Found and then Ada_83 and then Others_Passed and then not Others_Only and then not Full_Others then Error_Msg_N ("invalid context for OTHERS and named " & "associations (4.3.2 (6) Ada 83)", N); Error_Found := True; end if; -- Named associations -- Check if we are able to determine now that Constraint Error will -- be raised a run time. if not Error_Found and then Static_Choices and then not List_Present (Posit_List) and then not Others_Passed then Get_Choices_Bounds (Assoc_List, Agg_Lo_Val, Agg_Hi_Val); if not Error_Found and then Static_Index and then UI_Gt (Agg_Hi_Val, Agg_Lo_Val) then -- Check if the range is out of bounds considering sliding if (UI_Lt (Agg_Lo_Val, Ind_Lo_Val) or else UI_Lt (Ind_Hi_Val, Agg_Hi_Val)) and then UI_Gt (Ind_Hi_Val, Ind_Lo_Val) and then Full_Others then Raise_C := True; Raise_Warning (N, Standard_Entity (S_Constraint_Error), "index values in aggregate " & "do not belong to index subtype?!"); end if; if Is_Constrained (Typ) then if UI_Gt (Ind_Hi_Val, Ind_Lo_Val) then -- Check if the size of the choice range is less or -- greater than the index range. if UI_Lt (UI_Difference (Ind_Hi_Val, Ind_Lo_Val), UI_Difference (Agg_Hi_Val, Agg_Lo_Val)) then Raise_C := True; Raise_Warning (N, Standard_Entity (S_Constraint_Error), "too few index values in aggregate?!"); elsif UI_Gt (UI_Difference (Ind_Hi_Val, Ind_Lo_Val), UI_Difference (Agg_Hi_Val, Agg_Lo_Val)) then Raise_C := True; Raise_Warning (N, Standard_Entity (S_Constraint_Error), "too many index values in aggregate?!"); end if; -- Check if the choice range is not null and the index -- range is. elsif UI_Lt (Ind_Hi_Val, Ind_Lo_Val) then Raise_C := True; Raise_Warning (N, Standard_Entity (S_Constraint_Error), "index subtype range in aggregate is null?!"); end if; end if; end if; end if; -- Positional associations if not Error_Found and then List_Present (Posit_List) and then Static_Index and then not Is_Constrained (Typ) and then not Others_Passed and then UI_Ne (Nb_Posit, UI_Difference (UI_Sum (Ind_Hi_Val, Uint_1), Ind_Lo_Val)) then Raise_C := True; Raise_Warning (N, Standard_Entity (S_Constraint_Error), "index bounds out of range in aggregate?!"); end if; -- Compute the number of values covered by an Others statemnt -- if present in the aggregate examined and set the flag that -- will determinate the expansion algorithm to use. if not Error_Found and then List_Present (Posit_List) and then Others_Passed and then Static_Index and then UI_Gt (UI_Difference ( UI_Difference (UI_Sum (Ind_Hi_Val, Uint_1), Ind_Lo_Val), Nb_Posit), Max_Val) then Others_In_Threshold := False; end if; if not Error_Found and then not List_Present (Posit_List) and then Others_Passed and then Static_Index and then Static_Choices and then UI_Gt (UI_Difference ( UI_Difference (UI_Sum (Ind_Hi_Val, Uint_1), Ind_Lo_Val), Nb_Values_Choices), Max_Val) then Others_In_Threshold := False; end if; end Resolve_Multi_Array_Aggregate; function Rewrite_Array_Aggregate (N : Node_Id; Typ, Ind : Entity_Id) return Node_Id is Expr_List : constant List_Id := Expressions (N); Assoc_List : constant List_Id := Component_Associations (N); New_Expr_List : List_Id := New_List; Expr_Comp : Node_Id; Expr : Node_Id; Assoc : Node_Id; Choice : Node_Id; New_Aggr : Node_Id; Next_Ind : constant Entity_Id := Next_Index (Ind); Ind_Lo : Entity_Id; Ind_Hi : Entity_Id; Lo_Rng : Entity_Id; Hi_Rng : Entity_Id; N_Expr : Entity_Id; Lo_Rng_Val : Uint; Hi_Rng_Val : Uint; Nb_Pos : Nat := 0; procedure Append_N_Copy (Lo, Hi : Node_Id; L : List_Id; V : Node_Id; Offset : Nat); -- Append N times a new copy of the V node in the L list. -- N is the number of values covered by the range Lo + Offset .. Hi. function Find_Expr (N, Lo : Node_Id; L : List_Id) return Node_Id; -- search in L list the node corresponding by its position -- to the node N in the list of index values and returns this node. procedure Append_N_Copy (Lo, Hi : Node_Id; L : List_Id; V : Node_Id; Offset : Nat) is Lo_Val : Uint := Expr_Value (Lo); Hi_Val : Uint := Expr_Value (Hi); begin for i in UI_To_Int (Lo_Val) + Offset .. UI_To_Int (Hi_Val) loop Append (New_Copy (V), L); end loop; end Append_N_Copy; function Find_Expr (N, Lo : Node_Id; L : List_Id) return Node_Id is Expr : Node_Id := First (L); Lo_Val : Uint := Expr_Value (Lo); N_Val : Uint := Expr_Value (N); begin while UI_Lt (Lo_Val, N_Val) loop Expr := Next (Expr); Lo_Val := UI_Sum (Lo_Val, Uint_1); end loop; return Expr; end Find_Expr; -- Processing for Rewrite_Array_Aggregate begin -- If a Constraint Error has been detected during the semantic -- analysis, then build an N_Aggregate node containing the correct -- number of positional associations. The value given to all -- associations is the value of the first association in the -- examined aggregate. If we deal with a multi-dimensional aggregate -- call recursively Rewrite_Array_Aggregate. if Raise_C then Get_Index_Bounds (Ind, Ind_Lo, Ind_Hi); if List_Present (Expr_List) then -- look for the first positional association Expr := First (Expr_List); if Present (Next_Ind) then Expr := Rewrite_Array_Aggregate (Expr, Typ, Next_Ind); end if; else -- Look for the first expression of the first named association Expr := Expression (First (Assoc_List)); if Present (Next_Ind) then Expr := Rewrite_Array_Aggregate (Expr, Typ, Next_Ind); end if; end if; -- Fill the new positional aggregate with Expr. Append_N_Copy (Ind_Lo, Ind_Hi, New_Expr_List, Expr, 0); -- The aggregate examined is correct. First deal with position -- aggregate with an Others statement. elsif List_Present (Expr_List) then -- Copy all the positional associations in the new list of -- positional associations. Expr := First (Expr_List); while Present (Expr) loop if Present (Next_Ind) then Append (Rewrite_Array_Aggregate (Expr, Typ, Next_Ind), New_Expr_List); else Append (New_Copy (Expr), New_Expr_List); end if; Nb_Pos := Nb_Pos + 1; Expr := Next (Expr); end loop; -- Append at the end of the new positional associations the -- missing positional values represented by Others. if List_Present (Assoc_List) then Expr_Comp := Expression (First (Assoc_List)); if Present (Next_Ind) then Expr_Comp := Rewrite_Array_Aggregate (Expr_Comp, Typ, Next_Ind); end if; Get_Index_Bounds (Ind, Ind_Lo, Ind_Hi); Append_N_Copy (Ind_Lo, Ind_Hi, New_Expr_List, Expr_Comp, Nb_Pos); end if; else -- Named associations -- First, build the New_Expr_List with the component passed to -- Others and if Others is not present the the list will be -- built with the first component passed to the aggregate. Get_Index_Bounds (Ind, Ind_Lo, Ind_Hi); Assoc := First (Assoc_List); while Present (Assoc) loop Choice := First (Choices (Assoc)); Expr_Comp := Expression (Assoc); if Nkind (Choice) = N_Others_Choice then if Present (Next_Ind) then Expr_Comp := Rewrite_Array_Aggregate (Expr_Comp, Typ, Next_Ind); end if; Append_N_Copy (Ind_Lo, Ind_Hi, New_Expr_List, Expr_Comp, 0); end if; Assoc := Next (Assoc); end loop; if Is_Empty_List (New_Expr_List) then Append_N_Copy (Ind_Lo, Ind_Hi, New_Expr_List, Expression (First (Assoc_List)), 0); end if; -- Now we place the component values given in the aggregate -- in the New_Expr_List at their right position. Assoc := First (Assoc_List); while Present (Assoc) loop Choice := First (Choices (Assoc)); while Present (Choice) loop if Nkind (Choice) = N_Others_Choice then null; elsif Nkind (Choice) = N_Range then Lo_Rng := Low_Bound (Choice); Hi_Rng := High_Bound (Choice); Lo_Rng_Val := Expr_Value (Lo_Rng); Hi_Rng_Val := Expr_Value (Hi_Rng); Expr := Find_Expr (Lo_Rng, Ind_Lo, New_Expr_List); Expr_Comp := Expression (Assoc); if Present (Next_Ind) then Expr_Comp := Rewrite_Array_Aggregate (Expr_Comp, Typ, Next_Ind); end if; while UI_Lt (Lo_Rng_Val, Hi_Rng_Val) loop Insert_After (Expr, New_Copy (Expr_Comp)); N_Expr := Next (Expr); Remove (Expr); Expr := Next (N_Expr); Lo_Rng_Val := UI_Sum (Lo_Rng_Val, Uint_1); end loop; Insert_After (Expr, New_Copy (Expr_Comp)); Remove (Expr); else Expr := Find_Expr (Choice, Ind_Lo, New_Expr_List); Expr_Comp := Expression (Assoc); if Present (Next_Ind) then Expr_Comp := Rewrite_Array_Aggregate (Expr_Comp, Typ, Next_Ind); end if; Insert_After (Expr, New_Copy (Expr_Comp)); Remove (Expr); end if; Choice := Next (Choice); end loop; Assoc := Next (Assoc); end loop; end if; New_Aggr := Make_Aggregate (Sloc (N), Expressions => New_Expr_List); Set_Etype (New_Aggr, Any_Composite); return New_Aggr; end Rewrite_Array_Aggregate; function Build_Loop (N : Node_Id; Ind : Entity_Id; L : List_Id) return List_Id is Posit_List : constant List_Id := Expressions (N); Assoc_List : constant List_Id := Component_Associations (N); Assg_Stat_List : List_Id; New_Iden_List : List_Id := New_List_Copy (L); R : List_Id := New_List; Posit : Node_Id; Assoc : Node_Id; Choice : Node_Id; Iden : Node_Id; Iter_Sche : Node_Id; Loop_Stat : Node_Id; Next_Ind : Entity_Id := Next_Index (Ind); Ind_Lo : Entity_Id; Ind_Hi : Entity_Id; Nb_Comp : Uint; begin Get_Index_Bounds (Ind, Ind_Lo, Ind_Hi); -- First deal with OTHERS in the aggregate if List_Present (Assoc_List) then Assoc := First (Assoc_List); while Present (Assoc) loop Choice := First (Choices (Assoc)); while Present (Choice) loop if Nkind (Choice) = N_Others_Choice then -- Create a new identifier list by copying the list of -- identifiers visible at this point and adding a new -- identifier corresponding to the defining identifier -- just created. This list will be used as the indexed -- component of the assignment concerning the temporary. Iden := Make_Defining_Identifier (Sloc_N, Chars => New_Internal_Name ("i")); New_Iden_List := New_List_Copy (L); Append_To (New_Iden_List, Make_Identifier (Sloc_N, Chars => Chars (Iden))); -- Create the code : for I__xxx in Ind_Lo .. Ind_Hi loop Iter_Sche := Make_Iteration_Scheme (Sloc_N, Loop_Parameter_Specification => Make_Loop_Parameter_Specification (Sloc_N, Defining_Identifier => Iden, Discrete_Subtype_Definition => Make_Range (Sloc_N, Low_Bound => New_Copy (Ind_Lo), High_Bound => New_Copy (Ind_Hi)))); -- deal with a multi-dimensional aggregate or create the -- code : Tmp__xyz (New_Iden_List) := Expression (Assoc); if Present (Next_Ind) then Assg_Stat_List := Build_Loop (Expression (Assoc), Next_Ind, New_Iden_List); else Assg_Stat_List := New_List_1 ( Make_Assignment_Statement (Sloc_N, Name => Make_Indexed_Component (Sloc_N, Prefix => Make_Identifier (Sloc_N, Chars (Tmp)), Expressions => New_Iden_List), Expression => Expression (Assoc))); end if; Loop_Stat := Make_Loop_Statement (Sloc_N, Identifier => Empty, Iteration_Scheme => Iter_Sche, Statements => Assg_Stat_List); Append (Loop_Stat, R); end if; Choice := Next (Choice); end loop; Assoc := Next (Assoc); end loop; -- Named associations different from Others Assoc := First (Assoc_List); while Present (Assoc) loop Choice := First (Choices (Assoc)); while Present (Choice) loop if Nkind (Choice) = N_Others_Choice then null; -- range choice elsif Nkind (Choice) = N_Range then -- We need to build a loop that will instanciate -- the temporary for the values covering the range -- of the choice. So, we need a new defining identifier. -- The code created here is similar to the code created -- in the Others case. Iden := Make_Defining_Identifier (Sloc_N, Chars => New_Internal_Name ("i")); New_Iden_List := New_List_Copy (L); Append_To (New_Iden_List, Make_Identifier (Sloc_N, Chars (Iden))); Iter_Sche := Make_Iteration_Scheme (Sloc_N, Loop_Parameter_Specification => Make_Loop_Parameter_Specification (Sloc_N, Defining_Identifier => Iden, Discrete_Subtype_Definition => Make_Range (Sloc_N, Low_Bound => New_Copy (Low_Bound (Choice)), High_Bound => New_Copy (High_Bound (Choice))))); if Present (Next_Ind) then Assg_Stat_List := Build_Loop (Expression (Assoc), Next_Ind, New_Iden_List); else Assg_Stat_List := New_List_1 ( Make_Assignment_Statement (Sloc_N, Name => Make_Indexed_Component (Sloc_N, Prefix => Make_Identifier (Sloc_N, Chars (Tmp)), Expressions => New_Iden_List), Expression => Expression (Assoc))); end if; Loop_Stat := Make_Loop_Statement (Sloc_N, Identifier => Empty, Iteration_Scheme => Iter_Sche, Statements => Assg_Stat_List); Append (Loop_Stat, R); else -- Simple choice -- We just need to append the value of the choice to -- the list of visible identifiers. In this case, -- there is no loop created, just an assignment : -- Tmp (Iden_List, Choice) := Expression (Assoc); New_Iden_List := New_List_Copy (L); Append (New_Copy (Choice), New_Iden_List); if Present (Next_Ind) then Assg_Stat_List := Build_Loop (Expression (Assoc), Next_Ind, New_Iden_List); else Assg_Stat_List := New_List_1 ( Make_Assignment_Statement (Sloc_N, Name => Make_Indexed_Component (Sloc_N, Prefix => Make_Identifier (Sloc_N, Chars (Tmp)), Expressions => New_Iden_List), Expression => Expression (Assoc))); end if; Append_List (Assg_Stat_List, R); end if; Choice := Next (Choice); end loop; Assoc := Next (Assoc); end loop; end if; -- Positional associations -- We generate two different codes considering that the type of -- the index may be an enumeration type. if so, we will build -- a temporary whose value will be be updated by using each time -- the attribute 'succ of this temporary. Else, the value is -- directly passed in the indexed component list. if List_Present (Posit_List) then Posit := First (Posit_List); Assg_Stat_List := New_List; New_Iden_List := New_List_Copy (L); Nb_Comp := Uint_0; -- If the type of the index is an enumeration type, create a new -- numbered identifier, add it to the the list of identifiers and -- create the object declaration code Iden : Index_Type := Ind_Lo; -- Else, append the low bound of the index to the list of -- indentifiers. if Is_Enumeration_Type (Etype (Ind_Lo)) then Iden := Make_Defining_Identifier (Sloc_N, New_Internal_Name ("x")); Append (New_Reference_To (Iden, Sloc_N), New_Iden_List); Append_To (Assg_Stat_List, Make_Object_Declaration (Sloc_N, Defining_Identifier => Iden, Object_Definition => New_Reference_To (Etype (Ind_Lo), Sloc_N), Expression => New_Copy (Ind_Lo))); else Append (New_Copy (Ind_Lo), New_Iden_List); end if; -- If the next index is present, then we deal with a multi -- dimensional aggregate and so call recursively Build_Loop. -- Else, we create the following code for the assignment: -- Tmp (New_Iden_List) := Posit; if Present (Next_Ind) then Append_List (Build_Loop (Posit, Next_Ind, New_Iden_List), Assg_Stat_List); else Append_To (Assg_Stat_List, Make_Assignment_Statement (Sloc_N, Name => Make_Indexed_Component (Sloc_N, Prefix => Make_Identifier (Sloc_N, Chars (Tmp)), Expressions => New_Iden_List), Expression => New_Copy (Posit))); end if; Posit := Next (Posit); while Present (Posit) loop Nb_Comp := UI_Sum (Nb_Comp, Uint_1); -- In the index is an enumeration type then, create -- the assignment: -- Iden := Enum'Succ (Iden); -- Else, initialize a copy of the identifier list and -- add to this copy the code: -- Ind_Lo + Nb_Comp; if Is_Enumeration_Type (Etype (Ind_Lo)) then Append_To (Assg_Stat_List, Make_Assignment_Statement (Sloc_N, Name => Make_Identifier (Sloc_N, Chars (Iden)), Expression => Make_Attribute_Reference (Sloc_N, Prefix => Make_Identifier (Sloc_N, Chars => Chars (Etype (Ind_Lo))), Identifier => Make_Identifier (Sloc_N, Name_Succ), Expression => Make_Identifier (Sloc_N, Chars (Iden))))); else New_Iden_List := New_List_Copy (L); Append_To (New_Iden_List, Make_Op_Add (Sloc_N, Left_Opnd => New_Copy (Ind_Lo), Right_Opnd => Make_Integer_Literal (Sloc_N, Nb_Comp))); end if; if Present (Next_Ind) then Append_List (Build_Loop (Posit, Next_Ind, New_Iden_List), Assg_Stat_List); else Append_To (Assg_Stat_List, Make_Assignment_Statement (Sloc_N, Name => Make_Indexed_Component (Sloc_N, Prefix => Make_Identifier (Sloc_N, Chars (Tmp)), Expressions => New_Iden_List), Expression => New_Copy (Posit))); end if; Posit := Next (Posit); end loop; Append_List (Assg_Stat_List, R); end if; return R; end Build_Loop; function Fill_Index (N : Node_Id; Ind : Entity_Id) return List_Id is L : List_Id := New_List; Posit_List : constant List_Id := Expressions (N); Assoc_List : constant List_Id := Component_Associations (N); Posit : Node_Id; Assoc : Node_Id; Choice : Node_Id; Agg_Lo : Node_Id; Agg_Hi : Node_Id; Next_Ind : Entity_Id := Next_Index (Ind); Ind_Lo : Entity_Id; Ind_Hi : Entity_Id; Agg_Lo_Val : Uint; Agg_Hi_Val : Uint; Nb_Comp : Uint := Uint_0; begin -- Named associations if List_Present (Assoc_List) then -- Look for the first choice of the first association and assign -- the low bound and high bound of a range choice to respectively -- Agg_Lo ans Agg_Hi. if that's a simple choice then assign it to -- Agg_Lo and Agg_Hi. Assoc := First (Assoc_List); Choice := First (Choices (Assoc)); if Nkind (Choice) = N_Range then Agg_Lo := Low_Bound (Choice); Agg_Hi := High_Bound (Choice); else Agg_Lo := Choice; Agg_Hi := Choice; end if; -- If the values are not static then there is only one association -- with only one choice. Nothing else is needed, we know the low -- high bound that we need for the index of the array. Else, we -- need to examine all the choices of all the associations to find -- the low and high bound. Note, that we are sure that there's no -- Others choice because the type of the aggregate is an -- unconstrained array. if Is_Static_Expression (Agg_Lo) and then Is_Static_Expression (Agg_Hi) then Agg_Lo_Val := Expr_Value (Agg_Lo); Agg_Hi_Val := Expr_Value (Agg_Hi); while Present (Assoc) loop Choice := First (Choices (Assoc)); while Present (Choice) loop if Nkind (Choice) = N_Range then if UI_Lt (Expr_Value (Low_Bound (Choice)), Agg_Lo_Val) then Agg_Lo := Low_Bound (Choice); Agg_Lo_Val := Expr_Value (Agg_Lo); end if; if UI_Gt (Expr_Value (High_Bound (Choice)), Agg_Hi_Val) then Agg_Hi := High_Bound (Choice); Agg_Hi_Val := Expr_Value (Agg_Hi); end if; else if UI_Lt (Expr_Value (Choice), Agg_Lo_Val) then Agg_Lo := Choice; Agg_Lo_Val := Expr_Value (Agg_Lo); end if; if UI_Gt (Expr_Value (Choice), Agg_Hi_Val) then Agg_Hi := Choice; Agg_Hi_Val := Expr_Value (Agg_Hi); end if; end if; Choice := Next (Choice); end loop; Assoc := Next (Assoc); end loop; end if; -- Create the code Agg_Lo .. Agg_Hi and we deal with a multi -- dimensional aggregate, call recursively Fill_Index. Append_To (L, Make_Range (Sloc_N, Low_Bound => New_Copy (Agg_Lo), High_Bound => New_Copy (Agg_Hi))); if Present (Next_Ind) then Append_List (Fill_Index (Expression (First (Assoc_List)), Next_Ind), L); end if; -- Positional associations elsif List_Present (Posit_List) then -- Get the bounds of the index coresponding to the aggregate -- Compute the number of positional arguments. -- Note that we look directly to the second positional association -- because we are sure that there's at least one and we want this -- first one to correspond to a number of positional associations -- of zero. Get_Index_Bounds (Ind, Ind_Lo, Ind_Hi); Posit := Next (First (Posit_List)); while Present (Posit) loop Nb_Comp := UI_Sum (Nb_Comp, Uint_1); Posit := Next (Posit); end loop; if Is_Enumeration_Type (Etype (Ind_Lo)) then -- Create the following code for enumeration type: -- Ind_Lo .. Enum'Val (Enum'Pos (Ind_Lo) + Nb_Comp) Append_To (L, Make_Range (Sloc_N, Low_Bound => New_Copy (Ind_Lo), High_Bound => Make_Attribute_Reference (Sloc_N, Prefix => Make_Identifier (Sloc_N, Chars => Chars (Etype (Ind_Lo))), Identifier => Make_Identifier (Sloc_N, Name_Val), Expression => Make_Op_Add (Sloc_N, Left_Opnd => Make_Attribute_Reference (Sloc_N, Prefix => Make_Identifier (Sloc_N, Chars => Chars (Etype (Ind_Lo))), Identifier => Make_Identifier (Sloc_N, Name_Pos), Expression => New_Copy (Ind_Lo)), Right_Opnd => Make_Integer_Literal (Sloc_N, Intval => Nb_Comp))))); else -- Else create the following code: -- Ind_Lo .. Ind_Lo + Nb_Comp Append_To (L, Make_Range (Sloc_N, Low_Bound => New_Copy (Ind_Lo), High_Bound => Make_Op_Add (Sloc_N, Left_Opnd => New_Copy (Ind_Lo), Right_Opnd => Make_Integer_Literal (Sloc_N, Nb_Comp)))); end if; if Present (Next_Ind) then Append_List (Fill_Index (First (Posit_List), Next_Ind), L); end if; end if; return L; end Fill_Index; -- Processing for Resolve_Array_Aggregate begin if Nkind (Parent (N)) = N_Return_Statement or else Nkind (Parent (N)) = N_Parameter_Association -- The node N_Parameter_Association appears only if -- there is a formal parameter, so we need also to test -- if the parent is a N_Procedure_Call_Statement or a -- N_Function_Call node when there is not formal parameter. or else Nkind (Parent (N)) = N_Function_Call or else Nkind (Parent (N)) = N_Procedure_Call_Statement -- RM 4.3.7 (check reference???) or else Nkind (Parent (N)) = N_Qualified_Expression -- RM 4.3.8 (check reference???) or else Nkind (Parent (N)) = N_Component_Association or else Nkind (Parent (N)) = N_Aggregate then Full_Others := True; end if; Index := First_Index (Typ); Resolve_Multi_Array_Aggregate (N, Typ, Index); if Operating_Mode = Generate_Code and then not Error_Found then if Is_Constrained (Typ) and then Static_Indices and then Static_Choices and then Others_In_Threshold then New_Aggr := Rewrite_Array_Aggregate (N, Typ, First_Index (Typ)); if Raise_C then Create_Raise_Expression (New_Aggr, Standard_Entity (S_Constraint_Error)); end if; Rewrite_Substitute_Tree (N, New_Aggr); else -- If the array type of the aggregate is unconstrained then make -- an object declaration with a subtype indication whose index -- ranges will be filled by Fill_Index. The code created is: -- Array_Type (...); -- Else, create an object declaration whose code is: -- Tmp : Array_Type; Tmp := Make_Defining_Identifier (Sloc_N, New_Internal_Name ("tmp")); if not Is_Constrained (Typ) then Append_To (Actions_List, (Make_Object_Declaration (Sloc_N, Defining_Identifier => Tmp, Object_Definition => Make_Subtype_Indication (Sloc_N, Subtype_Mark => New_Occurrence_Of (Typ, Sloc_N), Constraint => Make_Index_Or_Discriminant_Constraint (Sloc_N, Constraints => Fill_Index (N, First_Index (Typ))))))); else Append_To (Actions_List, Make_Object_Declaration (Sloc_N, Defining_Identifier => Tmp, Object_Definition => New_Occurrence_Of (Typ, Sloc_N))); end if; if Raise_C then Append_To (Actions_List, Make_Raise_Statement (Sloc_N, Make_Identifier (Sloc_N, Chars => Chars (Standard_Entity (S_Constraint_Error))))); else Append_List (Build_Loop (N, First_Index (Typ), New_List), Actions_List); end if; Expr_Actions := Make_Expression_Actions (Sloc_N, Actions => Actions_List, Expression => Make_Identifier (Sloc_N, Chars (Tmp))); -- Analyze the different nodes of an Expression_Actions node. Action := First (Actions (Expr_Actions)); while Present (Action) loop Analyze (Action); Action := Next (Action); end loop; Analyze (Expression (Expr_Actions)); Set_Etype (Expr_Actions, Etype (Tmp)); Rewrite_Substitute_Tree (N, Expr_Actions); end if; end if; end Resolve_Array_Aggregate; ------------------ -- Resolve_Call -- ------------------ procedure Resolve_Call (N : Node_Id; Typ : Entity_Id) is Subp : constant Node_Id := Name (N); Nam : Entity_Id; I : Interp_Index; It : Interp; function Is_Predefined_Op (Nam : Entity_Id) return Boolean; -- Utility to check whether the name in the call is a predefined -- operator, in which case the call is made into an operator node. function Is_Predefined_Op (Nam : Entity_Id) return Boolean is begin return Is_Intrinsic (Nam) and then (Scope (Nam) = Standard_Standard or else Chars (Scope (Nam)) = Name_System); end Is_Predefined_Op; begin -- The context imposes a unique interpretation with type Typ on -- a procedure or function call. Find the entity of the subprogram -- that yields the expected type, and propagate the corresponding -- formal constraints on the actuals. The caller has established -- that an interpretation exists, and emitted an error if not unique. -- The context type is also the type of the call node. Set_Etype (N, Typ); if Ekind (Etype (Subp)) = E_Subprogram_Type then -- Call to an access to subprogram, dereference made explicit in -- Analyze_Call. Nam := Etype (Subp); elsif not (Is_Type (Entity (Subp))) then -- Name correctly established in Resolve Nam := Entity (Subp); Set_Entity_With_Style_Check (Subp, Nam); else if Is_Overloaded (Subp) then Get_First_Interp (Subp, I, It); while Present (It.Typ) loop if Covers (Typ, It.Typ) then Nam := It.Nam; Set_Entity_With_Style_Check (Subp, Nam); exit; end if; Get_Next_Interp (I, It); end loop; else Compiler_Abort; end if; end if; -- In the case where the call is to an overloaded subprogram, Analyze -- calls Normalize_Actuals once per overloaded subprogram. Therefore in -- such a case Normalize_Actuals needs to be called once more to order -- the actuals correctly. Otherwise the call will have the ordering -- given by the last overloaded subprogram whether this is the correct -- one being called or not. if Is_Overloaded (Subp) then if not Normalize_Actuals (N, Nam, False) then Compiler_Abort; end if; end if; -- In any case, call is fully resolved now. Reset Overload flag, to -- prevent subsequent overload resolution if node is analyzed again Set_Is_Overloaded (Subp, False); Set_Is_Overloaded (N, False); -- If subprogram name is a predefined operator, it was given in -- functional notation. Replace call node with operator node, so -- that actuals can be resolved appropriately. if Is_Predefined_Op (Nam) then Make_Call_Into_Operator (N); Resolve_Subexpr (N, Typ); return; elsif Present (Alias (Nam)) and then Is_Predefined_Op (Alias (Nam)) then Set_Entity (Subp, Alias (Nam)); Make_Call_Into_Operator (N); Resolve_Subexpr (N, Typ); return; end if; -- Propagate interpretation to actuals. Skip over those formals -- for which there are no matching actuals (named notation and/or -- default values). if List_Present (Parameter_Associations (N)) then declare A : Node_Id := First_Actual (N); F : Entity_Id := First_Formal (Nam); begin while Present (A) loop if Nkind (Parent (A)) /= N_Parameter_Association or else Chars (Selector_Name (Parent (A))) = Chars (F) then Resolve_Subexpr (A, Etype (F)); if Ekind (F) /= E_In_Parameter and then not Is_Variable (A) then Error_Msg_NE ("actual for& must be a variable", A, F); end if; if Nkind (A) in N_Subexpr then -- Constant-fold each argument Static_Evaluation (A); end if; if Ekind (F) /= E_Out_Parameter then Apply_Range_Check (A, Etype (F)); end if; A := Next_Actual (A); else -- there is a default value for this formal, which will be -- inserted during expansion. Current actual corresponds -- to some subsequent formal. null; end if; F := Next_Formal (F); end loop; end; -- Overloaded literals are rewritten as function calls, for -- purpose of resolution. After resolution, we can replace -- the call with the literal itself. if Is_Dispatching_Operation (Nam) then Check_Dispatching_Call (N); end if; elsif Ekind (Nam) = E_Enumeration_Literal then Copy_Node (Subp, N); end if; end Resolve_Call; ------------------------------- -- Resolve_Character_Literal -- ------------------------------- procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id) is B_Typ : constant Entity_Id := Base_Type (Typ); C : Entity_Id; begin -- Verify that the character does belong to the type of the context Set_Etype (N, B_Typ); -- Standard character types do not have an explicit list of literals if B_Typ = Standard_Character then return; end if; C := Current_Entity (N); while Present (C) loop if Etype (C) = B_Typ then Set_Entity_With_Style_Check (N, C); return; end if; C := Homonym (C); end loop; -- On exit, the literal does not belong to any character type, and -- either Typ is some predefined character type (for which the -- literals are not explicitly stored), or else the character is not -- a literal of Typ, and Constraint_Error must be raised???). end Resolve_Character_Literal; --------------------------- -- Resolve_Comparison_Op -- --------------------------- -- Context requires a boolean type, and plays no role in resolution. -- Processing identical to that for equality operators. procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id) is L : constant Node_Id := Left_Opnd (N); R : constant Node_Id := Right_Opnd (N); T : constant Entity_Id := Find_Unique_Type (L, R); begin if T /= Any_Type then Resolve_Subexpr (L, T); Resolve_Subexpr (R, T); end if; end Resolve_Comparison_Op; ------------------------ -- Resolve_Conversion -- ------------------------ procedure Resolve_Conversion (N : Node_Id; Typ : Entity_Id) is Target_Type : Entity_Id := Etype (N); Operand : Node_Id := Expression (N); Opnd_Type : Entity_Id := Etype (Operand); begin if not Valid_Conversion (N) then return; end if; -- If conversion has universal type, then we resolve using the -- widest available runtime type of the corresponding class. if Opnd_Type = Universal_Integer then Resolve_Subexpr (Operand, Standard_Longest_Runtime_Integer); elsif Opnd_Type = Universal_Real then Resolve_Subexpr (Expression (N), Standard_Longest_Runtime_Real); -- Otherwise resolve operand using its own type. else Resolve_Subexpr (Operand, Opnd_Type); end if; -- If no suppression of range checking is specified, enable flags to do -- range checking for type conversion. An overflow check is necessary -- in the case where the source target is larger than the target type -- of the conversion. Currently this check only occurrs for signed -- integer or enumeration types since it is premature to do this for -- fixed point, floating point and modular types. if Is_Discrete_Type (Target_Type) and then Ekind (Target_Type) not in Modular_Kind and then not Range_Checks_Suppressed (Target_Type) then if Esize (Etype (Operand)) > Esize (Target_Type) then Set_Do_Overflow_Check (N, True); end if; Apply_Range_Check (Operand, Target_Type); end if; end Resolve_Conversion; ------------------------- -- Resolve_Equality_Op -- ------------------------- -- Both arguments must have the same type, and the boolean context -- does not participate in the resolution. The first pass verifies -- that the interpretation is not ambiguous, and the type of the left -- argument is correctly set, or is Any_Type in case of ambiguity. -- Equality may be dispatching (???). procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id) is L : constant Node_Id := Left_Opnd (N); R : constant Node_Id := Right_Opnd (N); T : constant Entity_Id := Find_Unique_Type (L, R); begin if T /= Any_Type then Resolve_Subexpr (L, T); Resolve_Subexpr (R, T); end if; end Resolve_Equality_Op; ---------------------------------- -- Resolve_Explicit_Dereference -- ---------------------------------- procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id) is P : Node_Id := Prefix (N); I : Interp_Index; It : Interp; begin if Is_Overloaded (P) then -- Use the context type to select the prefix that has the -- correct designated type. Get_First_Interp (P, I, It); while Present (It.Typ) loop exit when Covers (Typ, Designated_Type (It.Typ)); Get_Next_Interp (I, It); end loop; Resolve_Subexpr (P, It.Typ); else Resolve_Subexpr (P, Etype (P)); end if; if Is_Access_Type (Etype (P)) then Apply_Access_Check (N, Etype (P)); end if; end Resolve_Explicit_Dereference; -------------------------------- -- Resolve_Expression_Actions -- -------------------------------- procedure Resolve_Expression_Actions (N : Node_Id; Typ : Entity_Id) is begin Set_Etype (N, Typ); Resolve_Subexpr (Expression (N), Typ); end Resolve_Expression_Actions; --------------------------------- -- Resolve_Extension_Aggregate -- --------------------------------- -- At the moment, cannot be called, because extension aggregates are -- not implemented, and we have already posted an error message. procedure Resolve_Extension_Aggregate (N : Node_Id; Typ : Entity_Id) is begin null; end Resolve_Extension_Aggregate; ------------------------ -- Resolve_Identifier -- ------------------------ procedure Resolve_Identifier (N : Node_Id; Typ : Entity_Id) is begin -- If it's a named number replace it with its value if Is_Named_Number (Entity (N)) then Rewrite_Named_Number (N, Typ); elsif Is_Type (Entity (N)) then Error_Msg_N ("Invalid use of subtype mark in expression", N); end if; end Resolve_Identifier; ------------------------------- -- Resolve_Indexed_Component -- ------------------------------- procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id) is Name : Node_Id := Prefix (N); Expr : Node_Id := First (Expressions (N)); Array_Type : Entity_Id; Index : Node_Id; begin if Is_Overloaded (Name) then -- Use the context type to select the prefix that yields the -- correct component type. Unimplemented (N, "Overloaded prefixes "); else Array_Type := Etype (Name); Resolve_Subexpr (Name, Etype (Name)); if Is_Access_Type (Array_Type) then Apply_Access_Check (N, Array_Type); Array_Type := Designated_Type (Array_Type); end if; Index := (First_Index (Array_Type)); while Present (Index) loop Resolve_Subexpr (Expr, Etype (Index)); Static_Evaluation (Expr); Apply_Range_Check (Expr, Etype (Index)); Index := Next_Index (Index); Expr := Next (Expr); end loop; end if; end Resolve_Indexed_Component; ----------------------------- -- Resolve_Integer_Literal -- ----------------------------- procedure Resolve_Integer_Literal (N : Node_Id; Typ : Entity_Id) is begin -- If the type is universal integer, then change it to the longest -- runtime integer type. Either the expression will be folded at -- compile time, in which case it doesn't matter how we type it, -- since folding is done using universal arithmetic anyway), or -- the expression doesn't get folded, in which case it's right -- to use the largest runtime integer type (and we will get a -- constraint error if the integer literal is too large in this case) if Typ = Universal_Integer then Set_Etype (N, Standard_Longest_Runtime_Integer); -- For all other cases, the type of the literal has been determined -- from context an is non-universal, so we just set the proper type. else Set_Etype (N, Typ); end if; end Resolve_Integer_Literal; ------------------------ -- Resolve_Logical_Op -- ------------------------ procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id) is B_Typ : Entity_Id; begin -- Predefined operations on scalar types yield the base type. On -- the other hand, logical operations on arrays yield the type of -- the arguments (and the context). if Is_Array_Type (Typ) then B_Typ := Typ; else B_Typ := Base_Type (Typ); end if; Resolve_Subexpr (Left_Opnd (N), B_Typ); Resolve_Subexpr (Right_Opnd (N), B_Typ); Set_Etype (N, B_Typ); end Resolve_Logical_Op; --------------------------- -- Resolve_Membership_Op -- --------------------------- -- The context can only be a boolean type, and does not determine -- the arguments. Take the non-universal type of either argument, -- if any, to complete the resolution of both. If the second argument -- is a subtype name, there is nothing to resolve. procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id) is L : constant Node_Id := Left_Opnd (N); R : constant Node_Id := Right_Opnd (N); T : constant Entity_Id := Intersect_Types (L, R); begin Resolve_Subexpr (L, T); if Is_Name (R) then null; else Resolve_Subexpr (R, T); end if; end Resolve_Membership_Op; ------------------ -- Resolve_Null -- ------------------ procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is begin -- The literal NULL takes its type from the context. -- (null = null) is now ambiguous in all cases ???. Set_Etype (N, Typ); end Resolve_Null; -------------------- -- Resolve_Op_Not -- -------------------- procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id) is B_Typ : Entity_Id; begin -- Predefined operations on scalar types yield the base type. On -- the other hand, logical operations on arrays yield the type of -- the arguments (and the context). if Is_Array_Type (Typ) then B_Typ := Typ; else B_Typ := Base_Type (Typ); end if; Resolve_Subexpr (Right_Opnd (N), B_Typ); Set_Etype (N, B_Typ); end Resolve_Op_Not; -------------------------------------- -- Resolve_Parenthesized_Expression -- -------------------------------------- procedure Resolve_Parenthesized_Expression (N : Node_Id; Typ : Entity_Id) is begin Set_Etype (N, Typ); Resolve_Subexpr (Expression (N), Typ); end Resolve_Parenthesized_Expression; ----------------------------- -- Resolve_Operator_Symbol -- ----------------------------- procedure Resolve_Operator_Symbol (N : Node_Id; Typ : Entity_Id) is begin null; end Resolve_Operator_Symbol; ----------------------- -- Resolve_Op_Concat -- ----------------------- procedure Resolve_Op_Concat (N : Node_Id; Typ : Entity_Id) is -- Internal procedure to resolve one argument of concatenation operator. -- The argument is either of the array type or of the component type. procedure Resolve_Concatenation_Arg (Arg : Node_Id) is begin if Has_Compatible_Type (Arg, Component_Type (Typ)) then Resolve_Subexpr (Arg, Component_Type (Typ)); -- ??? make component into one-component array. else Resolve_Subexpr (Arg, Typ); end if; end Resolve_Concatenation_Arg; begin Set_Etype (N, Base_Type (Typ)); Resolve_Concatenation_Arg (Left_Opnd (N)); Resolve_Concatenation_Arg (Right_Opnd (N)); end Resolve_Op_Concat; ---------------------- -- Resolve_Op_Expon -- ---------------------- -- Used for resolving all arithmetic operators except exponentiation procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id) is B_Typ : constant Entity_Id := Base_Type (Typ); -- We do the resolution using the base type, because intermediate values -- in expressions always are of the base type, not a subtype of it. begin Resolve_Subexpr (Left_Opnd (N), B_Typ); Resolve_Subexpr (Right_Opnd (N), Standard_Integer); Set_Etype (N, B_Typ); end Resolve_Op_Expon; ---------------------------------- -- Resolve_Qualified_Expression -- ---------------------------------- procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id) is begin Resolve_Subexpr (Expression (N), Entity (Subtype_Mark (N))); end Resolve_Qualified_Expression; ------------------- -- Resolve_Range -- ------------------- procedure Resolve_Range (N : Node_Id; Typ : Entity_Id) is L : constant Node_Id := Low_Bound (N); R : constant Node_Id := High_Bound (N); begin Set_Etype (N, Typ); Resolve_Subexpr (L, Typ); Resolve_Subexpr (R, Typ); end Resolve_Range; ------------------------------ -- Resolve_Record_Aggregate -- ------------------------------ -- Complete resolution of components in a record aggregate. If the -- record type has discriminants, we must first complete the -- resolution of the discrimant components, in order to determine the -- variant parts to which the rest of the aggregate must conform. -- We modify the tree by building an aggregate which contain -- only named arguments : we use the procedure Rewrite_Substitute_Tree. -- the discriminants and the components appear in the aggregate -- by following their order of declaration in the record. procedure Resolve_Record_Aggregate (N : Node_Id; Typ : Entity_Id) is Posit_List : List_Id := Expressions (N); Named_List : List_Id := Component_Associations (N); New_Assoc_List : List_Id := New_List; Others_List : List_Id := New_List; New_Aggr : Node_Id := New_Node (N_Aggregate, Sloc (N)); Posit : Node_Id; Named : Node_Id; Choice : Node_Id; All_Comp : Elist_Id := New_Elmt_List; Comp_Seen : Elist_Id := New_Elmt_List; Choices_Elist : Elist_Id := New_Elmt_List; Discr : Entity_Id; Comp : Entity_Id; Comp_Id : Entity_Id; Var_Part : Entity_Id; Others_Choice : Entity_Id; Comp_Elmt : Elmt_Id; Selector : Elmt_Id; Last_Pos_Comp : Elmt_Id := No_Elmt; Nb_Posit : Nat; -- Number of positional arguments in aggregate. Nb_Discr : Nat; -- Number of discriminants in record Nb_All_Comp : Nat := 0; -- Number of elements in All_Comp element list Nb_Comp_Seen : Nat := 0; -- Number of elements in Comp_Seen element list Comp_Pos : Nat := 1; I1 : Nat; Error_Found : Boolean := False; Others_Passed : Boolean := False; Others_Alone : Boolean := True; function Count_Pos (N : List_Id) return Nat; -- Count the number of positional arguments in aggregates function Count_Discriminant (Rec_Id : Entity_Id) return Nat; -- Count the number of discriminants in the record procedure Scan_Variant (N : Entity_Id); -- Scan the eventually nested variant parts of the record to -- determine all the components of the record. procedure Add_Association (C : Node_Id; E : Node_Id); -- Build a Component Association node and add it to the -- New_Assoc_List. function Count_Pos (N : List_Id) return Nat is Buffer : Nat := 0; Posit : Node_Id; begin if List_Present (N) then Posit := First (N); while Present (Posit) loop Buffer := Buffer + 1; Posit := Next (Posit); end loop; end if; return Buffer; end Count_Pos; function Count_Discriminant (Rec_Id : Entity_Id) return Nat is Buffer : Nat := 0; Discr : Entity_Id; begin if Has_Discriminants (Rec_Id) then Discr := First_Discriminant (Rec_Id); while Present (Discr) loop Buffer := Buffer + 1; Discr := Next_Discriminant (Discr); end loop; end if; return Buffer; end Count_Discriminant; procedure Scan_Variant (N : Entity_Id) is Variant : Entity_Id := First (Variants (N)); Discr_Name : Entity_Id := Name (N); Discr_Choice : Entity_Id; Comp_List : Entity_Id; Comp_Decl : Entity_Id; Comp_Iden : Entity_Id; Var_Nested : Entity_Id; Value_Discr : Node_Id; New_Assoc : Node_Id; Comp_Decl_List : List_Id; High : Uint; Low : Uint; Value : Uint; begin -- First, look to see if the variant part name exists -- among the discriminant names. New_Assoc := First (New_Assoc_List); while Present (New_Assoc) and then Chars (Discr_Name) /= Chars (First (Choices (New_Assoc))) loop New_Assoc := Next (New_Assoc); end loop; -- If the name we are looking is not in the list of -- discriminants we stop the processing. if not Present (New_Assoc) then Error_Found := True; else -- Retrieve value corresponding to the discriminant scanned Value_Discr := Expression (New_Assoc); -- Look if the value of the discriminant is static -- if not raise error message else compute value if not Is_Static_Expression (Value_Discr) then Error_Msg_N ("value for discriminant must be static", Value_Discr); Error_Found := True; else Value := Expr_Value (Value_Discr); -- Search for the discriminant value in each variants BCL : while Present (Variant) loop Discr_Choice := First (Discrete_Choices (Variant)); while Present (Discr_Choice) loop exit BCL when Nkind (Discr_Choice) = N_Others_Choice; if Nkind (Discr_Choice) = N_Range then Low := Expr_Value (Low_Bound (Discr_Choice)); High := Expr_Value (High_Bound (Discr_Choice)); exit BCL when UI_Le (Low, Value) and then UI_Le (Value, High); else exit BCL when UI_Eq (Expr_Value (Discr_Choice), Value); end if; Discr_Choice := Next (Discr_Choice); end loop; Variant := Next (Variant); end loop BCL; -- If we have found the corresponding choice, look for the -- declared components which will be added to the component -- list. Otherwise generate an appropriate error message. if Present (Discr_Choice) then Comp_List := Component_List (Variant); -- If the component declaration is not null then select -- all components declared and add them to the element -- list of all the components in the record. if not Null_Present (Comp_List) then Comp_Decl_List := Component_Declarations (Comp_List); if List_Present (Comp_Decl_List) then Comp_Decl := First (Comp_Decl_List); while Present (Comp_Decl) loop Comp_Iden := Defining_Identifier (Comp_Decl); Append_Elmt (Comp_Iden, All_Comp); Nb_All_Comp := Nb_All_Comp + 1; Comp_Decl := Next (Comp_Decl); end loop; end if; -- Look for nested variant part Var_Nested := Variant_Part (Comp_List); if Present (Var_Nested) then Scan_Variant (Var_Nested); end if; end if; else Error_Msg_N ("discriminant value is out of range", Discr_Name); Error_Found := True; end if; end if; end if; end Scan_Variant; procedure Add_Association (C : Node_Id; E : Node_Id) is New_Assoc : Node_Id := New_Node (N_Component_Association, Sloc (E)); New_Choices_List : List_Id := New_List; begin Append (New_Occurrence_Of (C, Sloc (E)), New_Choices_List); Set_Choices (New_Assoc, New_Choices_List); Set_Expression (New_Assoc, New_Copy (E)); Append (New_Assoc, New_Assoc_List); end Add_Association; -- Start of processing for Resolve_Record_Aggregate begin -- Traverse the aggregate to call Analyze on all expresssions before -- beginning Semantic Analysis. if Is_Abstract (Typ) then Error_Msg_N ("type of aggregate cannot be abstract", N); end if; if List_Present (Posit_List) then Posit := First (Posit_List); while Present (Posit) loop Analyze (Posit); Posit := Next (Posit); end loop; end if; if List_Present (Named_List) then Named := First (Named_List); while Present (Named) loop Analyze (Expression (Named)); Named := Next (Named); end loop; end if; Nb_Discr := Count_Discriminant (Typ); Nb_Posit := Count_Pos (Posit_List); -- Set I1 to min (Nb_Discr, Nb_Posit) if Nb_Discr < Nb_Posit then I1 := Nb_Discr; else I1 := Nb_Posit; end if; -- Build the New_Assoc List containing the (hopefully) static -- value corresponding to each discriminant of the record. First we -- deal with the positional arguments. if I1 >= 1 then Discr := First_Discriminant (Typ); Posit := First (Posit_List); Add_Association (Discr, Posit); for I in 2 .. I1 loop Discr := Next_Discriminant (Discr); Posit := Next (Posit); Add_Association (Discr, Posit); end loop; end if; -- If necessary, find remaining discriminants among the named components for I in I1 + 1 .. Nb_Discr loop if I = 1 then Discr := First_Discriminant (Typ); else Discr := Next_Discriminant (Discr); end if; -- If the corresponding component is found, call Add_Association -- else report error. if List_Present (Named_List) then Named := First (Named_List); BCL : while Present (Named) loop Choice := First (Choices (Named)); while Present (Choice) loop -- Exit the whole search process when the discriminant -- name is found. exit BCL when Nkind (Choice) = N_Others_Choice or else Chars (Discr) = Chars (Choice); Choice := Next (Choice); end loop; Named := Next (Named); end loop BCL; else Choice := Empty; end if; if Present (Choice) then Add_Association (Discr, Expression (Named)); else Error_Msg_NE ("no value supplied for discriminant", N, Discr); Error_Found := True; end if; exit when Error_Found; end loop; if not Error_Found then -- Now perform type resolution of the discriminant values, and -- verify that they are static if List_Present (New_Assoc_List) then Named := First (New_Assoc_List); while Present (Named) loop Resolve_Complete_Context (Expression (Named), Etype (First (Choices (Named)))); Named := Next (Named); end loop; end if; -- Build a list with the components corresponding to the subtype -- selected by the discriminants. First select the components of -- the invariant part of the record. Comp := First_Component (Typ); -- special treatment for the first component of root tagged types -- (field _tag) if (Is_Tagged_Type (Typ) and then (Etype (Typ) = Typ)) then -- add the association for the _tag field declare Loc : Source_Ptr := Sloc (N); Conv_Node : Node_Id; begin Conv_Node := Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Occurrence_Of (RTE (RE_Tag), Loc), Expression => New_Occurrence_Of (Access_Disp_Table (Typ), Loc)); Set_Etype (Conv_Node, RTE (RE_Tag)); Add_Association (First_Component (Typ), Conv_Node); end; -- don't put the field _tag into the list of components Comp := Next_Component (Comp); end if; while Present (Comp) and then Nkind (Parent (Parent (Parent (Comp)))) /= N_Variant loop Append_Elmt (Comp, All_Comp); Nb_All_Comp := Nb_All_Comp + 1; Comp := Next_Component (Comp); end loop; -- Now scan the variant part of the record declaration and -- collect the types corresponding to the given discriminants. Var_Part := Variant_Part (Component_List (Type_Definition (Parent (Base_Type (Typ))))); if Present (Var_Part) then Scan_Variant (Var_Part); end if; end if; -- Scan the positional arguments of the aggregate if not Error_Found and then List_Present (Posit_List) then if I1 > 0 then Posit := Next (Posit); else Posit := First (Posit_List); end if; Comp_Elmt := First_Elmt (All_Comp); while Present (Posit) loop if Comp_Pos > Nb_All_Comp then Error_Msg_N ("too many components for record aggregate", N); Error_Found := True; exit; end if; Comp_Id := Id_Of (Comp_Elmt); Resolve_Complete_Context (Posit, Etype (Comp_Id)); Append_Elmt (Comp_Id, Comp_Seen); Nb_Comp_Seen := Nb_Comp_Seen + 1; Add_Association (Comp_Id, Posit); Last_Pos_Comp := Comp_Elmt; Comp_Elmt := Next_Elmt (Comp_Elmt); Comp_Pos := Comp_Pos + 1; Posit := Next (Posit); end loop; end if; -- Now scan for the named arguments of the aggregate if not Error_Found and then List_Present (Named_List) then Named := First (Named_List); BLO : while Present (Named) loop Others_Alone := True; Choices_Elist := New_Elmt_List; Choice := First (Choices (Named)); while Present (Choice) loop case Nkind (Choice) is when N_Range => Error_Msg_N ("range choice not allowed in record aggregate", Choice); Error_Found := True; exit BLO; when N_Others_Choice => if Others_Passed then Error_Msg_N ("OTHERS must appear only once", Choice); Error_Found := True; exit BLO; elsif not Others_Alone then Error_Msg_N ("OTHERS must appear alone", Choice); Error_Found := True; exit BLO; elsif Nb_Comp_Seen >= Nb_All_Comp then Error_Msg_N ("OTHERS must represent at least one component", Choice); Error_Found := True; exit BLO; else -- Scan every component of the record and -- look if it has been seen before. -- if not check the type of aggregate value Comp_Elmt := First_Elmt (All_Comp); while Comp_Elmt /= No_Elmt loop Comp_Id := Id_Of (Comp_Elmt); Selector := First_Elmt (Comp_Seen); while Selector /= No_Elmt and then Chars (Id_Of (Selector)) /= Chars (Comp_Id) loop Selector := Next_Elmt (Selector); end loop; if Selector = No_Elmt then Resolve_Complete_Context (Expression (Named), Etype (Comp_Id)); Append_Elmt (Comp_Id, Choices_Elist); Append_Elmt (Comp_Id, Comp_Seen); Append (New_Occurrence_Of (Comp_Id, Sloc (Choice)), Others_List); end if; Comp_Elmt := Next_Elmt (Comp_Elmt); end loop; end if; Nb_Comp_Seen := Nb_All_Comp; Others_Passed := True; Others_Alone := False; when others => if not Others_Alone and then Others_Passed then Error_Msg_N ("OTHERS must appear alone", Choice); Error_Found := True; exit BLO; elsif Others_Passed then Error_Msg_N ("OTHERS must be the last aggregate component", Choice); Error_Found := True; exit BLO; end if; -- Simple choice. Verify that the named component -- is one of the selected the component names Comp_Elmt := First_Elmt (All_Comp); while Comp_Elmt /= No_Elmt and then Chars (Id_Of (Comp_Elmt)) /= Chars (Choice) loop Comp_Elmt := Next_Elmt (Comp_Elmt); end loop; if Comp_Elmt = No_Elmt then Discr := Empty; if Has_Discriminants (Typ) then Discr := First_Discriminant (Typ); while Present (Discr) and then Chars (Discr) /= Chars (Choice) loop Discr := Next_Discriminant (Discr); end loop; end if; if not Present (Discr) then Error_Msg_N ("undefined component name", Choice); Error_Found := True; exit BLO; else Append_Elmt (Discr, Choices_Elist); end if; else -- Check that named aggregate hasn't been seen before Selector := First_Elmt (Comp_Seen); while Selector /= No_Elmt and then Chars (Id_Of (Selector)) /= Chars (Choice) loop Selector := Next_Elmt (Selector); end loop; if Selector /= No_Elmt then Error_Msg_N ("duplicate value for component& in aggregate", Choice); Error_Found := True; exit BLO; end if; Comp_Id := Id_Of (Comp_Elmt); Resolve_Complete_Context (Expression (Named), Etype (Comp_Id)); Append_Elmt (Comp_Id, Choices_Elist); Append_Elmt (Comp_Id, Comp_Seen); Comp_Pos := Comp_Pos + 1; Others_Alone := False; end if; end case; Choice := Next (Choice); end loop; -- Verify that all choices have the same type Comp_Elmt := First_Elmt (Choices_Elist); Selector := Next_Elmt (Comp_Elmt); while Selector /= No_Elmt and then Base_Type (Etype (Id_Of (Selector))) = Base_Type (Etype (Id_Of (Comp_Elmt))) loop Selector := Next_Elmt (Selector); end loop; if Selector /= No_Elmt then Error_Msg_N ("components on a choice list must have same type", N); Error_Found := True; exit BLO; end if; Named := Next (Named); end loop BLO; end if; -- Scan all declared components and check that everyone has -- been seen if not Error_Found then Comp_Elmt := First_Elmt (All_Comp); while Comp_Elmt /= No_Elmt loop Comp_Id := Id_Of (Comp_Elmt); Selector := First_Elmt (Comp_Seen); while Selector /= No_Elmt loop exit when Comp_Id = Id_Of (Selector); Selector := Next_Elmt (Selector); end loop; if Selector = No_Elmt then if Nb_Comp_Seen = Nb_All_Comp - 1 then Error_Msg_NE ("no value supplied for component&", N, Comp_Id); Error_Found := True; end if; end if; Comp_Elmt := Next_Elmt (Comp_Elmt); end loop; end if; -- We need to complete the New_Assoc_list with the -- remaining components: those which are named in the aggregate if Operating_Mode = Generate_Code and then not Error_Found then if Last_Pos_Comp /= No_Elmt then Comp_Elmt := Next_Elmt (Last_Pos_Comp); else Comp_Elmt := First_Elmt (All_Comp); end if; while Comp_Elmt /= No_Elmt loop Comp_Id := Id_Of (Comp_Elmt); Named := First (Named_List); BLP : while Present (Named) loop Choice := First (Choices (Named)); while Present (Choice) loop if Nkind (Choice) = N_Others_Choice then Others_Choice := First (Others_List); while Present (Others_Choice) loop if Chars (Others_Choice) = Chars (Comp_Id) then Add_Association (Comp_Id, Expression (Named)); exit BLP; end if; Others_Choice := Next (Others_Choice); end loop; elsif Chars (Choice) = Chars (Comp_Id) then Add_Association (Comp_Id, Expression (Named)); exit BLP; end if; Choice := Next (Choice); end loop; Named := Next (Named); end loop BLP; Comp_Elmt := Next_Elmt (Comp_Elmt); end loop; Set_Expressions (New_Aggr, No_List); Set_Component_Associations (New_Aggr, New_Assoc_List); Rewrite_Substitute_Tree (N, New_Aggr); end if; end Resolve_Record_Aggregate; -------------------------- -- Resolve_Real_Literal -- -------------------------- procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id) is begin -- If the type is universal real, then change it to the longest -- runtime real type. Either the expression will be folded at -- compile time, in which case it doesn't matter how we type it, -- since folding is done using universal arithmetic anyway), or -- the expression doesn't get folded, in which case it's right -- to use the largest runtime real type (and we will get a -- constraint error if the real literal is too large in this case) if Typ = Universal_Real then Set_Etype (N, Standard_Longest_Runtime_Real); -- For all other cases, the type of the literal has been determined -- from context an is non-universal, so we just set the proper type. else Set_Etype (N, Typ); end if; end Resolve_Real_Literal; ----------------------- -- Resolve_Reference -- ----------------------- procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id) is begin null; -- TBD ??? end Resolve_Reference; -------------------------------- -- Resolve_Selected_Component -- -------------------------------- procedure Resolve_Selected_Component (N : Node_Id; Typ : Entity_Id) is P : Node_Id := Prefix (N); T : Entity_Id := Etype (P); begin -- The prefix may be overloaded, or may involve expressions that -- must be further resolved. if Is_Overloaded (P) then -- Use the context type to select the prefix that has a selector -- of the correct name and type. Unimplemented (N, "Overloaded prefixes"); else Resolve_Subexpr (P, T); end if; if Is_Access_Type (Etype (P)) then Apply_Access_Check (N, Etype (P)); end if; end Resolve_Selected_Component; ------------------- -- Resolve_Slice -- ------------------- procedure Resolve_Slice (N : Node_Id; Typ : Entity_Id) is Name : constant Node_Id := Prefix (N); Array_Type : Entity_Id; Index : Node_Id; begin if Is_Overloaded (Name) then -- Use the context type to select the prefix that yields the -- correct component type. Unimplemented (N, "Overloaded prefixes"); else Array_Type := Etype (Name); Resolve_Subexpr (Name, Array_Type); if Is_Access_Type (Array_Type) then Apply_Access_Check (N, Array_Type); Array_Type := Designated_Type (Array_Type); end if; Index := First_Index (Array_Type); Resolve_Subexpr (Discrete_Range (N), Etype (Index)); end if; end Resolve_Slice; --------------------------- -- Resolve_Short_Circuit -- --------------------------- procedure Resolve_Short_Circuit (N : Node_Id; Typ : Entity_Id) is begin Resolve_Subexpr (Left_Opnd (N), Standard_Boolean); Resolve_Subexpr (Right_Opnd (N), Standard_Boolean); end Resolve_Short_Circuit; ---------------------------- -- Resolve_String_Literal -- ---------------------------- procedure Resolve_String_Literal (N : Node_Id; Typ : Entity_Id) is Subtype_Id : Entity_Id; begin -- Must verify that all characters belong to the element type of the -- array type of the context. Create a special subtype for the -- N_String_Literal node which becomes its Etype. Subtype_Id := New_Implicit_Type (Sloc (N)); Set_Ekind (Subtype_Id, E_String_Literal_Subtype); Set_Component_Type (Subtype_Id, Component_Type (Typ)); Set_String_Literal_Length (Subtype_Id, UI_From_Int (String_Length (Strval (N)))); Set_Etype (Subtype_Id, Base_Type (Typ)); Set_Etype (N, Subtype_Id); end Resolve_String_Literal; ---------------------- -- Resolve_Unary_Op -- ---------------------- procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id) is begin Set_Etype (N, Base_Type (Typ)); Resolve_Subexpr (Right_Opnd (N), Typ); end Resolve_Unary_Op; ----------------------------- -- Make_Call_Into_Operator -- ----------------------------- procedure Make_Call_Into_Operator (N : Node_Id) is Op_Name : constant Name_Id := Chars (Entity (Name (N))); Act1 : constant Node_Id := First_Actual (N); Act2 : constant Node_Id := Next_Actual (Act1); Is_Binary : constant Boolean := Present (Act2); Kind : Node_Kind; Op_Node : Node_Id; begin if Is_Binary then if Op_Name = Name_Op_And then Kind := N_Op_And; elsif Op_Name = Name_Op_Or then Kind := N_Op_Or; elsif Op_Name = Name_Op_Xor then Kind := N_Op_Xor; elsif Op_Name = Name_Op_Eq then Kind := N_Op_Eq; elsif Op_Name = Name_Op_Ne then Kind := N_Op_Ne; elsif Op_Name = Name_Op_Lt then Kind := N_Op_Lt; elsif Op_Name = Name_Op_Le then Kind := N_Op_Le; elsif Op_Name = Name_Op_Gt then Kind := N_Op_Gt; elsif Op_Name = Name_Op_Ge then Kind := N_Op_Ge; elsif Op_Name = Name_Op_Add then Kind := N_Op_Add; elsif Op_Name = Name_Op_Subtract then Kind := N_Op_Subtract; elsif Op_Name = Name_Op_Concat then Kind := N_Op_Concat; elsif Op_Name = Name_Op_Multiply then Kind := N_Op_Multiply; elsif Op_Name = Name_Op_Divide then Kind := N_Op_Divide; elsif Op_Name = Name_Op_Mod then Kind := N_Op_Mod; elsif Op_Name = Name_Op_Rem then Kind := N_Op_Rem; elsif Op_Name = Name_Op_Expon then Kind := N_Op_Expon; else Compiler_Abort; end if; else if Op_Name = Name_Op_Add then Kind := N_Op_Plus; elsif Op_Name = Name_Op_Subtract then Kind := N_Op_Minus; elsif Op_Name = Name_Op_Abs then Kind := N_Op_Abs; elsif Op_Name = Name_Op_Not then Kind := N_Op_Not; else Compiler_Abort; end if; end if; Op_Node := New_Node (Kind, Sloc (N)); if Is_Binary then Set_Left_Opnd (Op_Node, New_Copy (Act1)); Set_Right_Opnd (Op_Node, New_Copy (Act2)); Set_Chars (Op_Node, Op_Name); else Set_Right_Opnd (Op_Node, New_Copy (Act1)); Set_Chars (Op_Node, Op_Name); end if; Set_Etype (Op_Node, Etype (N)); Rewrite_Substitute_Tree (N, Op_Node); end Make_Call_Into_Operator; ---------------------- -- Valid_Conversion -- ---------------------- function Valid_Conversion (N : Node_Id) return Boolean is Target_Type : Entity_Id := Etype (N); Operand : Node_Id := Expression (N); Opnd_Type : Entity_Id := Etype (Operand); function Conversion_Check (Valid : Boolean; Msg : Str) return Boolean is begin if not Valid then Error_Msg_N (Msg, Operand); end if; return Valid; end Conversion_Check; begin if Is_Overloaded (Operand) then Error_Msg_N ("ambiguous operand in conversion", Operand); return False; elsif Unchecked_Conversion (N) then return True; elsif Chars (Current_Scope) = Name_Unchecked_Conversion then return True; elsif Is_Numeric_Type (Target_Type) then return Conversion_Check (Is_Numeric_Type (Opnd_Type), "illegal operand for numeric conversion"); elsif Is_Array_Type (Target_Type) then -- additional tests on index and component types ??? return Conversion_Check (Is_Array_Type (Opnd_Type) and then Number_Dimensions (Target_Type) = Number_Dimensions (Opnd_Type), "illegal operand for array conversion"); elsif Ekind (Target_Type) = E_General_Access_Type then -- additional tests on designated types, tagged types ??? return Conversion_Check (Is_Access_Type (Opnd_Type), "illegal operand for access type conversion"); elsif Ekind (Target_Type) = E_Access_Subprogram_Type then -- check that designated types are type conformant ??? return Conversion_Check (Ekind (Opnd_Type) = E_Access_Subprogram_Type, "illegal operand for access subprogram conversion"); else return Conversion_Check (Root_Type (Target_Type) = Root_Type (Opnd_Type), "illegal operand for conversion"); end if; end Valid_Conversion; ------------------------------ -- Rewrite_Operator_As_Call -- ------------------------------ procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id) is Actuals : List_Id := New_List; begin if Nkind (N) in N_Binary_Op then Append (Left_Opnd (N), Actuals); end if; Append (Right_Opnd (N), Actuals); Change_Node (N, N_Function_Call); Set_Etype (N, Etype (Nam)); Set_Name (N, New_Occurrence_Of (Nam, Sloc (N))); Set_Parameter_Associations (N, Actuals); end Rewrite_Operator_As_Call; end Sem_Res; tity_Id) is begin null; -- TBD ??? end Resolve_Reference; -------------------------------- -- Resolve_Selected_Component -- -------------------------------- procedure Resolve_Selected_Component (N : Node_Id; Typ : Entity_Id) is gnat-1.67-src/src/sem_res.ads 444 10015 7640 7335 5506244410 11247 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ R E S -- -- -- -- S p e c -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Sem_Res is -- As described in Sem_Ch4, the type resolution proceeds in two phases. -- The first phase is a bottom up pass that is achieved during the -- recursive traversal performed by the Analyze procedures. This phase -- determines unambiguous types, and collects sets of possible types -- where the interpretation is potentially ambiguous. -- On completing this bottom up pass, which corresponds to a call to -- Analyze on a complete context, the Resolve_Complete_Context routine -- is called which performs a top down resolution by making recursive -- calls the Resolve_Subexpr routine. -- Since in practice a lot of semantic analysis has to be postponed until -- types are known (e.g. static folding, setting of suppress flags), the -- Resolve routines also complete the semantic analyze, and also call the -- expander for possibly expansion of the completely type resolved node. procedure Resolve_Complete_Context (N : Node_Id; Typ : Entity_Id); -- Top level type-checking procedure, called in a complete context. The -- construct N, which is a subexpression, has already been analyzed, and -- is required to be of type Typ given the analysis of the context (which -- uses the information gathered on the bottom up phase in Analyze). -- The call to Resolve_Complete_Context also performs required static -- evaluation of the entire expression. procedure Resolve_Subexpr (N : Node_Id; Typ : Entity_Id); -- Recursive type and overload resolution procedure. Performs top-down -- type propagation over expression tree. This routine differs from the -- Resolve_Complete_Context call in that it does not reinitialize the -- overload resolution data structures, and does not perform static -- evaluation, since this is performed only at the top level. As implied, -- by the name of the procedure, Nkind (N) is always in N_Subexpr. end Sem_Res; Set_Component_Type (Subtype_Id, Component_Type (Typ)); Set_String_Literal_Length (Subtype_Id, UI_From_Int (String_Length (Strval (N)))); Set_Etype (Subtype_Id, Base_Type (Typ)); Set_Etype (N, Subtype_Id); end Resolve_String_Literal; ----------------------gnat-1.67-src/src/sem_util.adb 444 10015 7640 71127 5506244411 11433 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ U T I L -- -- -- -- B o d y -- -- -- -- $Revision: 1.46 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Comperr; use Comperr; with Csets; use Csets; with Debug; use Debug; with Errout; use Errout; with Lib; use Lib; with Namet; use Namet; with Nmake; use Nmake; with Output; use Output; with Opt; use Opt; with Sem; use Sem; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; with Sinfo; use Sinfo; with Sinput; use Sinput; with Stand; use Stand; with Tbuild; use Tbuild; with Uintp; use Uintp; package body Sem_Util is ------------------------------ -- Access_Checks_Suppressed -- ------------------------------ function Access_Checks_Suppressed (E : Entity_Id) return Boolean is begin return Scope_Suppress.Access_Checks or else Suppress_Access_Checks (E); end Access_Checks_Suppressed; ------------------------------------- -- Accessibility_Checks_Suppressed -- ------------------------------------- function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean is begin return Scope_Suppress.Accessibility_Checks or else Suppress_Accessibility_Checks (E); end Accessibility_Checks_Suppressed; -------------------- -- Current_Entity -- -------------------- -- The currently visible definition for a given identifier is the -- one most chained at the start of the visibility chain, i.e. the -- one that is referenced by the Node_Id value of the name of the -- given identifier. function Current_Entity (N : Node_Id) return Entity_Id is begin return Get_Name_Entity_Id (Chars (N)); end Current_Entity; ------------------- -- Current_Scope -- ------------------- function Current_Scope return Entity_Id is C : constant Entity_Id := Scope_Stack.Table (Scope_Stack.last).Entity; begin if Present (C) then return C; else return Standard_Standard; end if; end Current_Scope; ------------------------------------ -- Discriminant_Checks_Suppressed -- ------------------------------------ function Discriminant_Checks_Suppressed (E : Entity_Id) return Boolean is begin return Scope_Suppress.Discriminant_Checks or else Suppress_Discriminant_Checks (E); end Discriminant_Checks_Suppressed; -------------------------------- -- Division_Checks_Suppressed -- -------------------------------- function Division_Checks_Suppressed (E : Entity_Id) return Boolean is begin return Scope_Suppress.Division_Checks or else Suppress_Division_Checks (E); end Division_Checks_Suppressed; ----------------------------------- -- Elaboration_Checks_Suppressed -- ----------------------------------- function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean is begin return Scope_Suppress.Elaboration_Checks or else Suppress_Elaboration_Checks (E); end Elaboration_Checks_Suppressed; ---------------- -- Enter_Name -- ---------------- procedure Enter_Name (Def_Id : Node_Id) is E : constant Entity_Id := Current_Entity (Def_Id); S : constant Entity_Id := Current_Scope; begin -- Add new name to current scope declarations if Present (E) and then Scope (E) = S then if Etype (E) = Any_Type then -- Previous entity was entered because of a missing declaration -- or else a bad subtype indication. Best is to use the new -- entity, and make the previous one invisible. Set_Is_Directly_Visible (E, False); else -- Genuine duplicate declaration. Keep previous one visible, -- but give some usable attributes to new one. Set_Ekind (Def_Id, E_Variable); Set_Etype (Def_Id, Any_Type); Set_Scope (Def_Id, S); Error_Msg_Sloc_1 := Sloc (E); Error_Msg_N ("declaration of& conflicts with line #", Def_Id); return; end if; end if; Set_Ekind (Def_Id, E_Void); Set_Etype (Def_Id, Any_Type); -- The kind E_Void insures that premature uses of the entity will be -- detected. Any_Type insures that no cascaded errors will occur. Set_Is_Directly_Visible (Def_Id); Set_Current_Entity (Def_Id); Set_Homonym (Def_Id, E); Append_Entity (Def_Id, S); Set_Public_Status (Def_Id); end Enter_Name; -------------------------- -- Get_Declaration_Node -- -------------------------- function Get_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is N : Node_Id := Parent (Unit_Id); begin if Ekind (Unit_Id) = E_Operator then -- Predefined operators do not have a full function declaration. return N; end if; while Nkind (N) /= N_Generic_Package_Declaration and then Nkind (N) /= N_Generic_Subprogram_Declaration and then Nkind (N) /= N_Package_Declaration and then Nkind (N) /= N_Subprogram_Declaration and then Nkind (N) /= N_Subprogram_Body and then Nkind (N) /= N_Package_Renaming_Declaration and then Nkind (N) /= N_Subprogram_Renaming_Declaration loop N := Parent (N); end loop; return N; end Get_Declaration_Node; --------------------------- -- Has_Private_Component -- --------------------------- function Has_Private_Component (Type_Id : Entity_Id) return Boolean is T : Entity_Id := Base_Type (Type_Id); Component : Entity_Id; begin if Ekind (T) in Private_Kind then return No (Full_Declaration (T)) and not Is_Generic_Type (T); elsif Ekind (T) in Array_Kind then return Has_Private_Component (Component_Type (T)); elsif Ekind (T) in Access_Kind then return Is_Private_Type (Designated_Type (T)); elsif Ekind (T) in Record_Kind then Component := First_Entity (T); while Present (Component) loop if Has_Private_Component (Etype (Component)) then return True; end if; Component := Next_Entity (Component); end loop; return False; else return False; end if; end Has_Private_Component; -------------------------- -- Has_Tagged_Component -- -------------------------- function Has_Tagged_Component (Typ : Entity_Id) return Boolean is Comp : Entity_Id; begin if Is_Array_Type (Typ) then return Is_Tagged_Type (Component_Type (Typ)); elsif Is_Tagged_Type (Typ) then return True; elsif Is_Record_Type (Typ) then Comp := First_Component (Typ); while Present (Comp) loop if Has_Tagged_Component (Etype (Comp)) then return True; end if; Comp := Next_Component (Typ); end loop; return False; else return False; end if; end Has_Tagged_Component; ----------------------------- -- Index_Checks_Suppressed -- ----------------------------- function Index_Checks_Suppressed (E : Entity_Id) return Boolean is begin return Scope_Suppress.Index_Checks or else Suppress_Index_Checks (E); end Index_Checks_Suppressed; ------------- -- Is_Name -- ------------- function Is_Name (N : Node_Id) return Boolean is begin return Nkind (N) in N_Entity_Name; end Is_Name; ------------------------------ -- Length_Checks_Suppressed -- ------------------------------ function Length_Checks_Suppressed (E : Entity_Id) return Boolean is begin return Scope_Suppress.Length_Checks or else Suppress_Length_Checks (E); end Length_Checks_Suppressed; ------------------------- -- New_External_Entity -- ------------------------- function New_External_Entity (Kind : Entity_Kind; Scope_Id : Entity_Id; Sloc_Value : Source_Ptr; Related_Id : Entity_Id; Suffix : Str; Index : Nat := 0; Prefix : Str := "") return Entity_Id is N : constant Entity_Id := Make_Defining_Identifier (Sloc_Value, New_External_Name (Chars (Related_Id), Suffix, Index, Prefix)); begin Set_Ekind (N, Kind); Set_Is_Internal (N); Append_Entity (N, Scope_Id); Set_Current_Entity (N); return N; end New_External_Entity; ------------------------- -- New_Internal_Entity -- ------------------------- function New_Internal_Entity (Kind : Entity_Kind; Scope_Id : Entity_Id; Sloc_Value : Source_Ptr; Id_Str : Str) return Entity_Id is N : constant Entity_Id := Make_Defining_Identifier (Sloc_Value, New_Internal_Name (Id_Str)); begin Set_Ekind (N, Kind); Set_Is_Internal (N); Append_Entity (N, Scope_Id); Set_Current_Entity (N); return N; end New_Internal_Entity; ----------------------- -- New_Implicit_Type -- ----------------------- function New_Implicit_Type (Sloc_Value : Source_Ptr; Related_Id : Entity_Id := Empty; Suffix : Str := ""; Index : Nat := 0; Scope_Id : Entity_Id := Current_Scope) return Entity_Id is N : Entity_Id; begin if Related_Id = Empty then N := New_Internal_Entity (E_Void, Scope_Id, Sloc_Value, "ityp"); else N := New_External_Entity (E_Void, Scope_Id, Sloc_Value, Related_Id, Suffix, Index, "ityp"); end if; Set_Etype (N, Any_Type); Set_Public_Status (N); Append_To (Implicit_Type_List, Make_Implicit_Type (Sloc_Value, N)); return N; end New_Implicit_Type; ----------------------- -- Normalize_Actuals -- ----------------------- -- Chain actuals according to formals of subprogram. If there are -- no named associations, the chain is simply the list of Parameter -- Associations, since the order is the same as the declaration order. -- If there are named associations, then the First_Named_Actual field -- in the N_Procedure_Call_Statement node or N_Function_Call node -- points to the Parameter_Association node for the parameter that -- comes first in declaration order. The remaining named parameters -- are then chained in declaration order using Next_Named_Actual. -- This routine also verifies that the number of actuals is compatible -- with the number and default values of formals, but performs no type -- checking (type checking is done by the caller). -- If the matching succeeds, the function returns True, and the caller -- proceeds with type-checking. If the match is unsuccessful, then the -- function returns False, and the caller attempts a different inter- -- pretation, if there is one. -- If the flag Report is on, the call is not overloaded, and a failure -- to match can be reported here, rather than in the caller. function Normalize_Actuals (N : Node_Id; S : Entity_Id; Report : Boolean) return Boolean is Actuals : constant List_Id := Parameter_Associations (N); Actual : Node_Id := Empty; Formal : Entity_Id; Last : Entity_Id := Empty; First_Named : Entity_Id := Empty; Found : Boolean; Formals_To_Match : Integer := 0; Actuals_To_Match : Integer := 0; procedure Chain (A : Node_Id) is begin if No (Last) then -- Call node points to first actual in list. Set_First_Named_Actual (N, Actual_Parameter (A)); else Set_Next_Named_Actual (Last, Actual_Parameter (A)); end if; Last := A; end Chain; -- Start of processing for Normalize_Actuals begin Formal := First_Formal (S); while Present (Formal) loop Formals_To_Match := Formals_To_Match + 1; Formal := Next_Formal (Formal); end loop; -- Find if there is a named association, and verify that no positional -- associations appear after named ones. if List_Present (Actuals) then Actual := First (Actuals); end if; while Present (Actual) and then Nkind (Actual) /= N_Parameter_Association loop Actuals_To_Match := Actuals_To_Match + 1; Actual := Next (Actual); end loop; if No (Actual) and Actuals_To_Match = Formals_To_Match then -- Most common case: positional notation, no defaults return True; elsif Actuals_To_Match > Formals_To_Match then -- Too many actuals: will not work. if Report then Error_Msg_N ("too many arguments in call", N); end if; return False; end if; First_Named := Actual; while Present (Actual) loop if Nkind (Actual) /= N_Parameter_Association then Error_Msg_N ("positional parameters not allowed after named ones", Actual); return False; else Actuals_To_Match := Actuals_To_Match + 1; end if; Actual := Next (Actual); end loop; if List_Present (Actuals) then Actual := First (Actuals); end if; Formal := First_Formal (S); while Present (Formal) loop -- Match the formals in order. If the corresponding actual -- is positional, nothing to do. Else scan the list of named -- actuals to find the one with the right name. if Present (Actual) and then Nkind (Actual) /= N_Parameter_Association then Actual := Next (Actual); Actuals_To_Match := Actuals_To_Match - 1; Formals_To_Match := Formals_To_Match - 1; else -- For named parameters, search the list of actuals to find -- one that matches the next formal name. Actual := First_Named; Found := False; while Present (Actual) loop if Chars (Selector_Name (Actual)) = Chars (Formal) then Found := True; Chain (Actual); Actuals_To_Match := Actuals_To_Match - 1; Formals_To_Match := Formals_To_Match - 1; exit; end if; Actual := Next (Actual); end loop; if not Found then if Ekind (Formal) /= E_In_Parameter or else No (Default_Value (Formal)) then if Report then Error_Msg_NE ("missing argument in call:&", N, Formal); end if; return False; else Formals_To_Match := Formals_To_Match - 1; null; -- Chain_Default_Node; end if; end if; end if; Formal := Next_Formal (Formal); end loop; if Formals_To_Match = 0 and then Actuals_To_Match = 0 then return True; else if Report then Error_Msg_N ("too many arguments in call", N); end if; return False; end if; end Normalize_Actuals; -------------------------------- -- Overflow_Checks_Suppressed -- -------------------------------- function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean is begin return Scope_Suppress.Overflow_Checks or else Suppress_Overflow_Checks (E); end Overflow_Checks_Suppressed; ----------------------------- -- Range_Checks_Suppressed -- ----------------------------- function Range_Checks_Suppressed (E : Entity_Id) return Boolean is begin return Scope_Suppress.Range_Checks or else Suppress_Range_Checks (E); end Range_Checks_Suppressed; ------------------------ -- Set_Current_Entity -- ------------------------ -- The given entity is to be set as the currently visible definition -- of its associated name (i.e. the Node_Id associated with its name). -- All we have to do is to get the name from the identifier, and -- then set the associated Node_Id to point to the given entity. procedure Set_Current_Entity (E : Entity_Id) is begin Set_Name_Entity_Id (Chars (E), E); end Set_Current_Entity; ----------------------- -- Set_Public_Status -- ----------------------- procedure Set_Public_Status (Id : Entity_Id) is S : Entity_Id := Current_Scope; begin if S = Standard_Standard or else (Is_Public (S) and then ((Ekind (S) = E_Package and then not Is_Package_Body (S)) or else Is_Record_Type (S) or else Ekind (S) = E_Void)) then Set_Is_Public (Id); end if; end Set_Public_Status; ------------------------------- -- Storage_Checks_Suppressed -- ------------------------------- function Storage_Checks_Suppressed (E : Entity_Id) return Boolean is begin return Scope_Suppress.Storage_Checks or else Suppress_Storage_Checks (E); end Storage_Checks_Suppressed; ----------------- -- Trace_Scope -- ----------------- procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : Str) is begin if Debug_Flag_C then for I in 0 .. Scope_Stack.Last loop Write_Str (" "); end loop; Write_Str (Msg); Write_Name (Chars (E)); Write_Str (" line "); Write_Int (Int (Get_Line_Number (Sloc (N)))); Write_Eol; end if; end Trace_Scope; --------------------------- -- Tag_Checks_Suppressed -- --------------------------- function Tag_Checks_Suppressed (E : Entity_Id) return Boolean is begin return Scope_Suppress.Tag_Checks or else Suppress_Tag_Checks (E); end Tag_Checks_Suppressed; ------------------------ -- Apply_Access_Check -- ------------------------ procedure Apply_Access_Check (N : Node_Id; Typ : Entity_Id) is begin if not Access_Checks_Suppressed (Typ) then Set_Do_Access_Check (N, True); end if; end Apply_Access_Check; ------------------------------ -- Apply_Discriminant_Check -- ------------------------------ procedure Apply_Discriminant_Check (N : Node_Id; Typ : Entity_Id) is begin if not Discriminant_Checks_Suppressed (Typ) then Set_Do_Discriminant_Check (N, True); end if; end Apply_Discriminant_Check; ----------------------- -- Apply_Range_Check -- ----------------------- -- A range constraint may be applied in some of the following contexts: -- object declaration, subtype declaration, derived declaration -- assignment, function/procedure/entry call, type conversion procedure Apply_Range_Check (N : Node_Id; Target_Type : Entity_Id) is Source_Type : constant Entity_Id := Etype (N); begin if Range_Checks_Suppressed (Target_Type) or else Index_Checks_Suppressed (Target_Type) then return; -- Confine the range checks currently to only signed integer types and -- enumeration types since support for floating point and fixed point -- types is too limited to do useful checks at this time and checks -- for modular types need to be better understood by us. elsif not (Is_Discrete_Type (Source_Type) and then Ekind (Source_Type) not in Modular_Kind) then return; -- ??? -- Currently the Etype of literals are given the subtype of LHS -- rather than the base type. When this is corrected this test can -- be removed. elsif Nkind (N) = N_Integer_Literal then if Is_Static_Subtype (Target_Type) and then UI_Le (Expr_Value (Type_Low_Bound (Target_Type)), Intval (N)) and then UI_Ge (Expr_Value (Type_High_Bound (Target_Type)), Intval (N)) then return; else null; end if; -- There is no need to have a range check at run-time if the value -- considered is guaranteed to be in the range of the target type -- even if it might be a dynamic value. elsif In_Subrange_Of (Source_Type, Target_Type) then return; end if; Set_Do_Range_Check (N, True); end Apply_Range_Check; -------------------------- -- Rewrite_Named_Number -- -------------------------- procedure Rewrite_Named_Number (N : Node_Id; Typ : Entity_Id) is E : constant Entity_Id := Entity (N); Expr : Node_Id; begin Expr := Expression (Parent (E)); -- The Nkind of Expr which is the value given in the original -- number declaration should be N_Interal_Literal or N_Real_Literal -- at this point since it has already been constant folded. Set_Is_Static (N, True); if Ekind (E) = E_Named_Integer then Rewrite_Int_Literal (N, Intval (Expr)); else Rewrite_Real_Literal (N => N, Num => Numerator (Expr), Den => Denominator (Expr), Decimal_Flag => Decimal (Expr)); end if; Set_Etype (N, Typ); end Rewrite_Named_Number; ------------------------------- -- Defining_Unit_Simple_Name -- ------------------------------- function Defining_Unit_Simple_Name (N : Node_Id) return Entity_Id is Nam : Node_Id := Defining_Unit_Name (N); begin if Nkind (Nam) in N_Entity then return Nam; else return Defining_Identifier (Nam); end if; end Defining_Unit_Simple_Name; ---------------------- -- Get_Index_Bounds -- ---------------------- procedure Get_Index_Bounds (I : Node_Id; L, H : out Node_Id) is Kind : Node_Kind := Nkind (I); begin if Kind = N_Range then L := Low_Bound (I); H := High_Bound (I); elsif Kind = N_Subtype_Indication then L := Low_Bound (Range_Expression (Constraint (I))); H := High_Bound (Range_Expression (Constraint (I))); elsif Kind in N_Entity_Name and then Is_Type (Entity (I)) then L := Low_Bound (Scalar_Range (Entity (I))); H := High_Bound (Scalar_Range (Entity (I))); else Compiler_Abort; end if; end Get_Index_Bounds; -------------------- -- In_Subrange_Of -- -------------------- function In_Subrange_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is begin if T1 = T2 or else Is_Subtype_Of (T1, T2) then return True; elsif not (Is_Static_Subtype (T1) and then Is_Static_Subtype (T2)) then return False; elsif Is_Discrete_Type (T1) then return UI_Le (Expr_Value (Type_Low_Bound (T2)), Expr_Value (Type_Low_Bound (T1))) and then UI_Ge (Expr_Value (Type_High_Bound (T2)), Expr_Value (Type_High_Bound (T1))); else return False; end if; end In_Subrange_Of; --------------- -- Same_Name -- --------------- function Same_Name (N1, N2 : Node_Id) return Boolean is K1 : constant Node_Kind := Nkind (N1); K2 : constant Node_Kind := Nkind (N2); begin if (K1 = N_Identifier or else K1 = N_Defining_Identifier) and then (K2 = N_Identifier or else K2 = N_Defining_Identifier) then return Chars (N1) = Chars (N2); elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name) and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name) then return Same_Name (Selector_Name (N1), Selector_Name (N2)) and then Same_Name (Prefix (N1), Prefix (N2)); else return False; end if; end Same_Name; --------------------------------- -- Set_Entity_With_Style_Check -- --------------------------------- procedure Set_Entity_With_Style_Check (N : Node_Id; Val : Node_Id) is SN : Source_Ptr := Sloc (N); SV : Source_Ptr := Sloc (Val); TN : Source_Buffer_Ptr; TV : Source_Buffer_Ptr; begin if GNAT_Style_Check and then Nkind (N) = N_Identifier and then Nkind (Val) = N_Defining_Identifier and then SN /= No_Location and then SN /= Standard_Location and then SV /= No_Location and then SV /= Standard_Location and then Length_Of_Name (Chars (N)) = Length_Of_Name (Chars (Val)) then TN := File.Table (Get_Sloc_Unit_Number (SN)).Source; TV := File.Table (Get_Sloc_Unit_Number (SV)).Source; -- A defensive check, if the two Sloc's do not point to instances -- of identical names, then we have some internal node with a strange -- Sloc, and we should not carry out the rest of the check. for I in 1 .. Length_Of_Name (Chars (N)) loop if Fold_Lower (TN (SN)) /= Fold_Lower (TV (SV)) then goto Done; end if; SN := SN + 1; SV := SV + 1; end loop; -- And both identifiers should now be ended! if Identifier_Char (TN (SN)) or else Identifier_Char (TV (SV)) then goto Done; end if; -- OK, this looks like a safe case to carry out the check SN := Sloc (N); SV := Sloc (Val); for I in 1 .. Length_Of_Name (Chars (N)) loop if TN (SN) /= TV (SV) then Error_Msg_Node_1 := Val; Error_Msg ("(style) bad identifier spelling, should be&", SN); goto Done; end if; SN := SN + 1; SV := SV + 1; end loop; end if; -- Come here when error check is completed <> Set_Entity (N, Val); end Set_Entity_With_Style_Check; ------------------------------ -- Static_Universal_Integer -- ------------------------------ function Static_Integer (N : Node_Id) return Uint is begin Analyze (N); Resolve_Complete_Context (N, Any_Integer); if Is_Static_Expression (N) then return Expr_Value (N); else Error_Msg_N ("static expression required here", N); return No_Uint; end if; end Static_Integer; ------------------- -- Unimplemented -- ------------------- procedure Unimplemented (N : Node_Id; Feature : Str) is Nstring : Str (1 .. Feature'Length + 21); begin -- Note: this is one place where we really would prefer to use & -- Error_Msg_N (Msg & " not implemented yet", N), but unfortunately -- dynamic concatenation is still a client of this procedure ??? Nstring (1 .. Feature'Length) := Feature; Nstring (Feature'Length + 1 .. Nstring'Length) := " not implemented yet!"; Error_Msg_N (Nstring, N); end Unimplemented; end Sem_Util; procedure Apply_Range_Check (N : Node_Id; Target_Type : Entity_Id) is Source_Type : constant Entity_Id := Etype (N); begin if Range_Checks_Suppressed (Target_Type) or else Index_Checks_Suppressed (Target_Type) then return; -- Confine the range checks currently to only signed integer types and -- enumeration types since support for floating point and fixed point gnat-1.67-src/src/sem_disp.ads 444 10015 7640 10347 5506244412 11434 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M - D I S P -- -- -- -- S p e c -- -- -- -- $Revision: 1.5 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This package contains routines involved in tagged types and dynamic -- dispatching. with Types; use Types; package Sem_Disp is procedure Check_Dispatching_Call (N : Node_Id); -- Check if a call is a dispatching call. The subprogram is known to -- be a dispatching operation. The call is dispatching if all the -- controlling actuals are dynamically tagged. This procedure is called -- after overload resolution, so the call is known to be unambiguous. procedure Check_Dispatching_Operation (Subp : Entity_Id); -- If a subprogram has a dispatching argument or result, add it to -- the list of primitive operations of the corresponding type. function Find_Controlling_Arg (N : Node_Id) return Node_Id; -- Returns the actual controlling argument if N is dynamically tagged, -- and Empty if it is not dynamically tagged. function Find_Dispatching_Type (Subp : Entity_Id) return Entity_Id; -- Check whether a subprogram is dispatching, and find the tagged -- type of the controlling argument or arguments. function Is_Dynamically_Tagged (N : Node_Id) return Boolean; -- Used to determine whether a call is dispatching, i.e. if is an -- an expression of a class_Wide type, or a call to a function with -- controlling result where at least one operand is dynamically tagged. function Is_Tag_Indeterminate (N : Node_Id) return Boolean; -- An expression is tag-indeterminate if it is a call that dispatches -- on result, and all controlling operands are also indeterminate. -- Such a function call may inherit a tag from an enclosing call. procedure Override_Dispatching_Operation (Prev_Op, New_Op : Entity_Id); -- Replace an implicit dispatching operation with an explicit one. -- Prev_Op is an inherited primitive operation which is overriden by -- the explicit declaration of New_Op. Find the tagged type of which both -- are dispatching operations, and replace Prev_Op in the corresponding -- list. The replacement must be a the same position because both must -- appear in the same location in the dispatch table. procedure Propagate_Tag (Control : Node_Id; Actual : Node_Id); -- If a function call is tag-indeterminate, its controlling argument is -- found in the context; either an enclosing call, or the left-hand side -- of the enclosing assignment statement. The tag must be propagated -- recursively to the tag-indeterminate actuals of the call. end Sem_Disp; -- -- -- -- S E M - D I S P -- -- -- -- S pgnat-1.67-src/src/sem_disp.adb 444 10015 7640 25542 5506244412 11416 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M - D I S P -- -- -- -- B o d y -- -- -- -- $Revision: 1.11 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Debug; use Debug; with Einfo; use Einfo; with Exp_Ch6; use Exp_Ch6; with Errout; use Errout; with Output; use Output; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; package body Sem_Disp is --------------------------- -- Find_Dispatching_Type -- --------------------------- function Find_Dispatching_Type (Subp : Entity_Id) return Entity_Id is Formal : Entity_Id := First_Formal (Subp); Tagged_Type : Entity_Id; Tagged_Seen : Entity_Id := Empty; procedure Check_Controlling_Type (T : Entity_Id) is begin if Is_Tagged_Type (T) then Tagged_Type := T; elsif (Is_Access_Type (T) and then Is_Tagged_Type (Designated_Type (T))) then Tagged_Type := Designated_Type (T); else Tagged_Type := Empty; end if; if Present (Tagged_Type) and then not Is_Class_Type (Tagged_Type) then if Present (Tagged_Seen) and then Tagged_Type /= Tagged_Seen then Error_Msg_N ("operation can be dispatching in only one type", Formal); else Tagged_Seen := Tagged_Type; end if; end if; end Check_Controlling_Type; -- Start of processing Find_Dispatching_Type begin while Present (Formal) loop Check_Controlling_Type (Etype (Formal)); Formal := Next_Formal (Formal); end loop; -- The subprogram may also be dispatching on result if Present (Etype (Subp)) then Check_Controlling_Type (Etype (Subp)); end if; return Tagged_Seen; end Find_Dispatching_Type; ---------------------------------- -- Check_Dispatching_Operation -- ---------------------------------- procedure Check_Dispatching_Operation (Subp : Entity_Id) is Tagged_Seen : constant Entity_Id := Find_Dispatching_Type (Subp); begin if Present (Tagged_Seen) and then not Is_Frozen (Tagged_Seen) then -- Subprogram is primitive operation of tagged type Append_Elmt (Subp, Primitive_Operations (Tagged_Seen)); Set_Is_Dispatching_Operation (Subp, True); if Is_Abstract (Subp) and then not Is_Abstract (Tagged_Seen) then Error_Msg_N ("only an abstract type can have dispatching operations", Subp); end if; else Set_Is_Dispatching_Operation (Subp, False); end if; end Check_Dispatching_Operation; ---------------------------- -- Check_Dispatching_Call -- ---------------------------- procedure Check_Dispatching_Call (N : Node_Id) is Actual : Node_Id; Control : Node_Id := Empty; begin -- Find a controlling argument, if any if List_Present (Parameter_Associations (N)) then Actual := First_Actual (N); while Present (Actual) loop Control := Find_Controlling_Arg (Actual); exit when Present (Control); Actual := Next_Actual (Actual); end loop; if Present (Control) then -- Verify that no controlling arguments are statically tagged if Debug_Flag_E then Write_Str ("Found Dispatching call"); Write_Int (Int (N)); Write_Eol; end if; Actual := First_Actual (N); while Present (Actual) loop if Actual /= Control then if not Is_Tagged_Type (Etype (Actual)) then null; -- can be anything elsif (Is_Dynamically_Tagged (Actual)) then null; -- valid parameter elsif Is_Tag_Indeterminate (Actual) then -- The tag is inherited from the enclosing call, -- namely the node we are currently analyzing. -- Expand the actual explicitly, because the previous -- call to expand (From resolve_call) did not know -- about the dispatching needed. Propagate_Tag (Control, Actual); else Error_Msg_N ("all dispatching call controlling arguments " & "must be dynamically tagged", Actual); return; end if; end if; Actual := Next_Actual (Actual); end loop; -- Mark call as a dispatching call Set_Controlling_Argument (N, Control); end if; else -- If dispatching on result, the enclosing call, if any, will -- determine the controlling argument. Otherwise this is the -- primitive operation of the root type. null; end if; end Check_Dispatching_Call; --------------------------- -- Is_Dynamically_Tagged -- --------------------------- function Is_Dynamically_Tagged (N : Node_Id) return Boolean is begin return Find_Controlling_Arg (N) /= Empty; end Is_Dynamically_Tagged; -------------------------- -- Find_Controlling_Arg -- -------------------------- function Find_Controlling_Arg (N : Node_Id) return Node_Id is Orig_Node : constant Node_Id := Original_Node (N); begin if not Is_Tagged_Type (Etype (N)) then return Empty; elsif (Is_Name (N) or else Nkind (N) = N_Explicit_Dereference or else Nkind (N) = N_Type_Conversion) and then Is_Class_Type (Etype (N)) then return N; elsif Nkind (Orig_Node) = N_Function_Call and then Present (Controlling_Argument (Orig_Node)) then return Controlling_Argument (Orig_Node); elsif Nkind (N) = N_Parenthesized_Expression or else Nkind (N) = N_Qualified_Expression then return Find_Controlling_Arg (Expression (N)); else return Empty; end if; end Find_Controlling_Arg; -------------------------- -- Is_Tag_Indeterminate -- -------------------------- function Is_Tag_Indeterminate (N : Node_Id) return Boolean is Nam : Entity_Id; Actual : Node_Id; Orig_Node : constant Node_Id := Original_Node (N); begin if Nkind (Orig_Node) = N_Function_Call then Nam := Entity (Name (Orig_Node)); if List_Present (Parameter_Associations (Orig_Node)) then Actual := First_Actual (Orig_Node); while Present (Actual) loop if Is_Tagged_Type (Etype (Actual)) and then Is_Dynamically_Tagged (Actual) then return False; -- one operand is dispatching end if; Actual := Next_Actual (Actual); end loop; return True; -- If there are no actuals, the call is tag-indeterminate else return True; end if; elsif Nkind (Orig_Node) = N_Parenthesized_Expression or else Nkind (Orig_Node) = N_Qualified_Expression then return Is_Tag_Indeterminate (Expression (Orig_Node)); else return False; end if; end Is_Tag_Indeterminate; ------------------------------------ -- Override_Dispatching_Operation -- ------------------------------------ procedure Override_Dispatching_Operation (Prev_Op, New_Op : Entity_Id) is Formal : Entity_Id := First_Entity (Prev_Op); Tagged_Type : Entity_Id := Empty; Prim_Ops : Elist_Id; Op_Elmt : Elmt_Id; begin while Present (Formal) loop if Is_Tagged_Type (Etype (Formal)) then Tagged_Type := Etype (Formal); exit; end if; Formal := Next_Entity (Formal); end loop; if No (Tagged_Type) then Tagged_Type := Etype (Prev_Op); -- Subprogram must be dispatching on result end if; Prim_Ops := Primitive_Operations (Tagged_Type); Op_Elmt := First_Elmt (Prim_Ops); while Op_Elmt /= No_Elmt loop if Id_Of (Op_Elmt) = Prev_Op then Insert_Elmt_Before (Op_Elmt, New_Op); Remove_Elmt (Op_Elmt); Remove_Elmt (Last_Elmt (Prim_Ops)); exit; end if; Op_Elmt := Next_Elmt (Op_Elmt); end loop; end Override_Dispatching_Operation; ------------------- -- Propagate_Tag -- ------------------- procedure Propagate_Tag (Control : Node_Id; Actual : Node_Id) is Call_Node : Node_Id; Arg : Node_Id; begin if Nkind (Actual) = N_Function_Call then Call_Node := Actual; else -- Parenthesized or qualified expression. Call_Node := Expression (Actual); end if; Set_Controlling_Argument (Call_Node, Control); Arg := First_Actual (Call_Node); while Present (Arg) loop if Is_Tag_Indeterminate (Arg) then Propagate_Tag (Control, Arg); end if; Arg := Next_Actual (Arg); end loop; Expand_Dispatch_Call (Call_Node); end Propagate_Tag; end Sem_Disp; ation of tagged type Append_Elmt (Subp, Primitive_Operations (Tagged_Seen)); Set_Is_Dispatching_Operation (Subp, True); if Is_Absgnat-1.67-src/src/sem_type.ads 444 10015 7640 25730 5506244413 11461 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ T Y P E -- -- -- -- S p e c -- -- -- -- $Revision: 1.5 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This unit contains the routines used to handle type determination, -- including the routine used to support overload resolution. with Table; with Types; use Types; package Sem_Type is --------------------------------------------- -- Data Structures for Overload Resolution -- --------------------------------------------- -- To determine the unique meaning of an identifier, overload resolution -- may have to be performed if the visibility rules alone identify more -- than one possible entity as the denotation of a given identifier. When -- the visibility rules find such a potential ambiguity, the set of -- possible interpretations must be attached to the identifier, and -- overload resolution must be performed over the innermost enclosing -- complete context. At the end of the resolution, either a single -- interpretation is found for all identifiers in the context, or else a -- type error (invalid type or ambiguous reference) must be signalled. -- The set of interpretations of a given name is stored in a data structure -- that is separate from the syntax tree, because it corresponds to -- transient information. The interpretations themselves are stored in -- table All_Interp. A mapping from tree nodes to sets of interpretations -- called Interp_Map, is maintained by the overload resolution routines. -- Both these structures are initialized at the beginning of every complete -- context. -- Corresponding to the set of interpretation for a given overloadable -- identifier, there is a set of possible types corresponding to the types -- that the overloaded call may return. We keep a 1-to-1 correspondence -- between interpretations and types: for user-defined subprograms the -- type is the declared return type. For operators, the type is determined -- by the type of the arguments. If the arguments themselves are -- overloaded, we enter the operator name in the names table for each -- possible result type. In most cases, arguments are not overloaded and -- only one interpretation is present anyway. -- Note: the All_Interp table is reset initially by calling Init_Interp. -- Subsequently, it is reset by Resolve_Complete_Context, since a call to -- Resolve_Complete_Context means that a complete context has been resolved -- and thus the interpretations stored in All_Interp are no longer needed. type Interp is record Nam : Entity_Id; Typ : Entity_Id; end record; No_Interp : constant Interp := (Empty, Empty); package All_Interp is new Table ( Component_Type => Interp, Index_Type => Int, Low_Bound => 0, Initial => 100, Increment => 10, Table_Name => "All_Interp"); -- The following data structures establish a mapping between nodes and -- their interpretations. Eventually the Interp_Index corresponding to -- the first interpretation of a node may be stored directly in the -- corresponding node. subtype Interp_Index is Int; type Interp_Ref is record Node : Node_Id; Index : Interp_Index; end record; package Interp_Map is new Table ( Component_Type => Interp_Ref, Index_Type => Int, Low_Bound => 0, Initial => 1000, Increment => 10, Table_Name => "Interp_Map"); -- For now Interp_Map is searched sequentially ----------------- -- Subprograms -- ----------------- procedure Init_Interp; -- Overload resolution is performed over each complete context. The data -- structures that store interpretations of overloaded nodes are reset -- by this call. It is not required that Init_Interp be called other -- than at the start of a compilation to initialize the data structures. -- However, efficiency in both time and space is improved by resetting -- the data structures more frequently between complete contexts. procedure Collect_Interps (N : Node_Id); -- Invoked when the name N has more than one visible interpretation. -- This is the high level routine which accumulates the possible -- interpretations of the node. The first meaning and type of N have -- already been stored in N. If the name is an expanded name, the homonyms -- are only those that belong to the same scope. procedure New_Interps (N : Node_Id); -- Initialize collection of interpretations for the given node, which is -- either an overloaded entity, or an operation whose arguments have -- multiple intepretations. Interpretations can be added to only one -- node at a time. procedure Add_One_Interp (N : Node_Id; E : Entity_Id; T : Entity_Id); -- Add (E, T) to the list of interpretations of the node being resolved. -- For calls and operators, i.e. for nodes that have a name field, -- E is an overloadable entity, and T is its type. For constructs such -- as indexed expressions, the caller sets E equal to T, because the -- overloading comes from other fields, and the node itself has no name -- to resolve. Add_One_Interp includes the semantic processing to deal -- with adding entries that hide one another etc. procedure End_Interp_List; -- End the list of interpretations of current node. procedure Get_First_Interp (N : Node_Id; I : out Interp_Index; It : out Interp); -- Initialize iteration over set of interpretations for Node N. The first -- interpretation is placed in It, and I is initialized for subsequent -- calls to Get_Next_Interp. procedure Get_Next_Interp (I : in out Interp_Index; It : out Interp); -- Iteration step over set of interpretations. Using the value in I, which -- was set by a previous call to Get_First_Interp or Get_Next_Interp, the -- next interpretation is placed in It, and I is updated for the next call. -- The end of the list of interpretations is signalled by It.Nam = Empty. procedure Remove_Interp (I : in out Interp_Index); -- Remove an interpretation that his hidden by another, or that does not -- match the context. The value of I on input was set by a call to either -- Get_First_Interp or Get_Next_Interp and references the interpretation -- to be removed. The only allowed use of the exit value of I is as input -- to a subsequent call to Get_Next_Interp, which yields the interpretation -- following the removed one. function Covers (T1, T2 : Entity_Id) return Boolean; -- This is the basic type compatibility routine. T1 is the expexted -- type, imposed by context, and T2 is the actual type. The processing -- reflects both the definition of type coverage and the rules -- for operand matching. function Disambiguate (Nam1, Nam2 : Entity_Id; Typ : Entity_Id) return Entity_Id; -- If two interpretations of a name in a call are visible, apply -- preference rules (universal types first) and operator visibility -- in order to remove ambiguity. function Find_Unique_Type (L : Node_Id; R : Node_Id) return Entity_Id; -- Used in second pass of resolution, for equality and comparison nodes. -- L is the left operand, whose type is known to be correct, and R is -- the right operand, which has one interpretation compatible with that -- of L. Return the type intersection of the two. function Has_Compatible_Type (N : Node_Id; Typ : Entity_Id) return Boolean; -- Verify that some interpretation of the node N has a type compatible -- with Typ. If N is not overloaded, then its unique type must be -- compatible with Typ. Otherwise iterate through the interpretations -- of N looking for a compatible one. function Hides_Op (F : Entity_Id; Op : Entity_Id) return boolean; -- A user-defined function hides a predefined operator if it is -- matches the signature of the operator, and is declared in an -- open scope, or in the scope of the result type. function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean; -- Checks whether T1 is any subtype of T2 directly or indirectly. function Intersect_Types (L, R : Node_Id) return Entity_Id; -- Simplest type checking for operators, no overloading: bottom-up check -- that arguments are consistent. If one of the arguments is universal, -- the result has the more specific type of the two. function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean; -- Used to resolve subprograms renaming operators, and calls to user -- defined operators. Determines whether a given operator Op, matches -- a specification, New_S. function Valid_Comparison_Arg (T : Entity_Id) return Boolean; -- A valid argument to an ordering operator must be a discrete type, a -- real type, or a one dimensional array with a discrete component type. function Valid_Boolean_Arg (T : Entity_Id) return Boolean; -- A valid argument of a boolean operator is either some boolean type, -- or a one-dimensional array of boolean type. procedure Write_Overloads (N : Node_Id); -- Debugging procedure to output info on possibly overloaded entities -- for specified node. end Sem_Type; Nkind (N1); K2 : constant Node_Kingnat-1.67-src/src/sem_type.adb 444 10015 7640 62433 5506244414 11442 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ T Y P E -- -- -- -- B o d y -- -- -- -- $Revision: 1.25 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Comperr; use Comperr; with Debug; use Debug; with Einfo; use Einfo; with Errout; use Errout; with Output; use Output; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Util; use Sem_Util; with Stand; use Stand; with Sinfo; use Sinfo; with Snames; use Snames; package body Sem_Type is ------------------------------------- -- Handling of Overload Resolution -- ------------------------------------- -- Overload resolution uses two passes over the syntax tree of a complete -- context. In the first, bottom-up pass, the types of actuals in calls -- are used to resolve possibly overloaded subprogram and operator names. -- In the second top-down pass, the type of the context (for example the -- condition in a while statement) is used to resolve a possibly ambiguous -- call, and the unique subprogram name in turn imposes a specific context -- on each of its actuals. -- Most expressions are in fact unambiguous, and the bottom-up pass is -- sufficient to resolve most everything. To simplify the common case, -- names and expressions carry a flag Is_Overloaded to indicate whether -- they have more than one interpretation. If the flag is off, then each -- name has already a unique meaning and type, and the bottom-up pass is -- sufficient (and much simpler). -------------------------- -- Operator Overloading -- -------------------------- -- The visibility of operators is handled differently from that of -- other entities. We do not introduce explicit versions of primitive -- operators for each type definition. As a result, there is only one -- entity corresponding to predefined addition on all numeric types, etc. -- The back-end resolves predefined operators according to their type. -- The visibility of primitive operations then reduces to the visibility -- of the resulting type: (a + b) is a legal interpretation of some -- primitive operator + if the type of the result (which must also be -- the type of a and b) is directly visible or use-visible. -- User-defined operators are treated like other functions, but the -- visibility of these user-defined operations must be special-cased -- to determine whether they hide or are hidden by predefined operators. -- The form P."+" (x, y) requires additional handling. -- -- Concatenation is treated more conventionally: for every one-dimensional -- array type we introduce a explicit concatenation operator. This is -- necessary to handle the case of (element & element => array) which -- cannot be handled conveniently if there is no explicit instance of -- resulting type of the operation. ----------------------- -- Local Subprograms -- ----------------------- function Is_Ancestor (T1, T2 : Entity_Id) return Boolean; -- T1 is a class type. Verify that it is one of the ancestors of -- type T2. ----------------- -- Init_Interp -- ----------------- procedure Init_Interp is begin Interp_Map.Init; All_Interp.Init; end Init_Interp; ----------------- -- New_Interps -- ----------------- procedure New_Interps (N : Node_Id) is begin Interp_Map.Increment_Last; All_Interp.Increment_Last; Interp_Map.Table (Interp_Map.Last) := (N, All_Interp.Last); All_Interp.Table (All_Interp.Last) := No_Interp; Set_Is_Overloaded (N, True); end New_Interps; --------------------- -- Collect_Interps -- --------------------- procedure Collect_Interps (N : Node_Id) is H : Entity_Id; First_Interp : Interp_Index; begin New_Interps (N); First_Interp := All_Interp.Last; Add_One_Interp (N, Entity (N), Etype (N)); H := Homonym (Entity (N)); if Nkind (N) = N_Expanded_Name then while Present (H) and then Scope (H) = Scope (Entity (N)) loop Add_One_Interp (N, H, Etype (H)); H := Homonym (H); end loop; else while Present (H) loop exit when not Is_Overloadable (H); if Is_Directly_Visible (H) or else Is_Use_Visible (H) then -- Only add interpretation if not hidden by an inner -- directly-visible one. for I in First_Interp .. All_Interp.Last - 1 loop -- Current homograph is not hidden. Add to overloads. if not Is_Directly_Visible (All_Interp.Table (I).Nam) then exit; -- Homograph is hidden elsif Type_Conformant (All_Interp.Table (I).Nam, H) then goto next_homograph; end if; end loop; -- On exit, we know that current homograph is not hidden. Add_One_Interp (N, H, Etype (H)); if Debug_Flag_E then Write_Str ("Add overloaded Interpretation "); Write_Int (Int (H)); Write_Eol; end if; end if; <> H := Homonym (H); end loop; end if; -- If more than one interpretation exists, then mark the end -- of the list of interpretations. if Is_Overloaded (N) then End_Interp_List; end if; end Collect_Interps; -------------------- -- Add_One_Interp -- -------------------- procedure Add_One_Interp (N : Node_Id; E : Entity_Id; T : Entity_Id) is procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id) is Index : Interp_Index; It : Interp; begin Get_First_Interp (N, Index, It); while Present (It.Nam) loop -- A user-defined function hides another declared at an outer -- level, or one that is use-visible. if Ekind (Name) = E_Function and then Ekind (It.Nam) = E_Function and then Is_Directly_Visible (It.Nam) and then Type_Conformant (Name, It.Nam) then -- Previous definition hides new one (which is either in outer -- scope or use-visible). return; end if; Get_Next_Interp (Index, It); end loop; -- On exit, enter new interpretation. The context, or a preference -- rule, will resolve the ambiguity on the second pass. All_Interp.Table (All_Interp.Last) := (Name, Typ); All_Interp.Increment_Last; All_Interp.Table (All_Interp.Last) := No_Interp; end Add_Entry; -- Processing for Add_One_Interp starts here begin -- If the interpretation is a predefined operator, verify that the -- result type is visible. if Ekind (E) = E_Operator and then not (In_Open_Scopes (Scope (T)) or else Is_Use_Visible (T)) then return; end if; -- If this is the first interpretation of N, N has type Any_Type. -- In that case place the new type on the node. If one interpretation -- already exists, indicate that the node is overloaded, and store -- both the previous and the new interpretation in All_Interp. If -- this is a later interpretation, just add it to the set. if Etype (N) = Any_Type then if Is_Type (E) then Set_Etype (N, T); else -- Record both the operator or subprogram name, and its type. if Nkind (N) in N_Op or else Is_Name (N) then Set_Entity (N, E); end if; Set_Etype (N, T); end if; -- Either there is no current interpretation in the table for any -- node or the interpretation that is present is for a different -- node. In both cases add a new interpretation to the table. elsif Interp_Map.Last < Interp_Map.First or else Interp_Map.Table (Interp_Map.Last).Node /= N then New_Interps (N); if (Nkind (N) in N_Op or else Is_Name (N)) and then Present (Entity (N)) then Add_Entry (Entity (N), Etype (N)); elsif Nkind (N) = N_Function_Call or else Nkind (N) = N_Procedure_Call_Statement then Add_Entry (Entity (Name (N)), Etype (N)); else -- Overloaded prefix in indexed or selected component, etc. Add_Entry (Etype (N), Etype (N)); end if; Add_Entry (E, T); else Add_Entry (E, T); end if; end Add_One_Interp; --------------------- -- End_Interp_List -- --------------------- procedure End_Interp_List is begin All_Interp.Table (All_Interp.Last) := No_Interp; All_Interp.Increment_Last; end End_Interp_List; ---------------------- -- Get_First_Interp -- ---------------------- procedure Get_First_Interp (N : Node_Id; I : out Interp_Index; It : out Interp) is Int_Ind : Interp_Index; begin for Index in 0 .. Interp_Map.Last loop if Interp_Map.Table (Index).Node = N then Int_Ind := Interp_Map.Table (Index).Index; It := All_Interp.Table (Int_Ind); I := Int_Ind; return; end if; end loop; -- Procedure should never be called if the node has no interpretations Compiler_Abort; end Get_First_Interp; ---------------------- -- Get_Next_Interp -- ---------------------- procedure Get_Next_Interp (I : in out Interp_Index; It : out Interp) is begin I := I + 1; It := All_Interp.Table (I); end Get_Next_Interp; ------------------- -- Remove_Interp -- ------------------- procedure Remove_Interp (I : in out Interp_Index) is II : Interp_Index; begin -- Find end of Interp list and copy downward to erase the discarded one II := I + 1; while Present (All_Interp.Table (II).Typ) loop II := II + 1; end loop; for J in I + 1 .. II loop All_Interp.Table (J - 1) := All_Interp.Table (J); end loop; -- Back up interp. index to insure that iterator will pick up next -- available interpretation. I := I - 1; end Remove_Interp; ------------ -- Covers -- ------------ function Covers (T1, T2 : Entity_Id) return Boolean is Typ1 : Entity_Id := T1; Typ2 : Entity_Id := T2; begin pragma Assert (Present (T1) and Present (T2)); -- Result is returned as a giant logical expression covering the cases return -- Simplest case: same types Base_Type (Typ1) = Base_Type (Typ2) -- Literals are compatible with types in a given "class" or else (Typ2 = Universal_Integer and then Is_Integer_Type (Typ1)) or else (Typ2 = Universal_Real and then Is_Real_Type (Typ1)) or else (Typ2 = Any_String and then Is_String_Type (Typ1)) or else (Typ2 = Any_Character and then Is_Character_Type (Typ1)) or else (Typ2 = Any_Access and then Is_Access_Type (Typ1)) -- The context and/or the actual type may be class types or else ( Is_Class_Type (Typ1) and then Is_Ancestor (Etype (Typ1), Typ2)) or else ( Is_Class_Type (Typ2) and then Etype (Typ2) = Typ1) -- Some contexts require a class of types rather than a specific type or else (Typ1 = Any_Integer and then Is_Integer_Type (Typ2)) or else (Typ1 = Any_Boolean and then Is_Boolean_Type (Typ2)) -- An aggregate is compatible with an array or record type or else (Typ2 = Any_Composite and then Ekind (Typ1) in E_Array_Type .. E_Record_Subtype) -- If the expected type is an anonymous access, the designated -- type must cover that of the expression. or else (Ekind (Typ1) = E_Anonymous_Access_Type and then Covers (Designated_Type (Typ1), Designated_Type (Typ2))) or else (Ekind (Typ1) = E_Access_Subprogram_Type and then Is_Access_Type (Typ2) and then Is_Overloadable (Designated_Type (Typ2)) and then Type_Conformant (Designated_Type (Typ1), Designated_Type (Typ2))) or else (Ekind (Typ2) = E_Allocator_Type and then Covers (Designated_Type (Typ1), Designated_Type (Typ2))) -- the actual type may be the result of a previous error or else (Typ2 = Any_Type); end Covers; function Disambiguate (Nam1, Nam2 : Entity_Id; Typ : Entity_Id) return Entity_Id is Predef_Subp : Entity_Id; User_Subp : Entity_Id; begin if Ekind (Nam1) = E_Operator then Predef_Subp := Nam1; User_Subp := Nam2; elsif Ekind (Nam2) = E_Operator then Predef_Subp := Nam2; User_Subp := Nam1; else -- if two user defined subprograms are visible, there is a true -- ambiguity. return Any_Id; end if; -- If the context is universal, the predefined operator is preferred. if Typ = Universal_Integer or else Typ = Universal_Real then return Predef_Subp; -- If the user-defined operator is in an open scope, or in the scope -- of the resulting type, it hides the predefined operator for the -- type. elsif Hides_Op (User_Subp, Predef_Subp) then return User_Subp; -- otherwise, the predefined operator has precedence. else return Predef_Subp; end if; end Disambiguate; ------------------------- -- Has_Compatible_Type -- ------------------------- function Has_Compatible_Type (N : Node_Id; Typ : Entity_Id) return Boolean is I : Interp_Index; It : Interp; begin if not Is_Overloaded (N) then return Covers (Typ, Etype (N)) or else (not Is_Tagged_Type (Typ) and then Covers (Etype (N), Typ)); else Get_First_Interp (N, I, It); while Present (It.Typ) loop if Covers (Typ, It.Typ) or else (not Is_Tagged_Type (Typ) and then Covers (It.Typ, Typ)) then return True; end if; Get_Next_Interp (I, It); end loop; return False; end if; end Has_Compatible_Type; -------------- -- Hides_Op -- -------------- function Hides_Op (F : Entity_Id; Op : Entity_Id) return boolean is begin -- TBSL: if result type is universal, prefer universal (predefined) -- interpretation. return Operator_Matches_Spec (Op, F) and then (In_Open_Scopes (Scope (F)) or else Scope (F) = Scope (Etype (First_Formal (F)))); end Hides_Op; ----------------- -- Is_Ancestor -- ----------------- function Is_Ancestor (T1, T2 : Entity_Id) return Boolean is Par : Entity_Id; begin if T1 = T2 then return True; else Par := Etype (T2); loop if T1 = Par then return True; elsif Etype (Par) /= Par then Par := Etype (Par); else return False; end if; end loop; end if; end Is_Ancestor; ------------------- -- Is_Subtype_Of -- ------------------- function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is S : Entity_Id; begin S := Parent_Subtype (T1); while Present (S) loop if S = T2 then return True; else S := Parent_Subtype (S); end if; end loop; return False; end Is_Subtype_Of; ---------------------- -- Find_Unique_Type -- ---------------------- function Find_Unique_Type (L : Node_Id; R : Node_Id) return Entity_Id is I : Interp_Index; It : Interp; T : Entity_Id := Etype (L); begin if Is_Overloaded (R) then Get_First_Interp (R, I, It); while Present (It.Typ) loop if Covers (T, It.Typ) or else Covers (It.Typ, T) then Set_Etype (R, It.Typ); exit; end if; Get_Next_Interp (I, It); end loop; else -- Etype of R is correct. null; end if; return Intersect_Types (L, R); end Find_Unique_Type; --------------------- -- Intersect_Types -- --------------------- function Intersect_Types (L, R : Node_Id) return Entity_Id is T1 : Entity_Id := Etype (L); T2 : Entity_Id := Etype (R); begin if (T1 = Any_Type or else T2 = Any_Type) then return Any_Type; end if; if Base_Type (T1) = Base_Type (T2) then return Base_Type (T1); elsif (T1 = Universal_Integer and then Is_Integer_Type (T2)) or else (T1 = Universal_Real and then Is_Real_Type (T2)) then return Base_Type (T2); elsif (T2 = Universal_Integer and then Is_Integer_Type (T1)) or else (T2 = Universal_Real and then Is_Real_Type (T1)) then return Base_Type (T1); elsif (T2 = Any_String and then Is_String_Type (T1)) then return Base_Type (T1); elsif (T1 = Any_String and then Is_String_Type (T2)) then return Base_Type (T2); elsif (T2 = Any_Character and then Is_Character_Type (T1)) then return Base_Type (T1); elsif (T1 = Any_Character and then Is_Character_Type (T2)) then return Base_Type (T2); elsif (T1 = Any_Access and then Is_Access_Type (T2)) then return T2; elsif (T2 = Any_Access and then Is_Access_Type (T1)) then return T1; elsif (T2 = Any_Composite and then Ekind (T1) in E_Array_Type .. E_Record_Subtype) then return T1; elsif (T1 = Any_Composite and then Ekind (T2) in E_Array_Type .. E_Record_Subtype) then return T2; elsif Is_Class_Type (T1) and then Is_Ancestor (Etype (T1), T2) then -- Can only happen for equality operators (the other predefined -- operators cannot apply to tagged types). return T1; elsif Is_Class_Type (T2) and then Is_Ancestor (Etype (T2), T1) then return T2; else Error_Msg_N ("incompatible types for operator", Parent (L)); return Any_Type; end if; end Intersect_Types; --------------------------- -- Operator_Matches_Spec -- --------------------------- function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean is New_F, Old_F : Entity_Id; Num : Int := 0; Op_Name : Name_Id := Chars (Op); T1, T2 : Entity_Id; T : constant Entity_Id := Etype (New_S); begin -- To verify that a predefined operator matches a given signature, -- do a case analysis of the operator classes. Function can have one -- or two formals and must have the proper result type. New_F := First_Formal (New_S); Old_F := First_Formal (Op); while Present (New_F) and then Present (Old_F) loop Num := Num + 1; New_F := Next_Formal (New_F); Old_F := Next_Formal (Old_F); end loop; if Present (Old_F) or else Present (New_F) then return False; -- different number of parameters elsif Num = 1 then T1 := Etype (First_Formal (New_S)); if Op_Name = Name_Op_Subtract or else Op_Name = Name_Op_Add or else Op_Name = Name_Op_Abs then return Base_Type (T1) = Base_Type (T) and then Is_Numeric_Type (T); elsif Op_Name = Name_Op_Not then return Base_Type (T1) = Base_Type (T) and then Valid_Boolean_Arg (Base_Type (T)); else return False; end if; else -- Binary operators. T1 := Etype (First_Formal (New_S)); T2 := Etype (Next_Formal (First_Formal (New_S))); if Op_Name = Name_Op_And or else Op_Name = Name_Op_Or or else Op_Name = Name_Op_Xor then return Base_Type (T1) = Base_Type (T2) and then Base_Type (T1) = Base_Type (T) and then Valid_Boolean_Arg (Base_Type (T)); elsif Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne then return Base_Type (T1) = Base_Type (T2) and then Is_Boolean_Type (T); elsif Op_Name = Name_Op_Lt or else Op_Name = Name_Op_Le or else Op_Name = Name_Op_Gt or else Op_Name = Name_Op_Ge then return Base_Type (T1) = Base_Type (T2) and then Valid_Comparison_Arg (T1) and then Is_Boolean_Type (T); elsif Op_Name = Name_Op_Add or else Op_Name = Name_Op_Subtract then return Base_Type (T1) = Base_Type (T2) and then Base_Type (T1) = Base_Type (T) and then Is_Numeric_Type (T); elsif Op_Name = Name_Op_Multiply or else Op_Name = Name_Op_Divide then -- TBSL : mixed-mode operators. return Base_Type (T1) = Base_Type (T2) and then Base_Type (T1) = Base_Type (T) and then Is_Numeric_Type (T); elsif Op_Name = Name_Op_Mod or else Op_Name = Name_Op_Rem then return Base_Type (T1) = Base_Type (T2) and then Base_Type (T1) = Base_Type (T) and then Is_Integer_Type (T); elsif Op_Name = Name_Op_Expon then return Base_Type (T1) = Base_Type (T) and then Is_Numeric_Type (T) and then Is_Integer_Type (T2); elsif Op_Name = Name_Op_Concat then return Is_Array_Type (T) and then (Base_Type (T1) = Base_Type (T) or else (Base_Type (T1) = Base_Type (Component_Type (T)))) and then (Base_Type (T2) = Base_Type (T) or else (Base_Type (T2) = Base_Type (Component_Type (T)))); else return False; end if; end if; end Operator_Matches_Spec; --------------------------- -- Valid_Comparison_Arg -- --------------------------- function Valid_Comparison_Arg (T : Entity_Id) return Boolean is begin return Is_Discrete_Type (T) or else Is_Real_Type (T) or else (Is_Array_Type (T) and then Number_Dimensions (T) = 1 and then Is_Discrete_Type (Component_Type (T))); end Valid_Comparison_Arg; ----------------------- -- Valid_Boolean_Arg -- ----------------------- function Valid_Boolean_Arg (T : Entity_Id) return Boolean is begin return Is_Boolean_Type (T) or else (Is_Array_Type (T) and then Number_Dimensions (T) = 1 and then Is_Boolean_Type (Component_Type (T))) or else Ekind (T) in Modular_Kind or else T = Universal_Integer; end Valid_Boolean_Arg; --------------------- -- Write_Overloads -- --------------------- procedure Write_Overloads (N : Node_Id) is I : Interp_Index; It : Interp; Nam : Entity_Id; begin if not Is_Overloaded (N) then Write_Str ("Non-overloaded entity "); Write_Eol; Write_Entity_Info (Entity (N), " "); else Get_First_Interp (N, I, It); Write_Str ("Overloaded entity "); Write_Eol; Nam := It.Nam; while Present (Nam) loop Write_Entity_Info (Nam, " "); Write_Str ("================="); Write_Eol; Get_Next_Interp (I, It); Nam := It.Nam; end loop; end if; end Write_Overloads; end Sem_Type; rn True; else S := Parent_Subtype (S); end if; end loop; return False; end Is_Subtype_Of; ---------------------- -- Find_Unique_Type -- ---------------------- function Fignat-1.67-src/src/sinfo.ads 444 10015 7640 665635 5506244422 11010 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S I N F O -- -- -- -- S p e c -- -- -- -- $Revision: 1.128 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Sinfo is -- This package defines the structure of the abstract syntax tree. The Tree -- package provides a basic tree structure. Sinfo describes how this -- structure is used to represent the syntax of an Ada program. -- Note: the grammar used here is taken from Version 3.0 of the AARM, dated -- 8 July 1993 14:33. The grammar in the AARM is followed very closely in -- the tree design, and is repeated as part of this document. It also -- incorporates changes (in the area of abstract types) made after the -- recent WG9 meeting in Boston. -- The tree contains not only the full syntactic representation of the -- program, but also the results of semantic analysis. In particular, the -- nodes for defining identifiers, defining character literals and defining -- operator symbols, collectively referred to as entities, represent what -- would normally be regarded as the symbol table information. In addition -- a number of the tree nodes contain semantic information. -- WARNING: There is a C version of this package. Any changes to this -- source file must be properly reflected in this C header file sinfo.h -- which is created automatically from sinfo_.ada using xsinfo.spt. --------------------------------- -- Making Changes to This File -- --------------------------------- -- If changes are made to this file, a number of related steps must be -- carried out to ensure consistency. First, if a field access function -- is added, it appears in six places: -- The documentation associated with the node -- The spec of the access function in sinfo.ads -- The body of the access function in sinfo.adb -- The spec of the set procedure in sinfo.ads -- The body of the set procedure in sinfo.adb -- The pragma Inline at the end of sinfo.ads -- The field chosen must be consistent in all places, and, for a node -- that is a subexpression, must not overlap any of the standard -- expression fields. In the body, the calls to the Dcheck_Node debug -- procedure will need cross-references adding in alphabetical order. -- If a new tree node is added, then the following changes are made -- Add it to the documentation in the appropriate place -- Add its fields to this documentation section -- Define it in the appropriate classification in Node_Kind -- In the body (sinfo), add entries to the Dcheck calls for all -- its fields (except standard expression fields) to include -- the new node in the debug cross-reference list -- Add an appropriate section to the case statement in sprint.adb -- Add an appropriate section to the case statement in sem.adb -- For a subexpression, add an appropriate sections to the case -- statement in sem_eval.adb -- For a subexpression, add an appropriate sections to the case -- statement in sem_res.adb -- Finally, four utility programs must be run: -- Run csinfo.spt to check that you have made the changes consistently. -- It checks most of the rules given above, with clear error messages. -- This utility reads sinfo.ads and sinfo.adb and generates a report -- to standard output. -- Run xsinfo.spt to create a-sinfo.h, the corresponding C header. This -- utility reads sinfo.ads and generates a-sinfo.h. Note that it -- does not need to read sinfo.adb, since the contents of the body -- are algorithmically determinable from the spec. -- Run xtreeprs.spt to create treeprs.ads, an updated version of -- the module that is used to drive the tree print routine. This -- utility reads (but does not modify) treeprs.adt, the template -- that provides the basic structure of the file, and then fills in -- the data from the comments in sinfo.ads. -- Run xnmake.spt to create nmake.ads and nmake.adb, the package body -- and spec of the Nmake package which contains functions for -- constructing nodes. -- Note: sometime we could write a utility that actually generated the -- body of sinfo from the spec instead of simply checking it, since, as -- noted above, the contents of the body can be determined from the spec. -------------------------------- -- Implicit Nodes in the Tree -- -------------------------------- -- Generally the structure of the tree very closely follows the grammar -- as defined in the RM. However, certain nodes are omitted to save -- space and simplify semantic processing. Two general classes of such -- omitted nodes are as follows: -- If the only possibilities for a non-terminal are one or more other -- non terminals (i.e. the rule is a "skinny" rule), then usually the -- corresponding node is omitted from the tree, and the target construct -- appears directly. For example, a real type definition is either a -- floating point definition or a fixed point definition. No explicit -- node appears for real type definition. Instead either the floating -- point definition or fixed point definition appears directly. -- If a non-terminal corresponds to a list of some other non-terminal -- (possibly with separating punctuation), then usually it is omitted -- from the tree, and a list of components appears instead. For -- example, sequence of statements does not appear explicitly in the -- tree. Instead a list of statements appears directly. -- Some additional cases of omitted nodes occur and are documented -- individually. In particular, many nodes are omitted in the tree -- generated for an expression. ------------------------------------------- -- Handling of Defining Identifier Lists -- ------------------------------------------- -- In several declarative forms in the syntax, lists of defining -- identifiers appear (object declarations, component declarations, -- number declarations etc.) -- The semantics of such statements are equivalent to a series of -- identical declarations of single defining identifiers (except that -- conformance checks require the same grouping of identifiers in the -- parameter case). -- To simplify semantic processing, the parser breaks down such multiple -- declaration cases into sequences of single declarations, duplicating -- type and initialization information as required. The flags More_Ids -- and Prev_Ids are used to record the original form of the source in -- the case where the original source used a list of names, More_Ids -- being set on all but the last name and Prev_Ids being set on all -- but the first name. These flags are used to reconstruct the original -- source (e.g. in the Sprint package), and also are included in the -- conformance checks, but otherwise have no semantic significance. -- Note: the reason that we use More_Ids and Prev_Ids rather than -- First_Name and Last_Name flags is so that the flags are off in the -- normal one identifier case, which minimizes tree print output. ----------------------- -- Use of Node Lists -- ----------------------- -- With a few exceptions, if a construction of the form {non-terminal} -- appears in the tree, lists are used in the corresponding tree node -- (see package Atree for handling of node lists). In this case a field of -- the parent node points to a list of nodes for the non-terminal. The -- field name for such fields has a plural name which always ends in "s". -- For example, a case statement has a field Alternatives pointing to a -- list of case statement alternative nodes. -- Only fields pointing to lists have names ending in "s", so generally -- the structure is strongly typed, fields not ending in s point to -- single nodes, and fields ending in s point to lists. -- The following example shows how a traversal of a list is written. We -- suppose here that Stmt points to a N_Case_Statement node which has -- a list field called Alternatives: -- Alt := First (Alternatives (Decl)); -- while Present (Alt) loop -- .. -- -- processing for case statement alternative Alt -- .. -- Alt := Next (Alt); -- end loop; -- The Present function tests for Empty, which in this case signals the -- end of the list. First returns Empty immediately if the list is empty. -- The exceptions to this rule occur with {DEFINING_IDENTIFIERS} in all -- contexts, which is handled as described in the previous section, and -- with {,library_unit_NAME} in the N_With_Clause mode, which is handled -- using the First_Name and Last_Name flags, as further detailed in the -- description of the N_With_Clause node. --------------------- -- Optional Fields -- --------------------- -- Fields which correspond to a section of the syntax enclosed in square -- brackets are generally omitted (and the corresponding field set to -- Empty for a node, or No_List for a list). The documentation of such -- fields notes these cases. One exception to this rule occurs in the -- case of possibly empty statement sequences (such as the sequence of -- statements in an entry call alternative). Such cases appear in the -- syntax rules as [SEQUENCE_OF_STATEMENTS] and the fields corresponding -- to such optional statement sequences always contain an empty list (not -- No_List) if no statements are present. -- Note: the utility program that constructs the body and spec of the -- Nmake package relies on the format of the comments to determine if -- a field should have a default value in the corresponding make routine. -- The rule is that if the first line of the description of the field -- contains the string "(set to xxx if", then a default value of xxx is -- provided for this field in the corresponding Make_yyy routine. ----------------------------------- -- Note on Body/Spec Terminology -- ----------------------------------- -- In informal discussions about Ada, it is customary to refer to package -- and subprogram specs and bodies. However, this is not technically -- correct, what is normally referred to as a spec or specification is in -- fact a package declaration or subprogram declaration. We are careful -- in GNAT to use the correct terminology and in particular, the full -- word specification is never used as an incorrect substitute for -- declaration. The structure and terminology used in the tree also -- reflects the grammar and thus uses declaration and specification in -- the technically correct manner. -- However, there are contexts in which the informal terminology is -- useful. We have the word "body" to refer to the entity declared by -- the declaration of a unit body, and in some contexts we need a -- similar term to refer to the entity declared by the package or -- subprogram declaration, and simply using declaration can be confusing -- since the body also has a declaration. -- An example of such a context is the link between the package body -- and its declaration. With_Declaration is confusing, since -- the package body itself is a declaration. -- To deal with this problem, we reserve the informal term Spec, i.e. -- the popular abbreviation used in this context, to refer to the entity -- declared by the package or subprogram declaration. So in the above -- example case, the field in the body is called With_Spec. -- Another important context for the use of the word Spec is in error -- messages, where a hyper-correct use of declaration would be confusing -- to a typical Ada programmer, and even for an expert programmer can -- cause confusion since the body has a declaration as well. -- So, to summarize: -- Declaration always refers to the syntactic entity that is called -- a declaration. In particular, subprogram declaration -- and package declaration are used to describe the -- syntactic entity that includes the semicolon. -- Specification always refers to the syntactic entity that is called -- a specification. In particular, the terms procedure -- specification, function specification, package -- specification, subprogram specification always refer -- to the syntactic entity that has no semicolon. -- Spec is an informal term, used to refer to the entity -- that is declared by a task declaration, protected -- declaration, generic declaration, subprogram -- declaration or package declaration. -- This convention is followed throughout the GNAT documentation -- both internal and external, and in all error message text. ------------------------ -- Internal Use Nodes -- ------------------------ -- These are Node_Kind settings used in the internal implementation -- which are not logically part of the specification. -- N_Unused_At_Start -- Completely unused entry at the start of the enumeration type. This -- is inserted so that no legitimate value is zero, which helps to get -- better debugging behavior, since zero is a likely uninitialized value). -- N_Unused_At_End -- Completely unused entry at the end of the enumeration type. This is -- handy so that arrays with Node_Kind as the index type have an extra -- entry at the end (see for example the use of the Pchar_Pos_Array in -- Treepr, where the extra entry provides the limit value when dealing -- with the last used entry in the array). --------------------- -- Syntactic Nodes -- --------------------- -- In the following node definitions, all fields, both syntactic and -- semantic, are documented, as well as fields that are set by the -- library processing. The one exception is in the case of entities -- (defining indentifiers, character literals and operator symbols), -- where the usage of the fields depends on the entity kind. -- Some fields are marked -Lib, which means that they are the result -- of the library processing. The description of the usage of these -- fields appears in a following section in this file. -- In the node definitions, three common sets of fields are abbreviated -- to save both space in the documentation, and also space in the string -- (defined in Tree_Print_Strings) used to print trees. The following -- abbreviations are used: -- "plus fields for binary operator" -- Chars (Name1) contains the Name_Id for the operator -- Left_Opnd (Node2) is the left operand expression -- Right_Opnd (Node3) is the right operand expression -- Entity (Node4-Sem) -- Do_Overflow_Check (Flag2-Sem) -- "plus fields for unary operator" -- Chars (Name1) contains the Name_Id for the operator -- Right_Opnd (Node3) is the right operand expression -- Entity (Node4-Sem) -- Do_Overflow_Check (Flag2-Sem) -- "plus fields for expression" -- Parens (Flag1) set if parenthesized -- Etype (Node5-Sem) is the type of the expression -- Is_Overloaded (Flag5-Sem) used during overload resolution -- Is_Static (Flag6-Sem) set for static expression -- Is_Evaluated (Flag7-Sem) set if expression evaluated -- Has_No_Side_Effects (Flag8-Sem) set if known to be SE free -- Do_Range_Check (Flag9-Sem) set if a range check is required -- Evaluate_Once (Flag10-Sem) set to evaluate expression only once -- Node_Kind is the type used in the Nkind field to indicate the node -- kind. The actual definition of this type is given later (the reason -- for this is that we want the descriptions ordered by logical chapter -- in the RM, but the type definition is reordered to facilitate the -- definition of some subtype ranges. The individual descriptions of -- the nodes show how the various fields are used in each node kind, -- as well as providing logical names for the fields. Functions and -- procedures are provided for accessing and setting these fields -- using these logical names. ------------------------ -- Common Flag Fields -- ------------------------ -- The following flag fields appear in all nodes -- Analyzed (Flag19-Sem) -- This flag is used to indicate that a node (and all its children -- have been analyzed. It is used to avoid reanalysis of a node that -- has already been analyzed, both for efficiency and functional -- correctness reasons. -- Error_Posted (Flag20) -- This flag is used to avoid multiple error messages being posted -- on or referring to the same node. This flag is set if an error -- message refers to a node or is posted on its source location, -- and has the effect of inhibiting further messages involving -- this same node. ------------------------------------ -- Description of Semantic Fields -- ------------------------------------ -- The meaning of the syntactic fields is generally clear from their -- names without any further description, since the names are chosen -- to correspond very closely to the syntax in the reference manual. -- This section describes the usage of the semantic fields, which are -- used to contain additional information determined during semantic -- analysis. -- Activation_Chain_Entity (Node2-Sem) -- This is used in tree nodes representing task activators (blocks, -- subprogram bodies, package declarations, and task bodies). It is -- initially Empty, and then gets set to point to the entity for the -- declared Activation_Chain variable when the first task is declared. -- When tasks are declared in the corresponding declarative region -- this entity is located by name (its name is always _Chain) and -- the declared tasks are added to the chain. -- Acts_As_Spec (Flag4-Sem) -- A flag set in the N_Subprogram_Body node for a subprogram body -- which is acting as its own spec. This flag also appears in the -- compilation unit node at the library level for such a subprogram -- (see further description in spec of Lib package). -- Assignment_OK (Flag5-Sem) -- This flag is set in an assignment node to permit an assignment to -- a discriminant without generating a semantic error. Such assignments -- are not permitted at the Ada source level, but they occur during the -- creation of subsidiary routines for copying and initializing variant -- record values. This flag is also used to permit an assignment to -- a limited private type (used for initialization of task values). -- Body_Required (Flag3-Sem) -- A flag that appears in the N_Compilation_Unit node for a package -- spec to indicate that a body is required. In Ada 9X, if this flag -- is not set, then a body may not be present. In Ada 83, if this flag -- is not set, then a body is optional. -- Controlling_Argument (Node1-Sem) -- This field is set in procedure and function call nodes if the call -- is a dispatching call (it is Empty for a non-dispatching call). -- It indicates the source of the controlling tag for the call. For -- Procedure calls, the Controlling_Argument is one of the actuals. -- For a function that has a dispatching result, it is an entity in -- the context of the call that can provide a tag, or else it is the -- tag of the root type of the class. -- Corresponding_Body (Node5-Sem) -- This field is set in subprogram declarations, where it is needed -- if a pragma Inline is present and the subprogram is called, in -- generic declarations if the generic is instantiated, and also in -- package declarations that contain inlined subprograms that are -- called, or generic declarations that are instantiated. It points -- to the defining entity for the corresponding body. -- Corresponding_Spec (Node5-Sem) -- This field is set in subprogram and package body nodes, where it -- points to the defining entity for the corresponding spec, and also -- in the N_With_Clause node, where it points to the defining entity -- for the with'ed spec. It is Empty if there is no corresponding -- spec in the case where a subprogram body serves as its own spec. -- This field is also set in a subprogram renaming declaration when -- it is a Renaming_As_Body and in a task body (where it points to -- the task type eneity). -- Debug_Statement (Node3-Sem) -- This field is present in an N_Pragma node. It is used only for -- a Debug pragma or pragma Assert with a second parameter. The -- parameter is of the form of an expression, as required by the -- pragma syntax, but is actually a procedure call. To simplify -- semantic processing, the parser creates a copy of the argument -- rearranged into a procedure call statement and places it in the -- Debug_Statement field. -- Do_Access_Check (Flag2-Sem) -- This flag is set on N_Explicit_Deference, N_Indexed_Component or -- N_Selected_Component nodes to indicate that the Prefix field of -- the node points to a pointer whose value must be checked for null -- before carrying out the operation. The actual check is dealt with -- by Gigi (all the front end does is to set the flag). -- Do_Accessibility_Check (Flag3-Sem) -- This flag is set on N_Parameter_Specification nodesto indicate that -- that an accessibility check is required for the parameter. It is -- not yet decided who takes care of this check (TBD). -- Do_Discriminant_Check (Flag3-Sem) -- This flag is set on N_Selected_Component nodes to indicate that a -- discriminant check is required using the discriminant check routine -- associated with the selector. The actual check is dealt with by -- Gigi (all the front end does is to set the flag). -- Do_Division_Check (Flag3-Sem) -- This flag is set on a division operator (/ mod rem) to indicate -- that a zero divide check is required. The actual check is dealt -- with by the backend (all the front end does is to set the flag). -- Do_Elaboration_Check (Flag2-Sem) -- This flag is set in a call (N_Entry_Call_Statement, N_Function_Call -- or N_Procedure_Call_Statement) to indicate that an elaboration -- check is required before the call can proceed. It is not yet -- determined who deals with this flag (TBD). -- Do_Length_Check (Flag4-Sem) -- This flag is set in an N_Assignment_Statement, N_Op_And, N_Op_Or, -- N_Op_Xor, or N_Type_Conversion node to indicate that a length check -- is required. It is not determined who deals with this flag (TBD). -- Do_Overflow_Check (Flag2-Sem) -- This flag is set on an operator where an overflow check is required -- on the operation. The actual check is dealt with by the backend -- (all the front end does is to set the flag). The other case where -- this flag is used is on a Type_Conversion node. In this case it -- means that the type conversion is from one base type to another, -- and the value may not fit in the target base type. See also the -- description of Do_Range_Check for this case. -- Do_Range_Check (Flag9-Sem) -- This flag is set on an expression which appears in a context where -- a range check is required. The target type is clear from the -- context. The contexts in which this flag can appear are limited to -- the following. -- Right side of an assignment. In this case the target type is -- taken from the left side of the assignment, which is referenced -- by the Name of the N_Assignment_Statement node. -- Subscript expressions in an indexed component. In this case the -- target type is determined from the type of the array, which is -- referenced by the Prefix of the N_Indexed_Component node. -- Parameter expression for an IN parameter, appearing either -- directly in the Parameter_Associations list of a call or as -- the Expression of an N_Parameter_Association node that appears -- in this list. In either case, the check is against the type of -- the formal. Note that OUT and IN OUT parameters are handled by -- expanding assignments and explicit type conversions where a -- range check is required. -- Initialization expression for the initial value in an object -- declaration. In this case the Do_Range_Check flag is set on -- the initialization expression, and the check is against the -- range of the type of the object being declared. -- The expression of a type conversion. In this case the range check -- is against the target type of the conversion. See also the use of -- Do_Overflow_Check on a type conversion. The distinction is that -- the ovrflow check protects against a value that is outside the -- range of the target base type, whereas a range check checks that -- the resulting value (which is a value of the base type of the -- target type), satisfies the range constraint of the target type. -- Note: when a range check is required in contexts other than those -- listed above (e.g. in a return statement), an additional type -- conversion node is introduced to represent the required check. -- Do_Storage_Check (Flag2-Sem) -- This flag is set in an N_Allocator node to indicate that a storage -- check is required for the allocation, or in an N_Subprogram_Body -- node to indicate that a stack check is required in the subprogram -- prolog. The N_Allocator case is handled by the routine that expands -- the call to the runtime routine. The N_Subprogram_Body case is -- handled by the backend, and all the semantics does is set the flag. -- Do_Tag_Check (Flag3-Sem) -- This flag is set on an N_Assignment_Statement, N_Function_Call, -- N_Procedure_Call_Statement, N_Type_Conversion or N_Return_Statememt -- node to indicate that the tag check can be suppressed. It is not -- yet decided how this flag is used (TBD). -- Elaborate_Present (Flag4-Sem) -- This flag is set in the N_With_Clause node to indicate that a -- pragma Elaborate pragma appears for the with'ed units. -- Elaborate_All_Present (Flag1-Sem) -- This flag is set in the N_With_Clause node to indicate that a -- pragma Elaborate_All pragma appears for the with'ed units. -- Elaborate_Body_Present (Flag7-Sem) -- This flag is set in the N_Compilation_Unit node to indicate that -- a valid Elaborate_Body pragma appears for this unit. -- Enclosing_Variant (Node2-Sem) -- This field is present in the N_Variant node and identifies the -- Node_Id corresponding to the immediately enclosing variant when -- the variant is nested, and N_Empty otherwise. Set during semantic -- processing of the variant part of a record type. -- Entity (Node4-Sem) -- Appears in all direct names (identifier, character literal, -- operator symbol), as well as expanded names, and attributes that -- denote entities, such as 'Class. Points to the entity for the -- corresponding defining occurrence. Set after name resolution. -- In the case of identifiers in a WITH list, the corresponding -- defining occurrence is in a separately compiled file, and this -- pointer must be set using the library Load procedure. Note that -- during name resolution, the value in Entity may be temporarily -- incorrect (e.g. during overload resolution, Entity is -- initially set to the first possible correct interpretation, and -- then later modified if necessary to contain the correct value -- after resolution). -- Etype (Node5-Sem) -- Appears in all expression nodes, all direct names, and all -- entities. Points to the entity for the related type. Set after -- type resolution. Normally this is the actual subtype of the -- expression. However, in certain contexts such as the right side -- of an assignment, subscripts, arguments to calls, returned value -- in a function, initial value etc. it is the desired target type. -- In the event that this is different from the actual type, the -- Do_Range_Check flag will be set if a range check is required. -- Evaluate_Once (Flag10-Sem) -- This flag is set on an expression that may have more than one -- reference in the tree to ensure that the expression is only evaluated -- once, and that subsequence references use the same value. Otherwise, -- if an expression appears in the tree more than once it will be -- evaluated multiple times. Note that if an expression appears only -- once in the tree, Evaluate_Once has no semantic effect, but should -- be False from an efficiency point of view (since extra processing -- is required in Gigi to deal with the Evaluate_Once flag). -- First_Named_Actual (Node4-Sem) -- Present in procedure call statement and function call nodes. Set -- during semantic analysis to point to the first named parameter -- where parameters are ordered by declaration order (as opposed to -- the actual order in the call which may be different due to named -- associations). Note that this field points to the actual parameter -- itself, not to the N_Parameter_Association node (its parent). -- Generic_Parent (Node5-Sem) -- Generic_parent is defined on declaration nodes that are instances. -- The value of Generic_Parent is the generic entity from which the -- instance is obtained. -- Has_No_Side_Effects (Flag8-Sem) -- A flag present in all expression nodes. Set by semantic analysis -- after determining that a given subexpression has no side effects. -- Has_Priority_Pragma (Flag6-Sem) -- A flag present in N_Subprogram_Body, N_Task_Definition and -- N_Protected_Definition nodes to flag the presence of either -- a Priority or Interrupt_Priority pragma in the declaration -- sequence (public or private in the task and protected cases) -- Has_Task_Stack_Size_Pragma (Flag5-Sem) -- A flag present in an N_Task_Definition node to flag the presence -- of a Task_Stack_Size pragma -- Implicit_Types (List2-Sem) -- Appears only in a N_Record_Definition node and is a list of -- N_Implicit_Type nodes which are generated if there were any -- implicit subtypes introduced by component declaration of the -- record type. If none were introduced, field is equal to No_List. -- Implicit_With (Flag2-Sem) -- This flag is set in the N_With_Clause node that is implicitly -- generated for runtime units that are loaded by the expander, and -- also for package System, if it is loaded implicitly by a use of -- the 'Address or 'Tag attribute -- Is_Overloaded (Flag5-Sem) -- A flag present in all expression nodes. Used temporarily during -- overloading determination. The setting of this flag is not -- relevant once overloading analysis is complete. -- Is_Task_Master (Flag5-Sem) -- A flag set in a Subprogram_Body, Block_Statement or Task_Body node -- to indicate that the construct is a task master (i.e. has declared -- tasks or declares an access to a task type). -- Next_Named_Actual (Node4-Sem) -- Present in parameter association node. Set during semantic -- analysis to point to the next named parameter, where parameters -- are ordered by declaration order (as opposed to the actual order -- in the call, which may be different due to named associations). -- Note that this field points to the actual parameter itself, not -- to the N_Parameter_Association node (its parent). -- Others_Discrete_Choices (List1-Sem) -- When a case statement or variant is analyzed, the semantic checks -- determine the actual list of choices that correspond to an others -- choice. This list is materialized for later use by the expander -- and the Others_Discrete_Choices field of an N_Others_Choice node -- points to this materialized list of choices, which is in standard -- format for a list of discrete choices, except that of course it -- cannot contain an N_Others_Choice entry. -- Preelaborable (Flag2-Sem) -- A flag that appears in the N_Compilation_Unit node to indicate -- whether or not elaboration code is present for this unit. It is -- set true if a pragma Preelaborate is present, or if the front end -- determines that no elaboration is required. -- Redundant_Use (Flag2-Sem) -- A flag present in Identifier nodes. Used only for identifiers -- referenced in use package clauses. Set to indicate that a use -- is redundant (and therefore need not be undone on scope exit) -- Unchecked_Conversion (Flag11-Sem) -- This flag is set in an N_Type_Conversion node that represents an -- unchecked conversion. Such nodes are generated during expander -- actions, and by the special casing of the expansion of calls to -- the bodies of instantiated unchecked conversion functions. The -- Size values of the input and output types are guaranteed to be -- equal, and neither of the types has a dynamic size. ----------------------------------- -- Description of Library Fields -- ----------------------------------- -- The meaning of the syntactic fields is generally clear from their -- names without any further description, since the names are chosen -- to correspond very closely to the syntax in the reference manual. -- This section describes the usage of the library fields, which are -- used to contain additional information resulting from processing -- of library information (e.g. separate unit information) -- Acts_As_Spec -- A flag set in the N_Compilation_Unit node of a library subprogram -- which is acting as a spec (no separate source for the spec exists). -- Analyzed -- A flag in the N_Compilation_Unit node indicating that the unit has -- been semantically analyzed (used to avoid repeating this analysis -- on a given unit more than once). -- Expanded -- A flag in the N_Compilation_Unit node indicating that the unit has -- been expanded (used to avoid repeating this expansion on a given -- unit more than once). -- Library_Unit -- In a stub node, the Library_Unit field points to the compilation unit -- node of the corresponding subunit. -- -- In a with clause node, the Library_Unit field points to the spec -- of the with'ed unit. -- -- In a compilation unit node, the use of this field depends on -- the unit type: -- -- For a subprogram body, the Library_Unit field points to the -- compilation unit node of the corresponding spec, unless -- Acts_As_Spec is set, in which case it points to itself. -- -- For a package body, the Library_Unit field points to the -- compilation unit node of the corresponding spec. -- -- For a subprogram spec to which pragma Inline applies, the -- Library_Unit field points to the compilation unit node of -- the corresponding body, if inlining is active. -- -- For a generic declaration, the Library_Unit field points -- to the compilation unit node of the corresponding generic body. -- -- For a subunit, the Library_Unit field points to the compilation -- unit node of the parent body. -- -- Note that this field is not used to hold the parent pointer for a -- child unit (which might in any case need to use it for some other -- purpose as described above). Instead for a child unit, implicit -- with's are generated for all parents. -- Parent_Spec -- For a library unit that is a child unit spec (package or subprogram -- declaration, generic declaration or instantiation, or library level -- rename, this field points to the compilation unit node for the parent -- package specification. This field is Empty for library bodies (the -- parent spec in this case can be found from the corresponding spec). --------------------- -- 2.3 Identifier -- --------------------- -- IDENTIFIER ::= LETTER {LETTER | DIGIT | UNDERLINE} -- An IDENTIFIER shall not contain two underlines in a row -- An IDENTIFIER shall not be a reserved word -- Note: in GNAT, a reserved word can be treated as an identifier -- in two cases. First, an incorrect use of a reserved word as an -- identifier is diagnosed and then treated as a normal identifier. -- Second, an attribute designator of the form of a reserved word -- (access, delta, digits, range) is treated as an identifier. -- Note: GNAT permits the use of a leading underline in identifiers -- when compiling the spec of package System. This allows handling of -- the declarations for Address and Tag, which are subtype renamings -- of the internal types _Address and _Tag in Standard. -- Note: The set of letters that is permitted in an identifier depends -- on the character set in use. See package Csets for full details. -- In the Ada grammar identifiers are the bottom level tokens which -- have very few semantics. Actual program identifiers are direct -- names. If we were being 100% honest with the grammar, then we would -- have a node called N_Direct_Name which would point to an identifier. -- However, that's too many extra nodes, so we just use the N_Identifier -- node directly as a direct name, and it contains the expression fields -- and Entity field that correspond to its use as a direct name. -- However, in those few cases where identifiers are used in contexts -- where they are not direct names (notably pragma and attribute -- identifiers, then only the Chars field is set). -- N_Identifier -- Sloc points to identifier -- Chars (Name1) contains the Name_Id for the identifier -- Entity (Node4-Sem) -- Redundant_Use (Flag2-Sem) set for redundant use clause -- plus fields for expression -------------------------- -- 2.4 Numeric Literal -- -------------------------- -- NUMERIC_LITERAL ::= DECIMAL_LITERAL | BASED_LITERAL ---------------------------- -- 2.4.1 Decimal Literal -- ---------------------------- -- DECIMAL_LITERAL ::= NUMERAL [.NUMERAL] [EXPONENT] -- NUMERAL ::= DIGIT {DIGIT | UNDERLINE} -- A NUMERAL shall not contain two underlines in a row, -- nor end in an underline. -- EXPONENT ::= E [+] NUMERAL | E - NUMERAL -- Decimal literals appear in the tree as either integer literal nodes -- or real literal nodes, depending on whether a period is present. -- N_Integer_Literal -- Sloc points to literal -- Intval (Uint3) contains integer value of literal -- plus fields for expression -- N_Real_Literal -- Sloc points to literal -- Numerator (Uint3) contains numerator of literal as rational value -- Denominator (Uint4) contains denominator of literal -- Decimal (Flag2) set for decimal literal case, in which case the -- denominator is a power of 10. Otherwise, the denominator is an -- integer value, representing the true value. -- plus fields for expression -------------------------- -- 2.4.2 Based Literal -- -------------------------- -- BASED_LITERAL ::= -- BASE # BASED_NUMERAL [.BASED_NUMERAL] # [EXPONENT] -- BASE ::= NUMERAL -- BASED_NUMERAL ::= -- EXTENDED_DIGIT {EXTENDED_DIGIT | UNDERLINE} -- EXTENDED_DIGIT ::= DIGIT | LETTER -- A BASED_NUMERAL shall not contain two underlines in a row, -- nor end in an underline. -- Based literals appear in the tree as either integer literal nodes -- or real literal nodes, depending on whether a period is present. ---------------------------- -- 2.5 Character Literal -- ---------------------------- -- CHARACTER_LITERAL ::= ' GRAPHIC_CHARACTER ' -- N_Character_Literal -- Sloc points to literal -- Chars (Name1) contains the Name_Id for the identifier -- Char_Literal_Value (Char_Code2) contains the literal value -- Entity (Node4-Sem) -- plus fields for expression ------------------------- -- 2.6 String Literal -- ------------------------- -- STRING LITERAL ::= "{STRING_ELEMENT}" -- A STRING_ELEMENT is either a pair of quotation marks ("), or a -- single GRAPHIC_CHARACTER other than a quotation mark. -- N_String_Literal -- Sloc points to literal -- Strval (Str3) contains Id of string value -- plus fields for expression ------------------ -- 2.7 Comment -- ------------------ -- A COMMENT starts with two adjacent hyphens and extends up to the -- end of the line. A COMMENT may appear on any line of a program. -- Comments are skipped by the scanner and do not appear in the tree. -- It is possible to reconstruct the position of comments with respect -- to the elements of the tree by using the source position (Sloc) -- pointers that appear in every tree node. ----------------- -- 2.8 Pragma -- ----------------- -- PRAGMA ::= pragma IDENTIFIER -- [(PRAGMA_ARGUMENT_ASSOCIATION {, PRAGMA_ARGUMENT_ASSOCIATION})]; -- Note that a pragma may appear in the tree anywhere a declaration -- or a statement may appear, as well as in some other situations -- which are explicitly documented. -- N_Pragma -- Sloc points to PRAGMA -- Identifier (Node1) -- Pragma_Argument_Associations (List2) (set to No_List if none) -- Debug_Statement (Node3-Sem) -------------------------------------- -- 2.8 Pragma Argument Association -- -------------------------------------- -- PRAGMA_ARGUMENT_ASSOCIATION ::= -- [pragma_argument_IDENTIFIER =>] NAME -- | [pragma_argument_IDENTIFIER =>] EXPRESSION -- N_Pragma_Argument_Association -- Sloc points to first token in association -- Identifier (Node1) (set to Empty if no pragma argument identifier) -- Expression (Node3) ------------------------ -- 2.9 Reserved Word -- ------------------------ -- Reserved words are parsed by the scanner, and returned as the -- corresponding token types (e.g. PACKAGE is returned as Tok_Package) ---------------------------- -- 3.1 Basic Declaration -- ---------------------------- -- BASIC_DECLARATION ::= -- TYPE_DECLARATION | SUBTYPE_DECLARATION -- | OBJECT_DECLARATION | NUMBER_DECLARATION -- | SUBPROGRAM_DECLARATION | ABSTRACT_SUBPROGRAM_DECLARATION -- | PACKAGE_DECLARATION | RENAMING_DECLARATION -- | EXCEPTION_DECLARATION | GENERIC_DECLARATION -- | GENERIC_INSTANTIATION -- Basic declaration also includes IMPLICIT_LABEL_DECLARATION -- see further description in section on semantic nodes. -- Also, in the tree that is constructed, a pragma may appear -- anywhere that a declaration may appear. ------------------------------ -- 3.1 Defining Identifier -- ------------------------------ -- DEFINING_IDENTIFIER ::= IDENTIFIER -- A defining identifier is an entity, which has additional fields -- depending on the setting of the Ekind field. These additional -- fields are defined (and access subprograms declared) in package -- Entity_Info. -- Note: N_Defining_Identifier is an extended node whose fields are -- deliberate layed out to match the layout of fields in an ordinary -- N_Identifier node allowing for easy alteration of an identifier -- node into a defining identifier node. For details, see procedure -- Sinfo.Change.Change_Identifier_To_Defining_Identifier. -- N_Defining_Identifier -- Sloc points to identifier -- Chars (Name1) contains the Name_Id for the identifier -- Etype (Node5-Sem) ----------------------------- -- 3.2.1 Type Declaration -- ----------------------------- -- TYPE_DECLARATION ::= -- FULL_TYPE_DECLARATION -- | INCOMPLETE_TYPE_DECLARATION -- | PRIVATE_TYPE_DECLARATION -- | PRIVATE_EXTENSION_DECLARATION ---------------------------------- -- 3.2.1 Full Type Declaration -- ---------------------------------- -- FULL_TYPE_DECLARATION ::= -- type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] -- is TYPE_DEFINITION; -- | TASK_TYPE_DECLARATION -- | PROTECTED_TYPE_DECLARATION -- The full type declaration node is used only for the first case. The -- second case (concurrent type declaration), is represented directly -- by a task type declaration or a protected type declaration. -- N_Full_Type_Declaration -- Sloc points to TYPE -- Defining_Identifier (Node1) -- Discriminant_Specifications (List2) (set to No_List if none) -- Type_Definition (Node3) ---------------------------- -- 3.2.1 Type Definition -- ---------------------------- -- TYPE_DEFINITION ::= -- ENUMERATION_TYPE_DEFINITION | INTEGER_TYPE_DEFINITION -- | REAL_TYPE_DEFINITION | ARRAY_TYPE_DEFINITION -- | RECORD_TYPE_DEFINITION | ACCESS_TYPE_DEFINITION -- | DERIVED_TYPE_DEFINITION -------------------------------- -- 3.2.2 Subtype Declaration -- -------------------------------- -- SUBTYPE_DECLARATION ::= -- subtype DEFINING_IDENTIFIER is SUBTYPE_INDICATION; -- The subtype indication field is set to Empty for subtypes -- declared in package Standard (Positive, Natural). -- N_Subtype_Declaration -- Sloc points to SUBTYPE -- Defining_Identifier (Node1) -- Subtype_Indication (Node4) ------------------------------- -- 3.2.2 Subtype Indication -- ------------------------------- -- SUBTYPE_INDICATION ::= SUBTYPE_MARK [CONSTRAINT] -- Note: if no constraint is present, the subtype indication appears -- directly in the tree as a subtype mark. The N_Subtype_Indication -- node is used only if a constraint is present. -- Note: the reason that this node has expression fields is that a -- subtype indication can appear as an operand of a membership test. -- N_Subtype_Indication -- Sloc points to first token of subtype mark -- Subtype_Mark (Node4) -- Constraint (Node3) -- Etype (Node5-Sem) -- Note: Etype is a copy of the Etype field of the Subtype_Mark. The -- reason for this redundancy is so that in a list of array index types, -- the Etype can be uniformly accessed to determine the subscript type. ------------------------- -- 3.2.2 Subtype Mark -- ------------------------- -- SUBTYPE_MARK ::= subtype_NAME ----------------------- -- 3.2.2 Constraint -- ----------------------- -- CONSTRAINT ::= SCALAR_CONSTRAINT | COMPOSITE_CONSTRAINT ------------------------------ -- 3.2.2 Scalar Constraint -- ------------------------------ -- SCALAR_CONSTRAINT ::= -- RANGE_CONSTRAINT | DIGITS_CONSTRAINT | DELTA_CONSTRAINT --------------------------------- -- 3.2.2 Composite Constraint -- --------------------------------- -- COMPOSITE_CONSTRAINT ::= -- INDEX_CONSTRAINT | DISCRIMINANT_CONSTRAINT ------------------------------- -- 3.3.1 Object Declaration -- ------------------------------- -- OBJECT_DECLARATION ::= -- DEFINING_IDENTIFIER_LIST : [aliased] [constant] -- SUBTYPE_INDICATION [:= EXPRESSION]; -- | DEFINING_IDENTIFIER_LIST : [aliased] [constant] -- ARRAY_TYPE_DEFINITION [:= EXPRESSION]; -- | SINGLE_TASK_DECLARATION -- | SINGLE_PROTECTED_DECLARATION -- Note: aliased is not permitted in Ada 83 mode -- The N_Object_Declaration node is only for the first two cases. -- Single task declaration is handled by P_Task (9.1) -- Single protected declaration is handled by P_protected (9.5) -- Although the syntax allows multiple identifiers in the list, the -- semantics is as though successive declarations were given with -- identical type definition and expression components. To simplify -- semantic processing, the parser represents a multiple declaration -- case as a sequence of single declarations, using the More_Ids and -- Prev_Ids flags to preserve the original source form as described -- in the section on "Handling of Defining Identifier Lists". -- Note: if a range check is required for the initialization -- expression then the Do_Range_Check flag is set in the Expression, -- with the check being done against the type given by the object -- definition, which is also the Etype of the defining identifier. -- N_Object_Declaration -- Sloc points to first identifier -- Defining_Identifier (Node1) -- Aliased_Present (Flag1) set if ALIASED appears -- Constant_Present (Flag2) set if CONSTANT appears -- Object_Definition (Node2) subtype indication/array type definition -- Expression (Node3) (set to Empty if not present) -- More_Ids (Flag5) (set to False if no more identifiers in list) -- Prev_Ids (Flag6) (set to False if no previous identifiers in list) ------------------------------------- -- 3.3.1 Defining Identifier List -- ------------------------------------- -- DEFINING_IDENTIFIER_LIST ::= -- DEFINING_IDENTIFIER {, DEFINING_IDENTIFIER} ------------------------------- -- 3.3.2 Number Declaration -- ------------------------------- -- NUMBER_DECLARATION ::= -- DEFINING_IDENTIFIER_LIST : constant := static_EXPRESSION; -- Although the syntax allows multiple identifiers in the list, the -- semantics is as though successive declarations were given with -- identical expressions. To simplify semantic processing, the parser -- represents a multiple declaration case as a sequence of single -- declarations, using the More_Ids and Prev_Ids flags to preserve -- the original source form as described in the section on "Handling -- of Defining Identifier Lists". -- N_Number_Declaration -- Sloc points to first identifier -- Defining_Identifier (Node1) -- Expression (Node3) -- More_Ids (Flag5) (set to False if no more identifiers in list) -- Prev_Ids (Flag6) (set to False if no previous identifiers in list) ---------------------------------- -- 3.4 Derived Type Definition -- ---------------------------------- -- DERIVED_TYPE_DEFINITION ::= -- new [abstract] parent_SUBTYPE_INDICATION [RECORD_EXTENSION_PART] -- Note: ABSTRACT, record extension part not permitted in Ada 83 mode -- Note: a record extension part is required if ABSTRACT is present -- N_Derived_Type_Definition -- Sloc points to NEW -- Abstract_Present (Flag4) -- Subtype_Indication (Node4) -- Record_Extension_Part (Node3) (set to Empty if not present) --------------------------- -- 3.5 Range Constraint -- --------------------------- -- RANGE_CONSTRAINT ::= range RANGE -- N_Range_Constraint -- Sloc points to RANGE -- Range_Expression (Node4) ---------------- -- 3.5 Range -- ---------------- -- RANGE ::= -- RANGE_ATTRIBUTE_REFERENCE -- | SIMPLE_EXPRESSION .. SIMPLE_EXPRESSION -- Note: the case of a range given as a range attribute reference -- appears directly in the tree as an attribute reference. -- Note: the field name for a reference to a range is Range_Expression -- rather than Range, because range is a reserved keyword in Ada! -- Note: the reason that this node has expression fields is that a -- range can appear as an operand of a membership test. -- N_Range -- Sloc points to .. -- Low_Bound (Node1) -- High_Bound (Node2) -- plus fields for expression -- Note: if the range appears in a context, such as a subtype -- declaration, where range checks are required on one or both of -- the expression fields, then type conversion nodes are inserted -- to represent the required checks. ---------------------------------------- -- 3.5.1 Enumeration Type Definition -- ---------------------------------------- -- ENUMERATION_TYPE_DEFINITION ::= -- (ENUMERATION_LITERAL_SPECIFICATION -- {, ENUMERATION_LITERAL_SPECIFICATION}) -- Note: the Literals field in the node described below is null for -- the case of the standard types CHARACTER and WIDE_CHARACTER, for -- which special processing handles these types as special cases. -- N_Enumeration_Type_Definition -- Sloc points to left parenthesis -- Literals (List1) (Empty for CHARACTER or WIDE_CHARACTER) ---------------------------------------------- -- 3.5.1 Enumeration Literal Specification -- ---------------------------------------------- -- ENUMERATION_LITERAL_SPECIFICATION ::= -- DEFINING_IDENTIFIER | DEFINING_CHARACTER_LITERAL --------------------------------------- -- 3.5.1 Defining Character Literal -- --------------------------------------- -- DEFINING_CHARACTER_LITERAL ::= CHARACTER_LITERAL -- A defining character literal is an entity, which has additional -- fields depending on the setting of the Ekind field. These -- additional fields are defined (and access subprograms declared) -- in package Entity_Info. -- Note: N_Defining_Character_Literal is an extended node whose fields -- are deliberate layed out to match the layout of fields in an ordinary -- N_Character_Literal node allowing for easy alteration of a character -- literal node into a defining character literal node. For details, see -- Sinfo.Change.Change_Character_Literal_To_Defining_Character_Literal. -- N_Defining_Character_Literal -- Sloc points to literal -- Chars (Name1) contains the Name_Id for the identifier -- Etype (Node5-Sem) ------------------------------------ -- 3.5.4 Integer Type Definition -- ------------------------------------ -- Note: there is an error in this rule in the latest version of the -- grammar, so we have retained the old rule pending clarification. -- INTEGER_TYPE_DEFINITION ::= -- SIGNED_INTEGER_TYPE_DEFINITION -- MODULAR_TYPE_DEFINITION ------------------------------------------- -- 3.5.4 Signed Integer Type Definition -- ------------------------------------------- -- SIGNED_INTEGER_TYPE_DEFINITION ::= -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION -- Note: the Low_Bound and High_Bound fields are set to Empty for -- integer types defined in package Standard. -- N_Signed_Integer_Type_Definition -- Sloc points to RANGE -- Low_Bound (Node1) -- High_Bound (Node2) ----------------------------------------- -- 3.5.4 Unsigned Range Specification -- ----------------------------------------- -- MODULAR_TYPE_DEFINITION ::= mod static_EXPRESSION -- N_Modular_Type_Definition -- Sloc points to MOD -- Expression (Node3) --------------------------------- -- 3.5.6 Real Type Definition -- --------------------------------- -- REAL_TYPE_DEFINITION ::= -- FLOATING_POINT_DEFINITION | FIXED_POINT_DEFINITION -------------------------------------- -- 3.5.7 Floating Point Definition -- -------------------------------------- -- FLOATING_POINT_DEFINITION ::= -- digits static_SIMPLE_EXPRESSION [REAL_RANGE_SPECIFICATION] -- Note: The Digits_Expression and Real_Range_Specifications fields -- are set to Empty for floating-point types declared in Standard. -- N_Floating_Point_Definition -- Sloc points to DIGITS -- Digits_Expression (Node2) -- Real_Range_Specification (Node4) (set to Empty if not present) ------------------------------------- -- 3.5.7 Real Range Specification -- ------------------------------------- -- REAL_RANGE_SPECIFICATION ::= -- range static_SIMPLE_EXPRESSION .. static_SIMPLE_EXPRESSION -- N_Real_Range_Specification -- Sloc points to RANGE -- Low_Bound (Node1) -- High_Bound (Node2) ----------------------------------- -- 3.5.9 Fixed Point Definition -- ----------------------------------- -- FIXED_POINT_DEFINITION ::= -- ORDINARY_FIXED_POINT_DEFINITION | DECIMAL_FIXED_POINT_DEFINITION -------------------------------------------- -- 3.5.9 Ordinary Fixed Point Definition -- -------------------------------------------- -- ORDINARY_FIXED_POINT_DEFINITION ::= -- delta static_EXPRESSION REAL_RANGE_SPECIFICATION -- | DECIMAL_FIXED_POINT_DEFINITION -- Note: In Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION -- Note: the Delta_Expression and Real_Range_Specification fields -- are set to Empty for fixed point types declared in Standard. -- N_Ordinary_Fixed_Point_Definition -- Sloc points to DELTA -- Delta_Expression (Node3) -- Real_Range_Specification (Node4) ------------------------------------------- -- 3.5.9 Decimal Fixed Point Definition -- ------------------------------------------- -- DECIMAL_FIXED_POINT_DEFINITION ::= -- delta static_SIMPLE_EXPRESSION -- digits static_SIMPLE_EXPRESSION [REAL_RANGE_SPECIFICATION] -- Note: decimal types are not permitted in Ada 83 mode -- N_Decimal_Fixed_Point_Definition -- Sloc points to DELTA -- Delta_Expression (Node3) -- Digits_Expression (Node2) -- Real_Range_Specification (Node4) (set to Empty if not present) ------------------------------ -- 3.5.9 Digits Constraint -- ------------------------------ -- DIGITS_CONSTRAINT ::= -- digits static_EXPRESSION [RANGE_CONSTRAINT] -- Note: in Ada 83, the EXPRESSION must be a SIMPLE_EXPRESSION -- Note: in Ada 9X, reduced accuracy subtypes are obsolescent -- N_Digits_Constraint -- Sloc points to DIGITS -- Digits_Expression (Node2) -- Range_Constraint (Node4) (set to Empty if not present) ----------------------------- -- 3.5.9 Delta Constraint -- ----------------------------- -- Note: this is moved to section N.2 in the 9X document, since -- it is considered to be an "obsolescent" feature in Ada 9X. -- DELTA CONSTRAINT ::= DELTA STATIC_EXPRESSION [RANGE_CONSTRAINT] -- N_Delta_Constraint -- Sloc points to DELTA -- Delta_Expression (Node3) -- Range_Constraint (Node4) (set to Empty if not present) -------------------------------- -- 3.6 Array Type Definition -- -------------------------------- -- ARRAY_TYPE_DEFINITION ::= -- UNCONSTRAINED_ARRAY_DEFINITION | CONSTRAINED_ARRAY_DEFINITION ----------------------------------------- -- 3.6 Unconstrained Array Definition -- ----------------------------------------- -- UNCONSTRAINED_ARRAY_DEFINITION ::= -- array (INDEX_SUBTYPE_DEFINITION {, INDEX_SUBTYPE_DEFINITION}) of -- COMPONENT_DEFINITION -- Note: dimensionality of array is indicated by number of entries in -- the Subtype_Marks list, which has one entry for each dimension. -- N_Unconstrained_Array_Definition -- Sloc points to ARRAY -- Subtype_Marks (List2) -- Aliased_Present (Flag1) in component definition -- Subtype_Indication (Node4) in component definition ----------------------------------- -- 3.6 Index Subtype Definition -- ----------------------------------- -- INDEX_SUBTYPE_DEFINITION ::= SUBTYPE_MARK range <> -- There is no explicit node in the tree for an index subtype -- definition since the N_Unconstrained_Array_Definition node -- incorporates the type marks which appear in this context. --------------------------------------- -- 3.6 Constrained Array Definition -- --------------------------------------- -- CONSTRAINED_ARRAY_DEFINITION ::= -- ARRAY (DISCRETE_SUBTYPE_DEFINITION -- {, DISCRETE_SUBTYPE_DEFINITION}) OF COMPONENT_DEFINITION -- Note: dimensionality of array is indicated by number of entries -- in the Discrete_Subtype_Definitions list, which has one entry -- for each dimension. -- N_Constrained_Array_Definition -- Sloc points to ARRAY -- Discrete_Subtype_Definitions (List2) -- Aliased_Present (Flag1) in component definition -- Subtype_Indication (Node4) in component definition -------------------------------------- -- 3.6 Discrete Subtype Definition -- -------------------------------------- -- DISCRETE_SUBTYPE_DEFINITION ::= -- discrete_SUBTYPE_INDICATION | RANGE ------------------------------- -- 3.6 Component Definition -- ------------------------------- -- COMPONENT_DEFINITION ::= [aliased] SUBTYPE_INDICATION -- There is no explicit node in the tree for a component definition. -- Instead the subtype indication appears directly, and the ALIASED -- indication (Aliased_Present flag) is in the parent node. -- Note: although the syntax does not permit a component definition to -- be an anonymous array (and the parser will diagnose such an attempt -- with an appropriate message), it is possible for anonymous arrays -- to appear as component definitions. The semantics and back end handle -- this case properly, and the expander in fact generates such cases. ----------------------------- -- 3.6.1 Index Constraint -- ----------------------------- -- INDEX_CONSTRAINT ::= (DISCRETE_RANGE {, DISCRETE_RANGE}) -- It is not in general possible to distinguish between discriminant -- constraints and index constraints at parse time, since a simple -- name could be either the subtype mark of a discrete range, or an -- expression in a discriminant association with no name. Either -- entry appears simply as the name, and the semantic parse must -- distinguish between the two cases. Thus we use a common tree -- node format for both of these constraint types. -- See Discriminant_Constraint for format of node --------------------------- -- 3.6.1 Discrete Range -- --------------------------- -- DISCRETE_RANGE ::= discrete_SUBTYPE_INDICATION | RANGE ---------------------------- -- 3.7 Discriminant Part -- ---------------------------- -- DISCRIMINANT_PART ::= -- UNKNOWN_DISCRIMINANT_PART | KNOWN_DISCRIMINANT_PART ------------------------------------ -- 3.7 Unknown Discriminant Part -- ------------------------------------ -- UNKNOWN_DISCRIMINANT_PART ::= (<>) -- Note: unknown discriminant parts are not permitted in Ada 83 mode -- There is no explicit node in the tree for an unknown discriminant -- part. Instead the Has_Unknown_Discriminants flag is set in the -- parent node. ---------------------------------- -- 3.7 Known Discriminant Part -- ---------------------------------- -- KNOWN_DISCRIMINANT_PART ::= -- (DISCRIMINANT_SPECIFICATION {; DISCRIMINANT_SPECIFICATION}) ------------------------------------- -- 3.7 Discriminant Specification -- ------------------------------------- -- DISCRIMINANT_SPECIFICATION ::= -- DEFINING_IDENTIFIER_LIST : SUBTYPE_MARK -- [:= DEFAULT_EXPRESSION] -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION -- [:= DEFAULT_EXPRESSION] -- Although the syntax allows multiple identifiers in the list, the -- semantics is as though successive specifications were given with -- identical type definition and expression components. To simplify -- semantic processing, the parser represents a multiple declaration -- case as a sequence of single specifications, using the More_Ids and -- Prev_Ids flags to preserve the original source form as described -- in the section on "Handling of Defining Identifier Lists". -- N_Discriminant_Specification -- Sloc points to first identifier -- Defining_Identifier (Node1) -- Discriminant_Type (Node2) subtype mark or -- access parameter definition -- Expression (Node3) (set to Empty if no default expression) -- More_Ids (Flag5) (set to False if no more identifiers in list) -- Prev_Ids (Flag6) (set to False if no previous identifiers in list) ----------------------------- -- 3.7 Default Expression -- ----------------------------- -- DEFAULT_EXPRESSION ::= EXPRESSION ------------------------------------ -- 3.7.1 Discriminant Constraint -- ------------------------------------ -- DISCRIMINANT_CONSTRAINT ::= -- (DISCRIMINANT_ASSOCIATION {, DISCRIMINANT_ASSOCIATION}) -- It is not in general possible to distinguish between discriminant -- constraints and index constraints at parse time, since a simple -- name could be either the subtype mark of a discrete range, or an -- expression in a discriminant association with no name. Either -- entry appears simply as the name, and the semantic parse must -- distinguish between the two cases. Thus we use a common tree -- node format for both of these constraint types. -- N_Index_Or_Discriminant_Constraint -- Sloc points to left paren -- Constraints (List1) points to list of discrete ranges or -- discriminant associations ------------------------------------- -- 3.7.1 Discriminant Association -- ------------------------------------- -- DISCRIMINANT_ASSOCIATION ::= -- [discriminant_SELECTOR_NAME -- {| discriminant_SELECTOR_NAME} =>] EXPRESSION -- Note: a discriminant association that has no selector name list -- appears directly as an expression in the tree. -- N_Discriminant_Association -- Sloc points to first token of discriminant association -- Selector_Names (List1) (always non-empty, since if no selector -- names are present, this node is not used, see comment above) -- Expression (Node3) --------------------------------- -- 3.8 Record Type Definition -- --------------------------------- -- RECORD_TYPE_DEFINITION ::= -- [abstract] [tagged] [limited] RECORD_DEFINITION -- Note: ABSTRACT, TAGGED, LIMITED are not permitted in Ada 83 mode -- There is no explicit node in the tree for a record type definition. -- Instead the flags for Tagged_Present and Limited_Present appear in -- the N_Record_Definition node for a record definition appearing in -- the context of a record type definition. ---------------------------- -- 3.8 Record Definition -- ---------------------------- -- RECORD_DEFINITION ::= -- record -- COMPONENT_LIST -- end record -- | null record -- Note: the Abstract_Present, Tagged_Present and Limited_Present -- flags appear only for a record definition appearing in a record -- type definition. -- Note: the NULL RECORD case is not permitted in Ada 83 -- N_Record_Definition -- Sloc points to RECORD or NULL -- Abstract_Present (Flag4) -- Tagged_Present (Flag1) -- Limited_Present (Flag2) -- Component_List (Node1) empty in null record case -- Implicit_Types (List2-Sem) list of implicit types (may be empty) -- Null_Present (Flag3) set in null record case ------------------------- -- 3.8 Component List -- ------------------------- -- COMPONENT_LIST ::= -- COMPONENT_DECLARATION {COMPONENT_DECLARATION} -- | {COMPONENT_DECLARATION} VARIANT_PART -- | null; -- N_Component_List -- Sloc points to first token of component list -- Component_Declarations (List3) -- Variant_Part (Node4) (set to Empty if no variant part) -- Null_Present (Flag3) -------------------------------- -- 3.8 Component Declaration -- -------------------------------- -- COMPONENT_DECLARATION ::= -- DEFINING_IDENTIFIER_LIST : COMPONENT_DEFINITION -- [:= DEFAULT_EXPRESSION] -- Note: although the syntax does not permit a component definition to -- be an anonymous array (and the parser will diagnose such an attempt -- with an appropriate message), it is possible for anonymous arrays -- to appear as component definitions. The semantics and back end handle -- this case properly, and the expander in fact generates such cases. -- Although the syntax allows multiple identifiers in the list, the -- semantics is as though successive declarations were given with the -- same component definition and expression components. To simplify -- semantic processing, the parser represents a multiple declaration -- case as a sequence of single declarations, using the More_Ids and -- Prev_Ids flags to preserve the original source form as described -- in the section on "Handling of Defining Identifier Lists". -- N_Component_Declaration -- Sloc points to first identifier -- Defining_Identifier (Node1) -- Aliased_Present (Flag1) in component definition -- Subtype_Indication (Node4) in component definition -- Expression (Node3) (set to Empty if no default expression) -- More_Ids (Flag5) (set to False if no more identifiers in list) -- Prev_Ids (Flag6) (set to False if no previous identifiers in list) ------------------------- -- 3.8.1 Variant Part -- ------------------------- -- VARIANT_PART ::= -- case discriminant_DIRECT_NAME is -- VARIANT -- {VARIANT} -- end case; -- N_Variant_Part -- Sloc points to CASE -- Name (Node2) -- Variants (List1) -------------------- -- 3.8.1 Variant -- -------------------- -- VARIANT ::= when DISCRETE_CHOICE_LIST => COMPONENT_LIST -- N_Variant -- Sloc points to WHEN -- Discrete_Choices (List4) -- Component_List (Node1) -- Enclosing_Variant (Node2-Sem) --------------------------------- -- 3.8.1 Discrete Choice List -- --------------------------------- -- DISCRETE_CHOICE_LIST ::= DISCRETE_CHOICE {| DISCRETE_CHOICE} ---------------------------- -- 3.8.1 Discrete Choice -- ---------------------------- -- DISCRETE_CHOICE ::= EXPRESSION | DISCRETE_RANGE | others -- Note: in Ada 83 mode, the expression must be a simple expression -- The only choice that appears explicitly is the OTHERS choice, as -- defined here. Other cases of discrete choice (expression and -- discrete range) appear directly. This production is also used -- for the OTHERS possibility of an exception choice. -- Note: in accordance with the syntax, the parser does not check that -- OTHERS appears at the end on its own in a choice list context. This -- is a semantic check. -- N_Others_Choice -- Sloc points to OTHERS -- Others_Discrete_Choices (List1-Sem) ---------------------------------- -- 3.9.1 Record Extension Part -- ---------------------------------- -- RECORD_EXTENSION_PART ::= with RECORD_DEFINITION -- Note: record extension parts are not permitted in Ada 83 mode ---------------------------------- -- 3.10 Access Type Definition -- ---------------------------------- -- ACCESS_TYPE_DEFINITION ::= -- ACCESS_TO_OBJECT_DEFINITION -- | ACCESS_TO_SUBPROGRAM_DEFINITION -- This is split into two separate cases for the normal subtype -- case and the access to subprogram case, in other words the -- modified grammar has: -- ACCESS_TYPE_DEFINITION ::= -- ACCESS_SUBTYPE_DEFINITION | ACCESS_SUBPROGRAM_DEFINITION --------------------------------------- -- 3.10 Access To Object Definition -- --------------------------------------- -- ACCESS_TO_OBJECT_DEFINITION ::= -- access [GENERAL_ACCESS_MODIFIER] SUBTYPE_INDICATION -- N_Access_To_Object_Definition -- Sloc points to ACCESS -- All_Present (Flag1) -- Subtype_Indication (Node4) -- Constant_Present (Flag2) ----------------------------------- -- 3.10 General Access Modifier -- ----------------------------------- -- GENERAL_ACCESS_MODIFIER ::= all | constant -- Note: general access modifiers are not permitted in Ada 83 mode -- There is no explicit node in the tree for general access modifier. -- Instead the All_Present or Constant_Present flags are set in the -- parent node. ---------------------------------------- -- 3.10 Access Subprogram Definition -- ---------------------------------------- -- ACCESS_TO_SUBPROGRAM_DEFINITION -- access [protected] function PARAMETER_AND_RESULT_PROFILE -- | access [protected] procedure PARAMETER_PROFILE -- Note: access to subprograms are not permitted in Ada 83 mode -- N_Access_Function_Definition -- Sloc points to ACCESS -- Protected_Present (Flag1) -- Parameter_Specifications (List2) (set to No_List if no formal part) -- Subtype_Mark (Node4) result subtype -- N_Access_Procedure_Definition -- Sloc points to ACCESS -- Protected_Present (Flag1) -- Parameter_Specifications (List2) (set to No_List if no formal part) ----------------------------- -- 3.10 Access Definition -- ----------------------------- -- ACCESS_DEFINITION ::= access SUBTYPE_MARK -- N_Access_Definition -- Sloc points to ACCESS -- Subtype_Mark (Node4) ----------------------------------------- -- 3.10.1 Incomplete Type Declaration -- ----------------------------------------- -- INCOMPLETE_TYPE_DECLARATION ::= -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART]; -- N_Incomplete_Type_Declaration -- Sloc points to TYPE -- Defining_Identifier (Node1) -- Discriminant_Specifications (List2) (set to No_List if no -- discriminant part, or if the discriminant part is an -- unknown discriminant part) -- Has_Unknown_Discriminants (Flag3) set if (<>) discriminant ---------------------------- -- 3.11 Declarative Part -- ---------------------------- -- DECLARATIVE_PART ::= {DECLARATIVE_ITEM} -- Note: although the parser enforces the syntactic requirement that -- a declarative part can contain only declarations, the semantic -- processing may add statements to the list of actions in a -- declarative part, so the code generator should be prepared -- to accept a statement in this position. ---------------------------- -- 3.11 Declarative Item -- ---------------------------- -- DECLARATIVE_ITEM ::= BASIC_DECLARATIVE_ITEM | BODY ---------------------------------- -- 3.11 Basic Declarative Item -- ---------------------------------- -- BASIC_DECLARATIVE_ITEM ::= -- BASIC_DECLARATION | REPRESENTATION_CLAUSE | USE_CLAUSE ---------------- -- 3.11 Body -- ---------------- -- BODY ::= PROPER_BODY | BODY_STUB ----------------------- -- 3.11 Proper Body -- ----------------------- -- PROPER_BODY ::= -- SUBPROGRAM_BODY | PACKAGE_BODY | TASK_BODY | PROTECTED_BODY --------------- -- 4.1 Name -- --------------- -- NAME ::= -- DIRECT_NAME | EXPLICIT_DEREFERENCE -- | INDEXED_COMPONENT | SLICE -- | SELECTED_COMPONENT | ATTRIBUTE_REFERENCE -- | TYPE_CONVERSION | FUNCTION_CALL -- | CHARACTER_LITERAL ---------------------- -- 4.1 Direct Name -- ---------------------- -- DIRECT_NAME ::= IDENTIFIER | OPERATOR_SYMBOL ----------------- -- 4.1 Prefix -- ----------------- -- PREFIX ::= NAME | IMPLICIT_DEREFERENCE ------------------------------- -- 4.1 Explicit Dereference -- ------------------------------- -- EXPLICIT_DEREFERENCE ::= NAME . all -- N_Explicit_Dereference -- Sloc points to ALL -- Prefix (Node2) -- Do_Access_Check (Flag2-Sem) -- plus fields for expression ------------------------------- -- 4.1 Implicit Dereference -- ------------------------------- -- IMPLICIT_DEREFERENCE ::= NAME ------------------------------ -- 4.1.1 Indexed Component -- ------------------------------ -- INDEXED_COMPONENT ::= PREFIX (EXPRESSION {, EXPRESSION}) -- Note: the parser may generate this node in some situations where it -- should be a function call. The semantic pass must correct this -- misidentification (which is inevitable at the parser level). -- N_Indexed_Component -- Sloc points to first token of prefix -- Prefix (Node2) -- Expressions (List3) -- Do_Access_Check (Flag2-Sem) -- plus fields for expression -- Note: if any of the subscripts requires a range check, then the -- Do_Range_Check flag is set on the corresponding expression, with -- the index type being determined from the type of the Prefix, which -- references the array being indexed. ------------------ -- 4.1.2 Slice -- ------------------ -- SLICE ::= PREFIX (DISCRETE_RANGE) -- N_Slice -- Sloc points to first token of prefix -- Prefix (Node2) -- Discrete_Range (Node4) -- Do_Access_Check (Flag2-Sem) -- plus fields for expression ------------------------------- -- 4.1.3 Selected Component -- ------------------------------- -- SELECTED_COMPONENT ::= PREFIX . SELECTOR_NAME -- Note: selected components that are semantically expanded names get -- changed during semantic processing into the separate N_Expanded_Name -- node. See description of this node in the section on semantic nodes. -- N_Selected_Component -- Sloc points to period -- Prefix (Node2) -- Selector_Name (Node3) -- Do_Access_Check (Flag2-Sem) -- Do_Discriminant_Check (Flag3-Sem) -- plus fields for expression -------------------------- -- 4.1.3 Selector Name -- -------------------------- -- SELECTOR_NAME ::= IDENTIFIER | CHARACTER_LITERAL | OPERATOR_SYMBOL -------------------------------- -- 4.1.4 Attribute Reference -- -------------------------------- -- ATTRIBUTE_REFERENCE ::= PREFIX ' ATTRIBUTE_DESIGNATOR -- Note: the syntax is quite ambiguous at this point. Consider: -- A'Length (X) X is part of the attribute designator -- A'Pos (X) X is an actual parameter of function A'Pos -- A'Class (X) X is the expression of a type conversion -- It would be possible for the parser to distinguish these cases -- by looking at the attribute identifier. However, that would mean -- more work in introducing new implementation defined attributes, -- and also it would mean that special processing for attributes -- would be scattered around, instead of being centralized in the -- semantic routine that handles an N_Attribute_Reference node. -- Consequently, the parser in all the above cases stores the -- expression (which appears as X in these examples) in the -- Expression field of the N_Attribute_Reference node. -- N_Attribute_Reference -- Sloc points to apostrophe -- Prefix (Node2) -- Identifier (Node1) from attribute designator -- Expression (Node3) (set to Empty if no expression in designator) -- Entity (Node4-Sem) used if the attribute yields a type -- Do_Access_Check (Flag2-Sem) -- plus fields for expression --------------------------------- -- 4.1.4 Attribute Designator -- --------------------------------- -- ATTRIBUTE_DESIGNATOR ::= -- IDENTIFIER [(static_EXPRESSION)] -- | access | delta | digits -- There is no explicit node in the tree for an attribute designator. -- Instead the identifier and expression fields of the parent node -- (N_Attribute_Reference node) hold the information. -- Note: if ACCESS, DELTA or DIGITS appears in an attribute -- designator, then they are treated as identifiers internally -- rather than the keywords of the same name. -------------------------------------- -- 4.1.4 Range Attribute Reference -- -------------------------------------- -- RANGE_ATTRIBUTE_REFERENCE ::= PREFIX ' RANGE_ATTRIBUTE_DESIGNATOR -- A range attribute reference is represented in the tree using the -- normal N_Attribute_Reference node. --------------------------------------- -- 4.1.4 Range Attribute Designator -- --------------------------------------- -- RANGE_ATTRIBUTE_DESIGNATOR ::= PREFIX [(static_EXPRESSION)] -- A range attribute designator is represented in the tree using the -- normal N_Attribute_Reference node. -------------------- -- 4.3 Aggregate -- -------------------- -- AGGREGATE ::= -- RECORD_AGGREGATE | EXTENSION_AGGREGATE | ARRAY_AGGREGATE ----------------------------- -- 4.3.1 Record Aggregate -- ----------------------------- -- RECORD_AGGREGATE ::= (RECORD_COMPONENT_ASSOCIATION_LIST) -- N_Aggregate -- Sloc points to left parenthesis -- Expressions (List3) (Empty if none or null record case) -- Component_Associations (List4) (set to No_List if none) -- Null_Record_Present (Flag2) -- plus fields for expression -- Note: this structure is used for both record and array aggregates -- since the two cases are not separable by the parser. The parser -- makes no attempt to enforce consistency here, so it is up to the -- semantic phase to make sure that the aggregate is consistent (i.e. -- that it is not a "half-and-half" case that mixes record and array -- syntax. In particular, for a record aggregate, the expressions -- field will be set if there are positional associations. ---------------------------------------------- -- 4.3.1 Record Component Association List -- ---------------------------------------------- -- RECORD_COMPONENT_ASSOCIATION_LIST ::= -- RECORD_COMPONENT_ASSOCIATION {, RECORD_COMPONENT_ASSOCIATION} -- | NULL RECORD -- There is no explicit node in the tree for a record component -- association list. Instead the Null_Record_Present flag is set in -- the parent node for the NULL RECORD case. ----------------------------------------- -- 4.3.1 Record Component Association -- ----------------------------------------- -- RECORD_COMPONENT_ASSOCIATION ::= -- component_SELECTOR_NAME {| component_SELECTOR_NAME} => EXPRESSION -- | others => EXPRESSION -- N_Component_Association -- Sloc points to first selector name -- Choices (List1) -- Expression (Node3) -- Note: this structure is used for both record component associations -- and array component associations, since the two cases aren't always -- separable by the parser. The choices list may represent either a -- list of selector names in the record aggregate case, or a list of -- discrete choices in the array aggregate case. -------------------------------- -- 4.3.2 Extension Aggregate -- -------------------------------- -- EXTENSION_AGGREGATE ::= -- (EXPRESSION with RECORD_COMPONENT_ASSOCIATION_LIST) -- Note: extension aggregates are not permitted in Ada 83 mode -- N_Extension_Aggregate -- Sloc points to left parenthesis -- Expression (Node3) -- Component_Associations (List4) (set to No_List if null record case) -- Null_Record_Present (Flag2) -- plus fields for expression ---------------------------- -- 4.3.3 Array Aggregate -- ---------------------------- -- ARRAY_AGGREGATE ::= -- POSITIONAL_ARRAY_AGGREGATE | NAMED_ARRAY_AGGREGATE --------------------------------------- -- 4.3.3 Positional Array Aggregate -- --------------------------------------- -- POSITIONAL_ARRAY_AGGREGATE ::= -- (EXPRESSION, EXPRESSION {, EXPRESSION}) -- | (EXPRESSION {, EXPRESSION}, others => EXPRESSION) -- See Record_Aggregate (4.3.1) for node structure ---------------------------------- -- 4.3.3 Named Array Aggregate -- ---------------------------------- -- NAMED_ARRAY_AGGREGATE ::= -- | (ARRAY_COMPONENT_ASSOCIATION {, ARRAY_COMPONENT_ASSOCIATION}) -- See Record_Aggregate (4.3.1) for node structure ---------------------------------------- -- 4.3.3 Array Component Association -- ---------------------------------------- -- ARRAY_COMPONENT_ASSOCIATION ::= -- DISCRETE_CHOICE_LIST => EXPRESSION -- See Record_Component_Association (4.3.1) for node structure -------------------------------------------------- -- 4.4 Expression/Relation/Term/Factor/Primary -- -------------------------------------------------- -- EXPRESSION ::= -- RELATION {and RELATION} | RELATION {and then RELATION} -- | RELATION {or RELATION} | RELATION {or else RELATION} -- | RELATION {xor RELATION} -- RELATION ::= -- SIMPLE_EXPRESSION [RELATIONAL_OPERATOR SIMPLE_EXPRESSION] -- | SIMPLE_EXPRESSION [not] in RANGE -- | SIMPLE_EXPRESSION [not] in SUBTYPE_MARK -- SIMPLE_EXPRESSION ::= -- [UNARY_ADDING_OPERATOR] TERM {BINARY_ADDING_OPERATOR TERM} -- TERM ::= FACTOR {MULTIPLYING_OPERATOR FACTOR} -- FACTOR ::= PRIMARY [** PRIMARY] | abs PRIMARY | not PRIMARY -- No nodes are generated for any of these constructs. Instead, the -- node for the operator appears directly. When we refer to an -- expression in this description, we mean any of the possible -- consistuent components of an expression (e.g. identifier is -- an example of an expression). ------------------ -- 4.4 Primary -- ------------------ -- PRIMARY ::= -- NUMERIC_LITERAL | null -- | STRING_LITERAL | AGGREGATE -- | NAME | QUALIFIED_EXPRESSION -- | ALLOCATOR | (EXPRESSION) -- Usually there is no explicit node in the tree for primary. Instead -- the constituent (e.g. AGGREGATE) appears directly. There are two -- exceptions. First, there is an explicit node for a null primary. -- N_Null -- Sloc points to NULL -- plus fields for expression -- Second, the case of (EXPRESSION) is handled specially. Ada requires -- that the parser keep track of which subexpressions are enclosed -- in parentheses, and how many levels of parentheses are used. This -- information is required for optimization purposes, and also for -- some semantic checks (e.g. (((1))) in a procedure spec does not -- conform with ((((1)))) in a procedure body). A single layer of -- parentheses, the most common case, is recorded by setting the -- Parens flag in the expression node (all nodes that can appear as -- expressions contain this flag field). If more than one level of -- parentheses is present, then we generate an extra node in the tree: -- N_Parenthesized_Expression -- Sloc points to left paren -- Expression (Node3) -- plus fields for expression -- Note: the level of parentheses always present in things like -- aggregates does not count, only the parentheses in the primary -- (EXPRESSION) affect the setting of the Parens flag, or the -- creation of N_Parenthesized_Expression nodes. -- Note: since N_Parenthesized_Expression itself has a Parens flag, -- we only need one of these nodes for every 2 levels of parentheses. -------------------- -- 4.5 Operators -- -------------------- -- UNARY_ADDING_OPERATOR ::= + | - -- LOGICAL_OPERATOR ::= AND | OR | XOR -- RELATIONAL_OPERATOR ::= = | /= | < | <= | > | >= -- BINARY_ADDING_OPERATOR ::= + | - | & -- MULTIPLYING_OPERATOR ::= * | / | MOD | REM -- HIGHEST_PRECEDENCE_OPERATOR ::= ** | ABS | NOT -- N_Op_And -- Sloc points to AND -- Do_Length_Check (Flag4-Sem) -- plus fields for binary operator -- plus fields for expression -- N_Op_And_Then -- Sloc points to AND of AND THEN -- plus fields for binary operator -- plus fields for expression -- N_Op_Or -- Sloc points to OR -- Do_Length_Check (Flag4-Sem) -- plus fields for binary operator -- plus fields for expression -- N_Op_Or_Else -- Sloc points to OR of OR ELSE -- plus fields for binary operator -- plus fields for expression -- N_Op_Xor -- Sloc points to XOR -- Do_Length_Check (Flag4-Sem) -- plus fields for binary operator -- plus fields for expression -- N_Op_In -- Sloc points to IN -- plus fields for binary operator -- plus fields for expression -- N_Op_Not_In -- Sloc points to NOT of NOT IN -- plus fields for binary operator -- plus fields for expression -- N_Op_Eq -- Sloc points to = -- plus fields for binary operator -- plus fields for expression -- N_Op_Ne -- Sloc points to /= -- plus fields for binary operator -- plus fields for expression -- N_Op_Lt -- Sloc points to < -- plus fields for binary operator -- plus fields for expression -- N_Op_Le -- Sloc points to <= -- plus fields for binary operator -- plus fields for expression -- N_Op_Gt -- Sloc points to > -- plus fields for binary operator -- plus fields for expression -- N_Op_Ge -- Sloc points to >= -- plus fields for binary operator -- plus fields for expression -- N_Op_Add -- Sloc points to + (binary) -- plus fields for binary operator -- plus fields for expression -- N_Op_Subtract -- Sloc points to - (binary) -- plus fields for binary operator -- plus fields for expression -- N_Op_Concat -- Sloc points to & -- plus fields for binary operator -- plus fields for expression -- N_Op_Multiply -- Sloc points to * -- plus fields for binary operator -- plus fields for expression -- N_Op_Divide -- Sloc points to / -- Do_Division_Check (Flag3-Sem) -- plus fields for binary operator -- plus fields for expression -- N_Op_Mod -- Sloc points to MOD -- Do_Division_Check (Flag3-Sem) -- plus fields for binary operator -- plus fields for expression -- N_Op_Rem -- Sloc points to REM -- Do_Division_Check (Flag3-Sem) -- plus fields for binary operator -- plus fields for expression -- N_Op_Expon -- Sloc points to ** -- plus fields for binary operator -- plus fields for expression -- N_Op_Plus -- Sloc points to + (unary) -- plus fields for unary operator -- plus fields for expression -- N_Op_Minus -- Sloc points to - (unary) -- plus fields for unary operator -- plus fields for expression -- N_Op_Abs -- Sloc points to ABS -- plus fields for unary operator -- plus fields for expression -- N_Op_Not -- Sloc points to NOT -- plus fields for unary operator -- plus fields for expression -------------------------- -- 4.6 Type Conversion -- -------------------------- -- TYPE_CONVERSION ::= -- SUBTYPE_MARK (EXPRESSION) | SUBTYPE_MARK (NAME) -- In the (NAME) case, the name is stored as the expression -- Note: the parser never generates a type conversion node, since it -- looks like an indexed component which is generated by preference. -- The semantic pass must correct this misidentification. -- N_Type_Conversion -- Sloc points to first token of subtype mark -- Subtype_Mark (Node4) -- Expression (Node3) -- Do_Overflow_Check (Flag2-Sem) -- Do_Tag_Check (Flag3-Sem) -- Do_Length_Check (Flag4-Sem) -- Unchecked_Conversion (Flag11-Sem) -- plus fields for expression -- Note: if a range check is required, then the Do_Range_Check flag -- is set in the Expression with the check being done against the -- target type range (after the base type conversion, if any). ------------------------------- -- 4.7 Qualified Expression -- ------------------------------- -- QUALIFIED_EXPRESSION ::= -- SUBTYPE_MARK ' (EXPRESSION) | SUBTYPE_MARK ' AGGREGATE -- Note: the parentheses in the (EXPRESSION) case are deemed to enclose -- the expression, so the Expression field of this node always points -- to a parenthesized expression in this case (i.e. either Parens will -- be set, or the referenced node will be an N_Parenthesized_Expression -- node if there are additional levels of parentheses. -- N_Qualified_Expression -- Sloc points to apostrophe -- Subtype_Mark (Node4) -- Expression (Node3) expression or aggregate -- plus fields for expression -------------------- -- 4.8 Allocator -- -------------------- -- ALLOCATOR ::= -- new SUBTYPE_INDICATION | new QUALIFIED_EXPRESSION -- N_Allocator -- Sloc points to NEW -- Expression (Node3) subtype indication or qualified expression -- Do_Storage_Check (Flag2-Sem) -- plus fields for expression --------------------------------- -- 5.1 Sequence Of Statements -- --------------------------------- -- SEQUENCE_OF_STATEMENTS ::= STATEMENT {STATEMENT} -- Note: Although the parser will not accept a declaration as a -- statement, the semantic analyzer may insert declarations (e.g. -- declarations of implicit types needed for execution of other -- statements) into a sequence of statements, so the code genmerator -- should be prepared to accept a declaration where a statement is -- expected. Note also that pragmas can appear as statements. -------------------- -- 5.1 Statement -- -------------------- -- STATEMENT ::= -- {LABEL} SIMPLE_STATEMENT | {LABEL} COMPOUND_STATEMENT -- There is no explicit node in the tree for a statement. Instead, the -- individual statement appears directly. Labels are treated as a -- kind of statement, i.e. they are linked into a statement list at -- the point they appear, so the labeled statement appears following -- the label or labels in the statement list. --------------------------- -- 5.1 Simple Statement -- --------------------------- -- SIMPLE_STATEMENT ::= -- NULL_STATEMENT | ASSIGNMENT_STATEMENT -- | EXIT_STATEMENT | RETURN_STATEMENT -- | GOTO_STATEMENT | PROCEDURE_CALL_STATEMENT -- | ENTRY_CALL_STATEMENT | REQUEUE_STATEMENT -- | DELAY_STATEMENT | ABORT_STATEMENT -- | RAISE_STATEMENT | CODE_STATEMENT ----------------------------- -- 5.1 Compound Statement -- ----------------------------- -- COMPOUND_STATEMENT ::= -- IF_STATEMENT | CASE_STATEMENT -- | LOOP_STATEMENT | BLOCK_STATEMENT -- | ACCEPT_STATEMENT | SELECT_STATEMENT ---------------- -- 5.1 Label -- ---------------- -- LABEL ::= <> -- STATEMENT_INDENTIFIER ::= DIRECT_NAME -- The IDENTIFIER of a STATEMENT_IDENTIFIER shall be an identifier -- (not an OPERATOR_SYMBOL) -- Note that the occurrence of a label is not a defining identifier, -- but rather a referencing occurrence. The defining occurrence is -- in the implicit label declaration which occurs in the innermost -- enclosing block. -- N_Label -- Sloc points to << -- Identifier (Node1) direct name -------------------------------- -- Implicit Label Declaration -- -------------------------------- -- An implicit label declaration is created for every occurrence of a -- label on a statement or a label on a block or loop. It is chained -- in the declarations of the innermost enclosing block as specified -- in RM section 5.1 (3). -- Note: from the grammar, this might better be called an implicit -- statement identifier declaration, but the term we choose seems -- friendlier, since at least informally statement identifiers are -- called labels in both cases (i.e. when used in labels, and when -- used as the identifiers of blocks and loops). -- The label field in the implicit label node points to the node -- containing the label (N_Label, N_Loop_Statement, N_Block_Statement). -- N_Implicit_Label_Declaration -- Sloc points to the << of the label -- Defining_Identifier (Node1) -- Label (Node2) points to the associated node ------------------------- -- 5.1 Null Statement -- ------------------------- -- NULL_STATEMENT ::= null; -- N_Null_Statement -- Sloc points to NULL ------------------------------- -- 5.2 Assignment Statement -- ------------------------------- -- ASSIGNMENT_STATEMENT ::= -- variable_NAME := EXPRESSION; -- N_Assignment_Statement -- Sloc points to := -- Name (Node2) -- Expression (Node3) -- Do_Tag_Check (Flag3-Sem) -- Do_Length_Check (Flag4-Sem) -- Assignment_OK (Flag5-Sem) -- Note: if a range check is required, then the Do_Range_Check flag -- is set in the Expression (right hand side), with the check being -- done against the type of the Name (left hand side). ----------------------- -- 5.3 If Statement -- ----------------------- -- IF_STATEMENT ::= -- if CONDITION then -- SEQUENCE_OF_STATEMENTS -- {elsif CONDITION then -- SEQUENCE_OF_STATEMENTS} -- [else -- SEQUENCE_OF_STATEMENTS] -- end if; -- N_If_Statement -- Sloc points to IF -- Condition (Node5) -- Then_Statements (List2) -- Elsif_Parts (List3) (set to No_List if none present) -- Else_Statements (List4) (set to No_List if no else part present) -- N_Elsif_Part -- Sloc points to ELSIF -- Condition (Node5) -- Then_Statements (List2) -------------------- -- 5.3 Condition -- -------------------- -- CONDITION ::= boolean_EXPRESSION ------------------------- -- 5.4 Case Statement -- ------------------------- -- CASE_STATEMENT ::= -- case EXPRESSION is -- CASE_STATEMENT_ALTERNATIVE -- {CASE_STATEMENT_ALTERNATIVE} -- end case; -- N_Case_Statement -- Sloc points to CASE -- Expression (Node3) -- Alternatives (List4) ------------------------------------- -- 5.4 Case Statement Alternative -- ------------------------------------- -- CASE_STATEMENT_ALTERNATIVE ::= -- when DISCRETE_CHOICE_LIST => -- SEQUENCE_OF_STATEMENTS -- N_Case_Statement_Alternative -- Sloc points to WHEN -- Discrete_Choices (List4) -- Statements (List3) ------------------------- -- 5.5 Loop Statement -- ------------------------- -- LOOP_STATEMENT ::= -- [loop_STATEMENT_IDENTIFIER :] -- [ITERATION_SCHEME] loop -- SEQUENCE_OF_STATEMENTS -- end loop [loop_IDENTIFIER]; -- Note: The occurrence of a loop label is not a defining identifier -- but rather a referencing occurrence. The defining occurrence is in -- the implicit label declaration which occurs in the innermost -- enclosing block. -- Note: there is always a loop statement identifier present in -- the tree, even if none was given in the source. In the case where -- no loop identifier is given in the source, the parser creates -- a name of the form _Loop_n, where n is a decimal integer (the -- two underlines ensure that the loop names created in this manner -- do not conflict with any user defined identifiers), and the flag -- Has_Created_Identifier is set to True. The only exception to the -- rule that all loop statement nodes have identifiers occurs for -- loops constructed by the expander, when it is known that no name -- is required. -- N_Loop_Statement -- Sloc points to LOOP -- Identifier (Node1) loop identifier (always present, see above) -- Iteration_Scheme (Node2) (set to Empty if no iteration scheme) -- Statements (List3) -- Has_Created_Identifier (Flag1) -------------------------- -- 5.5 Iteration Scheme -- -------------------------- -- ITERATION_SCHEME ::= -- while CONDITION | for LOOP_PARAMETER_SPECIFICATION -- N_Iteration_Scheme -- Sloc points to WHILE or FOR -- Condition (Node5) (set to Empty if for case) -- Loop_Parameter_Specification (Node2) (set to Empty if while case) --------------------------------------- -- 5.5 Loop parameter specification -- --------------------------------------- -- LOOP_PARAMETER_SPECIFICATION ::= -- DEFINING_IDENTIFIER in [reverse] DISCRETE_SUBTYPE_DEFINITION -- N_Loop_Parameter_Specification -- Sloc points to first identifier -- Defining_Identifier (Node1) -- Reverse_Present (Flag1) -- Discrete_Subtype_Definition (Node4) -------------------------- -- 5.6 Block Statement -- -------------------------- -- BLOCK_STATEMENT ::= -- [block_STATEMENT_IDENTIFIER:] -- [declare -- DECLARATIVE_PART] -- begin -- HANDLED_SEQUENCE_OF_STATEMENTS -- end [block_IDENTIFIER]; -- Note that the occurrence of a block identifier is not a defining -- identifier, but rather a referencing occurrence. The defining -- occurrence is in the implicit label declaration which occurs in -- the innermost enclosing block. -- Note: there is always a block statement identifier present in -- the tree, even if none was given in the source. In the case where -- no block identifier is given in the source, the parser creates -- a name of the form _Block_n, where n is a decimal integer (the -- two underlines ensure that the block names created in this manner -- do not conflict with any user defined identifiers), and the flag -- Has_Created_Identifier is set to True. The only exception to the -- rule that all loop statement nodes have identifiers occurs for -- loops constructed by the expander, when it is known that no name -- is required. -- N_Block_Statement -- Sloc points to DECLARE or BEGIN -- Identifier (Node1) block direct name (always present, see above) -- Declarations (List3) (set to No_List if no DECLARE part) -- Handled_Statement_Sequence (Node4) -- Is_Task_Master (Flag5-Sem) -- Activation_Chain_Entity (Node2-Sem) -- Has_Created_Identifier (Flag1) ------------------------- -- 5.7 Exit Statement -- ------------------------- -- EXIT_STATEMENT ::= exit [loop_NAME] [when CONDITION]; -- N_Exit_Statement -- Sloc points to EXIT -- Name (Node2) (set to Empty if no loop name present) -- Condition (Node5) (set to Empty if no when part present) --------------------------- -- 5.8 Return Statement -- --------------------------- -- RETURN_STATEMENT is moved to section 6.5 ------------------------- -- 5.9 Goto Statement -- ------------------------- -- GOTO_STATEMENT ::= goto label_NAME; -- N_Goto_Statement -- Sloc points to GOTO -- Name (Node2) --------------------------------- -- 6.1 Subprogram Declaration -- --------------------------------- -- SUBPROGRAM_DECLARATION ::= SUBPROGRAM_SPECIFICATION; -- N_Subprogram_Declaration -- Sloc points to FUNCTION or PROCEDURE -- Specification (Node1) -- Corresponding_Body (Node5-Sem) -- Parent_Spec (Node4-Lib) ------------------------------------------ -- 6.1 Abstract Subprogram Declaration -- ------------------------------------------ -- ABSTRACT_SUBPROGRAM_DECLARATION ::= -- SUBPROGRAM_SPECIFICATION is abstract; -- N_Abstract_Subprogram_Declaration -- Sloc points to ABSTRACT -- Specification (Node1) ----------------------------------- -- 6.1 Subprogram Specification -- ----------------------------------- -- SUBPROGRAM_SPECIFICATION ::= -- procedure DEFINING_PROGRAM_UNIT_NAME PARAMETER_PROFILE -- | function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE -- Note: there are no separate nodes for the profiles, instead the -- information appears directly in the following nodes. -- N_Function_Specification -- Sloc points to FUNCTION -- Defining_Unit_Name (Node1) (the designator) -- Parameter_Specifications (List2) (set to No_List if no formal part) -- Subtype_Mark (Node4) for return type -- Generic_Parent (Node5-Sem) -- N_Procedure_Specification -- Sloc points to PROCEDURE -- Defining_Unit_Name (Node1) -- Parameter_Specifications (List2) (set to No_List if no formal part) -- Generic_Parent (Node5-Sem) --------------------- -- 6.1 Designator -- --------------------- -- DESIGNATOR ::= -- [PARENT_UNIT_NAME .] IDENTIFIER | OPERATOR_SYMBOL -- Designators that are simply identifiers or operator symbols appear -- directly in the tree in this form. The following node is used only -- in the case where the designator has a parent unit name component. -- N_Designator -- Sloc points to period -- Name (Node2) holds the parent unit name. Note that this is always -- non-Empty, since this node is only used for the case where a -- parent library unit package name is present. -- Identifier (Node1) ------------------------------ -- 6.1 Defining Designator -- ------------------------------ -- DEFINING_DESIGNATOR ::= -- DEFINING_PROGRAM_UNIT_NAME | DEFINING_OPERATOR_SYMBOL ------------------------------------- -- 6.1 Defining Program Unit Name -- ------------------------------------- -- DEFINING_PROGRAM_UNIT_NAME ::= -- [parent_library_unit_package_NAME .] DEFINING_IDENTIFIER -- The parent library unit package name is present only in the case -- of a child unit name (permissible only for Ada 9X for a library -- level unit, i.e. a unit at scope level one). If no such name is -- present, the defining program unit name is represented simply as -- the defining identifier. In the child unit case, the following -- node is used to represent the child unit name. -- N_Defining_Program_Unit_Name -- Sloc points to period -- Name (Node2) holds the parent unit name. Note that this is always -- non-Empty, since this node is only used for the case where a -- parent library unit package name is present. -- Defining_Identifier (Node1) -------------------------- -- 6.1 Operator Symbol -- -------------------------- -- OPERATOR_SYMBOL ::= STRING_LITERAL -- Note: the fields of the N_Operator_Symbol node are layed out to -- match the corresponding fields of an N_Character_Literal node. This -- allows easy conversion of the operator symbol node into a character -- literal node in the case where a string constant of the form of an -- operator symbol is scanned out as such, but turns out semantically -- to be a string literal that is not an operator. For details see -- Sinfo.Change.Change_Operator_Symbol_To_String_Literal. -- N_Operator_Symbol -- Sloc points to literal -- Chars (Name1) contains the Name_Id for the operator symbol -- Strval (Str3) Id of string value. This is used if the operator -- symbol turns out to be a normal string after all. -- Entity (Node4-Sem) -- Etype (Node5-Sem) ----------------------------------- -- 6.1 Defining Operator Symbol -- ----------------------------------- -- DEFINING_OPERATOR_SYMBOL ::= OPERATOR_SYMBOL -- A defining operator symbol is an entity, which has additional -- fields depending on the setting of the Ekind field. These -- additional fields are defined (and access subprograms declared) -- in package Entity_Info. -- Note: N_Defining_Operator_Symbol is an extended node whose fields -- are deliberate layed out to match the layout of fields in an ordinary -- N_Operator_Symbol node allowing for easy alteration of an operator -- symbol node into a defining operator symbol node. For details, see -- Sinfo.Change.Change_Operator_Symbol_To_Defining_Operator_Symbol. -- N_Defining_Operator_Symbol -- Sloc points to literal -- Chars (Name1) contains the Name_Id for the operator symbol -- Etype (Node5-Sem) ---------------------------- -- 6.1 Parameter Profile -- ---------------------------- -- PARAMETER_PROFILE ::= [FORMAL_PART] --------------------------------------- -- 6.1 Parameter and Result Profile -- --------------------------------------- -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] RETURN SUBTYPE_MARK -- There is no explicit node in the tree for a parameter and result -- profile. Instead the information appears directly in the parent. ---------------------- -- 6.1 Formal part -- ---------------------- -- FORMAL_PART ::= (PARAMETER_SPECIFICATION -- {; PARAMETER_SPECIFICATION}) ---------------------------------- -- 6.1 Parameter specification -- ---------------------------------- -- PARAMETER_SPECIFICATION ::= -- DEFINING_IDENTIFIER_LIST : MODE SUBTYPE_MARK -- [:= DEFAULT_EXPRESSION] -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION -- [:= DEFAULT_EXPRESSION] -- Although the syntax allows multiple identifiers in the list, the -- semantics is as though successive specifications were given with -- identical type definition and expression components. To simplify -- semantic processing, the parser represents a multiple declaration -- case as a sequence of single Specifications, using the More_Ids and -- Prev_Ids flags to preserve the original source form as described -- in the section on "Handling of Defining Identifier Lists". -- N_Parameter_Specification -- Sloc points to first identifier -- Defining_Identifier (Node1) -- In_Present (Flag1) -- Out_Present (Flag2) -- Parameter_Type (Node2) subtype mark or access definition -- Expression (Node3) (set to Empty if no initialization present) -- Do_Accessibility_Check (Flag3-Sem) -- More_Ids (Flag5) (set to False if no more identifiers in list) -- Prev_Ids (Flag6) (set to False if no previous identifiers in list) --------------- -- 6.1 Mode -- --------------- -- MODE ::= [in] | in out | out -- There is no explicit node in the tree for the Mode. Instead the -- In_Present and Out_Present flags are set in the parent node to -- record the presence of keywords specifying the mode. -------------------------- -- 6.3 Subprogram Body -- -------------------------- -- SUBPROGRAM_BODY ::= -- SUBPROGRAM_SPECIFICATION is -- DECLARATIVE_PART -- begin -- HANDLED_SEQUENCE_OF_STATEMENTS -- end [DESIGNATOR]; -- N_Subprogram_Body -- Sloc points to FUNCTION or PROCEDURE -- Specification (Node1) -- Declarations (List3) -- Handled_Statement_Sequence (Node4) -- Bad_Is_Detected (Flag1) used only by parser -- Corresponding_Spec (Node5-Sem) -- Acts_As_Spec (Flag4-Sem) -- Do_Storage_Check (Flag2-Sem) -- Is_Task_Master (Flag5-Sem) -- Activation_Chain_Entity (Node2-Sem) -- Has_Priority_Pragma (Flag6-Sem) ----------------------------------- -- 6.4 Procedure Call Statement -- ----------------------------------- -- PROCEDURE_CALL_STATEMENT ::= -- procedure_NAME; | procedure_PREFIX ACTUAL_PARAMETER_PART; -- Note: the reason that a procedure call has expression fields is -- that it semantically resembles an expression, e.g. overloading is -- allowed and a type is concocted for semantic processing purposes. -- Certain of these fields, such as Parens are not relevant, but it -- is easier to just supply all of them together! -- N_Procedure_Call_Statement -- Sloc points to first token of name or prefix -- Name (Node2) stores name or prefix -- Parameter_Associations (List3) (set to No_List if no -- actual parameter part) -- First_Named_Actual (Node4-Sem) -- Controlling_Argument (Node1-Sem) controlling tag (set to Empty if -- non-dispatching call) -- Do_Elaboration_Check (Flag2-Sem) -- Do_Tag_Check (Flag3-Sem) -- plus fields for expression -- If any IN parameter requires a range check, then the corresponding -- argument expression has the Do_Range_Check flag set, and the range -- check is done against the formal type. Note that this argument -- expression may appear directly in the Parameter_Associations list, -- or may be a descendent of an N_Parameter_Association node that -- appears in this list. ------------------------ -- 6.4 Function Call -- ------------------------ -- FUNCTION_CALL ::= -- function_NAME | function_PREFIX ACTUAL_PARAMETER_PART -- Note: the parser may generate an indexed component node or simply -- a name node instead of a function call node. The semantic pass must -- correct this misidentification. -- N_Function_Call -- Sloc points to first token of name or prefix -- Name (Node2) stores name or prefix -- Parameter_Associations (List3) (set to No_List if no -- actual parameter part) -- First_Named_Actual (Node4-Sem) -- Controlling_Argument (Node1-Sem) controlling tag (set to Empty if -- non-dispatching call) -- Do_Elaboration_Check (Flag2) -- Do_Tag_Check (Flag3-Sem) -- plus fields for expression -------------------------------- -- 6.4 Actual Parameter Part -- -------------------------------- -- ACTUAL_PARAMETER_PART ::= -- (PARAMETER_ASSOCIATION {,PARAMETER_ASSOCIATION}) -------------------------------- -- 6.4 Parameter Association -- -------------------------------- -- PARAMETER_ASSOCIATION ::= -- [formal_parameter_SELECTOR_NAME =>] ACTUAL_PARAMETER -- Note: the N_Parameter_Association node is built only if a formal -- parameter selector name is present, otherwise the parameter -- association appears in the tree simply as the node for the -- actual parameter. -- N_Parameter_Association -- Sloc points to formal parameter -- Selector_Name (Node3) (always non-Empty, since this node is -- only used if a formal parameter selector name is present) -- Actual_Parameter (Node2) -- Next_Named_Actual (Node4-Sem) --------------------------- -- 6.4 Formal Parameter -- --------------------------- -- FORMAL_PARAMETER ::= parameter_SELECTOR_NAME --------------------------- -- 6.4 Actual Parameter -- --------------------------- -- ACTUAL_PARAMETER ::= EXPRESSION | variable_NAME --------------------------- -- 6.5 Return Statement -- --------------------------- -- RETURN_STATEMENT ::= return [EXPRESSION]; -- N_Return_Statement -- Sloc points to RETURN -- Expression (Node3) (set to Empty if no expression present) -- Do_Tag_Check (Flag3-Sem) -- Note: if a range check is required, then an additional type -- conversion node is introduced to represent the required check. ------------------------------ -- 7.1 Package Declaration -- ------------------------------ -- PACKAGE_DECLARATION ::= PACKAGE_SPECIFICATION; -- Note: the activation chain entity for a package spec is used for -- all tasks declared in the package spec, or in the package body. -- N_Package_Declaration -- Sloc points to PACKAGE -- Specification (Node1) -- Corresponding_Body (Node5-Sem) -- Parent_Spec (Node4-Lib) -- Activation_Chain_Entity (Node2-Sem) -------------------------------- -- 7.1 Package Specification -- -------------------------------- -- PACKAGE_SPECIFICATION ::= -- package DEFINING_PROGRAM_UNIT_NAME is -- {BASIC_DECLARATIVE_ITEM} -- [private -- {BASIC_DECLARATIVE_ITEM}] -- end [[PARENT_UNIT_NAME .] IDENTIFIER] -- N_Package_Specification -- Sloc points to PACKAGE -- Defining_Unit_Name (Node1) -- Visible_Declarations (List2) -- Private_Declarations (List4) (set to No_List if no private -- part present) -- Generic_Parent (Node5-Sem) ----------------------- -- 7.1 Package Body -- ----------------------- -- PACKAGE_BODY ::= -- package body DEFINING_PROGRAM_UNIT_NAME is -- DECLARATIVE_PART -- [begin -- HANDLED_SEQUENCE_OF_STATEMENTS] -- end [[parent_library_unit_package_NAME .] IDENTIFIER]; -- N_Package_Body -- Sloc points to PACKAGE -- Defining_Unit_Name (Node1) -- Declarations (List3) -- Handled_Statement_Sequence (Node4) (set to Empty if not present) -- Corresponding_Spec (Node5-Sem) ----------------------------------- -- 7.4 Private Type Declaration -- ----------------------------------- -- PRIVATE_TYPE_DECLARATION ::= -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] -- is [abstract] [tagged] [limited] private; -- Note: TAGGED is not permitted in Ada 83 mode -- N_Private_Type_Declaration -- Sloc points to TYPE -- Defining_Identifier (Node1) -- Discriminant_Specifications (List2) (set to No_List if no -- discriminant part) -- Has_Unknown_Discriminants (Flag3) set if (<>) discriminant -- Abstract_Present (Flag4) -- Tagged_Present (Flag1) -- Limited_Present (Flag2) ---------------------------------------- -- 7.4 Private Extension Declaration -- ---------------------------------------- -- PRIVATE_EXTENSION_DECLARATION ::= -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] -- is new [abstract] ancestor_SUBTYPE_INDICATION with private; -- Note: private extension declarations are not allowed in Ada 83 mode -- N_Private_Extension_Declaration -- Sloc points to TYPE -- Defining_Identifier (Node1) -- Discriminant_Specifications (List2) (set to No_List if no -- discriminant part) -- Has_Unknown_Discriminants (Flag3) set if (<>) discriminant -- Abstract_Present (Flag4) -- Subtype_Indication (Node4) --------------------- -- 8.4 Use Clause -- --------------------- -- USE_CLAUSE ::= USE_PACKAGE_CLAUSE | USE_TYPE_CLAUSE ----------------------------- -- 8.4 Use Package Clause -- ----------------------------- -- USE_PACKAGE_CLAUSE ::= use package_NAME {, package_NAME}; -- N_Use_Package_Clause -- Sloc points to USE -- Names (List2) -------------------------- -- 8.4 Use Type Clause -- -------------------------- -- USE_TYPE_CLAUSE ::= use type SUBTYPE_MARK {, SUBTYPE_MARK}; -- Note: use type clause is not permitted in Ada 83 mode -- N_Use_Type_Clause -- Sloc points to USE -- Subtype_Marks (List2) ------------------------------- -- 8.5 Renaming Declaration -- ------------------------------- -- RENAMING_DECLARATION ::= -- OBJECT_RENAMING_DECLARATION -- | EXCEPTION_RENAMING_DECLARATION -- | PACKAGE_RENAMING_DECLARATION -- | SUBPROGRAM_RENAMING_DECLARATION -- | GENERIC_RENAMING_DECLARATION -------------------------------------- -- 8.5 Object Renaming Declaration -- -------------------------------------- -- OBJECT_RENAMING_DECLARATION ::= -- DEFINING_IDENTIFIER : SUBTYPE_MARK renames object_NAME; -- N_Object_Renaming_Declaration -- Sloc points to first identifier -- Defining_Identifier (Node1) -- Subtype_Mark (Node4) -- Name (Node2) ----------------------------------------- -- 8.5 Exception Renaming Declaration -- ----------------------------------------- -- EXCEPTION_RENAMING_DECLARATION ::= -- DEFINING_IDENTIFIER : exception renames exception_NAME; -- N_Exception_Renaming_Declaration -- Sloc points to first identifier -- Defining_Identifier (Node1) -- Name (Node2) --------------------------------------- -- 8.5 Package Renaming Declaration -- --------------------------------------- -- PACKAGE_RENAMING_DECLARATION ::= -- package DEFINING_PROGRAM_UNIT_NAME renames package_NAME; -- N_Package_Renaming_Declaration -- Sloc points to PACKAGE -- Defining_Unit_Name (Node1) -- Name (Node2) -- Parent_Spec (Node4-Lib) ------------------------------------------ -- 8.5 Subprogram Renaming Declaration -- ------------------------------------------ -- SUBPROGRAM_RENAMING_DECLARATION ::= -- SUBPROGRAM_SPECIFICATION renames callable_entity_NAME; -- N_Subprogram_Renaming_Declaration -- Sloc points to RENAMES -- Specification (Node1) -- Name (Node2) -- Parent_Spec (Node4-Lib) -- Corresponding_Spec (Node5-Sem) ----------------------------------------- -- 8.5.5 Generic Renaming Declaration -- ----------------------------------------- -- GENERIC_RENAMING_DECLARATION ::= -- generic package DEFINING_PROGRAM_UNIT_NAME -- renames generic_package_NAME -- | generic procedure DEFINING_PROGRAM_UNIT_NAME -- renames generic_procedure_NAME -- | generic function DEFINING_PROGRAM_UNIT_NAME -- renames generic_function_NAME -- N_Generic_Package_Renaming_Declaration -- Sloc points to GENERIC -- Defining_Unit_Name (Node1) -- Name (Node2) -- Parent_Spec (Node4-Lib) -- N_Generic_Procedure_Renaming_Declaration -- Sloc points to GENERIC -- Defining_Unit_Name (Node1) -- Name (Node2) -- Parent_Spec (Node4-Lib) -- N_Generic_Function_Renaming_Declaration -- Sloc points to GENERIC -- Defining_Unit_Name (Node1) -- Name (Node2) -- Parent_Spec (Node4-Lib) -------------------------------- -- 9.1 Task Type Declaration -- -------------------------------- -- TASK_TYPE_DECLARATION ::= -- task type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] -- [is TASK_DEFINITITION]; -- N_Task_Type_Declaration -- Sloc points to TASK -- Defining_Identifier (Node1) -- Discriminant_Specifications (List2) (set to No_List if no -- discriminant part) -- Task_Definition (Node3) (set to Empty if not present) ---------------------------------- -- 9.1 Single Task Declaration -- ---------------------------------- -- SINGLE_TASK_DECLARATION ::= -- task DEFINING_IDENTIFIER [is TASK_DEFINITION]; -- N_Single_Task_Declaration -- Sloc points to TASK -- Defining_Identifier (Node1) -- Discriminant_Specifications (List2) (set to No_List if true, -- i.e. always set to No_List) -- Task_Definition (Node3) (set to Empty if not present) -- Note: the reason we add a Discriminant_Specifications field -- that is always set to No_List is to alow easier processing of -- single task declarations using code for task type declarations. -------------------------- -- 9.1 Task Definition -- -------------------------- -- TASK_DEFINITION ::= -- {TASK_ITEM} -- [private -- {TASK_ITEM} -- end [task_IDENTIFIER] -- Note: as a result of semantic analysis, the list of task items can -- include implicit type declarations resulting from entry families. -- N_Task_Definition -- Sloc points to first token of task definition -- Visible_Declarations (List2) -- Private_Declarations (List4) (set to No_List if no private part) -- Has_Priority_Pragma (Flag6-Sem) -- Has_Task_Stack_Size_Pragma (Flag5-Sem) -------------------- -- 9.1 Task Item -- -------------------- -- TASK_ITEM ::= ENTRY_DECLARATION | REPRESENTATION_CLAUSE -------------------- -- 9.1 Task Body -- -------------------- -- TASK_BODY ::= -- task body task_DEFINING_IDENTIFIER is -- DECLARATIVE_PART -- begin -- HANDLED_SEQUENCE_OF_STATEMENTS -- end [task_IDENTIFIER]; -- N_Task_Body -- Sloc points to TASK -- Defining_Identifier (Node1) -- Declarations (List3) -- Handled_Statement_Sequence (Node4) -- Is_Task_Master (Flag5-Sem) -- Activation_Chain_Entity (Node2-Sem) -- Corresponding_Spec (Node5-Sem) ------------------------------------- -- 9.4 Protected Type Declaration -- ------------------------------------- -- PROTECTED_TYPE_DECLARATION ::= -- protected type DEFINING_IDENTIFIER [KNOWN_DISCRIMINANT_PART] -- is PROTECTED_DEFINITION; -- Note: protected type declarations are not permitted in Ada 83 mode -- N_Protected_Type_Declaration -- Sloc points to PROTECTED -- Defining_Identifier (Node1) -- Discriminant_Specifications (List2) (set to No_List if no -- discriminant part) -- Protected_Definition (Node3) --------------------------------------- -- 9.4 Single Protected Declaration -- --------------------------------------- -- SINGLE_PROTECTED_DECLARATION ::= -- protected DEFINING_IDENTIFIER is PROTECTED_DEFINITION; -- Note: single protected declarations are not allowed in Ada 83 mode -- N_Single_Protected_Declaration -- Sloc points to PROTECTED -- Defining_Identifier (Node1) -- Discriminant_Specifications (List2) (set to No_List if true, -- i.e. always set to No_List) -- Protected_Definition (Node3) -- Note: the reason we add a Discriminant_Specifications field that -- is always set to No_List is to alow easier processing of single -- single protected declarations using code for protected type -- declarations. ------------------------------- -- 9.4 Protected Definition -- ------------------------------- -- PROTECTED_DEFINITION ::= -- {PROTECTED_OPERATION_DECLARATION} -- [private -- {PROTECTED_ELEMENT_DECLARATION}] -- end [protected_IDENTIFIER] -- N_Protected_Definition -- Sloc points to first token of protected definition -- Visible_Declarations (List2) -- Private_Declarations (List4) (set to No_List if no private part) -- Has_Priority_Pragma (Flag6-Sem) ------------------------------------------ -- 9.4 Protected Operation Declaration -- ------------------------------------------ -- PROTECTED_OPERATION_DECLARATION ::= -- SUBPROGRAM_DECLARATION | ENTRY_DECLARATION ---------------------------------------- -- 9.4 Protected Element Declaration -- ---------------------------------------- -- PROTECTED_ELEMENT_DECLARATION ::= -- PROTECTED_OPERATION_DECLARATION | COMPONENT_DECLARATION ------------------------- -- 9.4 Protected Body -- ------------------------- -- PROTECTED_BODY ::= -- protected body DEFINING_IDENTIFIER is -- {PROTECTED_OPERATION_ITEM} -- end [protected_IDENTIFIER]; -- Note: protected bodies are not allowed in Ada 83 mode -- N_Protected_Body -- Sloc points to PROTECTED -- Defining_Identifier (Node1) -- Declarations (List3) protected operation items (and pragmas) ----------------------------------- -- 9.4 Protected Operation Item -- ----------------------------------- -- PROTECTED_OPERATION_ITEM ::= -- SUBPROGRAM_DECLARATION | SUBPROGRAM_BODY | ENTRY_BODY ------------------------------ -- 9.5.2 Entry Declaration -- ------------------------------ -- ENTRY_DECLARATION ::= -- entry DEFINING_IDENTIFIER -- [(DISCRETE_SUBTYPE_DEFINITION)] PARAMETER_PROFILE; -- N_Entry_Declaration -- Sloc points to ENTRY -- Defining_Identifier (Node1) -- Discrete_Subtype_Definition (Node4) (set to Empty if not present) -- Parameter_Specifications (List2) formal part ----------------------------- -- 9.5.2 Accept statement -- ----------------------------- -- ACCEPT_STATEMENT ::= -- accept entry_DIRECT_NAME -- [(ENTRY_INDEX)] PARAMETER_PROFILE [do -- HANDLED_SEQUENCE_OF_STATEMENTS -- end [entry_IDENTIFIER]]; -- Note: the syntax does not allow for declarations, but for uniformtiy -- with other constructs having a handled sequence of statements, a -- Declarations field is present in the node. Normally this will be -- empty. The only time it is non-empty is as a result of expansion -- activity, on the way to converting the accept to a procedure body. -- N_Accept_Statement -- Sloc points to ACCEPT -- Accept_Name (Node1) -- Entry_Index (Node5) (set to Empty if not present) -- Declarations (List3) (set to No_List if none, see note above) -- Parameter_Specifications (List2) (set to No_List if no formal part) -- Handled_Statement_Sequence (Node4) ------------------------ -- 9.5.2 Entry Index -- ------------------------ -- ENTRY_INDEX ::= EXPRESSION ----------------------- -- 9.5.2 Entry Body -- ----------------------- -- ENTRY_BODY ::= -- entry DEFINING_IDENTIFIER ENTRY_BODY_FORMAL_PART ENTRY_BARRIER is -- DECLARATIVE_PART -- begin -- HANDLED_SEQUENCE_OF_STATEMENTS -- end [entry_IDENTIFIER]; -- ENTRY_BARRIER ::= when CONDITION -- N_Entry_Body -- Sloc points to ENTRY -- Defining_Identifier (Node1) -- Entry_Body_Formal_Part (Node2) -- Declarations (List3) -- Handled_Statement_Sequence (Node4) -- Condition (Node5) from entry barrier ----------------------------------- -- 9.5.2 Entry Body Formal Part -- ----------------------------------- -- ENTRY_BODY_FORMAL_PART ::= -- [(ENTRY_INDEX_SPECIFIATION)] [FORMAL_PART] -- Note that an entry body formal part node is present even if it is -- empty. This reflects the grammar, in which it is the components of -- the entry body formal part that are optional, not the entry body -- formal part itself. -- N_Entry_Body_Formal_Part -- Entry_Index_Specification (Node1) (set to Empty if not present) -- Parameter_Specifications (List2) (set to No_List if no formal part) -------------------------- -- 9.5.2 Entry Barrier -- -------------------------- -- ENTRY_BARRIER ::= when CONDITION -------------------------------------- -- 9.5.2 Entry Index Specification -- -------------------------------------- -- ENTRY_INDEX_SPECIFICATION ::= -- for DEFINING_IDENTIFIER in DISCRETE_SUBTYPE_DEFINITION -- N_Entry_Index_Specification -- Sloc points to FOR -- Defining_Identifier (Node1) -- Discrete_Subtype_Definition (Node4) --------------------------------- -- 9.5.3 Entry Call Statement -- --------------------------------- -- ENTRY_CALL_STATEMENT ::= entry_NAME [ACTUAL_PARAMETER_PART]; -- The parser may generate a procedure call for this construct. The -- semantic pass must correct this misidentification where needed. -- N_Entry_Call_Statement -- Sloc points to first token of name -- Name (Node2) -- Parameter_Associations (List3) (set to No_List if no -- actual parameter part) -- Do_Elaboration_Check (Flag2-Sem) ------------------------------ -- 9.5.4 Requeue Statement -- ------------------------------ -- REQUEUE_STATEMENT ::= requeue entry_NAME [with abort]; -- Note: requeue statements are not permitted in Ada 83 mode -- N_Requeue_Statement -- Sloc points to REQUEUE -- Name (Node2) -- Abort_Present (Flag1) -------------------------- -- 9.6 Delay Statement -- -------------------------- -- DELAY_STATEMENT ::= -- DELAY_UNTIL_STATEMENT -- | DELAY_RELATIVE_STATEMENT -------------------------------- -- 9.6 Delay Until Statement -- -------------------------------- -- DELAY_UNTIL_STATEMENT ::= delay until delay_EXPRESSION; -- Note: delay until statements are not permitted in Ada 83 mode -- N_Delay_Until_Statement -- Sloc points to DELAY -- Expression (Node3) ----------------------------------- -- 9.6 Delay Relative Statement -- ----------------------------------- -- DELAY_RELATIVE_STATEMENT ::= delay delay_EXPRESSION; -- N_Delay_Relative_Statement -- Sloc points to DELAY -- Expression (Node3) --------------------------- -- 9.7 Select Statement -- --------------------------- -- SELECT_STATEMENT ::= -- SELECTIVE_ACCEPT -- | CONDITIONAL_ENTRY_CALL -- | TIMED_ENTRY_CALL -- | ASYNCHRONOUS_SELECT ----------------------------- -- 9.7.1 Selective Accept -- ----------------------------- -- SELECTIVE_ACCEPT ::= -- select -- [GUARD] -- SELECT_ALTERNATIVE -- {or -- [GUARD] -- SELECT_ALTERNATIVE} -- [else -- SEQUENCE_OF_STATEMENTS] -- end select; -- GUARD ::= when CONDITION => -- Note: the CONDITION that is part of a GUARD is included in the -- node for the selective accept alternative for convenience. -- N_Selective_Accept -- Sloc points to SELECT -- Selective_Accept_Alternatives (List1) -- Else_Statements (List4) (set to No_List if no else part) ------------------ -- 9.7.1 Guard -- ------------------ -- GUARD ::= when CONDITION => -- As noted above, the CONDITION that is part of a GUARD is included -- in the node for the selective accept alernative for convenience. ------------------------------- -- 9.7.1 Select Alternative -- ------------------------------- -- SELECT_ALTERNATIVE ::= -- ACCEPT_ALTERNATIVE | DELAY_ALTERNATIVE | TERMINATE_ALTERNATIVE ------------------------------- -- 9.7.1 Accept Alternative -- ------------------------------- -- ACCEPT_ALTERNATIVE ::= -- ACCEPT_STATEMENT [SEQUENCE_OF_STATEMENTS] -- N_Accept_Alternative -- Sloc points to ACCEPT -- Accept_Statement (Node2) -- Condition (Node5) from the guard (set to Empty if no guard present) -- Statements (List3) (set to Empty_List if no statements) ------------------------------ -- 9.7.1 Delay Alternative -- ------------------------------ -- DELAY_ALTERNATIVE ::= -- DELAY_STATEMENT [SEQUENCE_OF_STATEMENTS] -- N_Delay_Alternative -- Sloc points to DELAY -- Delay_Statement (Node2) -- Condition (Node5) from the guard (set to Empty if no guard present) -- Statements (List3) (set to Empty_List if no statements) ---------------------------------- -- 9.7.1 Terminate Alternative -- ---------------------------------- -- TERMINATE_ALTERNATIVE ::= terminate; -- N_Terminate_Alternative -- Sloc points to TERMINATE -- Condition (Node5) from the guard (set to Empty if no guard present) ----------------------------------- -- 9.7.2 Conditional Entry Call -- ----------------------------------- -- CONDITIONAL_ENTRY_CALL ::= -- select -- ENTRY_CALL_ALTERNATIVE -- else -- SEQUENCE_OF_STATEMENTS -- end select; -- N_Conditional_Entry_Call -- Sloc points to SELECT -- Entry_Call_Alternative (Node1) -- Else_Statements (List4) ----------------------------------- -- 9.7.2 Entry Call Alternative -- ----------------------------------- -- ENTRY_CALL_ALTERNATIVE ::= -- ENTRY_CALL_STATEMENT [SEQUENCE_OF_STATEMENTS] -- N_Entry_Call_Alternative -- Sloc points to first token of entry call statement -- Entry_Call_Statement (Node1) -- Statements (List3) (set to Empty_List if no statements) ----------------------------- -- 9.7.3 Timed Entry Call -- ----------------------------- -- TIMED_ENTRY_CALL ::= -- select -- ENTRY_CALL_ALTERNATIVE -- or -- DELAY_ALTERNATIVE -- end select; -- N_Timed_Entry_Call -- Sloc points to SELECT -- Entry_Call_Alternative (Node1) -- Delay_Alternative (Node4) -------------------------------- -- 9.7.4 Asynchronous Select -- -------------------------------- -- ASYNCHRONOUS_SELECT ::= -- select -- TRIGGERING_ALTERNATIVE -- then abort -- ABORTABLE_PART -- end select; -- Note: asyncrhonous select is not permitted in Ada 83 mode -- N_Asynchronous_Select -- Sloc points to SELECT -- Triggering_Alternative (Node1) -- Abortable_Part (Node2) ----------------------------------- -- 9.7.4 Triggering Alternative -- ----------------------------------- -- TRIGGERING_ALTERNATIVE ::= -- TRIGGERING_STATEMENT [SEQUENCE_OF_STATEMENTS] -- N_Triggering_Alternative -- Sloc points to first token of triggering statement -- Triggering_Statement (Node1) -- Statements (List3) (set to Empty_List if no statements) --------------------------------- -- 9.7.4 Triggering Statement -- --------------------------------- -- TRIGGERING_STATEMENT ::= ENTRY_CALL_STATEMENT | DELAY_STATEMENT --------------------------- -- 9.7.4 Abortable Part -- --------------------------- -- ABORTABLE_PART ::= SEQUENCE_OF_STATEMENTS -- N_Abortable_Part -- Sloc points to ABORT -- Statements (List3) -------------------------- -- 9.8 Abort Statement -- -------------------------- -- ABORT_STATEMENT ::= abort task_NAME {, task_NAME}; -- N_Abort_Statement -- Sloc points to ABORT -- Names (List2) ------------------------- -- 10.1.1 Compilation -- ------------------------- -- COMPILATION ::= {COMPILATION_UNIT} ------------------------------ -- 10.1.1 Compilation Unit -- ------------------------------ -- COMPILATION_UNIT ::= -- CONTEXT_CLAUSE [private] LIBRARY_ITEM -- | CONTEXT_CLAUSE SUBUNIT -- N_Compilation_Unit -- Sloc points to first token of defining unit name -- Library_Unit (Node4-Lib) corresponding/parent spec/body -- Context_Items (List1) context items and pragmas preceding unit -- Private_Present (Flag1) set if library unit has private keyword -- Unit (Node2) library item or subunit -- Following_Pragmas (List3) pragmas after unit (set to No_List if -- no following pragmas) -- Preelaborable (Flag2-Sem) -- Body_Required (Flag3-Sem) set for spec if body is required -- Acts_As_Spec (Flag4-Lib) flag for subprogram body with no spec -- Elaborate_Body_Present (Flag7-Sem) set if Elaborate_Body pragma -------------------------- -- 10.1.1 Library Item -- -------------------------- -- LIBRARY_ITEM ::= -- private LIBRARY_UNIT_DECLARATION | LIBRARY_UNIT_BODY -- Note: PRIVATE is not allowed in Ada 83 mode -- There is no explicit node in the tree for library item, instead -- the declaration or body, and the flag for private if present, -- appear in the N_Compilation_Unit clause. ---------------------------------------- -- 10.1.1 Library Unit Declararation -- ---------------------------------------- -- LIBRARY_UNIT_DECLARATION ::= -- SUBPROGRAM_DECLARATION | PACKAGE_DECLARATION -- | GENERIC_DECLARATION | GENERIC_INSTANTIATION -- | LIBRARY_UNIT_RENAMING_DECLARATION ------------------------------------------------- -- 10.1.1 Library Unit Renaming Declararation -- ------------------------------------------------- -- LIBRARY_UNIT_RENAMING_DECLARATION ::= -- PACKAGE_RENAMING_DECLARATION -- | GENERIC_RENAMING_DECLARATION -- | SUBPROGRAM_RENAMING_DECLARATION ------------------------------- -- 10.1.1 Library unit body -- ------------------------------- -- LIBRARY_UNIT_BODY ::= SUBPROGRAM_BODY | PACKAGE_BODY ------------------------------ -- 10.1.1 Parent Unit Name -- ------------------------------ -- PARENT_UNIT_NAME ::= NAME ---------------------------- -- 10.1.2 Context clause -- ---------------------------- -- CONTEXT_CLAUSE ::= {CONTEXT_ITEM} -- Note: context items can also include pragma Elaborate and pragma -- Elaborate_Body, so these items can also appear in this list as -- well as other configuration pragmas that might appear. In addition, -- any pragmas appearing after the compilation unit, in particular, -- pragma Inline's are appended to the end of this list. -------------------------- -- 10.1.2 Context_Item -- -------------------------- -- CONTEXT_ITEM ::= WITH_CLAUSE | USE_CLAUSE ------------------------- -- 10.1.2 With clause -- ------------------------- -- WITH_CLAUSE ::= -- with library_unit_NAME {,library_unit_NAME}; -- A separate With clause is built for each name, so that we have -- a Corresponding_Spec field for each with'ed spec. The flags -- First_Name and Last_Name are used to reconstruct the exact -- source form. When a list of names appears in one with clause, -- the first name in the list has First_Name set, and the last -- has Last_Name set. If the with clause has only one name, then -- both of the flags First_Name and Last_Name are set in this name. -- N_With_Clause -- Sloc points to first token of library unit name -- Name (Node2) -- Library_Unit (Node4-Lib) -- Corresponding_Spec (Node5-Sem) -- First_Name (Flag5) (set to True if first name or only one name) -- Last_Name (Flag6) (set to True if last name or only one name) -- Context_Installed (Flag3-Sem) -- Elaborate_Present (Flag4-Sem) -- Elaborate_All_Present (Flag1-Sem) -- Implicit_With (Flag2-Sem) --------------------- -- 10.2 Body stub -- --------------------- -- BODY_STUB ::= -- SUBPROGRAM_BODY_STUB -- | PACKAGE_BODY_STUB -- | TASK_BODY_STUB -- | PROTECTED_BODY_STUB ---------------------------------- -- 10.1.3 Subprogram Body Stub -- ---------------------------------- -- SUBPROGRAM_BODY_STUB ::= -- SUBPROGRAM_SPECIFICATION is separate; -- N_Subprogram_Body_Stub -- Sloc points to FUNCTION or PROCEDURE -- Specification (Node1) -- Library_Unit (Node4-Lib) points to the subunit -- Corresponding_Body (Node5-Sem) ------------------------------- -- 10.1.3 Package Body Stub -- ------------------------------- -- PACKAGE_BODY_STUB ::= -- package body DEFINING_IDENTIFIER is separate; -- N_Package_Body_Stub -- Sloc points to PACKAGE -- Defining_Identifier (Node1) -- Library_Unit (Node4-Lib) points to the subunit -- Corresponding_Body (Node5-Sem) ---------------------------- -- 10.1.3 Task Body Stub -- ---------------------------- -- TASK_BODY_STUB ::= -- task body DEFINING_IDENTIFIER is separate; -- N_Task_Body_Stub -- Sloc points to TASK -- Defining_Identifier (Node1) -- Library_Unit (Node4-Lib) points to the subunit -- Corresponding_Body (Node5-Sem) --------------------------------- -- 10.1.3 Protected Body Stub -- --------------------------------- -- PROTECTED_BODY_STUB ::= -- protected body DEFINING_IDENTIFIER is separate; -- Note: protected body stubs are not allowed in Ada 83 mode -- N_Protected_Body_Stub -- Sloc points to PROTECTED -- Defining_Identifier (Node1) -- Library_Unit (Node4-Lib) points to the subunit -- Corresponding_Body (Node5-Sem) --------------------- -- 10.1.3 Subunit -- --------------------- -- SUBUNIT ::= separate (PARENT_UNIT_NAME) PROPER_BODY -- N_Subunit -- Sloc points to SEPARATE -- Name (Node2) is the name of the parent unit -- Proper_Body (Node1) is the subunit body --------------------------------- -- 11.1 Exception Declaration -- --------------------------------- -- EXCEPTION_DECLARATION ::= DEFINING_IDENTIFIER_LIST : exception; -- For consistency with object declarations etc, the parser converts -- the case of multiple identifiers being declared to a series of -- declarations in which the expression is copied, using the More_Ids -- and Prev_Ids flags to remember the souce form as described in the -- section on "Handling of Defining Identifier Lists". -- N_Exception_Declaration -- Sloc points to EXCEPTION -- Defining_Identifier (Node1) -- More_Ids (Flag5) (set to False if no more identifiers in list) -- Prev_Ids (Flag6) (set to False if no previous identifiers in list) ------------------------------------------ -- 11.2 Handled Sequence Of Statements -- ------------------------------------------ -- HANDLED_SEQUENCE_OF_STATEMENTS ::= -- SEQUENCE_OF_STATEMENTS -- [exception -- EXCEPTION_HANDLER -- {EXCEPTION_HANDLER}] -- [at end -- procedure_IDENTIFIER;] -- The AT END phrase is a GNAT extension to provide for cleanups. It is -- used only internally currently, but is considered to be syntactic. -- At the moment, the only cleanup action allowed is a single call to -- a parameterless procedure, and the Identifier field of the node is -- the procedure to be called. Also there is a current restriction -- that exception handles and a cleanup cannot be present in the same -- frame, so at least one of Exception_Handlers or the Identifier must -- be missing. -- N_Handled_Sequence_Of_Statements -- Sloc points to first token of first statement -- Statements (List3) -- Exception_Handlers (List4) (set to No_List if none present) -- Identifier (Node1) (set to Empty if no clean up procedure) -- Note: the parent always contains a Declarations field which contains -- declarations associated with the handled sequence of statements. This -- is true even in the case of an accept statement (see description of -- the N_Accept_Statement node). ----------------------------- -- 11.2 Exception Handler -- ----------------------------- -- EXCEPTION_HANDLER ::= -- when [CHOICE_PARAMETER_SPECIFICATION :] -- EXCEPTION_CHOICE {| EXCEPTION_CHOICE} => -- SEQUENCE_OF_STATEMENTS -- Note: choice parameter specification is not allowed in Ada 83 mode -- N_Exception_Handler -- Sloc points to WHEN -- Choice_Parameter (Node2) (set to Empty if not present) -- Exception_Choices (List4) -- Statements (List3) ------------------------------------------ -- 11.2 Choice parameter specification -- ------------------------------------------ -- CHOICE_PARAMETER_SPECIFICATION ::= DEFINING_IDENTIFIER ---------------------------- -- 11.2 Exception Choice -- ---------------------------- -- EXCEPTION_CHOICE ::= exception_NAME | others -- Except in the case of OTHERS, no explicit node appears in the tree -- for exception choice. Instead the exception name appears directly. -- An OTHERS choice is represented by a N_Others_Choice node (see -- section 3.8.1. --------------------------- -- 11.3 Raise Statement -- --------------------------- -- RAISE_STATEMENT ::= raise [exception_NAME]; -- N_Raise_Statement -- Sloc points to RAISE -- Name (Node2) (set to Empty if no exception name present) ------------------------------- -- 12.1 Generic Declaration -- ------------------------------- -- GENERIC_DECLARATION ::= -- GENERIC_SUBPROGRAM_DECLARATION | GENERIC_PACKAGE_DECLARATION ------------------------------------------ -- 12.1 Generic Subprogram Declaration -- ------------------------------------------ -- GENERIC_SUBPROGRAM_DECLARATION ::= -- GENERIC_FORMAL_PART SUBPROGRAM_SPECIFICATION; -- N_Generic_Subprogram_Declaration -- Sloc points to GENERIC -- Specification (Node1) subprogram specification -- Corresponding_Body (Node5-Sem) -- Generic_Formal_Declarations (List3) from generic formal part -- Parent_Spec (Node4-Lib) --------------------------------------- -- 12.1 Generic Package Declaration -- --------------------------------------- -- GENERIC_PACKAGE_DECLARATION ::= -- GENERIC_FORMAL_PART PACKAGE_SPECIFICATION; -- Note: when we do generics right, the Activation_Chain_Entity entry -- for this node can be removed (since the expander won't see generic -- units any more). -- N_Generic_Package_Declaration -- Sloc points to GENERIC -- Specification (Node1) subprogram specification -- Corresponding_Body (Node5-Sem) -- Generic_Formal_Declarations (List3) from generic formal part -- Parent_Spec (Node4-Lib) -- Activation_Chain_Entity (Node2-Sem) ------------------------------- -- 12.1 Generic Formal Part -- ------------------------------- -- GENERIC_FORMAL_PART ::= -- generic {GENERIC_FORMAL_PARAMETER_DECLARATION | USE_CLAUSE} ------------------------------------------------ -- 12.1 Generic Formal Parameter Declaration -- ------------------------------------------------ -- GENERIC_FORMAL_PARAMETER_DECLARATION ::= -- FORMAL_OBJECT_DECLARATION -- | FORMAL_TYPE_DECLARATION -- | FORMAL_SUBPROGRAM_DECLARATION -- | FORMAL_PACKAGE_DECLARATION --------------------------------- -- 12.3 Generic Instantiation -- --------------------------------- -- GENERIC_INSTANTIATION ::= -- package DEFINING_PROGRAM_UNIT_NAME is -- new generic_package_NAME [GENERIC_ACTUAL_PART]; -- | procedure DEFINING_PROGRAM_UNIT_NAME is -- new generic_procedure_NAME [GENERIC_ACTUAL_PART]; -- | function DEFINING_DESIGNATOR is -- new generic_function_NAME [GENERIC_ACTUAL_PART]; -- N_Package_Instantiation -- Sloc points to PACKAGE -- Defining_Unit_Name (Node1) -- Name (Node2) -- Parent_Spec (Node4-Lib) -- Generic_Associations (List3) (set to No_List if no -- generic actual part) -- N_Procedure_Instantiation -- Sloc points to PROCEDURE -- Defining_Unit_Name (Node1) -- Name (Node2) -- Parent_Spec (Node4-Lib) -- Generic_Associations (List3) (set to No_List if no -- generic actual part) -- N_Function_Instantiation -- Sloc points to FUNCTION -- Defining_Unit_Name (Node1) -- Name (Node2) -- Generic_Associations (List3) (set to No_List if no -- generic actual part) -- Parent_Spec (Node4-Lib) ------------------------------ -- 12.3 Generic Actual Part -- ------------------------------ -- GENERIC_ACTUAL_PART ::= -- (GENERIC_ASSOCIATION {, GENERIC_ASSOCIATION}) ------------------------------- -- 12.3 Generic Association -- ------------------------------- -- GENERIC_ASSOCIATION ::= -- [generic_formal_parameter_SELECTOR_NAME =>] -- EXPLICIT_GENERIC_ACTUAL_PARAMETER -- Note: unlike the procedure call case, a generic association node -- is generated for every association, even if no formal is present. -- In this case the parser will leave the Selector_Name field set -- to Empty, to be filled in later by the semantic pass. -- N_Generic_Association -- Sloc points to first token of generic association -- Selector_Name (Node3) (set to Empty if no formal -- parameter selector name) -- Explicit_Generic_Actual_Parameter (Node2) --------------------------------------------- -- 12.3 Explicit Generic Actual Parameter -- --------------------------------------------- -- EXPLICIT_GENERIC_ACTUAL_PARAMETER ::= -- EXPRESSION | variable_NAME | subprogram_NAME -- | entry_NAME | SUBTYPE_MARK | package_instance_NAME ------------------------------------- -- 12.4 Formal Object Declaration -- ------------------------------------- -- FORMAL_OBJECT_DECLARATION ::= -- DEFINING_IDENTIFIER_LIST : -- MODE SUBTYPE_MARK [:= DEFAULT_EXPRESSION]; -- Although the syntax allows multiple identifiers in the list, the -- semantics is as though successive declarations were given with -- identical type definition and expression components. To simplify -- semantic processing, the parser represents a multiple declaration -- case as a sequence of single declarations, using the More_Ids and -- Prev_Ids flags to preserve the original source form as described -- in the section on "Handling of Defining Identifier Lists". -- N_Formal_Object_Declaration -- Sloc points to first identifier -- Defining_Identifier (Node1) -- In_Present (Flag1) -- Out_Present (Flag2) -- Subtype_Mark (Node4) -- Expression (Node3) (set to Empty if no default expression) -- More_Ids (Flag5) (set to False if no more identifiers in list) -- Prev_Ids (Flag6) (set to False if no previous identifiers in list) ----------------------------------- -- 12.5 Formal Type Declaration -- ----------------------------------- -- FORMAL_TYPE_DECLARATION ::= -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] -- is FORMAL_TYPE_DEFINITION; -- N_Formal_Type_Declaration -- Sloc points to TYPE -- Defining_Identifier (Node1) -- Formal_Type_Definition (Node3) -- Discriminant_Specifications (List2) (set to No_List if no -- discriminant part) -- Has_Unknown_Discriminants (Flag3) set if (<>) discriminant ---------------------------------- -- 12.5 Formal type definition -- ---------------------------------- -- FORMAL_TYPE_DEFINITION ::= -- FORMAL_PRIVATE_TYPE_DEFINITION -- | FORMAL_DERIVED_TYPE_DEFINITION -- | FORMAL_DISCRETE_TYPE_DEFINITION -- | FORMAL_SIGNED_INTEGER_TYPE_DEFINITION -- | FORMAL_MODULAR_TYPE_DEFINITION -- | FORMAL_FLOATING_POINT_DEFINITION -- | FORMAL_ORDINARY_FIXED_POINT_DEFINITION -- | FORMAL_DECIMAL_FIXED_POINT_DEFINITION -- | FORMAL_ARRAY_TYPE_DEFINITION -- | FORMAL_ACCESS_TYPE_DEFINITION --------------------------------------------- -- 12.5.1 Formal Private Type Definition -- --------------------------------------------- -- FORMAL_PRIVATE_TYPE_DEFINITION ::= -- [abstract] [tagged] [limited] private -- Note: TAGGED is not allowed in Ada 83 mode -- N_Formal_Private_Type_Definition -- Sloc points to PRIVATE -- Abstract_Present (Flag4) -- Tagged_Present (Flag1) -- Limited_Present (Flag2) -------------------------------------------- -- 12.5.1 Formal Derived Type Definition -- -------------------------------------------- -- FORMAL_DERIVED_TYPE_DEFINITION ::= new SUBTYPE_MARK [with private] -- Note: WITH PRIVATE is not allowed in Ada 83 mode -- N_Formal_Derived_Type_Definition -- Sloc points to NEW -- Subtype_Mark (Node4) -- Private_Present (Flag1) --------------------------------------------- -- 12.5.2 Formal Discrete Type Definition -- --------------------------------------------- -- FORMAL_DISCRETE_TYPE_DEFINITION ::= (<>) -- N_Formal_Discrete_Type_Definition -- Sloc points to <> --------------------------------------------------- -- 12.5.2 Formal Signed Integer Type Definition -- --------------------------------------------------- -- FORMAL_SIGNED_INTEGER_TYPE_DEFINITION ::= range <> -- N_Formal_Signed_Integer_Type_Definition -- Sloc points to RANGE -------------------------------------------- -- 12.5.2 Formal Modular Type Definition -- -------------------------------------------- -- FORMAL_MODULAR_TYPE_DEFINITION ::= mod <> -- N_Formal_Modular_Type_Definition -- Sloc points to MOD ---------------------------------------------- -- 12.5.2 Formal Floating Point Definition -- ---------------------------------------------- -- FORMAL_FLOATING_POINT_DEFINITION ::= digits <> -- N_Formal_Floating_Point_Definition -- Sloc points to DIGITS ---------------------------------------------------- -- 12.5.2 Formal Ordinary Fixed Point Definition -- ---------------------------------------------------- -- FORMAL_ORDINARY_FIXED_POINT_DEFINITION ::= delta <> -- N_Formal_Ordinary_Fixed_Point_Definition -- Sloc points to DELTA --------------------------------------------------- -- 12.5.2 Formal Decimal Fixed Point Definition -- --------------------------------------------------- -- FORMAL_DECIMAL_FIXED_POINT_DEFINITION ::= delta <> digits <> -- Note: formal decimal fixed point definition not allowed in Ada 83 -- N_Formal_Decimal_Fixed_Point_Definition -- Sloc points to DELTA ------------------------------------------ -- 12.5.3 Formal Array Type Definition -- ------------------------------------------ -- FORMAL_ARRAY_TYPE_DEFINITION ::= ARRAY_TYPE_DEFINITION ------------------------------------------- -- 12.5.4 Formal Access Type Definition -- ------------------------------------------- -- FORMAL_ACCESS_TYPE_DEFINITION ::= ACCESS_TYPE_DEFINITION ----------------------------------------- -- 12.6 Formal Subprogram Declaration -- ----------------------------------------- -- FORMAL_SUBPROGRAM_DECLARATION ::= -- with SUBPROGRAM_SPECIFICATION [is SUBPROGRAM_DEFAULT]; -- N_Formal_Subprogram_Declaration -- Sloc points to WITH -- Specification (Node1) -- Default_Name (Node2) (set to Empty if no subprogram default) -- Box_Present (Flag1) -- Note: if no subprogram default is present, then Name is set -- to Empty, and Box_Present is False. ------------------------------ -- 12.6 Subprogram Default -- ------------------------------ -- SUBPROGRAM_DEFAULT ::= DEFAULT_NAME | <> -- There is no separate node in the tree for a subprogram default. -- Instead the parent (N_Formal_Subprogram_Declaration) node contains -- the default name or box indication, as needed. ------------------------ -- 12.6 Default Name -- ------------------------ -- DEFAULT_NAME ::= NAME -------------------------------------- -- 12.7 Formal Package Declaration -- -------------------------------------- -- FORMAL_PACKAGE_DECLARATION ::= -- with package DEFINING_IDENTIFIER -- is new generic_package_NAME FORMAL_PACKAGE_ACTUAL_PART; -- Note: formal package declarations not allowed in Ada 83 mode -- N_Formal_Package_Declaration -- Sloc points to WITH -- Defining_Identifier (Node1) -- Name (Node2) -- Generic_Associations (List3) (set to No_List if (<>) case or -- empty generic actual part) -- Box_Present (Flag1) -- Generic_Parent (Node5-Sem) -------------------------------------- -- 12.7 Formal Package Actual Part -- -------------------------------------- -- FORMAL_PACKAGE_ACTUAL_PART ::= -- (<>) | [GENERIC_ACTUAL_PART] -- There is no explicit node in the tree for a formal package -- actual part. Instead the information appears in the parent node -- (i.e. the formal package declaration node itself). --------------------------------- -- 13.1 Representation clause -- --------------------------------- -- REPRESENTATION_CLAUSE ::= -- ATTRIBUTE_DEFINITION_CLAUSE -- | ENUMERATION_REPRESENTATION_CLAUSE -- | RECORD_REPRESENTATION_CLAUSE -- | AT_CLAUSE --------------------------------------- -- 13.2 Attribute definition clause -- --------------------------------------- -- ATTRIBUTE_DEFINITION_CLAUSE ::= -- for DIRECT_NAME'ATTRIBUTE_DESIGNATOR use EXPRESSION; -- | for DIRECT_NAME'ATTRIBUTE_DESIGNATOR use NAME; -- In Ada 83, the expression must be a simple expression -- N_Attribute_Definition_Clause -- Sloc points to FOR -- Name (Node2) -- Identifier (Node1) the attribute designator -- Expression (Node3) the expression or name --------------------------------------------- -- 13.3 Enumeration representation clause -- --------------------------------------------- -- ENUMERATION_REPRESENTATION_CLAUSE ::= -- for first_subtype_DIRECT_NAME use ENUMERATION_AGGREGATE; -- N_Enumeration_Representation_Clause -- Sloc points to FOR -- Identifier (Node1) direct name -- Array_Aggregate (Node4) --------------------------------- -- 13.3 Enumeration aggregate -- --------------------------------- -- ENUMERATION_AGGREGATE ::= ARRAY_AGGREGATE ---------------------------------------- -- 13.4 Record representation clause -- ---------------------------------------- -- RECORD_REPRESENTATION_CLAUSE ::= -- for first_subtype_DIRECT_NAME use -- record [MOD_CLAUSE] -- {COMPONENT_CLAUSE} -- end record; -- N_Record_Representation_Clause -- Sloc points to FOR -- Identifier (Node1) direct name -- Mod_Clause (Node2) (set to Empty if no mod clause present) -- Component_Clauses (List3) ---------------------- -- 13.4 Mod clause -- ---------------------- -- MOD_CLAUSE ::= at mod static_EXPRESSION; -- Note: in Ada 83, the expression must be a simple expression -- Note: this feature is obsolescent in Ada 9X -- N_Mod_Clause -- Sloc points to AT -- Expression (Node3) ---------------------------- -- 13.4 Component clause -- ---------------------------- -- COMPONENT_CLAUSE ::= -- COMPONENT_CLAUSE_COMPONENT_NAME at POSITION -- range FIRST_BIT .. LAST_BIT; -- COMPONENT_CLAUSE_COMPONENT_NAME ::= -- component_DIRECT_NAME -- | component_DIRECT_NAME'ATTRIBUTE_DESIGNATOR -- | FIRST_SUBTYPE_DIRECT_NAME'ATTRIBUTE_DESIGNATOR -- POSITION ::= static_EXPRESSION -- FIRST_BIT ::= static_SIMPLE_EXPRESSION -- LAST_BIT ::= static_SIMPLE_EXPRESSION -- N_Component_Clause -- Sloc points to AT -- Component_Name (Node1) points to Name or Attribute_Reference -- Position (Node2) -- First_Bit (Node3) -- Last_Bit (Node4) --------------------- -- 13.5 At clause -- --------------------- -- AT_CLAUSE ::= for DIRECT_NAME use at EXPRESSION; -- Note: in Ada 83 the expression must be a simple expression -- Note: this feature is obsolescent in Ada 9X -- N_At_Clause -- Sloc points to FOR -- Identifier (Node1) -- Expression (Node3) -------------------------- -- 13.8 Code statement -- -------------------------- -- CODE_STATEMENT ::= QUALIFIED_EXPRESSION; -- N_Code_Statement -- Sloc points to first token of subtype mark -- Expression (Node3) -------------------- -- Semantic Nodes -- -------------------- -- These semantic nodes are used to hold additional semantic information. -- They are inserted into the tree as a resut of semantic processing --------------------- -- Concat Multiple -- --------------------- -- During semantic analysis, this node is created if a sequence of -- concatenation nodes construct a single concatenation result. The -- creation of this node is used to optimize both compile time -- evaluation and run time processing for concatenation, by avoiding -- the construction of intermediate results. -- N_Concat_Multiple -- Sloc points to first of the & operators -- Expressions (List3-Sem) points to list of operands -- plus fields for expression ------------------- -- Expanded_Name -- ------------------- -- The N_Expanded_Name node is used to represent a selected component -- name that has been resolved to an expanded name. The semantic phase -- replaces N_Selected_Component nodes that represent names by the use -- of this node, leaving the N_Selected_Component node used only when -- the prefix is a record or protected type. -- The fields of the N_Expanded_Name node are layed out identically -- to those of the N_Selected_Component node, allowing conversion of -- an expanded name node to a selected component node to be done -- easily, see Sinfo.Change.Change_Selected_Component_To_Expanded_Name. -- N_Expanded_Name -- Sloc points to the period -- Chars (Name1) copy of Chars field of selector name -- Prefix (Node2) -- Selector_Name (Node3) -- Entity (Node4-Sem) -- Redundant_Use (Flag2-Sem) set for redundant use clause -- plus fields for expression ------------------------ -- Expression Actions -- ------------------------ -- The N_Expression_Actions node is inserted into an expression as a -- result of semantic processing that indicates that some actions -- (e.g. the creation of some implicit types) are required as part -- of the processing for an expression. The list of actions can -- include declarations, statements and expressions. -- N_Expression_Actions -- Sloc is set to some relevant token in the original source -- Actions (List1) -- Expression (Node3) -- plus fields for expression ------------------- -- Freeze Entity -- ------------------- -- This node marks the point in a declarative part at which an entity -- declared therein becomes frozen. The expander places initialization -- procedures for types at those points. Gigi uses the freezing point -- to elaborate entities that may depend on previous private types. -- N_Freeze_Entity -- Entity (Node4-Sem) ------------------- -- Implicit Type -- ------------------- -- When types are constructed in situations like: -- type x is new integer range 1 .. 10; -- which really means: -- type anon is new integer; -- subtype x is anon range 1 .. 10; -- or -- var : integer range 1 .. 10; -- which really means: -- subtype anon is integer range 1 .. 10; -- Var : anon; -- then an entity is constructed for the implicit type, and it is -- treated like any other type. In addition, an implicit type node -- is inserted into the declaration list to reflect the presence of -- this created type. The only information required is a pointer to -- the created entity for the type (which is in the Defining_Identifier -- field. The remainder of the tree which would normally be present -- for a type declaration is omitted, since all the necessary semantic -- information is present in the entity. -- Note: the name of the defining identifier of an implicit type -- node always starts with the characters "Ityp__", and these are -- the only entities whose names start with this prefix. -- N_Implicit_Type -- Sloc is copied from the node giving rise to the implicit type -- Defining_Identifier (Node1) of the implicit type/subtype --------------- -- Reference -- --------------- -- Actuals in entry calls are placed into a single parameter block that -- is passed by reference to the called task. For parameters passed by -- reference, we need to store the "address" using exactly the same -- convention as we use for passing normal parameters. We cannot use -- the 'Access attribute, since the parameter may not be aliased, and -- also we must be able to pass parameters by reference to which the -- Aliased attribute does not apply (slices and aggregates). The special -- reference node constructs a value of type access to the type of the -- expression suitable for this use. -- N_Reference -- Sloc is copied from the expression (the name of a by-reference object) -- Expression (Node3) -- plus fields for expression ----------- -- Empty -- ----------- -- N_Empty -- Chars (Name1) is set to No_Name -- Used as the contents of the Nkind field of the dummy Empty node -- and in some other situations to indicate an uninitialized value. ----------- -- Error -- ----------- -- N_Error -- Chars (Name1) is set to Error_Name -- Used as the contents of the Nkind field of the dummy Error node -------------------------- -- Node Type Definition -- -------------------------- -- The following is the definition of the Node_Kind type. As previously -- discussed, this is separated off to allow rearrangement of the order -- to facilitiate definition of subtype ranges. The comments show the -- subtype classes which apply to each set of node kinds. The first -- entry in the comment characterizes the following list of nodes. type Node_Kind is ( N_Unused_At_Start, -- N_Has_Chars N_Empty, N_Error, -- N_Entity, N_Has_Etype, N_Has_Chars N_Defining_Identifier, N_Defining_Character_Literal, N_Defining_Operator_Symbol, -- N_Subexpr, N_Has_Etype, N_Has_Chars, N_Entity_Name N_Expanded_Name, -- N_Direct_Name, N_Subexpr, N_Has_Etype, N_Has_Chars, N_Entity_Name N_Identifier, -- N_Direct_Name, N_Subexpr, N_Has_Etype, N_Has_Chars N_Character_Literal, N_Operator_Symbol, -- N_Binary_Op, N_Op, N_Subexpr, N_Has_Etype, N_Has_Chars N_Op_And, N_Op_And_Then, N_Op_Or, N_Op_Or_Else, N_Op_Xor, N_Op_In, N_Op_Not_In, N_Op_Eq, N_Op_Ne, N_Op_Lt, N_Op_Le, N_Op_Gt, N_Op_Ge, N_Op_Add, N_Op_Subtract, N_Op_Concat, N_Op_Multiply, N_Op_Divide, N_Op_Mod, N_Op_Rem, N_Op_Expon, -- N_Unary_Op, N_Op, N_Subexpr, N_Has_Etype, N_Has_Chars N_Op_Plus, N_Op_Minus, N_Op_Abs, N_Op_Not, -- N_Subexpr, N_Has_Etype N_Integer_Literal, N_Real_Literal, N_String_Literal, N_Explicit_Dereference, N_Indexed_Component, N_Slice, N_Function_Call, N_Selected_Component, N_Attribute_Reference, N_Aggregate, N_Extension_Aggregate, N_Null, N_Parenthesized_Expression, N_Reference, N_Type_Conversion, N_Qualified_Expression, N_Allocator, N_Concat_Multiple, N_Expression_Actions, N_Range, -- N_Has_Etype, N_Subexpr, N_Procedure_Call_Statement, -- N_Has_Etype N_Subtype_Indication, -- N_Access_To_Subprogram_Definition N_Access_Function_Definition, N_Access_Procedure_Definition, -- N_Array_Type_Definition N_Unconstrained_Array_Definition, N_Constrained_Array_Definition, -- N_Body_Stub, N_Later_Decl_Item N_Subprogram_Body_Stub, N_Package_Body_Stub, N_Task_Body_Stub, N_Protected_Body_Stub, -- N_Generic_Instantiation, N_Later_Decl_Item N_Package_Instantiation, N_Procedure_Instantiation, N_Function_Instantiation, -- N_Unit_Body, N_Later_Decl_Item N_Subprogram_Body, N_Package_Body, -- N_Later_Decl_Item N_Task_Body, N_Subprogram_Declaration, N_Package_Declaration, N_Task_Type_Declaration, N_Single_Task_Declaration, N_Implicit_Label_Declaration, N_Use_Package_Clause, N_Pragma, -- N_Generic_Declaration, N_Later_Decl_Item N_Generic_Package_Declaration, N_Generic_Subprogram_Declaration, -- N_Generic_Parameter_Declaration N_Formal_Object_Declaration, N_Formal_Type_Declaration, N_Formal_Subprogram_Declaration, N_Formal_Package_Declaration, -- N_Renaming_Declaration N_Object_Renaming_Declaration, N_Exception_Renaming_Declaration, N_Package_Renaming_Declaration, N_Subprogram_Renaming_Declaration, -- N_Generic_Renaming_Declarations, N_Renaming_Declaration N_Generic_Package_Renaming_Declaration, N_Generic_Procedure_Renaming_Declaration, N_Generic_Function_Renaming_Declaration, -- N_Representation_Clause N_Attribute_Definition_Clause, N_Enumeration_Representation_Clause, N_Record_Representation_Clause, N_Mod_Clause, N_Component_Clause, N_At_Clause, -- N_Subprogram_Specification N_Function_Specification, N_Procedure_Specification, -- N_Statement N_Abort_Statement, N_Accept_Statement, N_Assignment_Statement, N_Block_Statement, N_Case_Statement, N_Code_Statement, N_Delay_Relative_Statement, N_Delay_Until_Statement, N_Entry_Call_Statement, N_Exit_Statement, N_Goto_Statement, N_If_Statement, N_Loop_Statement, N_Null_Statement, N_Raise_Statement, N_Requeue_Statement, N_Return_Statement, -- Other nodes (not part of any subtype class) N_Abortable_Part, N_Abstract_Subprogram_Declaration, N_Accept_Alternative, N_Access_Definition, N_Access_To_Object_Definition, N_Asynchronous_Select, N_Case_Statement_Alternative, N_Compilation_Unit, N_Component_Association, N_Component_Declaration, N_Component_List, N_Conditional_Entry_Call, N_Derived_Type_Definition, N_Decimal_Fixed_Point_Definition, N_Defining_Program_Unit_Name, N_Delay_Alternative, N_Delta_Constraint, N_Designator, N_Digits_Constraint, N_Discriminant_Association, N_Discriminant_Specification, N_Elsif_Part, N_Enumeration_Type_Definition, N_Entry_Body, N_Entry_Body_Formal_Part, N_Entry_Call_Alternative, N_Entry_Declaration, N_Entry_Index_Specification, N_Exception_Declaration, N_Exception_Handler, N_Floating_Point_Definition, N_Formal_Decimal_Fixed_Point_Definition, N_Formal_Derived_Type_Definition, N_Formal_Discrete_Type_Definition, N_Formal_Floating_Point_Definition, N_Formal_Modular_Type_Definition, N_Formal_Ordinary_Fixed_Point_Definition, N_Formal_Private_Type_Definition, N_Formal_Signed_Integer_Type_Definition, N_Freeze_Entity, N_Full_Type_Declaration, N_Generic_Association, N_Handled_Sequence_Of_Statements, N_Implicit_Type, N_Incomplete_Type_Declaration, N_Index_Or_Discriminant_Constraint, N_Iteration_Scheme, N_Label, N_Loop_Parameter_Specification, N_Modular_Type_Definition, N_Number_Declaration, N_Object_Declaration, N_Ordinary_Fixed_Point_Definition, N_Others_Choice, N_Package_Specification, N_Parameter_Association, N_Parameter_Specification, N_Pragma_Argument_Association, N_Private_Extension_Declaration, N_Private_Type_Declaration, N_Protected_Body, N_Protected_Definition, N_Protected_Type_Declaration, N_Range_Constraint, N_Real_Range_Specification, N_Record_Definition, N_Selective_Accept, N_Signed_Integer_Type_Definition, N_Single_Protected_Declaration, N_Subtype_Declaration, N_Subunit, N_Task_Definition, N_Terminate_Alternative, N_Timed_Entry_Call, N_Triggering_Alternative, N_Use_Type_Clause, N_Variant, N_Variant_Part, N_With_Clause, N_Unused_At_End); ---------------------------- -- Node Class Definitions -- ---------------------------- -- The contents of these classes are keyed to the order of the -- literals in the Node_Kind type declaration, as declared above. subtype N_Access_To_Subprogram_Definition is Node_Kind range N_Access_Function_Definition .. N_Access_Procedure_Definition; subtype N_Array_Type_Definition is Node_Kind range N_Unconstrained_Array_Definition .. N_Constrained_Array_Definition; subtype N_Binary_Op is Node_Kind range N_Op_And .. N_Op_Expon; subtype N_Body_Stub is Node_Kind range N_Subprogram_Body_Stub .. N_Protected_Body_Stub; subtype N_Concurrent_Body_Stub is Node_Kind range N_Task_Body_Stub .. N_Protected_Body_Stub; subtype N_Direct_Name is Node_Kind range N_Identifier .. N_Operator_Symbol; subtype N_Entity is Node_Kind range N_Defining_Identifier .. N_Defining_Operator_Symbol; subtype N_Generic_Instantiation is Node_Kind range N_Package_Instantiation .. N_Function_Instantiation; subtype N_Generic_Parameter_Declaration is Node_Kind range N_Formal_Object_Declaration .. N_Formal_Package_Declaration; subtype N_Has_Chars is Node_Kind range N_Empty .. N_Op_Not; subtype N_Has_Etype is Node_Kind range N_Defining_Identifier .. N_Subtype_Indication; subtype N_Later_Decl_Item is Node_Kind range N_Subprogram_Body_Stub .. N_Generic_Subprogram_Declaration; -- Note: this is Ada 83 relevant only (see Ada 83 RM 3.9 (2)) and -- includes only those items which can appear as later declarative -- items. This also includes N_Pragma and N_Implicit_Label_Declaration -- which are not specifically in the grammar but may appear as a -- valid later declarative items. subtype N_Unit_Body is Node_Kind range N_Subprogram_Body .. N_Package_Body; subtype N_Generic_Declaration is Node_Kind range N_Generic_Package_Declaration .. N_Generic_Subprogram_Declaration; subtype N_Op is Node_Kind range N_Op_And .. N_Op_Not; subtype N_Renaming_Declaration is Node_Kind range N_Object_Renaming_Declaration .. N_Generic_Function_Renaming_Declaration; subtype N_Generic_Renaming_Declaration is Node_Kind range N_Generic_Package_Renaming_Declaration .. N_Generic_Function_Renaming_Declaration; subtype N_Representation_Clause is Node_Kind range N_Attribute_Definition_Clause .. N_At_Clause; subtype N_Statement is Node_Kind range N_Abort_Statement .. N_Return_Statement; -- Note that this includes all statement types except for the case -- of N_Procedure_Call_Statement, which is considered to be a -- subexpression (since it can be overloaded and requires resolution) subtype N_Subexpr is Node_Kind range -- things with expr fields N_Expanded_Name .. N_Procedure_Call_Statement; subtype N_Entity_Name is Node_Kind range N_Expanded_Name .. N_Identifier; subtype N_Subprogram_Specification is Node_Kind range N_Function_Specification .. N_Procedure_Specification; subtype N_Unary_Op is Node_Kind range N_Op_Plus .. N_Op_Not; --------------------------- -- Node Access Functions -- --------------------------- -- The following functions return the contents of the indicated field of -- the node referenced by the argument, which is a Node_Id. They provide -- logical access to fields in the node which could be accessed using -- the Tree.Generic_Access package, but the idea is always to use these -- higher level routines which preserve strong typing. In debug mode, -- these routines check that they are being applied to an appropriate -- node, as well as checking that the node is in range. function Abort_Present (N : Node_Id) return Boolean; -- Flag1 function Abortable_Part (N : Node_Id) return Node_Id; -- Node2 function Abstract_Present (N : Node_Id) return Boolean; -- Flag4 function Accept_Name (N : Node_Id) return Node_Id; -- Node1 function Accept_Statement (N : Node_Id) return Node_Id; -- Node2 function Actions (N : Node_Id) return List_Id; -- List1 function Activation_Chain_Entity (N : Node_Id) return Node_Id; -- Node2 function Acts_As_Spec (N : Node_Id) return Boolean; -- Flag4 function Actual_Parameter (N : Node_Id) return Node_Id; -- Node2 function Aliased_Present (N : Node_Id) return Boolean; -- Flag1 function All_Present (N : Node_Id) return Boolean; -- Flag1 function Alternatives (N : Node_Id) return List_Id; -- List4 function Analyzed (N : Node_Id) return Boolean; -- Flag19 function Array_Aggregate (N : Node_Id) return Node_Id; -- Node4 function Assignment_OK (N : Node_Id) return Boolean; -- Flag5 function Bad_Is_Detected (N : Node_Id) return Boolean; -- Flag1 function Body_Required (N : Node_Id) return Boolean; -- Flag3 function Box_Present (N : Node_Id) return Boolean; -- Flag1 function Char_Literal_Value (N : Node_Id) return Char_Code; -- Char_Code2 function Chars (N : Node_Id) return Name_Id; -- Name1 function Choice_Parameter (N : Node_Id) return Node_Id; -- Node2 function Choices (N : Node_Id) return List_Id; -- List1 function Component_Associations (N : Node_Id) return List_Id; -- List4 function Component_Clauses (N : Node_Id) return List_Id; -- List3 function Component_Declarations (N : Node_Id) return List_Id; -- List3 function Component_List (N : Node_Id) return Node_Id; -- Node1 function Component_Name (N : Node_Id) return Node_Id; -- Node1 function Condition (N : Node_Id) return Node_Id; -- Node5 function Constant_Present (N : Node_Id) return Boolean; -- Flag2 function Constraint (N : Node_Id) return Node_Id; -- Node3 function Constraints (N : Node_Id) return List_Id; -- List1 function Context_Installed (N : Node_Id) return Boolean; -- Flag3 function Context_Items (N : Node_Id) return List_Id; -- List1 function Controlling_Argument (N : Node_Id) return Node_Id; -- Node1 function Corresponding_Body (N : Node_Id) return Node_Id; -- Node5 function Corresponding_Spec (N : Node_Id) return Node_Id; -- Node5 function Debug_Statement (N : Node_Id) return Node_Id; -- Node3 function Decimal (N : Node_Id) return Boolean; -- Flag2 function Declarations (N : Node_Id) return List_Id; -- List3 function Default_Name (N : Node_Id) return Node_Id; -- Node2 function Defining_Identifier (N : Node_Id) return Node_Id; -- Node1 function Defining_Unit_Name (N : Node_Id) return Node_Id; -- Node1 function Delay_Alternative (N : Node_Id) return Node_Id; -- Node4 function Delay_Statement (N : Node_Id) return Node_Id; -- Node2 function Delta_Expression (N : Node_Id) return Node_Id; -- Node3 function Denominator (N : Node_Id) return Uint; -- Uint4 function Digits_Expression (N : Node_Id) return Node_Id; -- Node2 function Discrete_Choices (N : Node_Id) return List_Id; -- List4 function Discrete_Range (N : Node_Id) return Node_Id; -- Node4 function Discrete_Subtype_Definition (N : Node_Id) return Node_Id; -- Node4 function Discrete_Subtype_Definitions (N : Node_Id) return List_Id; -- List2 function Discriminant_Specifications (N : Node_Id) return List_Id; -- List2 function Discriminant_Type (N : Node_Id) return Node_Id; -- Node2 function Do_Access_Check (N : Node_Id) return Boolean; -- Flag2 function Do_Accessibility_Check (N : Node_Id) return Boolean; -- Flag3 function Do_Discriminant_Check (N : Node_Id) return Boolean; -- Flag3 function Do_Division_Check (N : Node_Id) return Boolean; -- Flag3 function Do_Elaboration_Check (N : Node_Id) return Boolean; -- Flag2 function Do_Length_Check (N : Node_Id) return Boolean; -- Flag4 function Do_Overflow_Check (N : Node_Id) return Boolean; -- Flag2 function Do_Range_Check (N : Node_Id) return Boolean; -- Flag9 function Do_Storage_Check (N : Node_Id) return Boolean; -- Flag2 function Do_Tag_Check (N : Node_Id) return Boolean; -- Flag3 function Elaborate_Present (N : Node_Id) return Boolean; -- Flag4 function Elaborate_All_Present (N : Node_Id) return Boolean; -- Flag1 function Elaborate_Body_Present (N : Node_Id) return Boolean; -- Flag7 function Else_Statements (N : Node_Id) return List_Id; -- List4 function Elsif_Parts (N : Node_Id) return List_Id; -- List3 function Enclosing_Variant (N : Node_Id) return Node_Id; -- Node2 function Entity (N : Node_Id) return Node_Id; -- Node4 function Entry_Body_Formal_Part (N : Node_Id) return Node_Id; -- Node2 function Entry_Call_Alternative (N : Node_Id) return Node_Id; -- Node1 function Entry_Call_Statement (N : Node_Id) return Node_Id; -- Node1 function Entry_Index (N : Node_Id) return Node_Id; -- Node5 function Entry_Index_Specification (N : Node_Id) return Node_Id; -- Node1 function Error_Posted (N : Node_Id) return Boolean; -- Flag20 function Etype (N : Node_Id) return Node_Id; -- Node5 function Evaluate_Once (N : Node_Id) return Boolean; -- Flag10 function Exception_Choices (N : Node_Id) return List_Id; -- List4 function Exception_Handlers (N : Node_Id) return List_Id; -- List4 function Explicit_Generic_Actual_Parameter (N : Node_Id) return Node_Id; -- Node2 function Expression (N : Node_Id) return Node_Id; -- Node3 function Expressions (N : Node_Id) return List_Id; -- List3 function First_Bit (N : Node_Id) return Node_Id; -- Node3 function First_Name (N : Node_Id) return Boolean; -- Flag5 function First_Named_Actual (N : Node_Id) return Node_Id; -- Node4 function Following_Pragmas (N : Node_Id) return List_Id; -- List3 function Formal_Type_Definition (N : Node_Id) return Node_Id; -- Node3 function Generic_Associations (N : Node_Id) return List_Id; -- List3 function Generic_Formal_Declarations (N : Node_Id) return List_Id; -- List3 function Generic_Parent (N : Node_Id) return Node_Id; -- Node5 function Handled_Statement_Sequence (N : Node_Id) return Node_Id; -- Node4 function Has_Created_Identifier (N : Node_Id) return Boolean; -- Flag1 function Has_No_Side_Effects (N : Node_Id) return Boolean; -- Flag8 function Has_Priority_Pragma (N : Node_Id) return Boolean; -- Flag6 function Has_Task_Stack_Size_Pragma (N : Node_Id) return Boolean; -- Flag5 function Has_Unknown_Discriminants (N : Node_Id) return Boolean; -- Flag3 function High_Bound (N : Node_Id) return Node_Id; -- Node2 function Identifier (N : Node_Id) return Node_Id; -- Node1 function Implicit_Types (N : Node_Id) return List_Id; -- List2 function Implicit_With (N : Node_Id) return Boolean; -- Flag2 function In_Present (N : Node_Id) return Boolean; -- Flag1 function Intval (N : Node_Id) return Uint; -- Uint3 function Is_Evaluated (N : Node_Id) return Boolean; -- Flag7 function Is_Overloaded (N : Node_Id) return Boolean; -- Flag5 function Is_Task_Master (N : Node_Id) return Boolean; -- Flag5 function Is_Static (N : Node_Id) return Boolean; -- Flag6 function Iteration_Scheme (N : Node_Id) return Node_Id; -- Node2 function Left_Opnd (N : Node_Id) return Node_Id; -- Node2 function Label (N : Node_Id) return Node_Id; -- Node2 function Last_Bit (N : Node_Id) return Node_Id; -- Node4 function Last_Name (N : Node_Id) return Boolean; -- Flag6 function Library_Unit (N : Node_Id) return Node_Id; -- Node4 function Literals (N : Node_Id) return List_Id; -- List1 function Limited_Present (N : Node_Id) return Boolean; -- Flag2 function Loop_Parameter_Specification (N : Node_Id) return Node_Id; -- Node2 function Low_Bound (N : Node_Id) return Node_Id; -- Node1 function Mod_Clause (N : Node_Id) return Node_Id; -- Node2 function More_Ids (N : Node_Id) return Boolean; -- Flag5 function Name (N : Node_Id) return Node_Id; -- Node2 function Names (N : Node_Id) return List_Id; -- List2 function Next_Named_Actual (N : Node_Id) return Node_Id; -- Node4 function Null_Present (N : Node_Id) return Boolean; -- Flag3 function Null_Record_Present (N : Node_Id) return Boolean; -- Flag2 function Numerator (N : Node_Id) return Uint; -- Uint3 function Object_Definition (N : Node_Id) return Node_Id; -- Node2 function Others_Discrete_Choices (N : Node_Id) return List_Id; -- List1 function Out_Present (N : Node_Id) return Boolean; -- Flag2 function Parameter_Associations (N : Node_Id) return List_Id; -- List3 function Parameter_Specifications (N : Node_Id) return List_Id; -- List2 function Parameter_Type (N : Node_Id) return Node_Id; -- Node2 function Parens (N : Node_Id) return Boolean; -- Flag1 function Parent_Spec (N : Node_Id) return Node_Id; -- Node4 function Position (N : Node_Id) return Node_Id; -- Node2 function Pragma_Argument_Associations (N : Node_Id) return List_Id; -- List2 function Preelaborable (N : Node_Id) return Boolean; -- Flag2 function Prefix (N : Node_Id) return Node_Id; -- Node2 function Prev_Ids (N : Node_Id) return Boolean; -- Flag6 function Private_Declarations (N : Node_Id) return List_Id; -- List4 function Private_Present (N : Node_Id) return Boolean; -- Flag1 function Proper_Body (N : Node_Id) return Node_Id; -- Node1 function Protected_Definition (N : Node_Id) return Node_Id; -- Node3 function Protected_Present (N : Node_Id) return Boolean; -- Flag1 function Range_Constraint (N : Node_Id) return Node_Id; -- Node4 function Range_Expression (N : Node_Id) return Node_Id; -- Node4 function Real_Range_Specification (N : Node_Id) return Node_Id; -- Node4 function Record_Extension_Part (N : Node_Id) return Node_Id; -- Node3 function Redundant_Use (N : Node_Id) return Boolean; -- Flag2 function Reverse_Present (N : Node_Id) return Boolean; -- Flag1 function Right_Opnd (N : Node_Id) return Node_Id; -- Node3 function Selective_Accept_Alternatives (N : Node_Id) return List_Id; -- List1 function Selector_Name (N : Node_Id) return Node_Id; -- Node3 function Selector_Names (N : Node_Id) return List_Id; -- List1 function Specification (N : Node_Id) return Node_Id; -- Node1 function Statements (N : Node_Id) return List_Id; -- List3 function Strval (N : Node_Id) return String_Id; -- Str3 function Subtype_Indication (N : Node_Id) return Node_Id; -- Node4 function Subtype_Mark (N : Node_Id) return Node_Id; -- Node4 function Subtype_Marks (N : Node_Id) return List_Id; -- List2 function Tagged_Present (N : Node_Id) return Boolean; -- Flag1 function Task_Definition (N : Node_Id) return Node_Id; -- Node3 function Then_Statements (N : Node_Id) return List_Id; -- List2 function Triggering_Alternative (N : Node_Id) return Node_Id; -- Node1 function Triggering_Statement (N : Node_Id) return Node_Id; -- Node1 function Type_Definition (N : Node_Id) return Node_Id; -- Node3 function Unchecked_Conversion (N : Node_Id) return Boolean; -- Flag11 function Unit (N : Node_Id) return Node_Id; -- Node2 function Variant_Part (N : Node_Id) return Node_Id; -- Node4 function Variants (N : Node_Id) return List_Id; -- List1 function Visible_Declarations (N : Node_Id) return List_Id; -- List2 -- End functions (note used by xsinfo utility program to end processing) ---------------------------- -- Node Update Procedures -- ---------------------------- -- These are the corresponding node update routines, which again provide -- a high level logical access with type checking. In addition to setting -- the indicated field of the node N to the given Val, in the case of -- tree pointers (List1-4), the parent pointer of the Val node is set to -- point back to node N. This automates the setting of the parent pointer. procedure Set_Abort_Present (N : Node_Id; Val : Boolean); -- Flag1 procedure Set_Abortable_Part (N : Node_Id; Val : Node_Id); -- Node2 procedure Set_Abstract_Present (N : Node_Id; Val : Boolean); -- Flag4 procedure Set_Accept_Name (N : Node_Id; Val : Node_Id); -- Node1 procedure Set_Accept_Statement (N : Node_Id; Val : Node_Id); -- Node2 procedure Set_Actions (N : Node_Id; Val : List_Id); -- List1 procedure Set_Activation_Chain_Entity (N : Node_Id; Val : Node_Id); -- Node2 procedure Set_Acts_As_Spec (N : Node_Id; Val : Boolean); -- Flag4 procedure Set_Actual_Parameter (N : Node_Id; Val : Node_Id); -- Node2 procedure Set_Aliased_Present (N : Node_Id; Val : Boolean); -- Flag1 procedure Set_All_Present (N : Node_Id; Val : Boolean); -- Flag1 procedure Set_Alternatives (N : Node_Id; Val : List_Id); -- List4 procedure Set_Analyzed (N : Node_Id; Val : Boolean); -- Flag19 procedure Set_Array_Aggregate (N : Node_Id; Val : Node_Id); -- Node4 procedure Set_Assignment_OK (N : Node_Id; Val : Boolean); -- Flag5 procedure Set_Bad_Is_Detected (N : Node_Id; Val : Boolean); -- Flag1 procedure Set_Body_Required (N : Node_Id; Val : Boolean); -- Flag3 procedure Set_Box_Present (N : Node_Id; Val : Boolean); -- Flag1 procedure Set_Char_Literal_Value (N : Node_Id; Val : Char_Code); -- Char_Code2 procedure Set_Chars (N : Node_Id; Val : Name_Id); -- Name1 procedure Set_Choice_Parameter (N : Node_Id; Val : Node_Id); -- Node2 procedure Set_Choices (N : Node_Id; Val : List_Id); -- List1 procedure Set_Component_Associations (N : Node_Id; Val : List_Id); -- List4 procedure Set_Component_Clauses (N : Node_Id; Val : List_Id); -- List3 procedure Set_Component_Declarations (N : Node_Id; Val : List_Id); -- List3 procedure Set_Component_List (N : Node_Id; Val : Node_Id); -- Node1 procedure Set_Component_Name (N : Node_Id; Val : Node_Id); -- Node1 procedure Set_Condition (N : Node_Id; Val : Node_Id); -- Node5 procedure Set_Constant_Present (N : Node_Id; Val : Boolean); -- Flag2 procedure Set_Constraint (N : Node_Id; Val : Node_Id); -- Node3 procedure Set_Constraints (N : Node_Id; Val : List_Id); -- List1 procedure Set_Context_Installed (N : Node_Id; Val : Boolean); -- Flag3 procedure Set_Context_Items (N : Node_Id; Val : List_Id); -- List1 procedure Set_Controlling_Argument (N : Node_Id; Val : Node_Id); -- Node1 procedure Set_Corresponding_Body (N : Node_Id; Val : Node_Id); -- Node5 procedure Set_Corresponding_Spec (N : Node_Id; Val : Node_Id); -- Node5 procedure Set_Debug_Statement (N : Node_Id; Val : Node_Id); -- Node3 procedure Set_Decimal (N : Node_Id; Val : Boolean); -- Flag2 procedure Set_Declarations (N : Node_Id; Val : List_Id); -- List3 procedure Set_Default_Name (N : Node_Id; Val : Node_Id); -- Node2 procedure Set_Defining_Identifier (N : Node_Id; Val : Node_Id); -- Node1 procedure Set_Defining_Unit_Name (N : Node_Id; Val : Node_Id); -- Node1 procedure Set_Delay_Alternative (N : Node_Id; Val : Node_Id); -- Node4 procedure Set_Delay_Statement (N : Node_Id; Val : Node_Id); -- Node2 procedure Set_Delta_Expression (N : Node_Id; Val : Node_Id); -- Node3 procedure Set_Denominator (N : Node_Id; Val : Uint); -- Uint4 procedure Set_Digits_Expression (N : Node_Id; Val : Node_Id); -- Node2 procedure Set_Discrete_Choices (N : Node_Id; Val : List_Id); -- List4 procedure Set_Discrete_Range (N : Node_Id; Val : Node_Id); -- Node4 procedure Set_Discrete_Subtype_Definition (N : Node_Id; Val : Node_Id); -- Node4 procedure Set_Discrete_Subtype_Definitions (N : Node_Id; Val : List_Id); -- List2 procedure Set_Discriminant_Specifications (N : Node_Id; Val : List_Id); -- List2 procedure Set_Discriminant_Type (N : Node_Id; Val : Node_Id); -- Node2 procedure Set_Do_Access_Check (N : Node_Id; Val : Boolean); -- Flag2 procedure Set_Do_Accessibility_Check (N : Node_Id; Val : Boolean); -- Flag3 procedure Set_Do_Discriminant_Check (N : Node_Id; Val : Boolean); -- Flag3 procedure Set_Do_Division_Check (N : Node_Id; Val : Boolean); -- Flag3 procedure Set_Do_Elaboration_Check (N : Node_Id; Val : Boolean); -- Flag2 procedure Set_Do_Length_Check (N : Node_Id; Val : Boolean); -- Flag4 procedure Set_Do_Overflow_Check (N : Node_Id; Val : Boolean); -- Flag2 procedure Set_Do_Range_Check (N : Node_Id; Val : Boolean); -- Flag9 procedure Set_Do_Storage_Check (N : Node_Id; Val : Boolean); -- Flag2 procedure Set_Do_Tag_Check (N : Node_Id; Val : Boolean); -- Flag3 procedure Set_Elaborate_Present (N : Node_Id; Val : Boolean); -- Flag4 procedure Set_Elaborate_All_Present (N : Node_Id; Val : Boolean); -- Flag1 procedure Set_Elaborate_Body_Present (N : Node_Id; Val : Boolean); -- Flag7 procedure Set_Else_Statements (N : Node_Id; Val : List_Id); -- List4 procedure Set_Elsif_Parts (N : Node_Id; Val : List_Id); -- List3 procedure Set_Enclosing_Variant (N : Node_Id; Val : Node_Id); -- Node2 procedure Set_Entity (N : Node_Id; Val : Node_Id); -- Node4 procedure Set_Entry_Body_Formal_Part (N : Node_Id; Val : Node_Id); -- Node2 procedure Set_Entry_Call_Alternative (N : Node_Id; Val : Node_Id); -- Node1 procedure Set_Entry_Call_Statement (N : Node_Id; Val : Node_Id); -- Node1 procedure Set_Entry_Index (N : Node_Id; Val : Node_Id); -- Node5 procedure Set_Entry_Index_Specification (N : Node_Id; Val : Node_Id); -- Node1 procedure Set_Error_Posted (N : Node_Id; Val : Boolean); -- Flag20 procedure Set_Etype (N : Node_Id; Val : Node_Id); -- Node5 procedure Set_Evaluate_Once (N : Node_Id; Val : Boolean); -- Flag10 procedure Set_Exception_Choices (N : Node_Id; Val : List_Id); -- List4 procedure Set_Exception_Handlers (N : Node_Id; Val : List_Id); -- List4 procedure Set_Explicit_Generic_Actual_Parameter (N : Node_Id; Val : Node_Id); -- Node2 procedure Set_Expression (N : Node_Id; Val : Node_Id); -- Node3 procedure Set_Expressions (N : Node_Id; Val : List_Id); -- List3 procedure Set_First_Bit (N : Node_Id; Val : Node_Id); -- Node3 procedure Set_First_Name (N : Node_Id; Val : Boolean); -- Flag5 procedure Set_First_Named_Actual (N : Node_Id; Val : Node_Id); -- Node4 procedure Set_Following_Pragmas (N : Node_Id; Val : List_Id); -- List3 procedure Set_Formal_Type_Definition (N : Node_Id; Val : Node_Id); -- Node3 procedure Set_Generic_Associations (N : Node_Id; Val : List_Id); -- List3 procedure Set_Generic_Formal_Declarations (N : Node_Id; Val : List_Id); -- List3 procedure Set_Generic_Parent (N : Node_Id; Val : Node_Id); -- Node5 procedure Set_Handled_Statement_Sequence (N : Node_Id; Val : Node_Id); -- Node4 procedure Set_Has_Created_Identifier (N : Node_Id; Val : Boolean); -- Flag1 procedure Set_Has_No_Side_Effects (N : Node_Id; Val : Boolean); -- Flag8 procedure Set_Has_Priority_Pragma (N : Node_Id; Val : Boolean); -- Flag6 procedure Set_Has_Task_Stack_Size_Pragma (N : Node_Id; Val : Boolean); -- Flag5 procedure Set_Has_Unknown_Discriminants (N : Node_Id; Val : Boolean); -- Flag3 procedure Set_High_Bound (N : Node_Id; Val : Node_Id); -- Node2 procedure Set_Identifier (N : Node_Id; Val : Node_Id); -- Node1 procedure Set_Implicit_Types (N : Node_Id; Val : List_Id); -- List2 procedure Set_Implicit_With (N : Node_Id; Val : Boolean); -- Flag2 procedure Set_In_Present (N : Node_Id; Val : Boolean); -- Flag1 procedure Set_Intval (N : Node_Id; Val : Uint); -- Uint3 procedure Set_Is_Evaluated (N : Node_Id; Val : Boolean); -- Flag7 procedure Set_Is_Overloaded (N : Node_Id; Val : Boolean); -- Flag5 procedure Set_Is_Task_Master (N : Node_Id; Val : Boolean); -- Flag5 procedure Set_Is_Static (N : Node_Id; Val : Boolean); -- Flag6 procedure Set_Iteration_Scheme (N : Node_Id; Val : Node_Id); -- Node2 procedure Set_Label (N : Node_Id; Val : Node_Id); -- Node2 procedure Set_Last_Bit (N : Node_Id; Val : Node_Id); -- Node4 procedure Set_Last_Name (N : Node_Id; Val : Boolean); -- Flag6 procedure Set_Library_Unit (N : Node_Id; Val : Node_Id); -- Node4 procedure Set_Left_Opnd (N : Node_Id; Val : Node_Id); -- Node2 procedure Set_Literals (N : Node_Id; Val : List_Id); -- List1 procedure Set_Limited_Present (N : Node_Id; Val : Boolean); -- Flag2 procedure Set_Loop_Parameter_Specification (N : Node_Id; Val : Node_Id); -- Node2 procedure Set_Low_Bound (N : Node_Id; Val : Node_Id); -- Node1 procedure Set_Mod_Clause (N : Node_Id; Val : Node_Id); -- Node2 procedure Set_More_Ids (N : Node_Id; Val : Boolean); -- Flag5 procedure Set_Name (N : Node_Id; Val : Node_Id); -- Node2 procedure Set_Names (N : Node_Id; Val : List_Id); -- List2 procedure Set_Next_Named_Actual (N : Node_Id; Val : Node_Id); -- Node4 procedure Set_Null_Present (N : Node_Id; Val : Boolean); -- Flag3 procedure Set_Null_Record_Present (N : Node_Id; Val : Boolean); -- Flag2 procedure Set_Numerator (N : Node_Id; Val : Uint); -- Uint3 procedure Set_Object_Definition (N : Node_Id; Val : Node_Id); -- Node2 procedure Set_Others_Discrete_Choices (N : Node_Id; Val : List_Id); -- List1 procedure Set_Out_Present (N : Node_Id; Val : Boolean); -- Flag2 procedure Set_Parameter_Associations (N : Node_Id; Val : List_Id); -- List3 procedure Set_Parameter_Specifications (N : Node_Id; Val : List_Id); -- List2 procedure Set_Parameter_Type (N : Node_Id; Val : Node_Id); -- Node2 procedure Set_Parens (N : Node_Id; Val : Boolean); -- Flag1 procedure Set_Parent_Spec (N : Node_Id; Val : Node_Id); -- Node4 procedure Set_Position (N : Node_Id; Val : Node_Id); -- Node2 procedure Set_Pragma_Argument_Associations (N : Node_Id; Val : List_Id); -- List2 procedure Set_Preelaborable (N : Node_Id; Val : Boolean); -- Flag2 procedure Set_Prefix (N : Node_Id; Val : Node_Id); -- Node2 procedure Set_Prev_Ids (N : Node_Id; Val : Boolean); -- Flag6 procedure Set_Private_Declarations (N : Node_Id; Val : List_Id); -- List4 procedure Set_Private_Present (N : Node_Id; Val : Boolean); -- Flag1 procedure Set_Proper_Body (N : Node_Id; Val : Node_Id); -- Node1 procedure Set_Protected_Definition (N : Node_Id; Val : Node_Id); -- Node3 procedure Set_Protected_Present (N : Node_Id; Val : Boolean); -- Flag1 procedure Set_Range_Constraint (N : Node_Id; Val : Node_Id); -- Node4 procedure Set_Range_Expression (N : Node_Id; Val : Node_Id); -- Node4 procedure Set_Real_Range_Specification (N : Node_Id; Val : Node_Id); -- Node4 procedure Set_Record_Extension_Part (N : Node_Id; Val : Node_Id); -- Node3 procedure Set_Redundant_Use (N : Node_Id; Val : Boolean); -- Flag2 procedure Set_Reverse_Present (N : Node_Id; Val : Boolean); -- Flag1 procedure Set_Right_Opnd (N : Node_Id; Val : Node_Id); -- Node3 procedure Set_Selective_Accept_Alternatives (N : Node_Id; Val : List_Id); -- List1 procedure Set_Selector_Name (N : Node_Id; Val : Node_Id); -- Node3 procedure Set_Selector_Names (N : Node_Id; Val : List_Id); -- List1 procedure Set_Specification (N : Node_Id; Val : Node_Id); -- Node1 procedure Set_Statements (N : Node_Id; Val : List_Id); -- List3 procedure Set_Strval (N : Node_Id; Val : String_Id); -- Str3 procedure Set_Subtype_Indication (N : Node_Id; Val : Node_Id); -- Node4 procedure Set_Subtype_Mark (N : Node_Id; Val : Node_Id); -- Node4 procedure Set_Subtype_Marks (N : Node_Id; Val : List_Id); -- List2 procedure Set_Tagged_Present (N : Node_Id; Val : Boolean); -- Flag1 procedure Set_Task_Definition (N : Node_Id; Val : Node_Id); -- Node3 procedure Set_Then_Statements (N : Node_Id; Val : List_Id); -- List2 procedure Set_Triggering_Alternative (N : Node_Id; Val : Node_Id); -- Node1 procedure Set_Triggering_Statement (N : Node_Id; Val : Node_Id); -- Node1 procedure Set_Type_Definition (N : Node_Id; Val : Node_Id); -- Node3 procedure Set_Unchecked_Conversion (N : Node_Id; Val : Boolean); -- Flag11 procedure Set_Unit (N : Node_Id; Val : Node_Id); -- Node2 procedure Set_Variant_Part (N : Node_Id; Val : Node_Id); -- Node4 procedure Set_Variants (N : Node_Id; Val : List_Id); -- List1 procedure Set_Visible_Declarations (N : Node_Id; Val : List_Id); -- List2 -------------------- -- Inline Pragmas -- -------------------- pragma Inline (Abort_Present); pragma Inline (Abortable_Part); pragma Inline (Abstract_Present); pragma Inline (Accept_Name); pragma Inline (Accept_Statement); pragma Inline (Actions); pragma Inline (Activation_Chain_Entity); pragma Inline (Acts_As_Spec); pragma Inline (Actual_Parameter); pragma Inline (Aliased_Present); pragma Inline (All_Present); pragma Inline (Alternatives); pragma Inline (Analyzed); pragma Inline (Array_Aggregate); pragma Inline (Assignment_OK); pragma Inline (Bad_Is_Detected); pragma Inline (Body_Required); pragma Inline (Box_Present); pragma Inline (Char_Literal_Value); pragma Inline (Chars); pragma Inline (Choice_Parameter); pragma Inline (Choices); pragma Inline (Component_Associations); pragma Inline (Component_Clauses); pragma Inline (Component_Declarations); pragma Inline (Component_List); pragma Inline (Component_Name); pragma Inline (Condition); pragma Inline (Constant_Present); pragma Inline (Constraint); pragma Inline (Constraints); pragma Inline (Context_Installed); pragma Inline (Context_Items); pragma Inline (Controlling_Argument); pragma Inline (Corresponding_Body); pragma Inline (Corresponding_Spec); pragma Inline (Debug_Statement); pragma Inline (Declarations); pragma Inline (Decimal); pragma Inline (Default_Name); pragma Inline (Defining_Identifier); pragma Inline (Defining_Unit_Name); pragma Inline (Delay_Alternative); pragma Inline (Delay_Statement); pragma Inline (Delta_Expression); pragma Inline (Denominator); pragma Inline (Digits_Expression); pragma Inline (Discrete_Choices); pragma Inline (Discrete_Range); pragma Inline (Discrete_Subtype_Definition); pragma Inline (Discrete_Subtype_Definitions); pragma Inline (Discriminant_Specifications); pragma Inline (Discriminant_Type); pragma Inline (Do_Access_Check); pragma Inline (Do_Accessibility_Check); pragma Inline (Do_Discriminant_Check); pragma Inline (Do_Elaboration_Check); pragma Inline (Do_Length_Check); pragma Inline (Do_Division_Check); pragma Inline (Do_Overflow_Check); pragma Inline (Do_Range_Check); pragma Inline (Do_Storage_Check); pragma Inline (Do_Tag_Check); pragma Inline (Elaborate_Present); pragma Inline (Elaborate_All_Present); pragma Inline (Elaborate_Body_Present); pragma Inline (Else_Statements); pragma Inline (Elsif_Parts); pragma Inline (Enclosing_Variant); pragma Inline (Entity); pragma Inline (Entry_Body_Formal_Part); pragma Inline (Entry_Call_Alternative); pragma Inline (Entry_Call_Statement); pragma Inline (Entry_Index); pragma Inline (Entry_Index_Specification); pragma Inline (Error_Posted); pragma Inline (Etype); pragma Inline (Evaluate_Once); pragma Inline (Exception_Choices); pragma Inline (Exception_Handlers); pragma Inline (Explicit_Generic_Actual_Parameter); pragma Inline (Expression); pragma Inline (Expressions); pragma Inline (First_Bit); pragma Inline (First_Name); pragma Inline (First_Named_Actual); pragma Inline (Following_Pragmas); pragma Inline (Formal_Type_Definition); pragma Inline (Generic_Associations); pragma Inline (Generic_Formal_Declarations); pragma Inline (Generic_Parent); pragma Inline (Handled_Statement_Sequence); pragma Inline (Has_Created_Identifier); pragma Inline (Has_No_Side_Effects); pragma Inline (Has_Priority_Pragma); pragma Inline (Has_Task_Stack_Size_Pragma); pragma Inline (Has_Unknown_Discriminants); pragma Inline (High_Bound); pragma Inline (Identifier); pragma Inline (Implicit_Types); pragma Inline (Implicit_With); pragma Inline (In_Present); pragma Inline (Intval); pragma Inline (Is_Evaluated); pragma Inline (Is_Overloaded); pragma Inline (Is_Static); pragma Inline (Is_Task_Master); pragma Inline (Iteration_Scheme); pragma Inline (Label); pragma Inline (Last_Bit); pragma Inline (Last_Name); pragma Inline (Library_Unit); pragma Inline (Left_Opnd); pragma Inline (Limited_Present); pragma Inline (Literals); pragma Inline (Loop_Parameter_Specification); pragma Inline (Low_Bound); pragma Inline (Mod_Clause); pragma Inline (More_Ids); pragma Inline (Name); pragma Inline (Names); pragma Inline (Next_Named_Actual); pragma Inline (Null_Present); pragma Inline (Null_Record_Present); pragma Inline (Numerator); pragma Inline (Object_Definition); pragma Inline (Others_Discrete_Choices); pragma Inline (Out_Present); pragma Inline (Parameter_Associations); pragma Inline (Parameter_Specifications); pragma Inline (Parameter_Type); pragma Inline (Parens); pragma Inline (Parent_Spec); pragma Inline (Position); pragma Inline (Pragma_Argument_Associations); pragma Inline (Preelaborable); pragma Inline (Prefix); pragma Inline (Prev_Ids); pragma Inline (Private_Declarations); pragma Inline (Private_Present); pragma Inline (Proper_Body); pragma Inline (Protected_Definition); pragma Inline (Protected_Present); pragma Inline (Range_Constraint); pragma Inline (Range_Expression); pragma Inline (Real_Range_Specification); pragma Inline (Record_Extension_Part); pragma Inline (Redundant_Use); pragma Inline (Reverse_Present); pragma Inline (Right_Opnd); pragma Inline (Selective_Accept_Alternatives); pragma Inline (Selector_Name); pragma Inline (Selector_Names); pragma Inline (Specification); pragma Inline (Statements); pragma Inline (Strval); pragma Inline (Subtype_Indication); pragma Inline (Subtype_Mark); pragma Inline (Subtype_Marks); pragma Inline (Tagged_Present); pragma Inline (Task_Definition); pragma Inline (Then_Statements); pragma Inline (Triggering_Alternative); pragma Inline (Triggering_Statement); pragma Inline (Type_Definition); pragma Inline (Unchecked_Conversion); pragma Inline (Unit); pragma Inline (Variant_Part); pragma Inline (Variants); pragma Inline (Visible_Declarations); pragma Inline (Set_Analyzed); pragma Inline (Set_Error_Posted); end Sinfo; _Part (N : Node_Id; Val : Node_Id); -- Node3 procedure Set_Redundant_Use (N : Nodegnat-1.67-src/src/sinfo.adb 444 10015 7640 357070 5506244425 10761 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S I N F O -- -- -- -- B o d y -- -- -- -- $Revision: 1.107 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Comperr; use Comperr; with Debug; use Debug; with Output; use Output; package body Sinfo is use Atree.Unchecked_Access; -- This package is one of the few packages which is allowed to make direct -- references to tree nodes (since it is in the business of providing a -- higher level of tree access which other clients are expected to use and -- which implements checks). use Atree_Private_Part; -- The only reason that we ask for direct access to the private part of -- the tree package is so that we can directly reference the Nkind field -- of nodes table entries. We do this since it helps the efficiency of -- the Sinfo debugging checks considerably (note that when we are checking -- Nkind values, we don't need to check for a valid node reference, because -- we will check that anyway when we reference the field). NT : Nodes.Table_Ptr renames Nodes.Table; -- A short hand abbreviation, useful for the debugging checks -------------------------- -- Debugging Procedures -- -------------------------- -- These debugging procedures are called only if assertions are enabled procedure Dcheck_Bad_Nkind (N : Node_Id); -- Used to signal bad node kind for access to node N ---------------------- -- Dcheck_Bad_Nkind -- ---------------------- procedure Dcheck_Bad_Nkind (N : Node_Id) is begin -- Note: in the following debugging message, we use the Nkind function -- (rather than get the Nkind value directly) quite deliberately. It -- means that if the reason that we got a bad Nkind was that N was not -- a proper node in the first place, we get the right error message. Compiler_Error; Write_Eol; Write_String ("Dcheck_Bad_Nkind failure: Nkind = "); Write_String (Node_Kind'Image (Nkind (N))); Write_Eol; Compiler_Abort (N); end Dcheck_Bad_Nkind; ---------------------------- -- Field Access Functions -- ---------------------------- function Abort_Present (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Requeue_Statement, Dcheck_Bad_Nkind (N)); return Flag1 (N); end Abort_Present; function Abortable_Part (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Asynchronous_Select, Dcheck_Bad_Nkind (N)); return Node2 (N); end Abortable_Part; function Abstract_Present (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Derived_Type_Definition or else NT (N).Nkind = N_Formal_Private_Type_Definition or else NT (N).Nkind = N_Private_Extension_Declaration or else NT (N).Nkind = N_Private_Type_Declaration or else NT (N).Nkind = N_Record_Definition, Dcheck_Bad_Nkind (N)); return Flag4 (N); end Abstract_Present; function Accept_Name (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Accept_Statement, Dcheck_Bad_Nkind (N)); return Node1 (N); end Accept_Name; function Accept_Statement (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Accept_Alternative, Dcheck_Bad_Nkind (N)); return Node2 (N); end Accept_Statement; function Actions (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Expression_Actions, Dcheck_Bad_Nkind (N)); return List1 (N); end Actions; function Activation_Chain_Entity (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Block_Statement or else NT (N).Nkind = N_Generic_Package_Declaration or else NT (N).Nkind = N_Package_Declaration or else NT (N).Nkind = N_Subprogram_Body or else NT (N).Nkind = N_Task_Body, Dcheck_Bad_Nkind (N)); return Node2 (N); end Activation_Chain_Entity; function Acts_As_Spec (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Compilation_Unit or else NT (N).Nkind = N_Subprogram_Body, Dcheck_Bad_Nkind (N)); return Flag4 (N); end Acts_As_Spec; function Actual_Parameter (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Parameter_Association, Dcheck_Bad_Nkind (N)); return Node2 (N); end Actual_Parameter; function Aliased_Present (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Component_Declaration or else NT (N).Nkind = N_Constrained_Array_Definition or else NT (N).Nkind = N_Object_Declaration or else NT (N).Nkind = N_Unconstrained_Array_Definition, Dcheck_Bad_Nkind (N)); return Flag1 (N); end Aliased_Present; function All_Present (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Access_To_Object_Definition, Dcheck_Bad_Nkind (N)); return Flag1 (N); end All_Present; function Alternatives (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Case_Statement, Dcheck_Bad_Nkind (N)); return List4 (N); end Alternatives; function Analyzed (N : Node_Id) return Boolean is begin return Flag19 (N); end Analyzed; function Array_Aggregate (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Enumeration_Representation_Clause, Dcheck_Bad_Nkind (N)); return Node4 (N); end Array_Aggregate; function Assignment_OK (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Assignment_Statement, Dcheck_Bad_Nkind (N)); return Flag5 (N); end Assignment_OK; function Bad_Is_Detected (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Subprogram_Body, Dcheck_Bad_Nkind (N)); return Flag1 (N); end Bad_Is_Detected; function Body_Required (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Compilation_Unit, Dcheck_Bad_Nkind (N)); return Flag3 (N); end Body_Required; function Box_Present (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Formal_Package_Declaration or else NT (N).Nkind = N_Formal_Subprogram_Declaration, Dcheck_Bad_Nkind (N)); return Flag1 (N); end Box_Present; function Char_Literal_Value (N : Node_Id) return Char_Code is begin pragma Assert (False or else NT (N).Nkind = N_Character_Literal, Dcheck_Bad_Nkind (N)); return Char_Code2 (N); end Char_Literal_Value; function Chars (N : Node_Id) return Name_Id is begin pragma Assert (False or else NT (N).Nkind in N_Has_Chars, Dcheck_Bad_Nkind (N)); return Name1 (N); end Chars; function Choice_Parameter (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Exception_Handler, Dcheck_Bad_Nkind (N)); return Node2 (N); end Choice_Parameter; function Choices (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Component_Association, Dcheck_Bad_Nkind (N)); return List1 (N); end Choices; function Component_Associations (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Aggregate or else NT (N).Nkind = N_Extension_Aggregate, Dcheck_Bad_Nkind (N)); return List4 (N); end Component_Associations; function Component_Clauses (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Record_Representation_Clause, Dcheck_Bad_Nkind (N)); return List3 (N); end Component_Clauses; function Component_Declarations (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Component_List, Dcheck_Bad_Nkind (N)); return List3 (N); end Component_Declarations; function Component_List (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Record_Definition or else NT (N).Nkind = N_Variant, Dcheck_Bad_Nkind (N)); return Node1 (N); end Component_List; function Component_Name (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Component_Clause, Dcheck_Bad_Nkind (N)); return Node1 (N); end Component_Name; function Condition (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Accept_Alternative or else NT (N).Nkind = N_Delay_Alternative or else NT (N).Nkind = N_Elsif_Part or else NT (N).Nkind = N_Entry_Body or else NT (N).Nkind = N_Exit_Statement or else NT (N).Nkind = N_If_Statement or else NT (N).Nkind = N_Iteration_Scheme or else NT (N).Nkind = N_Terminate_Alternative, Dcheck_Bad_Nkind (N)); return Node5 (N); end Condition; function Constant_Present (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Access_To_Object_Definition or else NT (N).Nkind = N_Object_Declaration, Dcheck_Bad_Nkind (N)); return Flag2 (N); end Constant_Present; function Constraint (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Subtype_Indication, Dcheck_Bad_Nkind (N)); return Node3 (N); end Constraint; function Constraints (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Index_Or_Discriminant_Constraint, Dcheck_Bad_Nkind (N)); return List1 (N); end Constraints; function Context_Installed (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_With_Clause, Dcheck_Bad_Nkind (N)); return Flag3 (N); end Context_Installed; function Context_Items (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Compilation_Unit, Dcheck_Bad_Nkind (N)); return List1 (N); end Context_Items; function Controlling_Argument (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Function_Call or else NT (N).Nkind = N_Procedure_Call_Statement, Dcheck_Bad_Nkind (N)); return Node1 (N); end Controlling_Argument; function Corresponding_Body (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Generic_Package_Declaration or else NT (N).Nkind = N_Generic_Subprogram_Declaration or else NT (N).Nkind = N_Package_Body_Stub or else NT (N).Nkind = N_Package_Declaration or else NT (N).Nkind = N_Protected_Body_Stub or else NT (N).Nkind = N_Subprogram_Body_Stub or else NT (N).Nkind = N_Subprogram_Declaration or else NT (N).Nkind = N_Task_Body_Stub, Dcheck_Bad_Nkind (N)); return Node5 (N); end Corresponding_Body; function Corresponding_Spec (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Package_Body or else NT (N).Nkind = N_Subprogram_Body or else NT (N).Nkind = N_Subprogram_Renaming_Declaration or else NT (N).Nkind = N_Task_Body or else NT (N).Nkind = N_With_Clause, Dcheck_Bad_Nkind (N)); return Node5 (N); end Corresponding_Spec; function Debug_Statement (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Pragma, Dcheck_Bad_Nkind (N)); return Node3 (N); end Debug_Statement; function Decimal (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Real_Literal, Dcheck_Bad_Nkind (N)); return Flag2 (N); end Decimal; function Declarations (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Accept_Statement or else NT (N).Nkind = N_Block_Statement or else NT (N).Nkind = N_Entry_Body or else NT (N).Nkind = N_Package_Body or else NT (N).Nkind = N_Protected_Body or else NT (N).Nkind = N_Subprogram_Body or else NT (N).Nkind = N_Task_Body, Dcheck_Bad_Nkind (N)); return List3 (N); end Declarations; function Default_Name (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Formal_Subprogram_Declaration, Dcheck_Bad_Nkind (N)); return Node2 (N); end Default_Name; function Defining_Identifier (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Component_Declaration or else NT (N).Nkind = N_Defining_Program_Unit_Name or else NT (N).Nkind = N_Discriminant_Specification or else NT (N).Nkind = N_Entry_Body or else NT (N).Nkind = N_Entry_Declaration or else NT (N).Nkind = N_Entry_Index_Specification or else NT (N).Nkind = N_Exception_Declaration or else NT (N).Nkind = N_Exception_Renaming_Declaration or else NT (N).Nkind = N_Formal_Object_Declaration or else NT (N).Nkind = N_Formal_Package_Declaration or else NT (N).Nkind = N_Formal_Type_Declaration or else NT (N).Nkind = N_Full_Type_Declaration or else NT (N).Nkind = N_Implicit_Label_Declaration or else NT (N).Nkind = N_Implicit_Type or else NT (N).Nkind = N_Incomplete_Type_Declaration or else NT (N).Nkind = N_Loop_Parameter_Specification or else NT (N).Nkind = N_Number_Declaration or else NT (N).Nkind = N_Object_Declaration or else NT (N).Nkind = N_Object_Renaming_Declaration or else NT (N).Nkind = N_Package_Body_Stub or else NT (N).Nkind = N_Parameter_Specification or else NT (N).Nkind = N_Private_Extension_Declaration or else NT (N).Nkind = N_Private_Type_Declaration or else NT (N).Nkind = N_Protected_Body or else NT (N).Nkind = N_Protected_Body_Stub or else NT (N).Nkind = N_Protected_Type_Declaration or else NT (N).Nkind = N_Single_Protected_Declaration or else NT (N).Nkind = N_Single_Task_Declaration or else NT (N).Nkind = N_Subtype_Declaration or else NT (N).Nkind = N_Task_Body or else NT (N).Nkind = N_Task_Body_Stub or else NT (N).Nkind = N_Task_Type_Declaration, Dcheck_Bad_Nkind (N)); return Node1 (N); end Defining_Identifier; function Defining_Unit_Name (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Function_Instantiation or else NT (N).Nkind = N_Function_Specification or else NT (N).Nkind = N_Generic_Function_Renaming_Declaration or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration or else NT (N).Nkind = N_Package_Body or else NT (N).Nkind = N_Package_Instantiation or else NT (N).Nkind = N_Package_Renaming_Declaration or else NT (N).Nkind = N_Package_Specification or else NT (N).Nkind = N_Procedure_Instantiation or else NT (N).Nkind = N_Procedure_Specification, Dcheck_Bad_Nkind (N)); return Node1 (N); end Defining_Unit_Name; function Delay_Alternative (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Timed_Entry_Call, Dcheck_Bad_Nkind (N)); return Node4 (N); end Delay_Alternative; function Delay_Statement (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Delay_Alternative, Dcheck_Bad_Nkind (N)); return Node2 (N); end Delay_Statement; function Delta_Expression (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Decimal_Fixed_Point_Definition or else NT (N).Nkind = N_Delta_Constraint or else NT (N).Nkind = N_Ordinary_Fixed_Point_Definition, Dcheck_Bad_Nkind (N)); return Node3 (N); end Delta_Expression; function Denominator (N : Node_Id) return Uint is begin pragma Assert (False or else NT (N).Nkind = N_Real_Literal, Dcheck_Bad_Nkind (N)); return Uint4 (N); end Denominator; function Digits_Expression (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Decimal_Fixed_Point_Definition or else NT (N).Nkind = N_Digits_Constraint or else NT (N).Nkind = N_Floating_Point_Definition, Dcheck_Bad_Nkind (N)); return Node2 (N); end Digits_Expression; function Discrete_Choices (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Case_Statement_Alternative or else NT (N).Nkind = N_Variant, Dcheck_Bad_Nkind (N)); return List4 (N); end Discrete_Choices; function Discrete_Range (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Slice, Dcheck_Bad_Nkind (N)); return Node4 (N); end Discrete_Range; function Discrete_Subtype_Definition (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Entry_Declaration or else NT (N).Nkind = N_Entry_Index_Specification or else NT (N).Nkind = N_Loop_Parameter_Specification, Dcheck_Bad_Nkind (N)); return Node4 (N); end Discrete_Subtype_Definition; function Discrete_Subtype_Definitions (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Constrained_Array_Definition, Dcheck_Bad_Nkind (N)); return List2 (N); end Discrete_Subtype_Definitions; function Discriminant_Specifications (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Formal_Type_Declaration or else NT (N).Nkind = N_Full_Type_Declaration or else NT (N).Nkind = N_Incomplete_Type_Declaration or else NT (N).Nkind = N_Private_Extension_Declaration or else NT (N).Nkind = N_Private_Type_Declaration or else NT (N).Nkind = N_Protected_Type_Declaration or else NT (N).Nkind = N_Single_Protected_Declaration or else NT (N).Nkind = N_Single_Task_Declaration or else NT (N).Nkind = N_Task_Type_Declaration, Dcheck_Bad_Nkind (N)); return List2 (N); end Discriminant_Specifications; function Discriminant_Type (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Discriminant_Specification, Dcheck_Bad_Nkind (N)); return Node2 (N); end Discriminant_Type; function Do_Access_Check (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Attribute_Reference or else NT (N).Nkind = N_Explicit_Dereference or else NT (N).Nkind = N_Indexed_Component or else NT (N).Nkind = N_Selected_Component or else NT (N).Nkind = N_Slice, Dcheck_Bad_Nkind (N)); return Flag2 (N); end Do_Access_Check; function Do_Accessibility_Check (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Parameter_Specification, Dcheck_Bad_Nkind (N)); return Flag3 (N); end Do_Accessibility_Check; function Do_Discriminant_Check (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Selected_Component, Dcheck_Bad_Nkind (N)); return Flag3 (N); end Do_Discriminant_Check; function Do_Division_Check (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Op_Divide or else NT (N).Nkind = N_Op_Mod or else NT (N).Nkind = N_Op_Rem, Dcheck_Bad_Nkind (N)); return Flag3 (N); end Do_Division_Check; function Do_Elaboration_Check (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Entry_Call_Statement or else NT (N).Nkind = N_Function_Call or else NT (N).Nkind = N_Procedure_Call_Statement, Dcheck_Bad_Nkind (N)); return Flag2 (N); end Do_Elaboration_Check; function Do_Length_Check (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Assignment_Statement or else NT (N).Nkind = N_Op_And or else NT (N).Nkind = N_Op_Or or else NT (N).Nkind = N_Op_Xor or else NT (N).Nkind = N_Type_Conversion, Dcheck_Bad_Nkind (N)); return Flag4 (N); end Do_Length_Check; function Do_Overflow_Check (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind in N_Op or else NT (N).Nkind = N_Type_Conversion, Dcheck_Bad_Nkind (N)); return Flag2 (N); end Do_Overflow_Check; function Do_Range_Check (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind in N_Subexpr, Dcheck_Bad_Nkind (N)); return Flag9 (N); end Do_Range_Check; function Do_Storage_Check (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Allocator or else NT (N).Nkind = N_Subprogram_Body, Dcheck_Bad_Nkind (N)); return Flag2 (N); end Do_Storage_Check; function Do_Tag_Check (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Assignment_Statement or else NT (N).Nkind = N_Function_Call or else NT (N).Nkind = N_Procedure_Call_Statement or else NT (N).Nkind = N_Return_Statement or else NT (N).Nkind = N_Type_Conversion, Dcheck_Bad_Nkind (N)); return Flag3 (N); end Do_Tag_Check; function Elaborate_Present (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_With_Clause, Dcheck_Bad_Nkind (N)); return Flag4 (N); end Elaborate_Present; function Elaborate_All_Present (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_With_Clause, Dcheck_Bad_Nkind (N)); return Flag1 (N); end Elaborate_All_Present; function Elaborate_Body_Present (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Compilation_Unit, Dcheck_Bad_Nkind (N)); return Flag7 (N); end Elaborate_Body_Present; function Else_Statements (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Conditional_Entry_Call or else NT (N).Nkind = N_If_Statement or else NT (N).Nkind = N_Selective_Accept, Dcheck_Bad_Nkind (N)); return List4 (N); end Else_Statements; function Elsif_Parts (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_If_Statement, Dcheck_Bad_Nkind (N)); return List3 (N); end Elsif_Parts; function Enclosing_Variant (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Variant, Dcheck_Bad_Nkind (N)); return Node2 (N); end Enclosing_Variant; function Entity (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind in N_Op or else NT (N).Nkind = N_Attribute_Reference or else NT (N).Nkind = N_Character_Literal or else NT (N).Nkind = N_Expanded_Name or else NT (N).Nkind = N_Freeze_Entity or else NT (N).Nkind = N_Identifier or else NT (N).Nkind = N_Operator_Symbol, Dcheck_Bad_Nkind (N)); return Node4 (N); end Entity; function Entry_Body_Formal_Part (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Entry_Body, Dcheck_Bad_Nkind (N)); return Node2 (N); end Entry_Body_Formal_Part; function Entry_Call_Alternative (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Conditional_Entry_Call or else NT (N).Nkind = N_Timed_Entry_Call, Dcheck_Bad_Nkind (N)); return Node1 (N); end Entry_Call_Alternative; function Entry_Call_Statement (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Entry_Call_Alternative, Dcheck_Bad_Nkind (N)); return Node1 (N); end Entry_Call_Statement; function Entry_Index (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Accept_Statement, Dcheck_Bad_Nkind (N)); return Node5 (N); end Entry_Index; function Entry_Index_Specification (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Entry_Body_Formal_Part, Dcheck_Bad_Nkind (N)); return Node1 (N); end Entry_Index_Specification; function Error_Posted (N : Node_Id) return Boolean is begin return Flag20 (N); end Error_Posted; function Etype (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind in N_Has_Etype, Dcheck_Bad_Nkind (N)); return Node5 (N); end Etype; function Evaluate_Once (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind in N_Subexpr, Dcheck_Bad_Nkind (N)); return Flag10 (N); end Evaluate_Once; function Exception_Choices (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Exception_Handler, Dcheck_Bad_Nkind (N)); return List4 (N); end Exception_Choices; function Exception_Handlers (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Handled_Sequence_Of_Statements, Dcheck_Bad_Nkind (N)); return List4 (N); end Exception_Handlers; function Explicit_Generic_Actual_Parameter (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Generic_Association, Dcheck_Bad_Nkind (N)); return Node2 (N); end Explicit_Generic_Actual_Parameter; function Expression (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Allocator or else NT (N).Nkind = N_Assignment_Statement or else NT (N).Nkind = N_At_Clause or else NT (N).Nkind = N_Attribute_Definition_Clause or else NT (N).Nkind = N_Attribute_Reference or else NT (N).Nkind = N_Case_Statement or else NT (N).Nkind = N_Code_Statement or else NT (N).Nkind = N_Component_Association or else NT (N).Nkind = N_Component_Declaration or else NT (N).Nkind = N_Delay_Relative_Statement or else NT (N).Nkind = N_Delay_Until_Statement or else NT (N).Nkind = N_Discriminant_Association or else NT (N).Nkind = N_Discriminant_Specification or else NT (N).Nkind = N_Expression_Actions or else NT (N).Nkind = N_Extension_Aggregate or else NT (N).Nkind = N_Formal_Object_Declaration or else NT (N).Nkind = N_Mod_Clause or else NT (N).Nkind = N_Modular_Type_Definition or else NT (N).Nkind = N_Number_Declaration or else NT (N).Nkind = N_Object_Declaration or else NT (N).Nkind = N_Parameter_Specification or else NT (N).Nkind = N_Parenthesized_Expression or else NT (N).Nkind = N_Pragma_Argument_Association or else NT (N).Nkind = N_Qualified_Expression or else NT (N).Nkind = N_Reference or else NT (N).Nkind = N_Return_Statement or else NT (N).Nkind = N_Type_Conversion, Dcheck_Bad_Nkind (N)); return Node3 (N); end Expression; function Expressions (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Aggregate or else NT (N).Nkind = N_Concat_Multiple or else NT (N).Nkind = N_Indexed_Component, Dcheck_Bad_Nkind (N)); return List3 (N); end Expressions; function First_Bit (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Component_Clause, Dcheck_Bad_Nkind (N)); return Node3 (N); end First_Bit; function First_Name (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_With_Clause, Dcheck_Bad_Nkind (N)); return Flag5 (N); end First_Name; function First_Named_Actual (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Function_Call or else NT (N).Nkind = N_Procedure_Call_Statement, Dcheck_Bad_Nkind (N)); return Node4 (N); end First_Named_Actual; function Following_Pragmas (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Compilation_Unit, Dcheck_Bad_Nkind (N)); return List3 (N); end Following_Pragmas; function Formal_Type_Definition (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Formal_Type_Declaration, Dcheck_Bad_Nkind (N)); return Node3 (N); end Formal_Type_Definition; function Generic_Associations (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Formal_Package_Declaration or else NT (N).Nkind = N_Function_Instantiation or else NT (N).Nkind = N_Package_Instantiation or else NT (N).Nkind = N_Procedure_Instantiation, Dcheck_Bad_Nkind (N)); return List3 (N); end Generic_Associations; function Generic_Formal_Declarations (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Generic_Package_Declaration or else NT (N).Nkind = N_Generic_Subprogram_Declaration, Dcheck_Bad_Nkind (N)); return List3 (N); end Generic_Formal_Declarations; function Generic_Parent (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Formal_Package_Declaration or else NT (N).Nkind = N_Function_Specification or else NT (N).Nkind = N_Package_Specification or else NT (N).Nkind = N_Procedure_Specification, Dcheck_Bad_Nkind (N)); return Node5 (N); end Generic_Parent; function Handled_Statement_Sequence (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Accept_Statement or else NT (N).Nkind = N_Block_Statement or else NT (N).Nkind = N_Entry_Body or else NT (N).Nkind = N_Package_Body or else NT (N).Nkind = N_Subprogram_Body or else NT (N).Nkind = N_Task_Body, Dcheck_Bad_Nkind (N)); return Node4 (N); end Handled_Statement_Sequence; function Has_Created_Identifier (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Block_Statement or else NT (N).Nkind = N_Loop_Statement, Dcheck_Bad_Nkind (N)); return Flag1 (N); end Has_Created_Identifier; function Has_No_Side_Effects (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind in N_Subexpr, Dcheck_Bad_Nkind (N)); return Flag8 (N); end Has_No_Side_Effects; function Has_Priority_Pragma (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Protected_Definition or else NT (N).Nkind = N_Subprogram_Body or else NT (N).Nkind = N_Task_Definition, Dcheck_Bad_Nkind (N)); return Flag6 (N); end Has_Priority_Pragma; function Has_Task_Stack_Size_Pragma (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Task_Definition, Dcheck_Bad_Nkind (N)); return Flag5 (N); end Has_Task_Stack_Size_Pragma; function Has_Unknown_Discriminants (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Formal_Type_Declaration or else NT (N).Nkind = N_Incomplete_Type_Declaration or else NT (N).Nkind = N_Private_Extension_Declaration or else NT (N).Nkind = N_Private_Type_Declaration, Dcheck_Bad_Nkind (N)); return Flag3 (N); end Has_Unknown_Discriminants; function High_Bound (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Range or else NT (N).Nkind = N_Real_Range_Specification or else NT (N).Nkind = N_Signed_Integer_Type_Definition, Dcheck_Bad_Nkind (N)); return Node2 (N); end High_Bound; function Identifier (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_At_Clause or else NT (N).Nkind = N_Attribute_Definition_Clause or else NT (N).Nkind = N_Attribute_Reference or else NT (N).Nkind = N_Block_Statement or else NT (N).Nkind = N_Designator or else NT (N).Nkind = N_Enumeration_Representation_Clause or else NT (N).Nkind = N_Handled_Sequence_Of_Statements or else NT (N).Nkind = N_Label or else NT (N).Nkind = N_Loop_Statement or else NT (N).Nkind = N_Pragma or else NT (N).Nkind = N_Pragma_Argument_Association or else NT (N).Nkind = N_Record_Representation_Clause, Dcheck_Bad_Nkind (N)); return Node1 (N); end Identifier; function Implicit_Types (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Record_Definition, Dcheck_Bad_Nkind (N)); return List2 (N); end Implicit_Types; function Implicit_With (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_With_Clause, Dcheck_Bad_Nkind (N)); return Flag2 (N); end Implicit_With; function In_Present (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Formal_Object_Declaration or else NT (N).Nkind = N_Parameter_Specification, Dcheck_Bad_Nkind (N)); return Flag1 (N); end In_Present; function Intval (N : Node_Id) return Uint is begin pragma Assert (False or else NT (N).Nkind = N_Integer_Literal, Dcheck_Bad_Nkind (N)); return Uint3 (N); end Intval; function Is_Evaluated (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind in N_Subexpr, Dcheck_Bad_Nkind (N)); return Flag7 (N); end Is_Evaluated; function Is_Overloaded (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind in N_Subexpr, Dcheck_Bad_Nkind (N)); return Flag5 (N); end Is_Overloaded; function Is_Static (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind in N_Subexpr, Dcheck_Bad_Nkind (N)); return Flag6 (N); end Is_Static; function Is_Task_Master (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Block_Statement or else NT (N).Nkind = N_Subprogram_Body or else NT (N).Nkind = N_Task_Body, Dcheck_Bad_Nkind (N)); return Flag5 (N); end Is_Task_Master; function Iteration_Scheme (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Loop_Statement, Dcheck_Bad_Nkind (N)); return Node2 (N); end Iteration_Scheme; function Label (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Implicit_Label_Declaration, Dcheck_Bad_Nkind (N)); return Node2 (N); end Label; function Last_Bit (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Component_Clause, Dcheck_Bad_Nkind (N)); return Node4 (N); end Last_Bit; function Last_Name (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_With_Clause, Dcheck_Bad_Nkind (N)); return Flag6 (N); end Last_Name; function Library_Unit (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Compilation_Unit or else NT (N).Nkind = N_Package_Body_Stub or else NT (N).Nkind = N_Protected_Body_Stub or else NT (N).Nkind = N_Subprogram_Body_Stub or else NT (N).Nkind = N_Task_Body_Stub or else NT (N).Nkind = N_With_Clause, Dcheck_Bad_Nkind (N)); return Node4 (N); end Library_Unit; function Left_Opnd (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind in N_Binary_Op, Dcheck_Bad_Nkind (N)); return Node2 (N); end Left_Opnd; function Literals (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Enumeration_Type_Definition, Dcheck_Bad_Nkind (N)); return List1 (N); end Literals; function Limited_Present (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Formal_Private_Type_Definition or else NT (N).Nkind = N_Private_Type_Declaration or else NT (N).Nkind = N_Record_Definition, Dcheck_Bad_Nkind (N)); return Flag2 (N); end Limited_Present; function Loop_Parameter_Specification (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Iteration_Scheme, Dcheck_Bad_Nkind (N)); return Node2 (N); end Loop_Parameter_Specification; function Low_Bound (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Range or else NT (N).Nkind = N_Real_Range_Specification or else NT (N).Nkind = N_Signed_Integer_Type_Definition, Dcheck_Bad_Nkind (N)); return Node1 (N); end Low_Bound; function Mod_Clause (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Record_Representation_Clause, Dcheck_Bad_Nkind (N)); return Node2 (N); end Mod_Clause; function More_Ids (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Component_Declaration or else NT (N).Nkind = N_Discriminant_Specification or else NT (N).Nkind = N_Exception_Declaration or else NT (N).Nkind = N_Formal_Object_Declaration or else NT (N).Nkind = N_Number_Declaration or else NT (N).Nkind = N_Object_Declaration or else NT (N).Nkind = N_Parameter_Specification, Dcheck_Bad_Nkind (N)); return Flag5 (N); end More_Ids; function Name (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Assignment_Statement or else NT (N).Nkind = N_Attribute_Definition_Clause or else NT (N).Nkind = N_Defining_Program_Unit_Name or else NT (N).Nkind = N_Designator or else NT (N).Nkind = N_Entry_Call_Statement or else NT (N).Nkind = N_Exception_Renaming_Declaration or else NT (N).Nkind = N_Exit_Statement or else NT (N).Nkind = N_Formal_Package_Declaration or else NT (N).Nkind = N_Function_Call or else NT (N).Nkind = N_Function_Instantiation or else NT (N).Nkind = N_Generic_Function_Renaming_Declaration or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration or else NT (N).Nkind = N_Goto_Statement or else NT (N).Nkind = N_Object_Renaming_Declaration or else NT (N).Nkind = N_Package_Instantiation or else NT (N).Nkind = N_Package_Renaming_Declaration or else NT (N).Nkind = N_Procedure_Call_Statement or else NT (N).Nkind = N_Procedure_Instantiation or else NT (N).Nkind = N_Raise_Statement or else NT (N).Nkind = N_Requeue_Statement or else NT (N).Nkind = N_Subprogram_Renaming_Declaration or else NT (N).Nkind = N_Subunit or else NT (N).Nkind = N_Variant_Part or else NT (N).Nkind = N_With_Clause, Dcheck_Bad_Nkind (N)); return Node2 (N); end Name; function Names (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Abort_Statement or else NT (N).Nkind = N_Use_Package_Clause, Dcheck_Bad_Nkind (N)); return List2 (N); end Names; function Next_Named_Actual (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Parameter_Association, Dcheck_Bad_Nkind (N)); return Node4 (N); end Next_Named_Actual; function Null_Present (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Component_List or else NT (N).Nkind = N_Record_Definition, Dcheck_Bad_Nkind (N)); return Flag3 (N); end Null_Present; function Null_Record_Present (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Aggregate or else NT (N).Nkind = N_Extension_Aggregate, Dcheck_Bad_Nkind (N)); return Flag2 (N); end Null_Record_Present; function Numerator (N : Node_Id) return Uint is begin pragma Assert (False or else NT (N).Nkind = N_Real_Literal, Dcheck_Bad_Nkind (N)); return Uint3 (N); end Numerator; function Object_Definition (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Object_Declaration, Dcheck_Bad_Nkind (N)); return Node2 (N); end Object_Definition; function Others_Discrete_Choices (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Others_Choice, Dcheck_Bad_Nkind (N)); return List1 (N); end Others_Discrete_Choices; function Out_Present (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Formal_Object_Declaration or else NT (N).Nkind = N_Parameter_Specification, Dcheck_Bad_Nkind (N)); return Flag2 (N); end Out_Present; function Parameter_Associations (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Entry_Call_Statement or else NT (N).Nkind = N_Function_Call or else NT (N).Nkind = N_Procedure_Call_Statement, Dcheck_Bad_Nkind (N)); return List3 (N); end Parameter_Associations; function Parameter_Specifications (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Accept_Statement or else NT (N).Nkind = N_Access_Function_Definition or else NT (N).Nkind = N_Access_Procedure_Definition or else NT (N).Nkind = N_Entry_Body_Formal_Part or else NT (N).Nkind = N_Entry_Declaration or else NT (N).Nkind = N_Function_Specification or else NT (N).Nkind = N_Procedure_Specification, Dcheck_Bad_Nkind (N)); return List2 (N); end Parameter_Specifications; function Parameter_Type (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Parameter_Specification, Dcheck_Bad_Nkind (N)); return Node2 (N); end Parameter_Type; function Parens (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind in N_Subexpr, Dcheck_Bad_Nkind (N)); return Flag1 (N); end Parens; function Parent_Spec (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Function_Instantiation or else NT (N).Nkind = N_Generic_Function_Renaming_Declaration or else NT (N).Nkind = N_Generic_Package_Declaration or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration or else NT (N).Nkind = N_Generic_Subprogram_Declaration or else NT (N).Nkind = N_Package_Declaration or else NT (N).Nkind = N_Package_Instantiation or else NT (N).Nkind = N_Package_Renaming_Declaration or else NT (N).Nkind = N_Procedure_Instantiation or else NT (N).Nkind = N_Subprogram_Declaration or else NT (N).Nkind = N_Subprogram_Renaming_Declaration, Dcheck_Bad_Nkind (N)); return Node4 (N); end Parent_Spec; function Position (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Component_Clause, Dcheck_Bad_Nkind (N)); return Node2 (N); end Position; function Pragma_Argument_Associations (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Pragma, Dcheck_Bad_Nkind (N)); return List2 (N); end Pragma_Argument_Associations; function Preelaborable (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Compilation_Unit, Dcheck_Bad_Nkind (N)); return Flag2 (N); end Preelaborable; function Prefix (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Attribute_Reference or else NT (N).Nkind = N_Expanded_Name or else NT (N).Nkind = N_Explicit_Dereference or else NT (N).Nkind = N_Indexed_Component or else NT (N).Nkind = N_Selected_Component or else NT (N).Nkind = N_Slice, Dcheck_Bad_Nkind (N)); return Node2 (N); end Prefix; function Prev_Ids (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Component_Declaration or else NT (N).Nkind = N_Discriminant_Specification or else NT (N).Nkind = N_Exception_Declaration or else NT (N).Nkind = N_Formal_Object_Declaration or else NT (N).Nkind = N_Number_Declaration or else NT (N).Nkind = N_Object_Declaration or else NT (N).Nkind = N_Parameter_Specification, Dcheck_Bad_Nkind (N)); return Flag6 (N); end Prev_Ids; function Private_Declarations (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Package_Specification or else NT (N).Nkind = N_Protected_Definition or else NT (N).Nkind = N_Task_Definition, Dcheck_Bad_Nkind (N)); return List4 (N); end Private_Declarations; function Private_Present (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Compilation_Unit or else NT (N).Nkind = N_Formal_Derived_Type_Definition, Dcheck_Bad_Nkind (N)); return Flag1 (N); end Private_Present; function Proper_Body (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Subunit, Dcheck_Bad_Nkind (N)); return Node1 (N); end Proper_Body; function Protected_Definition (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Protected_Type_Declaration or else NT (N).Nkind = N_Single_Protected_Declaration, Dcheck_Bad_Nkind (N)); return Node3 (N); end Protected_Definition; function Protected_Present (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Access_Function_Definition or else NT (N).Nkind = N_Access_Procedure_Definition, Dcheck_Bad_Nkind (N)); return Flag1 (N); end Protected_Present; function Range_Constraint (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Delta_Constraint or else NT (N).Nkind = N_Digits_Constraint, Dcheck_Bad_Nkind (N)); return Node4 (N); end Range_Constraint; function Range_Expression (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Range_Constraint, Dcheck_Bad_Nkind (N)); return Node4 (N); end Range_Expression; function Real_Range_Specification (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Decimal_Fixed_Point_Definition or else NT (N).Nkind = N_Floating_Point_Definition or else NT (N).Nkind = N_Ordinary_Fixed_Point_Definition, Dcheck_Bad_Nkind (N)); return Node4 (N); end Real_Range_Specification; function Record_Extension_Part (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Derived_Type_Definition, Dcheck_Bad_Nkind (N)); return Node3 (N); end Record_Extension_Part; function Redundant_Use (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Expanded_Name or else NT (N).Nkind = N_Identifier, Dcheck_Bad_Nkind (N)); return Flag2 (N); end Redundant_Use; function Reverse_Present (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Loop_Parameter_Specification, Dcheck_Bad_Nkind (N)); return Flag1 (N); end Reverse_Present; function Right_Opnd (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind in N_Op, Dcheck_Bad_Nkind (N)); return Node3 (N); end Right_Opnd; function Selective_Accept_Alternatives (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Selective_Accept, Dcheck_Bad_Nkind (N)); return List1 (N); end Selective_Accept_Alternatives; function Selector_Name (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Expanded_Name or else NT (N).Nkind = N_Generic_Association or else NT (N).Nkind = N_Parameter_Association or else NT (N).Nkind = N_Selected_Component, Dcheck_Bad_Nkind (N)); return Node3 (N); end Selector_Name; function Selector_Names (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Discriminant_Association, Dcheck_Bad_Nkind (N)); return List1 (N); end Selector_Names; function Specification (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Abstract_Subprogram_Declaration or else NT (N).Nkind = N_Formal_Subprogram_Declaration or else NT (N).Nkind = N_Generic_Package_Declaration or else NT (N).Nkind = N_Generic_Subprogram_Declaration or else NT (N).Nkind = N_Package_Declaration or else NT (N).Nkind = N_Subprogram_Body or else NT (N).Nkind = N_Subprogram_Body_Stub or else NT (N).Nkind = N_Subprogram_Declaration or else NT (N).Nkind = N_Subprogram_Renaming_Declaration, Dcheck_Bad_Nkind (N)); return Node1 (N); end Specification; function Statements (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Abortable_Part or else NT (N).Nkind = N_Accept_Alternative or else NT (N).Nkind = N_Case_Statement_Alternative or else NT (N).Nkind = N_Delay_Alternative or else NT (N).Nkind = N_Entry_Call_Alternative or else NT (N).Nkind = N_Exception_Handler or else NT (N).Nkind = N_Handled_Sequence_Of_Statements or else NT (N).Nkind = N_Loop_Statement or else NT (N).Nkind = N_Triggering_Alternative, Dcheck_Bad_Nkind (N)); return List3 (N); end Statements; function Strval (N : Node_Id) return String_Id is begin pragma Assert (False or else NT (N).Nkind = N_Operator_Symbol or else NT (N).Nkind = N_String_Literal, Dcheck_Bad_Nkind (N)); return Str3 (N); end Strval; function Subtype_Indication (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Access_To_Object_Definition or else NT (N).Nkind = N_Component_Declaration or else NT (N).Nkind = N_Constrained_Array_Definition or else NT (N).Nkind = N_Derived_Type_Definition or else NT (N).Nkind = N_Private_Extension_Declaration or else NT (N).Nkind = N_Subtype_Declaration or else NT (N).Nkind = N_Unconstrained_Array_Definition, Dcheck_Bad_Nkind (N)); return Node4 (N); end Subtype_Indication; function Subtype_Mark (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Access_Definition or else NT (N).Nkind = N_Access_Function_Definition or else NT (N).Nkind = N_Formal_Derived_Type_Definition or else NT (N).Nkind = N_Formal_Object_Declaration or else NT (N).Nkind = N_Function_Specification or else NT (N).Nkind = N_Object_Renaming_Declaration or else NT (N).Nkind = N_Qualified_Expression or else NT (N).Nkind = N_Subtype_Indication or else NT (N).Nkind = N_Type_Conversion, Dcheck_Bad_Nkind (N)); return Node4 (N); end Subtype_Mark; function Subtype_Marks (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Unconstrained_Array_Definition or else NT (N).Nkind = N_Use_Type_Clause, Dcheck_Bad_Nkind (N)); return List2 (N); end Subtype_Marks; function Tagged_Present (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Formal_Private_Type_Definition or else NT (N).Nkind = N_Private_Type_Declaration or else NT (N).Nkind = N_Record_Definition, Dcheck_Bad_Nkind (N)); return Flag1 (N); end Tagged_Present; function Task_Definition (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Single_Task_Declaration or else NT (N).Nkind = N_Task_Type_Declaration, Dcheck_Bad_Nkind (N)); return Node3 (N); end Task_Definition; function Then_Statements (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Elsif_Part or else NT (N).Nkind = N_If_Statement, Dcheck_Bad_Nkind (N)); return List2 (N); end Then_Statements; function Triggering_Alternative (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Asynchronous_Select, Dcheck_Bad_Nkind (N)); return Node1 (N); end Triggering_Alternative; function Triggering_Statement (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Triggering_Alternative, Dcheck_Bad_Nkind (N)); return Node1 (N); end Triggering_Statement; function Type_Definition (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Full_Type_Declaration, Dcheck_Bad_Nkind (N)); return Node3 (N); end Type_Definition; function Unchecked_Conversion (N : Node_Id) return Boolean is begin pragma Assert (False or else NT (N).Nkind = N_Type_Conversion, Dcheck_Bad_Nkind (N)); return Flag11 (N); end Unchecked_Conversion; function Unit (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Compilation_Unit, Dcheck_Bad_Nkind (N)); return Node2 (N); end Unit; function Variant_Part (N : Node_Id) return Node_Id is begin pragma Assert (False or else NT (N).Nkind = N_Component_List, Dcheck_Bad_Nkind (N)); return Node4 (N); end Variant_Part; function Variants (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Variant_Part, Dcheck_Bad_Nkind (N)); return List1 (N); end Variants; function Visible_Declarations (N : Node_Id) return List_Id is begin pragma Assert (False or else NT (N).Nkind = N_Package_Specification or else NT (N).Nkind = N_Protected_Definition or else NT (N).Nkind = N_Task_Definition, Dcheck_Bad_Nkind (N)); return List2 (N); end Visible_Declarations; -------------------------- -- Field Set Procedures -- -------------------------- procedure Set_Abort_Present (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Requeue_Statement, Dcheck_Bad_Nkind (N)); Set_Flag1 (N, Val); end Set_Abort_Present; procedure Set_Abortable_Part (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Asynchronous_Select, Dcheck_Bad_Nkind (N)); Set_Node2_With_Parent (N, Val); end Set_Abortable_Part; procedure Set_Abstract_Present (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Derived_Type_Definition or else NT (N).Nkind = N_Formal_Private_Type_Definition or else NT (N).Nkind = N_Private_Extension_Declaration or else NT (N).Nkind = N_Private_Type_Declaration or else NT (N).Nkind = N_Record_Definition, Dcheck_Bad_Nkind (N)); Set_Flag4 (N, Val); end Set_Abstract_Present; procedure Set_Accept_Name (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Accept_Statement, Dcheck_Bad_Nkind (N)); Set_Node1_With_Parent (N, Val); end Set_Accept_Name; procedure Set_Accept_Statement (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Accept_Alternative, Dcheck_Bad_Nkind (N)); Set_Node2_With_Parent (N, Val); end Set_Accept_Statement; procedure Set_Actions (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Expression_Actions, Dcheck_Bad_Nkind (N)); Set_List1_With_Parent (N, Val); end Set_Actions; procedure Set_Activation_Chain_Entity (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Block_Statement or else NT (N).Nkind = N_Generic_Package_Declaration or else NT (N).Nkind = N_Package_Declaration or else NT (N).Nkind = N_Subprogram_Body or else NT (N).Nkind = N_Task_Body, Dcheck_Bad_Nkind (N)); Set_Node2 (N, Val); -- semantic node, no parent set end Set_Activation_Chain_Entity; procedure Set_Acts_As_Spec (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Compilation_Unit or else NT (N).Nkind = N_Subprogram_Body, Dcheck_Bad_Nkind (N)); Set_Flag4 (N, Val); end Set_Acts_As_Spec; procedure Set_Actual_Parameter (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Parameter_Association, Dcheck_Bad_Nkind (N)); Set_Node2_With_Parent (N, Val); end Set_Actual_Parameter; procedure Set_Aliased_Present (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Component_Declaration or else NT (N).Nkind = N_Constrained_Array_Definition or else NT (N).Nkind = N_Object_Declaration or else NT (N).Nkind = N_Unconstrained_Array_Definition, Dcheck_Bad_Nkind (N)); Set_Flag1 (N, Val); end Set_Aliased_Present; procedure Set_All_Present (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Access_To_Object_Definition, Dcheck_Bad_Nkind (N)); Set_Flag1 (N, Val); end Set_All_Present; procedure Set_Alternatives (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Case_Statement, Dcheck_Bad_Nkind (N)); Set_List4_With_Parent (N, Val); end Set_Alternatives; procedure Set_Analyzed (N : Node_Id; Val : Boolean) is begin Set_Flag19 (N, Val); end Set_Analyzed; procedure Set_Array_Aggregate (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Enumeration_Representation_Clause, Dcheck_Bad_Nkind (N)); Set_Node4_With_Parent (N, Val); end Set_Array_Aggregate; procedure Set_Assignment_OK (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Assignment_Statement, Dcheck_Bad_Nkind (N)); Set_Flag5 (N, Val); end Set_Assignment_OK; procedure Set_Bad_Is_Detected (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Subprogram_Body, Dcheck_Bad_Nkind (N)); Set_Flag1 (N, Val); end Set_Bad_Is_Detected; procedure Set_Body_Required (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Compilation_Unit, Dcheck_Bad_Nkind (N)); Set_Flag3 (N, Val); end Set_Body_Required; procedure Set_Box_Present (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Formal_Package_Declaration or else NT (N).Nkind = N_Formal_Subprogram_Declaration, Dcheck_Bad_Nkind (N)); Set_Flag1 (N, Val); end Set_Box_Present; procedure Set_Char_Literal_Value (N : Node_Id; Val : Char_Code) is begin pragma Assert (False or else NT (N).Nkind = N_Character_Literal, Dcheck_Bad_Nkind (N)); Set_Char_Code2 (N, Val); end Set_Char_Literal_Value; procedure Set_Chars (N : Node_Id; Val : Name_Id) is begin pragma Assert (False or else NT (N).Nkind in N_Has_Chars, Dcheck_Bad_Nkind (N)); Set_Name1 (N, Val); end Set_Chars; procedure Set_Choice_Parameter (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Exception_Handler, Dcheck_Bad_Nkind (N)); Set_Node2_With_Parent (N, Val); end Set_Choice_Parameter; procedure Set_Choices (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Component_Association, Dcheck_Bad_Nkind (N)); Set_List1_With_Parent (N, Val); end Set_Choices; procedure Set_Component_Associations (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Aggregate or else NT (N).Nkind = N_Extension_Aggregate, Dcheck_Bad_Nkind (N)); Set_List4_With_Parent (N, Val); end Set_Component_Associations; procedure Set_Component_Clauses (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Record_Representation_Clause, Dcheck_Bad_Nkind (N)); Set_List3_With_Parent (N, Val); end Set_Component_Clauses; procedure Set_Component_Declarations (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Component_List, Dcheck_Bad_Nkind (N)); Set_List3_With_Parent (N, Val); end Set_Component_Declarations; procedure Set_Component_List (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Record_Definition or else NT (N).Nkind = N_Variant, Dcheck_Bad_Nkind (N)); Set_Node1_With_Parent (N, Val); end Set_Component_List; procedure Set_Component_Name (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Component_Clause, Dcheck_Bad_Nkind (N)); Set_Node1_With_Parent (N, Val); end Set_Component_Name; procedure Set_Condition (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Accept_Alternative or else NT (N).Nkind = N_Delay_Alternative or else NT (N).Nkind = N_Elsif_Part or else NT (N).Nkind = N_Entry_Body or else NT (N).Nkind = N_Exit_Statement or else NT (N).Nkind = N_If_Statement or else NT (N).Nkind = N_Iteration_Scheme or else NT (N).Nkind = N_Terminate_Alternative, Dcheck_Bad_Nkind (N)); Set_Node5_With_Parent (N, Val); end Set_Condition; procedure Set_Constant_Present (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Access_To_Object_Definition or else NT (N).Nkind = N_Object_Declaration, Dcheck_Bad_Nkind (N)); Set_Flag2 (N, Val); end Set_Constant_Present; procedure Set_Constraint (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Subtype_Indication, Dcheck_Bad_Nkind (N)); Set_Node3_With_Parent (N, Val); end Set_Constraint; procedure Set_Constraints (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Index_Or_Discriminant_Constraint, Dcheck_Bad_Nkind (N)); Set_List1_With_Parent (N, Val); end Set_Constraints; procedure Set_Context_Installed (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_With_Clause, Dcheck_Bad_Nkind (N)); Set_Flag3 (N, Val); end Set_Context_Installed; procedure Set_Context_Items (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Compilation_Unit, Dcheck_Bad_Nkind (N)); Set_List1_With_Parent (N, Val); end Set_Context_Items; procedure Set_Controlling_Argument (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Function_Call or else NT (N).Nkind = N_Procedure_Call_Statement, Dcheck_Bad_Nkind (N)); Set_Node1 (N, Val); -- Note: semantic node, no parent set end Set_Controlling_Argument; procedure Set_Corresponding_Body (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Generic_Package_Declaration or else NT (N).Nkind = N_Generic_Subprogram_Declaration or else NT (N).Nkind = N_Package_Body_Stub or else NT (N).Nkind = N_Package_Declaration or else NT (N).Nkind = N_Protected_Body_Stub or else NT (N).Nkind = N_Subprogram_Body_Stub or else NT (N).Nkind = N_Subprogram_Declaration or else NT (N).Nkind = N_Task_Body_Stub, Dcheck_Bad_Nkind (N)); Set_Node5 (N, Val); -- Semantic node, no parent set end Set_Corresponding_Body; procedure Set_Corresponding_Spec (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Package_Body or else NT (N).Nkind = N_Subprogram_Body or else NT (N).Nkind = N_Subprogram_Renaming_Declaration or else NT (N).Nkind = N_Task_Body or else NT (N).Nkind = N_With_Clause, Dcheck_Bad_Nkind (N)); Set_Node5 (N, Val); -- Semantic node, no parent set end Set_Corresponding_Spec; procedure Set_Debug_Statement (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Pragma, Dcheck_Bad_Nkind (N)); Set_Node3 (N, Val); -- semantic node, no parent set end Set_Debug_Statement; procedure Set_Decimal (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Real_Literal, Dcheck_Bad_Nkind (N)); Set_Flag2 (N, Val); end Set_Decimal; procedure Set_Declarations (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Accept_Statement or else NT (N).Nkind = N_Block_Statement or else NT (N).Nkind = N_Entry_Body or else NT (N).Nkind = N_Package_Body or else NT (N).Nkind = N_Protected_Body or else NT (N).Nkind = N_Subprogram_Body or else NT (N).Nkind = N_Task_Body, Dcheck_Bad_Nkind (N)); Set_List3_With_Parent (N, Val); end Set_Declarations; procedure Set_Default_Name (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Formal_Subprogram_Declaration, Dcheck_Bad_Nkind (N)); Set_Node2_With_Parent (N, Val); end Set_Default_Name; procedure Set_Defining_Identifier (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Component_Declaration or else NT (N).Nkind = N_Defining_Program_Unit_Name or else NT (N).Nkind = N_Discriminant_Specification or else NT (N).Nkind = N_Entry_Body or else NT (N).Nkind = N_Entry_Declaration or else NT (N).Nkind = N_Entry_Index_Specification or else NT (N).Nkind = N_Exception_Declaration or else NT (N).Nkind = N_Exception_Renaming_Declaration or else NT (N).Nkind = N_Formal_Object_Declaration or else NT (N).Nkind = N_Formal_Package_Declaration or else NT (N).Nkind = N_Formal_Type_Declaration or else NT (N).Nkind = N_Full_Type_Declaration or else NT (N).Nkind = N_Implicit_Label_Declaration or else NT (N).Nkind = N_Implicit_Type or else NT (N).Nkind = N_Incomplete_Type_Declaration or else NT (N).Nkind = N_Loop_Parameter_Specification or else NT (N).Nkind = N_Number_Declaration or else NT (N).Nkind = N_Object_Declaration or else NT (N).Nkind = N_Object_Renaming_Declaration or else NT (N).Nkind = N_Package_Body_Stub or else NT (N).Nkind = N_Parameter_Specification or else NT (N).Nkind = N_Private_Extension_Declaration or else NT (N).Nkind = N_Private_Type_Declaration or else NT (N).Nkind = N_Protected_Body or else NT (N).Nkind = N_Protected_Body_Stub or else NT (N).Nkind = N_Protected_Type_Declaration or else NT (N).Nkind = N_Single_Protected_Declaration or else NT (N).Nkind = N_Single_Task_Declaration or else NT (N).Nkind = N_Subtype_Declaration or else NT (N).Nkind = N_Task_Body or else NT (N).Nkind = N_Task_Body_Stub or else NT (N).Nkind = N_Task_Type_Declaration, Dcheck_Bad_Nkind (N)); Set_Node1_With_Parent (N, Val); end Set_Defining_Identifier; procedure Set_Defining_Unit_Name (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Function_Instantiation or else NT (N).Nkind = N_Function_Specification or else NT (N).Nkind = N_Generic_Function_Renaming_Declaration or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration or else NT (N).Nkind = N_Package_Body or else NT (N).Nkind = N_Package_Instantiation or else NT (N).Nkind = N_Package_Renaming_Declaration or else NT (N).Nkind = N_Package_Specification or else NT (N).Nkind = N_Procedure_Instantiation or else NT (N).Nkind = N_Procedure_Specification, Dcheck_Bad_Nkind (N)); Set_Node1_With_Parent (N, Val); end Set_Defining_Unit_Name; procedure Set_Delay_Alternative (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Timed_Entry_Call, Dcheck_Bad_Nkind (N)); Set_Node4_With_Parent (N, Val); end Set_Delay_Alternative; procedure Set_Delay_Statement (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Delay_Alternative, Dcheck_Bad_Nkind (N)); Set_Node2_With_Parent (N, Val); end Set_Delay_Statement; procedure Set_Delta_Expression (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Decimal_Fixed_Point_Definition or else NT (N).Nkind = N_Delta_Constraint or else NT (N).Nkind = N_Ordinary_Fixed_Point_Definition, Dcheck_Bad_Nkind (N)); Set_Node3_With_Parent (N, Val); end Set_Delta_Expression; procedure Set_Denominator (N : Node_Id; Val : Uint) is begin pragma Assert (False or else NT (N).Nkind = N_Real_Literal, Dcheck_Bad_Nkind (N)); Set_Uint4 (N, Val); end Set_Denominator; procedure Set_Digits_Expression (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Decimal_Fixed_Point_Definition or else NT (N).Nkind = N_Digits_Constraint or else NT (N).Nkind = N_Floating_Point_Definition, Dcheck_Bad_Nkind (N)); Set_Node2_With_Parent (N, Val); end Set_Digits_Expression; procedure Set_Discrete_Choices (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Case_Statement_Alternative or else NT (N).Nkind = N_Variant, Dcheck_Bad_Nkind (N)); Set_List4_With_Parent (N, Val); end Set_Discrete_Choices; procedure Set_Discrete_Range (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Slice, Dcheck_Bad_Nkind (N)); Set_Node4_With_Parent (N, Val); end Set_Discrete_Range; procedure Set_Discrete_Subtype_Definition (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Entry_Declaration or else NT (N).Nkind = N_Entry_Index_Specification or else NT (N).Nkind = N_Loop_Parameter_Specification, Dcheck_Bad_Nkind (N)); Set_Node4_With_Parent (N, Val); end Set_Discrete_Subtype_Definition; procedure Set_Discrete_Subtype_Definitions (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Constrained_Array_Definition, Dcheck_Bad_Nkind (N)); Set_List2_With_Parent (N, Val); end Set_Discrete_Subtype_Definitions; procedure Set_Discriminant_Specifications (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Formal_Type_Declaration or else NT (N).Nkind = N_Full_Type_Declaration or else NT (N).Nkind = N_Incomplete_Type_Declaration or else NT (N).Nkind = N_Private_Extension_Declaration or else NT (N).Nkind = N_Private_Type_Declaration or else NT (N).Nkind = N_Protected_Type_Declaration or else NT (N).Nkind = N_Single_Protected_Declaration or else NT (N).Nkind = N_Single_Task_Declaration or else NT (N).Nkind = N_Task_Type_Declaration, Dcheck_Bad_Nkind (N)); Set_List2_With_Parent (N, Val); end Set_Discriminant_Specifications; procedure Set_Discriminant_Type (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Discriminant_Specification, Dcheck_Bad_Nkind (N)); Set_Node2_With_Parent (N, Val); end Set_Discriminant_Type; procedure Set_Do_Access_Check (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Attribute_Reference or else NT (N).Nkind = N_Explicit_Dereference or else NT (N).Nkind = N_Indexed_Component or else NT (N).Nkind = N_Selected_Component or else NT (N).Nkind = N_Slice, Dcheck_Bad_Nkind (N)); Set_Flag2 (N, Val); end Set_Do_Access_Check; procedure Set_Do_Accessibility_Check (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Parameter_Specification, Dcheck_Bad_Nkind (N)); Set_Flag3 (N, Val); end Set_Do_Accessibility_Check; procedure Set_Do_Discriminant_Check (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Selected_Component, Dcheck_Bad_Nkind (N)); Set_Flag3 (N, Val); end Set_Do_Discriminant_Check; procedure Set_Do_Division_Check (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Op_Divide or else NT (N).Nkind = N_Op_Mod or else NT (N).Nkind = N_Op_Rem, Dcheck_Bad_Nkind (N)); Set_Flag3 (N, Val); end Set_Do_Division_Check; procedure Set_Do_Elaboration_Check (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Entry_Call_Statement or else NT (N).Nkind = N_Function_Call or else NT (N).Nkind = N_Procedure_Call_Statement, Dcheck_Bad_Nkind (N)); Set_Flag2 (N, Val); end Set_Do_Elaboration_Check; procedure Set_Do_Length_Check (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Assignment_Statement or else NT (N).Nkind = N_Op_And or else NT (N).Nkind = N_Op_Or or else NT (N).Nkind = N_Op_Xor or else NT (N).Nkind = N_Type_Conversion, Dcheck_Bad_Nkind (N)); Set_Flag4 (N, Val); end Set_Do_Length_Check; procedure Set_Do_Overflow_Check (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind in N_Op or else NT (N).Nkind = N_Type_Conversion, Dcheck_Bad_Nkind (N)); Set_Flag2 (N, Val); end Set_Do_Overflow_Check; procedure Set_Do_Range_Check (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind in N_Subexpr, Dcheck_Bad_Nkind (N)); Set_Flag9 (N, Val); end Set_Do_Range_Check; procedure Set_Do_Storage_Check (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Allocator or else NT (N).Nkind = N_Subprogram_Body, Dcheck_Bad_Nkind (N)); Set_Flag2 (N, Val); end Set_Do_Storage_Check; procedure Set_Do_Tag_Check (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Assignment_Statement or else NT (N).Nkind = N_Function_Call or else NT (N).Nkind = N_Procedure_Call_Statement or else NT (N).Nkind = N_Return_Statement or else NT (N).Nkind = N_Type_Conversion, Dcheck_Bad_Nkind (N)); Set_Flag3 (N, Val); end Set_Do_Tag_Check; procedure Set_Elaborate_Present (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_With_Clause, Dcheck_Bad_Nkind (N)); Set_Flag4 (N, Val); end Set_Elaborate_Present; procedure Set_Elaborate_All_Present (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_With_Clause, Dcheck_Bad_Nkind (N)); Set_Flag1 (N, Val); end Set_Elaborate_All_Present; procedure Set_Elaborate_Body_Present (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Compilation_Unit, Dcheck_Bad_Nkind (N)); Set_Flag7 (N, Val); end Set_Elaborate_Body_Present; procedure Set_Else_Statements (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Conditional_Entry_Call or else NT (N).Nkind = N_If_Statement or else NT (N).Nkind = N_Selective_Accept, Dcheck_Bad_Nkind (N)); Set_List4_With_Parent (N, Val); end Set_Else_Statements; procedure Set_Elsif_Parts (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_If_Statement, Dcheck_Bad_Nkind (N)); Set_List3_With_Parent (N, Val); end Set_Elsif_Parts; procedure Set_Enclosing_Variant (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Variant, Dcheck_Bad_Nkind (N)); Set_Node2 (N, Val); -- semantic field, no parent pointer end Set_Enclosing_Variant; procedure Set_Entity (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind in N_Op or else NT (N).Nkind = N_Attribute_Reference or else NT (N).Nkind = N_Character_Literal or else NT (N).Nkind = N_Expanded_Name or else NT (N).Nkind = N_Freeze_Entity or else NT (N).Nkind = N_Identifier or else NT (N).Nkind = N_Operator_Symbol, Dcheck_Bad_Nkind (N)); Set_Node4 (N, Val); -- Note: sem field, don't set parent end Set_Entity; procedure Set_Entry_Call_Alternative (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Conditional_Entry_Call or else NT (N).Nkind = N_Timed_Entry_Call, Dcheck_Bad_Nkind (N)); Set_Node1_With_Parent (N, Val); end Set_Entry_Call_Alternative; procedure Set_Entry_Body_Formal_Part (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Entry_Body, Dcheck_Bad_Nkind (N)); Set_Node2_With_Parent (N, Val); end Set_Entry_Body_Formal_Part; procedure Set_Entry_Call_Statement (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Entry_Call_Alternative, Dcheck_Bad_Nkind (N)); Set_Node1_With_Parent (N, Val); end Set_Entry_Call_Statement; procedure Set_Entry_Index (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Accept_Statement, Dcheck_Bad_Nkind (N)); Set_Node5_With_Parent (N, Val); end Set_Entry_Index; procedure Set_Entry_Index_Specification (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Entry_Body_Formal_Part, Dcheck_Bad_Nkind (N)); Set_Node1_With_Parent (N, Val); end Set_Entry_Index_Specification; procedure Set_Error_Posted (N : Node_Id; Val : Boolean) is begin Set_Flag20 (N, Val); end Set_Error_Posted; procedure Set_Etype (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind in N_Has_Etype, Dcheck_Bad_Nkind (N)); Set_Node5 (N, Val); -- Sem field, don't set parent end Set_Etype; procedure Set_Evaluate_Once (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind in N_Subexpr, Dcheck_Bad_Nkind (N)); Set_Flag10 (N, Val); end Set_Evaluate_Once; procedure Set_Exception_Choices (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Exception_Handler, Dcheck_Bad_Nkind (N)); Set_List4_With_Parent (N, Val); end Set_Exception_Choices; procedure Set_Exception_Handlers (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Handled_Sequence_Of_Statements, Dcheck_Bad_Nkind (N)); Set_List4_With_Parent (N, Val); end Set_Exception_Handlers; procedure Set_Explicit_Generic_Actual_Parameter (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Generic_Association, Dcheck_Bad_Nkind (N)); Set_Node2_With_Parent (N, Val); end Set_Explicit_Generic_Actual_Parameter; procedure Set_Expression (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Allocator or else NT (N).Nkind = N_Assignment_Statement or else NT (N).Nkind = N_At_Clause or else NT (N).Nkind = N_Attribute_Definition_Clause or else NT (N).Nkind = N_Attribute_Reference or else NT (N).Nkind = N_Case_Statement or else NT (N).Nkind = N_Code_Statement or else NT (N).Nkind = N_Component_Association or else NT (N).Nkind = N_Component_Declaration or else NT (N).Nkind = N_Delay_Relative_Statement or else NT (N).Nkind = N_Delay_Until_Statement or else NT (N).Nkind = N_Discriminant_Association or else NT (N).Nkind = N_Discriminant_Specification or else NT (N).Nkind = N_Expression_Actions or else NT (N).Nkind = N_Extension_Aggregate or else NT (N).Nkind = N_Formal_Object_Declaration or else NT (N).Nkind = N_Mod_Clause or else NT (N).Nkind = N_Modular_Type_Definition or else NT (N).Nkind = N_Number_Declaration or else NT (N).Nkind = N_Object_Declaration or else NT (N).Nkind = N_Parameter_Specification or else NT (N).Nkind = N_Parenthesized_Expression or else NT (N).Nkind = N_Pragma_Argument_Association or else NT (N).Nkind = N_Qualified_Expression or else NT (N).Nkind = N_Reference or else NT (N).Nkind = N_Return_Statement or else NT (N).Nkind = N_Type_Conversion, Dcheck_Bad_Nkind (N)); Set_Node3_With_Parent (N, Val); end Set_Expression; procedure Set_Expressions (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Aggregate or else NT (N).Nkind = N_Concat_Multiple or else NT (N).Nkind = N_Indexed_Component, Dcheck_Bad_Nkind (N)); Set_List3_With_Parent (N, Val); end Set_Expressions; procedure Set_First_Bit (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Component_Clause, Dcheck_Bad_Nkind (N)); Set_Node3_With_Parent (N, Val); end Set_First_Bit; procedure Set_First_Name (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_With_Clause, Dcheck_Bad_Nkind (N)); Set_Flag5 (N, Val); end Set_First_Name; procedure Set_First_Named_Actual (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Function_Call or else NT (N).Nkind = N_Procedure_Call_Statement, Dcheck_Bad_Nkind (N)); Set_Node4 (N, Val); -- Note: semantic node, parent pointer not set end Set_First_Named_Actual; procedure Set_Following_Pragmas (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Compilation_Unit, Dcheck_Bad_Nkind (N)); Set_List3_With_Parent (N, Val); end Set_Following_Pragmas; procedure Set_Formal_Type_Definition (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Formal_Type_Declaration, Dcheck_Bad_Nkind (N)); Set_Node3_With_Parent (N, Val); end Set_Formal_Type_Definition; procedure Set_Generic_Associations (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Formal_Package_Declaration or else NT (N).Nkind = N_Function_Instantiation or else NT (N).Nkind = N_Package_Instantiation or else NT (N).Nkind = N_Procedure_Instantiation, Dcheck_Bad_Nkind (N)); Set_List3_With_Parent (N, Val); end Set_Generic_Associations; procedure Set_Generic_Formal_Declarations (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Generic_Package_Declaration or else NT (N).Nkind = N_Generic_Subprogram_Declaration, Dcheck_Bad_Nkind (N)); Set_List3_With_Parent (N, Val); end Set_Generic_Formal_Declarations; procedure Set_Generic_Parent (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Formal_Package_Declaration or else NT (N).Nkind = N_Function_Specification or else NT (N).Nkind = N_Package_Specification or else NT (N).Nkind = N_Procedure_Specification, Dcheck_Bad_Nkind (N)); Set_Node5 (N, Val); end Set_Generic_Parent; procedure Set_Handled_Statement_Sequence (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Accept_Statement or else NT (N).Nkind = N_Block_Statement or else NT (N).Nkind = N_Entry_Body or else NT (N).Nkind = N_Package_Body or else NT (N).Nkind = N_Subprogram_Body or else NT (N).Nkind = N_Task_Body, Dcheck_Bad_Nkind (N)); Set_Node4_With_Parent (N, Val); end Set_Handled_Statement_Sequence; procedure Set_Has_Created_Identifier (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Block_Statement or else NT (N).Nkind = N_Loop_Statement, Dcheck_Bad_Nkind (N)); Set_Flag1 (N, Val); end Set_Has_Created_Identifier; procedure Set_Has_No_Side_Effects (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind in N_Subexpr, Dcheck_Bad_Nkind (N)); Set_Flag8 (N, Val); end Set_Has_No_Side_Effects; procedure Set_Has_Priority_Pragma (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Protected_Definition or else NT (N).Nkind = N_Subprogram_Body or else NT (N).Nkind = N_Task_Definition, Dcheck_Bad_Nkind (N)); Set_Flag6 (N, Val); end Set_Has_Priority_Pragma; procedure Set_Has_Task_Stack_Size_Pragma (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Task_Definition, Dcheck_Bad_Nkind (N)); Set_Flag5 (N, Val); end Set_Has_Task_Stack_Size_Pragma; procedure Set_Has_Unknown_Discriminants (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Formal_Type_Declaration or else NT (N).Nkind = N_Incomplete_Type_Declaration or else NT (N).Nkind = N_Private_Extension_Declaration or else NT (N).Nkind = N_Private_Type_Declaration, Dcheck_Bad_Nkind (N)); Set_Flag3 (N, Val); end Set_Has_Unknown_Discriminants; procedure Set_High_Bound (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Range or else NT (N).Nkind = N_Real_Range_Specification or else NT (N).Nkind = N_Signed_Integer_Type_Definition, Dcheck_Bad_Nkind (N)); Set_Node2_With_Parent (N, Val); end Set_High_Bound; procedure Set_Identifier (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_At_Clause or else NT (N).Nkind = N_Attribute_Definition_Clause or else NT (N).Nkind = N_Attribute_Reference or else NT (N).Nkind = N_Block_Statement or else NT (N).Nkind = N_Designator or else NT (N).Nkind = N_Enumeration_Representation_Clause or else NT (N).Nkind = N_Handled_Sequence_Of_Statements or else NT (N).Nkind = N_Label or else NT (N).Nkind = N_Loop_Statement or else NT (N).Nkind = N_Pragma or else NT (N).Nkind = N_Pragma_Argument_Association or else NT (N).Nkind = N_Record_Representation_Clause, Dcheck_Bad_Nkind (N)); Set_Node1_With_Parent (N, Val); end Set_Identifier; procedure Set_Implicit_Types (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Record_Definition, Dcheck_Bad_Nkind (N)); Set_List2_With_Parent (N, Val); end Set_Implicit_Types; procedure Set_Implicit_With (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_With_Clause, Dcheck_Bad_Nkind (N)); Set_Flag2 (N, Val); end Set_Implicit_With; procedure Set_In_Present (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Formal_Object_Declaration or else NT (N).Nkind = N_Parameter_Specification, Dcheck_Bad_Nkind (N)); Set_Flag1 (N, Val); end Set_In_Present; procedure Set_Intval (N : Node_Id; Val : Uint) is begin pragma Assert (False or else NT (N).Nkind = N_Integer_Literal, Dcheck_Bad_Nkind (N)); Set_Uint3 (N, Val); end Set_Intval; procedure Set_Is_Evaluated (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind in N_Subexpr, Dcheck_Bad_Nkind (N)); Set_Flag7 (N, Val); end Set_Is_Evaluated; procedure Set_Is_Overloaded (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind in N_Subexpr, Dcheck_Bad_Nkind (N)); Set_Flag5 (N, Val); end Set_Is_Overloaded; procedure Set_Is_Static (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind in N_Subexpr, Dcheck_Bad_Nkind (N)); Set_Flag6 (N, Val); end Set_Is_Static; procedure Set_Is_Task_Master (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Block_Statement or else NT (N).Nkind = N_Subprogram_Body or else NT (N).Nkind = N_Task_Body, Dcheck_Bad_Nkind (N)); Set_Flag5 (N, Val); end Set_Is_Task_Master; procedure Set_Iteration_Scheme (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Loop_Statement, Dcheck_Bad_Nkind (N)); Set_Node2_With_Parent (N, Val); end Set_Iteration_Scheme; procedure Set_Label (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Implicit_Label_Declaration, Dcheck_Bad_Nkind (N)); Set_Node2 (N, Val); end Set_Label; procedure Set_Last_Bit (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Component_Clause, Dcheck_Bad_Nkind (N)); Set_Node4_With_Parent (N, Val); end Set_Last_Bit; procedure Set_Last_Name (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_With_Clause, Dcheck_Bad_Nkind (N)); Set_Flag6 (N, Val); end Set_Last_Name; procedure Set_Library_Unit (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Compilation_Unit or else NT (N).Nkind = N_Package_Body_Stub or else NT (N).Nkind = N_Protected_Body_Stub or else NT (N).Nkind = N_Subprogram_Body_Stub or else NT (N).Nkind = N_Task_Body_Stub or else NT (N).Nkind = N_With_Clause, Dcheck_Bad_Nkind (N)); Set_Node4 (N, Val); -- No parent, this is a library field end Set_Library_Unit; procedure Set_Left_Opnd (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind in N_Binary_Op, Dcheck_Bad_Nkind (N)); Set_Node2_With_Parent (N, Val); end Set_Left_Opnd; procedure Set_Literals (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Enumeration_Type_Definition, Dcheck_Bad_Nkind (N)); Set_List1_With_Parent (N, Val); end Set_Literals; procedure Set_Limited_Present (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Formal_Private_Type_Definition or else NT (N).Nkind = N_Private_Type_Declaration or else NT (N).Nkind = N_Record_Definition, Dcheck_Bad_Nkind (N)); Set_Flag2 (N, Val); end Set_Limited_Present; procedure Set_Loop_Parameter_Specification (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Iteration_Scheme, Dcheck_Bad_Nkind (N)); Set_Node2_With_Parent (N, Val); end Set_Loop_Parameter_Specification; procedure Set_Low_Bound (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Range or else NT (N).Nkind = N_Real_Range_Specification or else NT (N).Nkind = N_Signed_Integer_Type_Definition, Dcheck_Bad_Nkind (N)); Set_Node1_With_Parent (N, Val); end Set_Low_Bound; procedure Set_Mod_Clause (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Record_Representation_Clause, Dcheck_Bad_Nkind (N)); Set_Node2_With_Parent (N, Val); end Set_Mod_Clause; procedure Set_More_Ids (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Component_Declaration or else NT (N).Nkind = N_Discriminant_Specification or else NT (N).Nkind = N_Exception_Declaration or else NT (N).Nkind = N_Formal_Object_Declaration or else NT (N).Nkind = N_Number_Declaration or else NT (N).Nkind = N_Object_Declaration or else NT (N).Nkind = N_Parameter_Specification, Dcheck_Bad_Nkind (N)); Set_Flag5 (N, Val); end Set_More_Ids; procedure Set_Name (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Assignment_Statement or else NT (N).Nkind = N_Attribute_Definition_Clause or else NT (N).Nkind = N_Defining_Program_Unit_Name or else NT (N).Nkind = N_Designator or else NT (N).Nkind = N_Entry_Call_Statement or else NT (N).Nkind = N_Exception_Renaming_Declaration or else NT (N).Nkind = N_Exit_Statement or else NT (N).Nkind = N_Formal_Package_Declaration or else NT (N).Nkind = N_Function_Call or else NT (N).Nkind = N_Function_Instantiation or else NT (N).Nkind = N_Generic_Function_Renaming_Declaration or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration or else NT (N).Nkind = N_Goto_Statement or else NT (N).Nkind = N_Object_Renaming_Declaration or else NT (N).Nkind = N_Package_Instantiation or else NT (N).Nkind = N_Package_Renaming_Declaration or else NT (N).Nkind = N_Procedure_Call_Statement or else NT (N).Nkind = N_Procedure_Instantiation or else NT (N).Nkind = N_Raise_Statement or else NT (N).Nkind = N_Requeue_Statement or else NT (N).Nkind = N_Subprogram_Renaming_Declaration or else NT (N).Nkind = N_Subunit or else NT (N).Nkind = N_Variant_Part or else NT (N).Nkind = N_With_Clause, Dcheck_Bad_Nkind (N)); Set_Node2_With_Parent (N, Val); end Set_Name; procedure Set_Names (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Abort_Statement or else NT (N).Nkind = N_Use_Package_Clause, Dcheck_Bad_Nkind (N)); Set_List2_With_Parent (N, Val); end Set_Names; procedure Set_Next_Named_Actual (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Parameter_Association, Dcheck_Bad_Nkind (N)); Set_Node4 (N, Val); -- Note: semantic node, no parent pointer needed end Set_Next_Named_Actual; procedure Set_Null_Present (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Component_List or else NT (N).Nkind = N_Record_Definition, Dcheck_Bad_Nkind (N)); Set_Flag3 (N, Val); end Set_Null_Present; procedure Set_Null_Record_Present (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Aggregate or else NT (N).Nkind = N_Extension_Aggregate, Dcheck_Bad_Nkind (N)); Set_Flag2 (N, Val); end Set_Null_Record_Present; procedure Set_Numerator (N : Node_Id; Val : Uint) is begin pragma Assert (False or else NT (N).Nkind = N_Real_Literal, Dcheck_Bad_Nkind (N)); Set_Uint3 (N, Val); end Set_Numerator; procedure Set_Object_Definition (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Object_Declaration, Dcheck_Bad_Nkind (N)); Set_Node2_With_Parent (N, Val); end Set_Object_Definition; procedure Set_Others_Discrete_Choices (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Others_Choice, Dcheck_Bad_Nkind (N)); Set_List1_With_Parent (N, Val); end Set_Others_Discrete_Choices; procedure Set_Out_Present (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Formal_Object_Declaration or else NT (N).Nkind = N_Parameter_Specification, Dcheck_Bad_Nkind (N)); Set_Flag2 (N, Val); end Set_Out_Present; procedure Set_Parameter_Associations (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Entry_Call_Statement or else NT (N).Nkind = N_Function_Call or else NT (N).Nkind = N_Procedure_Call_Statement, Dcheck_Bad_Nkind (N)); Set_List3_With_Parent (N, Val); end Set_Parameter_Associations; procedure Set_Parameter_Specifications (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Accept_Statement or else NT (N).Nkind = N_Access_Function_Definition or else NT (N).Nkind = N_Access_Procedure_Definition or else NT (N).Nkind = N_Entry_Body_Formal_Part or else NT (N).Nkind = N_Entry_Declaration or else NT (N).Nkind = N_Function_Specification or else NT (N).Nkind = N_Procedure_Specification, Dcheck_Bad_Nkind (N)); Set_List2_With_Parent (N, Val); end Set_Parameter_Specifications; procedure Set_Parameter_Type (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Parameter_Specification, Dcheck_Bad_Nkind (N)); Set_Node2_With_Parent (N, Val); end Set_Parameter_Type; procedure Set_Parens (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind in N_Subexpr, Dcheck_Bad_Nkind (N)); Set_Flag1 (N, Val); end Set_Parens; procedure Set_Parent_Spec (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Function_Instantiation or else NT (N).Nkind = N_Generic_Function_Renaming_Declaration or else NT (N).Nkind = N_Generic_Package_Declaration or else NT (N).Nkind = N_Generic_Package_Renaming_Declaration or else NT (N).Nkind = N_Generic_Procedure_Renaming_Declaration or else NT (N).Nkind = N_Generic_Subprogram_Declaration or else NT (N).Nkind = N_Package_Declaration or else NT (N).Nkind = N_Package_Instantiation or else NT (N).Nkind = N_Package_Renaming_Declaration or else NT (N).Nkind = N_Procedure_Instantiation or else NT (N).Nkind = N_Subprogram_Declaration or else NT (N).Nkind = N_Subprogram_Renaming_Declaration, Dcheck_Bad_Nkind (N)); Set_Node4 (N, Val); -- semantic node, no parent pointer end Set_Parent_Spec; procedure Set_Position (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Component_Clause, Dcheck_Bad_Nkind (N)); Set_Node2 (N, Val); -- semantic node, no parent pointer end Set_Position; procedure Set_Pragma_Argument_Associations (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Pragma, Dcheck_Bad_Nkind (N)); Set_List2_With_Parent (N, Val); end Set_Pragma_Argument_Associations; procedure Set_Preelaborable (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Compilation_Unit, Dcheck_Bad_Nkind (N)); Set_Flag2 (N, Val); end Set_Preelaborable; procedure Set_Prefix (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Attribute_Reference or else NT (N).Nkind = N_Expanded_Name or else NT (N).Nkind = N_Explicit_Dereference or else NT (N).Nkind = N_Indexed_Component or else NT (N).Nkind = N_Selected_Component or else NT (N).Nkind = N_Slice, Dcheck_Bad_Nkind (N)); Set_Node2_With_Parent (N, Val); end Set_Prefix; procedure Set_Prev_Ids (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Component_Declaration or else NT (N).Nkind = N_Discriminant_Specification or else NT (N).Nkind = N_Exception_Declaration or else NT (N).Nkind = N_Formal_Object_Declaration or else NT (N).Nkind = N_Number_Declaration or else NT (N).Nkind = N_Object_Declaration or else NT (N).Nkind = N_Parameter_Specification, Dcheck_Bad_Nkind (N)); Set_Flag6 (N, Val); end Set_Prev_Ids; procedure Set_Private_Declarations (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Package_Specification or else NT (N).Nkind = N_Protected_Definition or else NT (N).Nkind = N_Task_Definition, Dcheck_Bad_Nkind (N)); Set_List4_With_Parent (N, Val); end Set_Private_Declarations; procedure Set_Private_Present (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Compilation_Unit or else NT (N).Nkind = N_Formal_Derived_Type_Definition, Dcheck_Bad_Nkind (N)); Set_Flag1 (N, Val); end Set_Private_Present; procedure Set_Proper_Body (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Subunit, Dcheck_Bad_Nkind (N)); Set_Node1_With_Parent (N, Val); end Set_Proper_Body; procedure Set_Protected_Definition (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Protected_Type_Declaration or else NT (N).Nkind = N_Single_Protected_Declaration, Dcheck_Bad_Nkind (N)); Set_Node3_With_Parent (N, Val); end Set_Protected_Definition; procedure Set_Protected_Present (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Access_Function_Definition or else NT (N).Nkind = N_Access_Procedure_Definition, Dcheck_Bad_Nkind (N)); Set_Flag1 (N, Val); end Set_Protected_Present; procedure Set_Range_Constraint (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Delta_Constraint or else NT (N).Nkind = N_Digits_Constraint, Dcheck_Bad_Nkind (N)); Set_Node4_With_Parent (N, Val); end Set_Range_Constraint; procedure Set_Range_Expression (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Range_Constraint, Dcheck_Bad_Nkind (N)); Set_Node4_With_Parent (N, Val); end Set_Range_Expression; procedure Set_Real_Range_Specification (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Decimal_Fixed_Point_Definition or else NT (N).Nkind = N_Floating_Point_Definition or else NT (N).Nkind = N_Ordinary_Fixed_Point_Definition, Dcheck_Bad_Nkind (N)); Set_Node4_With_Parent (N, Val); end Set_Real_Range_Specification; procedure Set_Record_Extension_Part (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Derived_Type_Definition, Dcheck_Bad_Nkind (N)); Set_Node3_With_Parent (N, Val); end Set_Record_Extension_Part; procedure Set_Redundant_Use (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Expanded_Name or else NT (N).Nkind = N_Identifier, Dcheck_Bad_Nkind (N)); Set_Flag2 (N, Val); end Set_Redundant_Use; procedure Set_Reverse_Present (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Loop_Parameter_Specification, Dcheck_Bad_Nkind (N)); Set_Flag1 (N, Val); end Set_Reverse_Present; procedure Set_Right_Opnd (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind in N_Op, Dcheck_Bad_Nkind (N)); Set_Node3_With_Parent (N, Val); end Set_Right_Opnd; procedure Set_Selective_Accept_Alternatives (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Selective_Accept, Dcheck_Bad_Nkind (N)); Set_List1_With_Parent (N, Val); end Set_Selective_Accept_Alternatives; procedure Set_Selector_Name (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Expanded_Name or else NT (N).Nkind = N_Generic_Association or else NT (N).Nkind = N_Parameter_Association or else NT (N).Nkind = N_Selected_Component, Dcheck_Bad_Nkind (N)); Set_Node3_With_Parent (N, Val); end Set_Selector_Name; procedure Set_Selector_Names (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Discriminant_Association, Dcheck_Bad_Nkind (N)); Set_List1_With_Parent (N, Val); end Set_Selector_Names; procedure Set_Specification (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Abstract_Subprogram_Declaration or else NT (N).Nkind = N_Formal_Subprogram_Declaration or else NT (N).Nkind = N_Generic_Package_Declaration or else NT (N).Nkind = N_Generic_Subprogram_Declaration or else NT (N).Nkind = N_Package_Declaration or else NT (N).Nkind = N_Subprogram_Body or else NT (N).Nkind = N_Subprogram_Body_Stub or else NT (N).Nkind = N_Subprogram_Declaration or else NT (N).Nkind = N_Subprogram_Renaming_Declaration, Dcheck_Bad_Nkind (N)); Set_Node1_With_Parent (N, Val); end Set_Specification; procedure Set_Statements (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Abortable_Part or else NT (N).Nkind = N_Accept_Alternative or else NT (N).Nkind = N_Case_Statement_Alternative or else NT (N).Nkind = N_Delay_Alternative or else NT (N).Nkind = N_Entry_Call_Alternative or else NT (N).Nkind = N_Exception_Handler or else NT (N).Nkind = N_Handled_Sequence_Of_Statements or else NT (N).Nkind = N_Loop_Statement or else NT (N).Nkind = N_Triggering_Alternative, Dcheck_Bad_Nkind (N)); Set_List3_With_Parent (N, Val); end Set_Statements; procedure Set_Strval (N : Node_Id; Val : String_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Operator_Symbol or else NT (N).Nkind = N_String_Literal, Dcheck_Bad_Nkind (N)); Set_Str3 (N, Val); end Set_Strval; procedure Set_Subtype_Indication (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Access_To_Object_Definition or else NT (N).Nkind = N_Component_Declaration or else NT (N).Nkind = N_Constrained_Array_Definition or else NT (N).Nkind = N_Derived_Type_Definition or else NT (N).Nkind = N_Private_Extension_Declaration or else NT (N).Nkind = N_Subtype_Declaration or else NT (N).Nkind = N_Unconstrained_Array_Definition, Dcheck_Bad_Nkind (N)); Set_Node4_With_Parent (N, Val); end Set_Subtype_Indication; procedure Set_Subtype_Mark (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Access_Definition or else NT (N).Nkind = N_Access_Function_Definition or else NT (N).Nkind = N_Formal_Derived_Type_Definition or else NT (N).Nkind = N_Formal_Object_Declaration or else NT (N).Nkind = N_Function_Specification or else NT (N).Nkind = N_Object_Renaming_Declaration or else NT (N).Nkind = N_Qualified_Expression or else NT (N).Nkind = N_Subtype_Indication or else NT (N).Nkind = N_Type_Conversion, Dcheck_Bad_Nkind (N)); Set_Node4_With_Parent (N, Val); end Set_Subtype_Mark; procedure Set_Subtype_Marks (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Unconstrained_Array_Definition or else NT (N).Nkind = N_Use_Type_Clause, Dcheck_Bad_Nkind (N)); Set_List2_With_Parent (N, Val); end Set_Subtype_Marks; procedure Set_Tagged_Present (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Formal_Private_Type_Definition or else NT (N).Nkind = N_Private_Type_Declaration or else NT (N).Nkind = N_Record_Definition, Dcheck_Bad_Nkind (N)); Set_Flag1 (N, Val); end Set_Tagged_Present; procedure Set_Task_Definition (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Single_Task_Declaration or else NT (N).Nkind = N_Task_Type_Declaration, Dcheck_Bad_Nkind (N)); Set_Node3_With_Parent (N, Val); end Set_Task_Definition; procedure Set_Then_Statements (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Elsif_Part or else NT (N).Nkind = N_If_Statement, Dcheck_Bad_Nkind (N)); Set_List2_With_Parent (N, Val); end Set_Then_Statements; procedure Set_Triggering_Alternative (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Asynchronous_Select, Dcheck_Bad_Nkind (N)); Set_Node1_With_Parent (N, Val); end Set_Triggering_Alternative; procedure Set_Triggering_Statement (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Triggering_Alternative, Dcheck_Bad_Nkind (N)); Set_Node1_With_Parent (N, Val); end Set_Triggering_Statement; procedure Set_Type_Definition (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Full_Type_Declaration, Dcheck_Bad_Nkind (N)); Set_Node3_With_Parent (N, Val); end Set_Type_Definition; procedure Set_Unchecked_Conversion (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Type_Conversion, Dcheck_Bad_Nkind (N)); Set_Flag11 (N, Val); end Set_Unchecked_Conversion; procedure Set_Unit (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Compilation_Unit, Dcheck_Bad_Nkind (N)); Set_Node2_With_Parent (N, Val); end Set_Unit; procedure Set_Variant_Part (N : Node_Id; Val : Node_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Component_List, Dcheck_Bad_Nkind (N)); Set_Node4_With_Parent (N, Val); end Set_Variant_Part; procedure Set_Variants (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Variant_Part, Dcheck_Bad_Nkind (N)); Set_List1_With_Parent (N, Val); end Set_Variants; procedure Set_Visible_Declarations (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Package_Specification or else NT (N).Nkind = N_Protected_Definition or else NT (N).Nkind = N_Task_Definition, Dcheck_Bad_Nkind (N)); Set_List2_With_Parent (N, Val); end Set_Visible_Declarations; end Sinfo; anded_Name or else NT (N).Nkind = N_Identifier, Dcheck_Bad_Nkind (N)); Set_Flag2 (N, Val); end Set_Redundant_Use; procedure Set_Reverse_Present (N : Node_Id; Val : Boolean) is begin pragma Assert (False or else NT (N).Nkind = N_Loop_Parameter_Specification, Dcheck_Bad_Nkind (N)); Set_Flag1 (N, Val); end Set_Reverse_Present; procedure Set_Right_Opnd (N : Node_Id; Val : Nognat-1.67-src/src/sinfo-change.ads 444 10015 7640 7571 5506244426 12164 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S I N F O . C H A N G E -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This child package of Sinfo contains some routines that permit in place -- alteration of existing tree nodes by changing the value in the Nkind -- field. Since Nkind functions logically in a manner similart to a variant -- record discriminant part, such alterations cannot be permitted in a -- general manner, but in some specific cases, the fields of related nodes -- have been deliberately layed out in a manner that permits such alteration. -- that determin package Sinfo.Change is procedure Change_Identifier_To_Defining_Identifier (N : in out Node_Id); -- N must refer to a node of type N_Identifier. This node is modified to -- be of type N_Defining_Identifier. The scanner always returns identifiers -- as N_Identifier. The parser then uses this routine to change the node -- to be a defining identifier where the context demands it. This routine -- also allocates the necessary extension node. Note that this procedure -- may (but is not required to) change the Id of the node in question. procedure Change_Character_Literal_To_Defining_Character_Literal (N : in out Node_Id); -- Similar processing for a character literal procedure Change_Operator_Symbol_To_Defining_Operator_Symbol (N : in out Node_Id); -- Similar processing for an operator symbol procedure Change_Operator_Symbol_To_String_Literal (N : Node_Id); -- The scanner returns any string that looks like an operator symbol as -- a N_Operator_Symbol node. The parser then uses this procedure to change -- the node to a normal N_String_Literal node if the context is not one -- in which an operator symbol is required. There are some cases where the -- parser cannot tell, in which case this transformation happens later on. procedure Change_Selected_Component_To_Expanded_Name (N : Node_Id); -- The parser always generates Selected_Component nodes. The semantics -- modifies these to Expanded_Name nodes where appropriate. Note that -- on return the Chars field is set to a copy of the contents of the -- Chars field of the Selector_Name field. end Sinfo.Change; xisting tree nodes by changing the value in the Nkind -- field. Since Nkind functions logically in a manner similart to a variant -- gnat-1.67-src/src/sinfo-change.adb 444 10015 7640 11114 5506244426 12147 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S I N F O . C H A N G E -- -- -- -- B o d y -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This child package of Sinfo contains some routines that permit in place -- alteration of existing tree nodes by changing the value in the Nkind -- field. Since Nkind functions logically in a manner similart to a variant -- record discriminant part, such alterations cannot be permitted in a -- general manner, but in some specific cases, the fields of related nodes -- have been deliberately layed out in a manner that permits such alteration. -- that determin with Atree; use Atree; package body Sinfo.Change is use Atree.Unchecked_Access; -- This package is one of the few packages which is allowed to make direct -- references to tree nodes (since it is in the business of providing a -- higher level of tree access which other clients are expected to use and -- which implements checks). ---------------------------------------------- -- Change_Identifier_To_Defining_Identifier -- ---------------------------------------------- procedure Change_Identifier_To_Defining_Identifier (N : in out Node_Id) is begin Set_Nkind (N, N_Defining_Identifier); N := Extend_Node (N); end Change_Identifier_To_Defining_Identifier; ------------------------------------------------------------ -- Change_Character_Literal_To_Defining_Character_Literal -- ------------------------------------------------------------ procedure Change_Character_Literal_To_Defining_Character_Literal (N : in out Node_Id) is begin Set_Nkind (N, N_Defining_Character_Literal); N := Extend_Node (N); end Change_Character_Literal_To_Defining_Character_Literal; -------------------------------------------------------- -- Change_Operator_Symbol_To_Defining_Operator_Symbol -- -------------------------------------------------------- procedure Change_Operator_Symbol_To_Defining_Operator_Symbol (N : in out Node_Id) is begin Set_Nkind (N, N_Defining_Operator_Symbol); Set_Node2 (N, Empty); -- Clear unused Str2 field N := Extend_Node (N); end Change_Operator_Symbol_To_Defining_Operator_Symbol; ---------------------------------------------- -- Change_Operator_Symbol_To_String_Literal -- ---------------------------------------------- procedure Change_Operator_Symbol_To_String_Literal (N : Node_Id) is begin Set_Nkind (N, N_String_Literal); Set_Node1 (N, Empty); -- clear Name1 field end Change_Operator_Symbol_To_String_Literal; ------------------------------------------------ -- Change_Selected_Component_To_Expanded_Name -- ------------------------------------------------ procedure Change_Selected_Component_To_Expanded_Name (N : Node_Id) is begin Set_Nkind (N, N_Expanded_Name); Set_Chars (N, Chars (Selector_Name (N))); end Change_Selected_Component_To_Expanded_Name; end Sinfo.Change; ant_Part, Dcheck_Bad_Nkind (N)); Set_List1_With_Parent (N, Val); end Set_Variants; procedure Set_Visible_Declarations (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Package_Specification or else NT (N).Nkind = N_Protected_Definition or else NT (N).Nkind = N_Task_Definition, Dcheck_Bad_Nkind (N)); Set_List2_With_Parentgnat-1.67-src/src/sinput.ads 444 10015 7640 10672 5506244427 11162 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S I N P U T -- -- -- -- S p e c -- -- -- -- $Revision: 1.13 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Sinput is -- This package contains the input routines used for reading the -- input source file. The actual I/O routines are in OS_Interface, -- with this module containing only the system independent processing. -- General Note: throughout the compiler, we use the term line or source -- line to refer to a physical line in the source, terminated by the end of -- line sequence (either LF or CR/LF depending on the system), as opposed -- to the Ada notion of logical line (which can be terminated by other -- format effectors (form feed and vertical tab). procedure Backup_Line (P : in out Source_Ptr); -- Back up the argument pointer to the start of the previous line. On -- entry, P points to the start of a physical line in the source buffer. -- On return, P is updated to point to the start of the previous line. -- The caller has checked that a Line_Terminator character precedes P so -- that there definitely is a previous line in the source buffer. function Line_Start (P : Source_Ptr) return Source_Ptr; -- Finds the source position of the start of the line containing the -- given source location. function Get_Col_Number (P : Source_Ptr) return Column_Number_Type; -- The ones-origin column number of the specified Source_Ptr value is -- determined and returned. Tab characters if present are assumed to -- represent the standard 1,9,17.. spacing pattern. function Get_Line_Number (P : Source_Ptr) return Line_Number_Type; -- The line number of the specified source position is obtained by -- doing a binary search on the source positions in the lines table -- for the unit containing the given source position. function Get_Source_Buffer_Ptr (P : Source_Ptr) return Source_Buffer_Ptr; -- Returns the pointer to the source buffer containing the given source -- location. Fatal error if given value not within a valid source file. procedure Next_Line; -- Next_Line is called when the end of the current line is met. On entry -- Scan_Ptr points just past the sequence of format effectors terminating -- the previous line (i.e. to the start of the next line). On exit, the -- value in Scan_Ptr is unchanged. The purpose of this call is to make a -- possible entry in the Lines table. procedure Write_Location (P : Source_Ptr); -- Writes out a string of the form "fff", line nn(cc), where fff, nn, cc -- are the file name, line number and column corresponding to the given -- source location. No_Location and Standard_Location appear as the -- strings and . The text is preceded -- by two blanks. end Sinput; Nkind (N, N_Expanded_Name); Set_Chars (N, Chars (Selector_Name (gnat-1.67-src/src/sinput.adb 444 10015 7640 17223 5506244427 11140 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S I N P U T -- -- -- -- B o d y -- -- -- -- $Revision: 1.24 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Alloc; use Alloc; with Lib; use Lib; with Namet; use Namet; with Output; use Output; with Scans; use Scans; package body Sinput is ----------------- -- Backup_Line -- ----------------- procedure Backup_Line (P : in out Source_Ptr) is Src : constant Source_Buffer_Ptr := Get_Source_Buffer_Ptr (P); begin P := P - 1; if P = Src'First then return; end if; if Src (P) = CR then if Src (P - 1) = LF then P := P - 1; end if; else -- Src (P) = LF if Src (P - 1) = CR then P := P - 1; end if; end if; -- Now find first character of the previous line while P > Src'First and then Src (P - 1) /= LF and then Src (P - 1) /= CR loop P := P - 1; end loop; end Backup_Line; ---------------- -- Line_Start -- ---------------- function Line_Start (P : Source_Ptr) return Source_Ptr is S : Source_Ptr := P; Src : constant Source_Buffer_Ptr := Get_Source_Buffer_Ptr (P); begin while S > Src'First and then Src (S - 1) /= CR and then Src (S - 1) /= LF loop S := S - 1; end loop; return S; end Line_Start; -------------------- -- Get_Col_Number -- -------------------- function Get_Col_Number (P : Source_Ptr) return Column_Number_Type is S : Source_Ptr; C : Column_Number_Type; Src : constant Source_Buffer_Ptr := Get_Source_Buffer_Ptr (P); begin S := Line_Start (P); C := 1; while S < P loop if Src (S) = HT then C := (C - 1) / 8 * 8 + (8 + 1); else C := C + 1; end if; S := S + 1; end loop; return C; end Get_Col_Number; --------------------- -- Get_Line_Number -- --------------------- function Get_Line_Number (P : Source_Ptr) return Line_Number_Type is Sunit : Unit_Number_Type; Table : Lines_Table_Ptr; Lo : Line_Number_Type; Hi : Line_Number_Type; Mid : Line_Number_Type; begin -- If the input source pointer is not a meaningful value then return -- at once with line number 1. This can happen for a file not found -- condition for a file loaded indirectly by RTE, and also perhaps on -- some unknown internal error conditions. In either case we certainly -- don't want to blow up. if P < 1 then return 1; -- Otherwise we can do the binary search else Sunit := Get_Sloc_Unit_Number (P); Table := File.Table (Sunit).Lines_Table; Lo := 1; Hi := File.Table (Sunit).Last_Line; loop Mid := (Lo + Hi) / 2; if P < Table (Mid) then Hi := Mid - 1; else -- P >= Table (Mid) if Mid = Hi or else P < Table (Mid + 1) then return Mid; else Lo := Mid + 1; end if; end if; end loop; end if; end Get_Line_Number; --------------------------- -- Get_Source_Buffer_Ptr -- --------------------------- function Get_Source_Buffer_Ptr (P : Source_Ptr) return Source_Buffer_Ptr is Sunit : Unit_Number_Type := Get_Sloc_Unit_Number (P); Table : Lines_Table_Ptr := File.Table (Sunit).Lines_Table; begin if P not in Source_Cache'range then Source_Cache := File.Table (Get_Sloc_Unit_Number (P)).Source; end if; return Source_Cache; end Get_Source_Buffer_Ptr; --------------- -- Next_Line -- --------------- procedure Next_Line is Lines_Table : Lines_Table_Ptr := File.Table (Scan_Unit).Lines_Table; Last_Line : Line_Number_Type := File.Table (Scan_Unit).Last_Line; begin Current_Line_Start := Scan_Ptr; -- Make entry in lines table if not already made (in some scan backup -- cases, we will be rescanning previously scanned source, so the entry -- may have already been made on the previous forward scan). if Source (Scan_Ptr) /= EOF and then Scan_Ptr > Lines_Table (Last_Line) then -- Reallocate the lines table if it has got too large. Note that we -- don't use the normal Table package mechanism because we have -- several of these tables, one for each source file. if Last_Line = Lines_Table'Last then declare New_Lines_Table : Lines_Table_Ptr := new Lines_Table_Type (1 .. (Last_Line * (100 + Alloc_Lines_Increment) / 100)); begin New_Lines_Table (1 .. Lines_Table'Last) := Lines_Table (1 .. Lines_Table'Last); Free_Lines (Lines_Table); Lines_Table := New_Lines_Table; File.Table (Scan_Unit).Lines_Table := Lines_Table; end; end if; Last_Line := Last_Line + 1; Lines_Table (Last_Line) := Current_Line_Start; File.Table (Scan_Unit).Last_Line := Last_Line; end if; end Next_Line; -------------------- -- Write_Location -- -------------------- procedure Write_Location (P : Source_Ptr) is Scol : Int; begin if P = No_Location then Write_String (" "); elsif P = Standard_Location then Write_String (" "); else Write_String (" """); Write_Name (File.Table (Get_Sloc_Unit_Number (P)).File_Name); Write_String (""", line "); Scol := Column; Write_Int (Int (Get_Line_Number (P))); Write_Char ('('); Write_Int (Int (Get_Col_Number (P))); Write_Char (')'); while Column < Scol + 7 loop Write_Char (' '); end loop; end if; end Write_Location; end Sinput; , Val); end Set_Variants; procedure Set_Visible_Declarations (N : Node_Id; Val : List_Id) is begin pragma Assert (False or else NT (N).Nkind = N_Package_Specification or else NT (N).Nkind = N_Protected_Definition or else NT (N).Nkind = N_Task_Definition, Dcheck_Bad_Nkind (N)); Set_List2_With_Parentgnat-1.67-src/src/snames.ads 444 10015 7640 112123 5506244430 11132 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S N A M E S -- -- -- -- S p e c -- -- -- -- $Revision: 1.37 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Snames is -- This package contains definitions of standard names (i.e. entries in the -- Names table) that are used throughout the GNAT compiler). It also contains -- the definitions of some enumeration types whose definitions are tied to -- the order of these preset names. ------------------ -- Preset Names -- ------------------ -- The following are preset entries in the names table, which are -- entered at the start of every compilation for easy access. Note -- that the order of initialization of these names in the body must -- be coordinated with the order of names in this table. -- Note: a name may not appear more than once in the following list. -- If additional pragmas or attributes are introduced which might -- otherwise cause a duplicate, then list it only once in this table, -- and adjust the definition of the functions for testing for pragma -- names and attribute names, and returning their ID values. Of course -- everything is simpler if no such duplications occur! -- Note: the following table is read by the utility program XSNAMES and -- should not be changed without coordinating with this program. The -- entry given on the comment line is for use by XSNAMES, and represents -- a name to be enclosed in double quotes in the names table. Note that -- the list of constant values here is also updated by XSNAMES. N : constant Name_Id := First_Name_Id; -- Synonym used in standard name definitions -- First we have the one character names used to optimize the lookup -- process for one character identifiers (avoid the hashing in this case) Name_A : constant Name_Id := N + 000; Name_B : constant Name_Id := N + 001; Name_C : constant Name_Id := N + 002; Name_D : constant Name_Id := N + 003; Name_E : constant Name_Id := N + 004; Name_F : constant Name_Id := N + 005; Name_G : constant Name_Id := N + 006; Name_H : constant Name_Id := N + 007; Name_I : constant Name_Id := N + 008; Name_J : constant Name_Id := N + 009; Name_K : constant Name_Id := N + 010; Name_L : constant Name_Id := N + 011; Name_M : constant Name_Id := N + 012; Name_N : constant Name_Id := N + 013; Name_O : constant Name_Id := N + 014; Name_P : constant Name_Id := N + 015; Name_Q : constant Name_Id := N + 016; Name_R : constant Name_Id := N + 017; Name_S : constant Name_Id := N + 018; Name_T : constant Name_Id := N + 019; Name_U : constant Name_Id := N + 020; Name_V : constant Name_Id := N + 021; Name_W : constant Name_Id := N + 022; Name_X : constant Name_Id := N + 023; Name_Y : constant Name_Id := N + 024; Name_Z : constant Name_Id := N + 025; -- Some special names used by the expander. Note that the lower case u's -- at the start of these names get translated to extra underscores. These -- names are only referenced internally by expander generated code. Note -- that we put these early in the list so that in particular Name_uParent -- and Name_uSize will be at fixed Name_Id values which will not change -- with the addition of other entries to Snames. This makes things easier -- because Gigi references these particular entries. Name_uParent : constant Name_Id := N + 026; Name_uSize : constant Name_Id := N + 027; -- Remaining names are not referenced by Gigi Name_uChain : constant Name_Id := N + 028; Name_uEquality : constant Name_Id := N + 029; Name_uExpunge : constant Name_Id := N + 030; Name_uIdepth : constant Name_Id := N + 031; Name_uInit : constant Name_Id := N + 032; Name_uMaster : constant Name_Id := N + 033; Name_uPriority : constant Name_Id := N + 034; Name_uTask : constant Name_Id := N + 035; Name_uTB_Snam : constant Name_Id := N + 036; Name_uTrace_Sp : constant Name_Id := N + 037; Name_uTag : constant Name_Id := N + 038; Name_uTags : constant Name_Id := N + 039; Name_uTask_Id : constant Name_Id := N + 040; Name_Version_B : constant Name_Id := N + 041; Name_Version_S : constant Name_Id := N + 042; -- Some miscellaneous names used by the parser for error detection/recovery Name_Error : constant Name_Id := N + 043; Name_Go : constant Name_Id := N + 044; Name_To : constant Name_Id := N + 045; -- Names for packages that are treated specially by the compiler Name_System : constant Name_Id := N + 046; Name_Unchecked_Conversion : constant Name_Id := N + 047; -- Operator Symbol entries First_Operator_Name : constant Name_Id := N + 048; Name_Op_Abs : constant Name_Id := N + 048; -- "ABS" Name_Op_And : constant Name_Id := N + 049; -- "AND" Name_Op_Mod : constant Name_Id := N + 050; -- "MOD" Name_Op_Not : constant Name_Id := N + 051; -- "NOT" Name_Op_Or : constant Name_Id := N + 052; -- "OR" Name_Op_Rem : constant Name_Id := N + 053; -- "REM" Name_Op_Xor : constant Name_Id := N + 054; -- "XOR" Name_Op_Eq : constant Name_Id := N + 055; -- "=" Name_Op_Ne : constant Name_Id := N + 056; -- "/=" Name_Op_Lt : constant Name_Id := N + 057; -- "<" Name_Op_Le : constant Name_Id := N + 058; -- "<=" Name_Op_Gt : constant Name_Id := N + 059; -- ">" Name_Op_Ge : constant Name_Id := N + 060; -- ">=" Name_Op_Add : constant Name_Id := N + 061; -- "+" Name_Op_Subtract : constant Name_Id := N + 062; -- "-" Name_Op_Concat : constant Name_Id := N + 063; -- "&" Name_Op_Multiply : constant Name_Id := N + 064; -- "*" Name_Op_Divide : constant Name_Id := N + 065; -- "/" Name_Op_Expon : constant Name_Id := N + 066; -- "**" Last_Operator_Name : constant Name_Id := N + 066; -- Additional names for operations which we syntatically consider to be -- operators but are not operator symbols, but we still want the names in -- the name list for use in error messages. Name_Op_In : constant Name_Id := N + 067; -- "IN" Name_Op_Not_In : constant Name_Id := N + 068; -- "NOT IN" Name_Op_And_Then : constant Name_Id := N + 069; -- "AND THEN" Name_Op_Or_Else : constant Name_Id := N + 070; -- "OR ELSE" -- Names for all pragmas recognized by GNAT. The entries with the comment -- "Ada 83" are pragmas that are defined in Ada 83, but not in Ada 9X. -- These pragmas are fully implemented in both Ada 83 and Ada 9X modes -- in GNAT. The entries marked GNAT are pragmas that are defined by GNAT -- and implemented in both Ada 83 and Ada 9X modes. First_Pragma_Name : constant Name_Id := N + 071; Name_Abort_Defer : constant Name_Id := N + 071; -- GNAT Name_Ada_83 : constant Name_Id := N + 072; -- GNAT Name_Ada_9X : constant Name_Id := N + 073; -- GNAT Name_All_Calls_Remote : constant Name_Id := N + 074; Name_Assert : constant Name_Id := N + 075; -- GNAT Name_Asynchronous : constant Name_Id := N + 076; Name_Atomic : constant Name_Id := N + 077; Name_Atomic_Components : constant Name_Id := N + 078; Name_Attach_Handler : constant Name_Id := N + 079; Name_Controlled : constant Name_Id := N + 080; Name_Convention : constant Name_Id := N + 081; Name_Debug : constant Name_Id := N + 082; -- GNAT Name_Elaborate : constant Name_Id := N + 083; -- Ada 83 Name_Elaborate_All : constant Name_Id := N + 084; Name_Elaborate_Body : constant Name_Id := N + 085; Name_Export : constant Name_Id := N + 086; Name_Import : constant Name_Id := N + 087; Name_Improve : constant Name_Id := N + 088; -- GNAT Name_Inline : constant Name_Id := N + 089; Name_Inspection_Point : constant Name_Id := N + 090; Name_Interface : constant Name_Id := N + 091; -- Ada 83 Name_Interface_Name : constant Name_Id := N + 092; -- GNAT Name_Interrupt_Handler : constant Name_Id := N + 093; Name_Interrupt_Priority : constant Name_Id := N + 094; Name_List : constant Name_Id := N + 095; Name_Locking_Policy : constant Name_Id := N + 096; Name_Memory_Size : constant Name_Id := N + 097; -- Ada 83 Name_Normalize_Scalars : constant Name_Id := N + 098; Name_Optimize : constant Name_Id := N + 099; Name_Pack : constant Name_Id := N + 100; Name_Page : constant Name_Id := N + 101; Name_Preelaborate : constant Name_Id := N + 102; Name_Priority : constant Name_Id := N + 103; Name_Pure : constant Name_Id := N + 104; Name_Queuing_Policy : constant Name_Id := N + 105; Name_Remote_Call_Interface : constant Name_Id := N + 106; Name_Remote_Types : constant Name_Id := N + 107; Name_Restrictions : constant Name_Id := N + 108; Name_Reviewable : constant Name_Id := N + 109; Name_Shared : constant Name_Id := N + 110; -- Ada 83 Name_Shared_Passive : constant Name_Id := N + 111; Name_Storage_Unit : constant Name_Id := N + 112; -- Ada 83 Name_Suppress : constant Name_Id := N + 113; Name_System_Name : constant Name_Id := N + 114; -- Ada 83 Name_Task_Dispatching_Policy : constant Name_Id := N + 115; Name_Task_Stack_Size : constant Name_Id := N + 116; -- GNAT Name_Volatile : constant Name_Id := N + 117; Name_Volatile_Components : constant Name_Id := N + 118; Last_Pragma_Name : constant Name_Id := N + 118; -- Language convention names for pragma Convention/Export/Import/Interface -- Note that Name_C is not included in this list, since it was already -- declared earlier in the context of one-character identifier names -- (where the order is critical to the fast look up process). First_Convention_Name : constant Name_Id := N + 119; Name_Ada : constant Name_Id := N + 119; Name_Asm : constant Name_Id := N + 120; Name_Assembler : constant Name_Id := N + 121; Name_Intrinsic : constant Name_Id := N + 122; Last_Convention_Name : constant Name_Id := N + 122; -- Other special names used in processing pragma arguments Name_Entity : constant Name_Id := N + 123; Name_Gcc : constant Name_Id := N + 124; Name_Gnat : constant Name_Id := N + 125; Name_Link_Name : constant Name_Id := N + 126; Name_Off : constant Name_Id := N + 127; Name_On : constant Name_Id := N + 128; Name_Space : constant Name_Id := N + 129; Name_Time : constant Name_Id := N + 130; -- Names of recognized attributes. The entries with the comment "Ada 83" -- are attributes that are defined in Ada 83, but not in Ada 9X. These -- attributes are implemented in both Ada 83 and Ada 9X modes in GNAT. First_Attribute_Name : constant Name_Id := N + 131; Name_Access : constant Name_Id := N + 131; Name_Address : constant Name_Id := N + 132; Name_Adjacent : constant Name_Id := N + 133; Name_Aft : constant Name_Id := N + 134; Name_Alignment : constant Name_Id := N + 135; Name_Bit_Order : constant Name_Id := N + 136; Name_Body_Version : constant Name_Id := N + 137; Name_Callable : constant Name_Id := N + 138; Name_Caller : constant Name_Id := N + 139; Name_Ceiling : constant Name_Id := N + 140; Name_Component_Size : constant Name_Id := N + 141; Name_Compose : constant Name_Id := N + 142; Name_Constrained : constant Name_Id := N + 143; Name_Copy_Sign : constant Name_Id := N + 144; Name_Count : constant Name_Id := N + 145; Name_Delta : constant Name_Id := N + 146; Name_Denorm : constant Name_Id := N + 147; Name_Digits : constant Name_Id := N + 148; Name_Emax : constant Name_Id := N + 149; -- Ada 83 Name_Epsilon : constant Name_Id := N + 150; -- Ada 83 Name_Exponent : constant Name_Id := N + 151; Name_External_Tag : constant Name_Id := N + 152; Name_First : constant Name_Id := N + 153; Name_First_Bit : constant Name_Id := N + 154; Name_Floor : constant Name_Id := N + 155; Name_Fore : constant Name_Id := N + 156; Name_Fraction : constant Name_Id := N + 157; Name_Identity : constant Name_Id := N + 158; Name_Image : constant Name_Id := N + 159; Name_Input : constant Name_Id := N + 160; Name_Large : constant Name_Id := N + 161; -- Ada 83 Name_Last : constant Name_Id := N + 162; Name_Last_Bit : constant Name_Id := N + 163; Name_Leading_Part : constant Name_Id := N + 164; Name_Length : constant Name_Id := N + 165; Name_Machine : constant Name_Id := N + 166; Name_Machine_Emax : constant Name_Id := N + 167; Name_Machine_Emin : constant Name_Id := N + 168; Name_Machine_Mantissa : constant Name_Id := N + 169; Name_Machine_Overflows : constant Name_Id := N + 170; Name_Machine_Radix : constant Name_Id := N + 171; Name_Machine_Rounds : constant Name_Id := N + 172; Name_Mantissa : constant Name_Id := N + 173; -- Ada 83 Name_Max : constant Name_Id := N + 174; Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 175; Name_Min : constant Name_Id := N + 176; Name_Model : constant Name_Id := N + 177; Name_Model_Emax : constant Name_Id := N + 178; -- Ada 83 Name_Model_Emin : constant Name_Id := N + 179; Name_Model_Epsilon : constant Name_Id := N + 180; Name_Model_Large : constant Name_Id := N + 181; -- Ada 83 Name_Model_Mantissa : constant Name_Id := N + 182; Name_Model_Small : constant Name_Id := N + 183; Name_Output : constant Name_Id := N + 184; Name_Pos : constant Name_Id := N + 185; Name_Position : constant Name_Id := N + 186; Name_Pred : constant Name_Id := N + 187; Name_Range : constant Name_Id := N + 188; Name_Read : constant Name_Id := N + 189; Name_Remainder : constant Name_Id := N + 190; Name_Round : constant Name_Id := N + 191; Name_Rounding : constant Name_Id := N + 192; Name_Safe_Emax : constant Name_Id := N + 193; -- Ada 83 Name_Safe_First : constant Name_Id := N + 194; Name_Safe_Large : constant Name_Id := N + 195; -- Ada 83 Name_Safe_Last : constant Name_Id := N + 196; Name_Safe_Small : constant Name_Id := N + 197; -- Ada 83 Name_Scale : constant Name_Id := N + 198; Name_Signed_Zeros : constant Name_Id := N + 199; Name_Size : constant Name_Id := N + 200; Name_Small : constant Name_Id := N + 201; Name_Storage_Pool : constant Name_Id := N + 202; Name_Storage_Size : constant Name_Id := N + 203; Name_Succ : constant Name_Id := N + 204; Name_Tag : constant Name_Id := N + 205; Name_Terminated : constant Name_Id := N + 206; Name_Truncation : constant Name_Id := N + 207; Name_Unbiased_Rounding : constant Name_Id := N + 208; Name_Unchecked_Access : constant Name_Id := N + 209; Name_Val : constant Name_Id := N + 210; Name_Valid : constant Name_Id := N + 211; Name_Value : constant Name_Id := N + 212; Name_Version : constant Name_Id := N + 213; Name_Wide_Image : constant Name_Id := N + 214; Name_Wide_Value : constant Name_Id := N + 215; Name_Width : constant Name_Id := N + 216; Name_Write : constant Name_Id := N + 217; -- These attributes are the ones that return Types First_Type_Attribute_Name : constant Name_Id := N + 218; Name_Base : constant Name_Id := N + 218; Name_Class : constant Name_Id := N + 219; Name_Standard_Access : constant Name_Id := N + 220; -- GNAT Last_Type_Attribute_Name : constant Name_Id := N + 220; Last_Attribute_Name : constant Name_Id := N + 220; -- Names of recognized locking policy identifiers First_Locking_Policy_Name : constant Name_Id := N + 221; Name_Ceiling_Locking : constant Name_Id := N + 221; Last_Locking_Policy_Name : constant Name_Id := N + 221; -- Names of recognized locking policy identifiers First_Queuing_Policy_Name : constant Name_Id := N + 222; Name_FIFO_Queuing : constant Name_Id := N + 222; Name_Priority_Queuing : constant Name_Id := N + 223; Last_Queuing_Policy_Name : constant Name_Id := N + 223; -- Names of recognized task dispatching policy identifiers First_Task_Dispatching_Policy_Name : constant Name_Id := N + 224; Name_Fifo_Within_Priorities : constant Name_Id := N + 224; Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 224; -- Names of recognized checks for pragma Suppress First_Check_Name : constant Name_Id := N + 225; Name_Access_Check : constant Name_Id := N + 225; Name_Accessibility_Check : constant Name_Id := N + 226; Name_Discriminant_Check : constant Name_Id := N + 227; Name_Division_Check : constant Name_Id := N + 228; Name_Elaboration_Check : constant Name_Id := N + 229; Name_Index_Check : constant Name_Id := N + 230; Name_Length_Check : constant Name_Id := N + 231; Name_Overflow_Check : constant Name_Id := N + 232; Name_Range_Check : constant Name_Id := N + 233; Name_Storage_Check : constant Name_Id := N + 234; Name_Tag_Check : constant Name_Id := N + 235; Name_All_Checks : constant Name_Id := N + 236; Last_Check_Name : constant Name_Id := N + 236; -- Names corresponding to reserved keywords, excluding those already -- declared in the attribute list (Access, Delta, Digits, Range). Name_Abort : constant Name_Id := N + 237; Name_Abs : constant Name_Id := N + 238; Name_Abstract : constant Name_Id := N + 239; Name_Accept : constant Name_Id := N + 240; Name_And : constant Name_Id := N + 241; Name_All : constant Name_Id := N + 242; Name_Array : constant Name_Id := N + 243; Name_At : constant Name_Id := N + 244; Name_Begin : constant Name_Id := N + 245; Name_Body : constant Name_Id := N + 246; Name_Case : constant Name_Id := N + 247; Name_Constant : constant Name_Id := N + 248; Name_Declare : constant Name_Id := N + 249; Name_Delay : constant Name_Id := N + 250; Name_Do : constant Name_Id := N + 251; Name_Else : constant Name_Id := N + 252; Name_Elsif : constant Name_Id := N + 253; Name_End : constant Name_Id := N + 254; Name_Entry : constant Name_Id := N + 255; Name_Exception : constant Name_Id := N + 256; Name_Exit : constant Name_Id := N + 257; Name_For : constant Name_Id := N + 258; Name_Function : constant Name_Id := N + 259; Name_Generic : constant Name_Id := N + 260; Name_Goto : constant Name_Id := N + 261; Name_If : constant Name_Id := N + 262; Name_In : constant Name_Id := N + 263; Name_Is : constant Name_Id := N + 264; Name_Limited : constant Name_Id := N + 265; Name_Loop : constant Name_Id := N + 266; Name_Mod : constant Name_Id := N + 267; Name_New : constant Name_Id := N + 268; Name_Not : constant Name_Id := N + 269; Name_Null : constant Name_Id := N + 270; Name_Of : constant Name_Id := N + 271; Name_Or : constant Name_Id := N + 272; Name_Others : constant Name_Id := N + 273; Name_Out : constant Name_Id := N + 274; Name_Package : constant Name_Id := N + 275; Name_Pragma : constant Name_Id := N + 276; Name_Private : constant Name_Id := N + 277; Name_Procedure : constant Name_Id := N + 278; Name_Raise : constant Name_Id := N + 279; Name_Record : constant Name_Id := N + 280; Name_Rem : constant Name_Id := N + 281; Name_Renames : constant Name_Id := N + 282; Name_Return : constant Name_Id := N + 283; Name_Reverse : constant Name_Id := N + 284; Name_Select : constant Name_Id := N + 285; Name_Separate : constant Name_Id := N + 286; Name_Subtype : constant Name_Id := N + 287; Name_Task : constant Name_Id := N + 288; Name_Terminate : constant Name_Id := N + 289; Name_Then : constant Name_Id := N + 290; Name_Type : constant Name_Id := N + 291; Name_Use : constant Name_Id := N + 292; Name_When : constant Name_Id := N + 293; Name_While : constant Name_Id := N + 294; Name_With : constant Name_Id := N + 295; Name_Xor : constant Name_Id := N + 296; -- Reserved words used only in Ada 9X First_9X_Reserved_Word : constant Name_Id := N + 297; Name_Aliased : constant Name_Id := N + 297; Name_Protected : constant Name_Id := N + 298; Name_Until : constant Name_Id := N + 299; Name_Requeue : constant Name_Id := N + 300; Name_Tagged : constant Name_Id := N + 301; Last_9X_Reserved_Word : constant Name_Id := N + 301; subtype Ada_9X_Reserved_Words is Name_Id range First_9X_Reserved_Word .. Last_9X_Reserved_Word; -- Mark last defined name for consistency check in Snames body Last_Predefined_Name : constant Name_Id := N + 301; ------------------------------ -- Attribute ID Definitions -- ------------------------------ type Attribute_Id is ( Attribute_Access, Attribute_Address, Attribute_Adjacent, Attribute_Aft, Attribute_Alignment, Attribute_Bit_Order, Attribute_Body_Version, Attribute_Callable, Attribute_Caller, Attribute_Ceiling, Attribute_Component_Size, Attribute_Compose, Attribute_Constrained, Attribute_Copy_Sign, Attribute_Count, Attribute_Delta, Attribute_Denorm, Attribute_Digits, Attribute_Emax, Attribute_Epsilon, Attribute_Exponent, Attribute_External_Tag, Attribute_First, Attribute_First_Bit, Attribute_Floor, Attribute_Fore, Attribute_Fraction, Attribute_Identity, Attribute_Image, Attribute_Input, Attribute_Large, Attribute_Last, Attribute_Last_Bit, Attribute_Leading_Part, Attribute_Length, Attribute_Machine, Attribute_Machine_Emax, Attribute_Machine_Emin, Attribute_Machine_Mantissa, Attribute_Machine_Overflows, Attribute_Machine_Radix, Attribute_Machine_Rounds, Attribute_Mantissa, Attribute_Max, Attribute_Max_Size_In_Storage_Elements, Attribute_Min, Attribute_Model, Attribute_Model_Emax, Attribute_Model_Emin, Attribute_Model_Epsilon, Attribute_Model_Large, Attribute_Model_Mantissa, Attribute_Model_Small, Attribute_Output, Attribute_Pos, Attribute_Position, Attribute_Pred, Attribute_Range, Attribute_Read, Attribute_Remainder, Attribute_Round, Attribute_Rounding, Attribute_Safe_Emax, Attribute_Safe_First, Attribute_Safe_Large, Attribute_Safe_Last, Attribute_Safe_Small, Attribute_Scale, Attribute_Signed_Zeros, Attribute_Size, Attribute_Small, Attribute_Storage_Pool, Attribute_Storage_Size, Attribute_Succ, Attribute_Tag, Attribute_Terminated, Attribute_Truncation, Attribute_Unbiased_Rounding, Attribute_Unchecked_Access, Attribute_Val, Attribute_Valid, Attribute_Value, Attribute_Version, Attribute_Wide_Image, Attribute_Wide_Value, Attribute_Width, Attribute_Write, -- Type attributes Attribute_Base, Attribute_Class, Attribute_Standard_Access); subtype Type_Attribute_Id is Attribute_Id range Attribute_Base .. Attribute_Standard_Access; ------------------------------- -- Check Name ID Definitions -- ------------------------------- type Check_Id is ( Access_Check, Accessibility_Check, Discriminant_Check, Division_Check, Elaboration_Check, Index_Check, Length_Check, Overflow_Check, Range_Check, Storage_Check, Tag_Check, All_Checks); ------------------------------------ -- Convention Name ID Definitions -- ------------------------------------ type Convention_Id is ( Convention_Ada, Convention_Asm, Convention_Assembler, Convention_C, Convention_Intrinsic); ----------------------------------- -- Locking Policy ID Definitions -- ----------------------------------- type Locking_Policy_Id is ( Locking_Policy_Ceiling_Locking); --------------------------- -- Pragma ID Definitions -- --------------------------- type Pragma_Id is ( Pragma_Abort_Defer, Pragma_Ada_83, Pragma_Ada_9X, Pragma_All_Calls_Remote, Pragma_Assert, Pragma_Asynchronous, Pragma_Atomic, Pragma_Atomic_Components, Pragma_Attach_Handler, Pragma_Controlled, Pragma_Convention, Pragma_Debug, Pragma_Elaborate, Pragma_Elaborate_All, Pragma_Elaborate_Body, Pragma_Export, Pragma_Import, Pragma_Improve, Pragma_Inline, Pragma_Inspection_Point, Pragma_Interface, Pragma_Interface_Name, Pragma_Interrupt_Handler, Pragma_Interrupt_Priority, Pragma_List, Pragma_Locking_Policy, Pragma_Memory_Size, Pragma_Normalize_Scalars, Pragma_Optimize, Pragma_Pack, Pragma_Page, Pragma_Preelaborate, Pragma_Priority, Pragma_Pure, Pragma_Queuing_Policy, Pragma_Remote_Call_Interface, Pragma_Remote_Types, Pragma_Restrictions, Pragma_Reviewable, Pragma_Shared, Pragma_Shared_Passive, Pragma_Storage_Unit, Pragma_Suppress, Pragma_System_Name, Pragma_Task_Dispatching_Policy, Pragma_Task_Stack_Size, Pragma_Volatile, Pragma_Volatile_Components); ------------------------------------ -- Queueing Policy ID definitions -- ------------------------------------ type Queuing_Policy_Id is ( Queuing_Policy_FIFO_Queuing, Queuing_Policy_Priority_Queuing); -------------------------------------------- -- Task Dispatching Policy ID definitions -- -------------------------------------------- type Task_Dispatching_Policy_Id is ( Task_Dispatching_FIFO_Within_Priorities); -- Id values used to identify task dispatching policies ----------------- -- Subprograms -- ----------------- procedure Initialize_Snames; -- Called to initialize the preset names in the names table. function Is_Attribute_Name (N : Name_Id) return Boolean; pragma Inline (Is_Attribute_Name); -- Test to see if the name N is the name of a recognized attribute function Is_Type_Attribute_Name (N : Name_Id) return Boolean; pragma Inline (Is_Type_Attribute_Name); -- Test to see if the name N is the name of a recognized type -- returning attribute function Is_Check_Name (N : Name_Id) return Boolean; pragma Inline (Is_Check_Name); -- Test to see if the name N is the name of a recognized suppress check -- as required by pragma Suppress. function Is_Convention_Name (N : Name_Id) return Boolean; pragma Inline (Is_Convention_Name); -- Test to see if the name N is the name of one of the recognized language -- conventions, as required by pragma Convention, Import, Export, Interface function Is_Locking_Policy_Name (N : Name_Id) return Boolean; pragma Inline (Is_Locking_Policy_Name); -- Test to see if the name N is the name of a recognized locking policy function Is_Operator_Symbol_Name (N : Name_Id) return Boolean; pragma Inline (Is_Operator_Symbol_Name); -- Test to see if the name N is the name of an operator symbol function Is_Pragma_Name (N : Name_Id) return Boolean; pragma Inline (Is_Pragma_Name); -- Test to see if the name N is the name of a recognized pragma function Is_Queuing_Policy_Name (N : Name_Id) return Boolean; pragma Inline (Is_Queuing_Policy_Name); -- Test to see if the name N is the name of a recognized queuing policy function Is_Task_Dispatching_Policy_Name (N : Name_Id) return Boolean; pragma Inline (Is_Task_Dispatching_Policy_Name); -- Test to see if the name N is the name of a recognized -- task dispatching policy function Get_Attribute_Id (N : Name_Id) return Attribute_Id; -- Returns Id of attribute corresponding to given name. It is an error to -- call this function with a name that is not the name of a attribute. function Get_Convention_Id (N : Name_Id) return Convention_Id; -- Returns Id of language convention corresponding to given name. It is an -- to call this function with a name that is not the name of a check. function Get_Check_Id (N : Name_Id) return Check_Id; -- Returns Id of suppress check corresponding to given name. It is an error -- to call this function with a name that is not the name of a check. function Get_Locking_Policy_Id (N : Name_Id) return Locking_Policy_Id; -- Returns Id of locking policy corresponding to given name. It is an error -- to call this function with a name that is not the name of a check. function Get_Pragma_Id (N : Name_Id) return Pragma_Id; -- Returns Id of pragma corresponding to given name. It is an error to -- call this function with a name that is not the name of a pragma. function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id; -- Returns Id of queuing policy corresponding to given name. It is an error -- to call this function with a name that is not the name of a check. function Get_Task_Dispatching_Policy_Id (N : Name_Id) return Task_Dispatching_Policy_Id; -- Returns Id of task dispatching policy corresponding to given name. It -- is an error to call this function with a name that is not the name -- of a check. end Snames; nal_Tag, Attribute_First, Attribute_First_Bit, Attribute_Floor, Attribute_Fore, Attribute_Fraction, Attribute_Identity, Attribute_Image, Attribute_Input, Attribute_Large, Attribute_Last, Attribute_Last_Bit, Attribute_Leading_Part, Attribute_Length, Attribute_Machine, Attribute_Machine_Emax, Attribute_Machine_Emin, Attribute_Mgnat-1.67-src/src/snames.adb 444 10015 7640 32124 5506244430 11073 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S N A M E S -- -- -- -- B o d y -- -- -- -- $Revision: 1.35 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Comperr; use Comperr; with Namet; use Namet; with Output; use Output; package body Snames is -- Table of names to be set by Initialize_Snames. Each name is terminated -- by a single #, and the end of the list is marked by a null entry, -- i.e. by two # marks in succession. Note that the table does not include -- the entries for a-z, since these are initialized by Namet itself. Preset_Names : constant Str := "_parent#" & "_size#" & "_chain#" & "_equality#" & "_expunge#" & "_idepth#" & "_init#" & "_master#" & "_priority#" & "_task#" & "_tb_snam#" & "_trace_sp#" & "_tag#" & "_tags#" & "_task_id#" & "version_b#" & "version_s#" & "#" & "go#" & "to#" & "system#" & "unchecked_conversion#" & """abs""#" & """and""#" & """mod""#" & """not""#" & """or""#" & """rem""#" & """xor""#" & """=""#" & """/=""#" & """<""#" & """<=""#" & """>""#" & """>=""#" & """+""#" & """-""#" & """&""#" & """*""#" & """/""#" & """**""#" & """in""#" & """not in""#" & """and then""#" & """or else""#" & "abort_defer#" & "ada_83#" & "ada_9x#" & "all_calls_remote#" & "assert#" & "asynchronous#" & "atomic#" & "atomic_components#" & "attach_handler#" & "controlled#" & "convention#" & "debug#" & "elaborate#" & "elaborate_all#" & "elaborate_body#" & "export#" & "import#" & "improve#" & "inline#" & "inspection_point#" & "interface#" & "interface_name#" & "interrupt_handler#" & "interrupt_priority#" & "list#" & "locking_policy#" & "memory_size#" & "normalize_scalars#" & "optimize#" & "pack#" & "page#" & "preelaborate#" & "priority#" & "pure#" & "queuing_policy#" & "remote_call_interface#" & "remote_types#" & "restrictions#" & "reviewable#" & "shared#" & "shared_passive#" & "storage_unit#" & "suppress#" & "system_name#" & "task_dispatching_policy#" & "task_stack_size#" & "volatile#" & "volatile_components#" & "ada#" & "asm#" & "assembler#" & "intrinsic#" & "entity#" & "gcc#" & "gnat#" & "link_name#" & "off#" & "on#" & "space#" & "time#" & "access#" & "address#" & "adjacent#" & "aft#" & "alignment#" & "bit_order#" & "body_version#" & "callable#" & "caller#" & "ceiling#" & "component_size#" & "compose#" & "constrained#" & "copy_sign#" & "count#" & "delta#" & "denorm#" & "digits#" & "emax#" & "epsilon#" & "exponent#" & "external_tag#" & "first#" & "first_bit#" & "floor#" & "fore#" & "fraction#" & "identity#" & "image#" & "input#" & "large#" & "last#" & "last_bit#" & "leading_part#" & "length#" & "machine#" & "machine_emax#" & "machine_emin#" & "machine_mantissa#" & "machine_overflows#" & "machine_radix#" & "machine_rounds#" & "mantissa#" & "max#" & "max_size_in_storage_elements#" & "min#" & "model#" & "model_emax#" & "model_emin#" & "model_epsilon#" & "model_large#" & "model_mantissa#" & "model_small#" & "output#" & "pos#" & "position#" & "pred#" & "range#" & "read#" & "remainder#" & "round#" & "rounding#" & "safe_emax#" & "safe_first#" & "safe_large#" & "safe_last#" & "safe_small#" & "scale#" & "signed_zeros#" & "size#" & "small#" & "storage_pool#" & "storage_size#" & "succ#" & "tag#" & "terminated#" & "truncation#" & "unbiased_rounding#" & "unchecked_access#" & "val#" & "valid#" & "value#" & "version#" & "wide_image#" & "wide_value#" & "width#" & "write#" & "base#" & "class#" & "standard_access#" & "ceiling_locking#" & "fifo_queuing#" & "priority_queuing#" & "fifo_within_priorities#" & "access_check#" & "accessibility_check#" & "discriminant_check#" & "division_check#" & "elaboration_check#" & "index_check#" & "length_check#" & "overflow_check#" & "range_check#" & "storage_check#" & "tag_check#" & "all_checks#" & "abort#" & "abs#" & "abstract#" & "accept#" & "and#" & "all#" & "array#" & "at#" & "begin#" & "body#" & "case#" & "constant#" & "declare#" & "delay#" & "do#" & "else#" & "elsif#" & "end#" & "entry#" & "exception#" & "exit#" & "for#" & "function#" & "generic#" & "goto#" & "if#" & "in#" & "is#" & "limited#" & "loop#" & "mod#" & "new#" & "not#" & "null#" & "of#" & "or#" & "others#" & "out#" & "package#" & "pragma#" & "private#" & "procedure#" & "raise#" & "record#" & "rem#" & "renames#" & "return#" & "reverse#" & "select#" & "separate#" & "subtype#" & "task#" & "terminate#" & "then#" & "type#" & "use#" & "when#" & "while#" & "with#" & "xor#" & "aliased#" & "protected#" & "until#" & "requeue#" & "tagged#" & "#"; ----------------------- -- Initialize_Snames -- ----------------------- procedure Initialize_Snames is P_Index : Int := 0; Discard_Name : Name_Id; begin loop Name_Len := 0; while Preset_Names (P_Index) /= '#' loop Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := Preset_Names (P_Index); P_Index := P_Index + 1; end loop; -- We do the Name_Find call to enter the name into the table, but -- we don't need to do anything with the result, since we already -- initialized all the preset names to have the right value (we -- are depending on the order of the names and Preset_Names). Discard_Name := Name_Find; P_Index := P_Index + 1; exit when Preset_Names (P_Index) = '#'; end loop; -- Make sure that number of names in standard table is correct. If -- this check fails, run utility program XSNAMES to construct a new -- properly matching version of the body. if Discard_Name /= Last_Predefined_Name then Compiler_Error; Write_Eol; Write_String ("Discard name = "); Write_Int (Int (Discard_Name)); Write_Eol; Write_String ("Last predefined name = "); Write_Int (Int (Last_Predefined_Name )); Write_Eol; Compiler_Abort; end if; end Initialize_Snames; ----------------------- -- Is_Attribute_Name -- ----------------------- function Is_Attribute_Name (N : Name_Id) return Boolean is begin return First_Attribute_Name <= N and then N <= Last_Attribute_Name; end Is_Attribute_Name; ---------------------------- -- Is_Type_Attribute_Name -- ---------------------------- function Is_Type_Attribute_Name (N : Name_Id) return Boolean is begin return First_Type_Attribute_Name <= N and then N <= Last_Type_Attribute_Name; end Is_Type_Attribute_Name; ------------------- -- Is_Check_Name -- ------------------- function Is_Check_Name (N : Name_Id) return Boolean is begin return First_Check_Name <= N and then N <= Last_Check_Name; end Is_Check_Name; ------------------------ -- Is_Convention_Name -- ------------------------ function Is_Convention_Name (N : Name_Id) return Boolean is begin return (First_Convention_Name <= N and then N <= Last_Convention_Name) or else N = Name_C; end Is_Convention_Name; ---------------------------- -- Is_Locking_Policy_Name -- ---------------------------- function Is_Locking_Policy_Name (N : Name_Id) return Boolean is begin return First_Locking_Policy_Name <= N and then N <= Last_Locking_Policy_Name; end Is_Locking_Policy_Name; ----------------------------- -- Is_Operator_Symbol_Name -- ----------------------------- function Is_Operator_Symbol_Name (N : Name_Id) return Boolean is begin return First_Operator_Name <= N and then N <= Last_Operator_Name; end Is_Operator_Symbol_Name; -------------------- -- Is_Pragma_Name -- -------------------- function Is_Pragma_Name (N : Name_Id) return Boolean is begin return First_Pragma_Name <= N and then N <= Last_Pragma_Name; end Is_Pragma_Name; ---------------------------- -- Is_Queuing_Policy_Name -- ---------------------------- function Is_Queuing_Policy_Name (N : Name_Id) return Boolean is begin return First_Queuing_Policy_Name <= N and then N <= Last_Queuing_Policy_Name; end Is_Queuing_Policy_Name; ------------------------------------- -- Is_Task_Dispatching_Policy_Name -- ------------------------------------- function Is_Task_Dispatching_Policy_Name (N : Name_Id) return Boolean is begin return First_Task_Dispatching_Policy_Name <= N and then N <= Last_Task_Dispatching_Policy_Name; end Is_Task_Dispatching_Policy_Name; ---------------------- -- Get_Attribute_Id -- ---------------------- function Get_Attribute_Id (N : Name_Id) return Attribute_Id is begin return Attribute_Id'Val (N - First_Attribute_Name); end Get_Attribute_Id; ------------------ -- Get_Check_Id -- ------------------ function Get_Check_Id (N : Name_Id) return Check_Id is begin return Check_Id'Val (N - First_Check_Name); end Get_Check_Id; ----------------------- -- Get_Convention_Id -- ----------------------- function Get_Convention_Id (N : Name_Id) return Convention_Id is begin if N = Name_C then return Convention_C; else return Convention_Id'Val (N - First_Convention_Name); end if; end Get_Convention_Id; --------------------------- -- Get_Locking_Policy_Id -- --------------------------- function Get_Locking_Policy_Id (N : Name_Id) return Locking_Policy_Id is begin return Locking_Policy_Id'Val (N - First_Locking_Policy_Name); end Get_Locking_Policy_Id; ------------------- -- Get_Pragma_Id -- ------------------- function Get_Pragma_Id (N : Name_Id) return Pragma_Id is begin return Pragma_Id'Val (N - First_Pragma_Name); end Get_Pragma_Id; --------------------------- -- Get_Queuing_Policy_Id -- --------------------------- function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id is begin return Queuing_Policy_Id'Val (N - First_Queuing_Policy_Name); end Get_Queuing_Policy_Id; ------------------------------------ -- Get_Task_Dispatching_Policy_Id -- ------------------------------------ function Get_Task_Dispatching_Policy_Id (N : Name_Id) return Task_Dispatching_Policy_Id is begin return Task_Dispatching_Policy_Id'Val (N - First_Task_Dispatching_Policy_Name); end Get_Task_Dispatching_Policy_Id; end Snames; "model#" & "model_emax#" & "model_emin#" & "model_epsilon#" & "model_large#" & "model_mantissa#" & "model_small#" & "output#" & "pos#" & "position#" & "pred#" & "range#" & "read#" & "remainder#" & "round#" & "rounding#" & "safe_emax#" & "safe_first#" & "safe_large#" & "safe_last#" & "safe_small#" & "scale#" & "signedgnat-1.67-src/src/sprint.ads 444 10015 7640 12630 5506244431 11146 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S P R I N T -- -- -- -- S p e c -- -- -- -- $Revision: 1.8 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This package (source print) contains routines for printing the source -- program corresponding to a specified syntax tree. These routines are -- intended for debugging use in the compiler (not as a user level pretty -- print tool). Only information present in the tree is output (e.g. no -- comments are present in the output), and as far as possible we avoid -- making any assumptions about the correctness of the tree, so a bad -- tree may either blow up on a debugging check, or list incorrect source. with Types; use Types; package Sprint is ----------------------- -- Syntax Extensions -- ----------------------- -- When the generated tree is printed, it contains constructs that are not -- pure Ada. For convenience, syntactic extensions to Ada have been defined -- purely for the purposes of this printout (they are not recognized by the -- parser) -- Unchecked conversion target_type!(source_expression) -- Expression actions [action; action; ...; value] -- Implicit type implicit type xxx is yyy -- Label declaration labelname : label -- Freeze action freeze typename -- Rational literal [numerator/denominator] -- Multiple concatenation expr && expr && expr ... && expr -- Cleanup action at end procedure name; -- Reference expression'reference ----------------- -- Subprograms -- ----------------- procedure Source_Dump (S : Char); -- This routine is called from the GNAT main program to dump source as -- requested by debug options. The argument indicates which stage it -- is called at and is 'P' for the call after the parser, and 'S' for -- the call after semantics. procedure Sprint_Comma_List (List : List_Id); -- Prints the nodes in a list, with separating commas. If the list -- is empty then no output is generated. procedure Sprint_Paren_Comma_List (List : List_Id); -- Prints the nodes in a list, surrounded by parentheses, and separated -- by comas. If the list is empty, then no output is generated. A blank -- is output before the initial left parenthesis. procedure Sprint_Opt_Paren_Comma_List (List : List_Id); -- Same as normal Sprint_Paren_Comma_List procedure, except that -- an extra blank is output if List is non-empty, and nothing at all is -- printed it the argument is No_List. procedure Sprint_Node_List (List : List_Id); -- Prints the nodes in a list with no separating characters. This is used -- in the case of lists of items which are printed on separate lines using -- the current indentation amount. Note that Sprint_Node_List itself -- does not generate any New_Line calls. procedure Sprint_Opt_Node_List (List : List_Id); -- Like Sprint_Node_List, but prints nothing if List = No_List. procedure Sprint_Indented_List (List : List_Id); -- Like Sprint_Line_List, except that the indentation level is -- increased before outputting the list of items, and then decremented -- (back to its original level) before returning to the caller. procedure Sprint_Node (Node : Node_Id); -- Prints a single node. No new lines are output, except as required for -- splitting lines that are too long to fit on a single physical line. -- No output is generated at all if Node is Empty. No trailing or leading -- blank characters are generated. procedure Sprint_Opt_Node (Node : Node_Id); -- Same as normal Sprint_Node procedure, except that one leading -- blank is output before the node if it is non-empty. end Sprint; Name (N : Name_Id) return Boolean is begin return First_Locking_Policy_Name <= N and thgnat-1.67-src/src/sprint.adb 444 10015 7640 213071 5506244433 11151 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S P R I N T -- -- -- -- B o d y -- -- -- -- $Revision: 1.76 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Csets; use Csets; with Debug; use Debug; with Einfo; use Einfo; with Lib; use Lib; with Namet; use Namet; with Opt; use Opt; with Output; use Output; with Sinfo; use Sinfo; with Stand; use Stand; with Stringt; use Stringt; with Uintp; use Uintp; with Uname; use Uname; package body Sprint is Indent : Int := 0; -- Number of columns for current line output indentation Indent_Annull_Flag : Boolean := False; -- Set True if subsequent Write_Indent call to be ignored, gets reset -- by this call, so it is only active to suppress a single indent call. ----------------------- -- Local Procedures -- ----------------------- procedure Indent_Annull; -- Causes following call to Write_Indent to be ignored. This is used when -- a higher level node wants to stop a lower level node from starting a -- new line, when it would otherwise be inclined to do so (e.g. the case -- of an accept statement called from an accept alternative with a guard) procedure Indent_Begin; -- Increase indentation level procedure Indent_End; -- Decrease indentation level procedure Sprint_Node_Actual (Node : Node_Id); -- This routine prints its node argument. It is a lower level routine than -- Sprint_Node, in that it does not bother about rewritten trees. procedure Write_Ekind (E : Entity_Id); -- Write the String corresponding to the Ekind without "E_". procedure Write_Id (Id : Node_Id); -- Write identifier name function Write_Identifiers (Node : Node_Id) return Boolean; -- Handle node where the grammar has a list of defining identifiers, but -- the tree has a separate declaration for each identifier. Handles the -- printing of the defining identifier, and returns True if the type and -- initialization information is to be printed, False if it is to be -- skipped (the latter case happens when printing defining identifiers -- other than the first in the original tree output case). procedure Write_Implicit_Def (E : Entity_Id); -- Write the definition of the implicit type E according to its Ekind procedure Write_Indent; -- Start a new line and write indent spacing function Write_Indent_Identifiers (Node : Node_Id) return Boolean; -- Like Write_Identifiers except that each new printed declaration -- is at the start of a new line. procedure Write_Indent_String (S : String); -- Start a new line and write indent spacing followed by given string procedure Write_Param_Specs (N : Node_Id); -- Output parameter specifications for node (which is either a function -- or procedure specification with a Parameter_Specifications field procedure Write_Real_Value (Node : Node_Id); -- Used to output real value from N_Real_Literal or N_Real_Value node procedure Write_Rewrite_String (S : String); -- Writes out a string (typically containing { or }) for a node created -- by rewriting the tree. Suppressed if Debug_Flag_G is set, since in this -- case we don't specially mark nodes created by rewriting). procedure Write_Uint (U : Uint); -- Used to output a Uint value ------------------- -- Indent_Annull -- ------------------- procedure Indent_Annull is begin Indent_Annull_Flag := True; end Indent_Annull; ------------------ -- Indent_Begin -- ------------------ procedure Indent_Begin is begin Indent := Indent + 3; end Indent_Begin; ---------------- -- Indent_End -- ---------------- procedure Indent_End is begin Indent := Indent - 3; end Indent_End; ----------------- -- Source_Dump -- ----------------- procedure Source_Dump (S : Char) is Max_Unit : Unit_Number_Type; procedure Underline; -- Put underline under string we just printed procedure Underline is Col : constant Int := Column; begin Write_Eol; while Col > Column loop Write_Char ('-'); end loop; Write_Eol; end Underline; -- Start of processing for Source_Dump begin if Debug_Flag_Z and then (S = 'S' or else Operating_Mode = Check_Syntax) then Write_Eol; Write_String ("Source recreated from tree of Standard (spec)"); if S = 'P' then Write_Str (" after parsing"); else Write_Str (" after semantics"); end if; Underline; Sprint_Node (Standard_Package_Node); Write_Eol; end if; if (Debug_Flag_S and then (S = 'S' or else Operating_Mode = Check_Syntax)) or else (Debug_Flag_W and then (S = 'P' and then Operating_Mode /= Check_Syntax)) then if Debug_Flag_F then Max_Unit := File.Last; else Max_Unit := Main_Unit; end if; for U in Main_Unit .. Max_Unit loop if File.Table (U).Source /= null then Write_Eol; Write_String ("Source recreated from tree for "); Write_Unit_Name (File.Table (U).Unit_Name); if S = 'P' then Write_Str (" after parsing "); else Write_Str (" after semantics "); end if; Underline; Sprint_Node (File.Table (U).Cunit); Write_Eol; end if; end loop; end if; end Source_Dump; --------------------- -- Sprint_Bar_List -- --------------------- procedure Sprint_Bar_List (List : List_Id) is Node : Node_Id; begin if Is_Non_Empty_List (List) then Node := First (List); loop Sprint_Node (Node); Node := Next (Node); exit when Node = Empty; Write_String (" | "); if Column > 70 then Write_Indent_String (" "); end if; end loop; end if; end Sprint_Bar_List; ----------------------- -- Sprint_Comma_List -- ----------------------- procedure Sprint_Comma_List (List : List_Id) is Node : Node_Id; begin if Is_Non_Empty_List (List) then Node := First (List); loop Sprint_Node (Node); Node := Next (Node); exit when Node = Empty; Write_String (", "); if Column > 70 then Write_Indent_String (" "); end if; end loop; end if; end Sprint_Comma_List; -------------------------- -- Sprint_Indented_List -- -------------------------- procedure Sprint_Indented_List (List : List_Id) is begin Indent_Begin; Sprint_Node_List (List); Indent_End; end Sprint_Indented_List; ----------------- -- Sprint_Node -- ----------------- procedure Sprint_Node (Node : Node_Id) is begin if Is_Rewrite_Insertion (Node) then if not Debug_Flag_O then Write_Rewrite_String ("{"); Sprint_Node_Actual (Node); Write_Rewrite_String ("}"); end if; elsif Is_Rewrite_Substitution (Node) then if Debug_Flag_G then Sprint_Node_Actual (Node); elsif Debug_Flag_O then Sprint_Node_Actual (Original_Node (Node)); else Sprint_Node_Actual (Original_Node (Node)); Write_Rewrite_String ("{"); Sprint_Node_Actual (Node); Write_Rewrite_String ("}"); end if; else Sprint_Node_Actual (Node); end if; end Sprint_Node; ------------------------ -- Sprint_Node_Actual -- ------------------------ procedure Sprint_Node_Actual (Node : Node_Id) is Paren_Flag : Boolean := False; -- Set true if closing parenthesis needed at end procedure Do_Parens; -- Used for nodes that have a Parens field. If the Parens field is set -- True, then a left paren is output at the time of call, and Paren_Flag -- is set True, which will cause a right paren to be output on exit from -- the Print_Node procedure. procedure Do_Parens is begin if Parens (Node) then Write_Char ('('); Paren_Flag := True; end if; end Do_Parens; begin if Node = Empty then return; end if; case Nkind (Node) is when N_Abort_Statement => Write_Indent_String ("abort "); Sprint_Comma_List (Names (Node)); Write_Char (';'); when N_Abortable_Part => Sprint_Indented_List (Statements (Node)); when N_Abstract_Subprogram_Declaration => Write_Indent; Sprint_Node (Specification (Node)); Write_String (" is abstract;"); when N_Accept_Alternative => if Present (Condition (Node)) then Write_Indent; Write_String ("when "); Sprint_Node (Condition (Node)); Write_String (" => "); Indent_Annull; end if; Sprint_Node (Accept_Statement (Node)); Sprint_Node_List (Statements (Node)); when N_Accept_Statement => Write_Indent_String ("accept "); Write_Id (Accept_Name (Node)); if Present (Entry_Index (Node)) then Write_String (" ("); Sprint_Node (Entry_Index (Node)); Write_String (")"); end if; Write_Param_Specs (Node); if Present (Handled_Statement_Sequence (Node)) then Write_String (" do"); Sprint_Node (Handled_Statement_Sequence (Node)); Write_Indent_String ("end "); Write_Id (Accept_Name (Node)); end if; Write_Char (';'); when N_Access_Definition => Write_String ("access "); Sprint_Node (Subtype_Mark (Node)); when N_Access_Function_Definition => Write_String ("access "); if Protected_Present (Node) then Write_String ("protected "); end if; Write_String ("function"); Write_Param_Specs (Node); Write_String (" return "); Sprint_Node (Subtype_Mark (Node)); when N_Access_Procedure_Definition => Write_String ("access "); if Protected_Present (Node) then Write_String ("protected "); end if; Write_String ("procedure"); Write_Param_Specs (Node); when N_Access_To_Object_Definition => Write_String ("access "); if All_Present (Node) then Write_String ("all "); elsif Constant_Present (Node) then Write_String ("constant "); end if; Sprint_Node (Subtype_Indication (Node)); when N_At_Clause => Write_Indent_String ("for "); Write_Id (Identifier (Node)); Write_String (" use at "); Sprint_Node (Expression (Node)); Write_Char (';'); when N_Aggregate => Do_Parens; if Null_Record_Present (Node) then Write_String ("(null record)"); else Write_Char ('('); if List_Present (Expressions (Node)) then Sprint_Comma_List (Expressions (Node)); if List_Present (Component_Associations (Node)) then Write_String (", "); end if; end if; if List_Present (Component_Associations (Node)) then Sprint_Comma_List (Component_Associations (Node)); end if; Write_Char (')'); end if; when N_Mod_Clause => Write_String ("at mod "); Sprint_Node (Expression (Node)); when N_Allocator => Do_Parens; Write_String ("new "); Sprint_Node (Expression (Node)); when N_Assignment_Statement => Write_Indent; Sprint_Node (Name (Node)); Write_String (" := "); Sprint_Node (Expression (Node)); Write_Char (';'); when N_Asynchronous_Select => Write_Indent_String ("select"); Indent_Begin; Sprint_Node (Triggering_Alternative (Node)); Indent_End; Write_Indent_String ("then abort"); Sprint_Node (Abortable_Part (Node)); Write_Indent_String ("end select;"); when N_Attribute_Definition_Clause => Write_Indent_String ("for "); Write_Id (Identifier (Node)); Write_String (" use "); Sprint_Node (Expression (Node)); Write_Char (';'); when N_Attribute_Reference => Do_Parens; Sprint_Node (Prefix (Node)); Write_Char ('''); Write_Id (Identifier (Node)); if Present (Expression (Node)) then Write_String (" ("); Sprint_Node (Expression (Node)); Write_Char (')'); end if; when N_Block_Statement => Write_Indent; if Present (Identifier (Node)) and then (not Has_Created_Identifier (Node) or else not Debug_Flag_O) then Write_Rewrite_String ("{"); Write_Id (Identifier (Node)); Write_String (" : "); Write_Rewrite_String ("}"); end if; if List_Present (Declarations (Node)) then Write_String ("declare"); Sprint_Indented_List (Declarations (Node)); Write_Indent; end if; Write_String ("begin"); Sprint_Node (Handled_Statement_Sequence (Node)); Write_Indent_String ("end"); if Present (Identifier (Node)) and then (not Has_Created_Identifier (Node) or else not Debug_Flag_O) then Write_Rewrite_String ("{"); Write_Char (' '); Write_Id (Identifier (Node)); Write_Rewrite_String ("}"); end if; Write_Char (';'); when N_Case_Statement => Write_Indent_String ("case "); Sprint_Node (Expression (Node)); Write_String (" is"); Sprint_Indented_List (Alternatives (Node)); Write_Indent_String ("end case;"); when N_Case_Statement_Alternative => Write_Indent_String ("when "); Sprint_Bar_List (Discrete_Choices (Node)); Write_String (" =>"); Sprint_Indented_List (Statements (Node)); when N_Character_Literal => Do_Parens; Write_Char ('''); if Char_Literal_Value (Node) in 16#20# .. 16#7E# then Write_Char (Char'Val (Char_Literal_Value (Node))); else Write_Str ("{Char_Code = "); Write_Int (Int (Char_Literal_Value (Node))); Write_Char ('}'); end if; Write_Char ('''); when N_Code_Statement => Write_Indent; Sprint_Node (Expression (Node)); Write_Char (';'); when N_Compilation_Unit => Sprint_Node_List (Context_Items (Node)); if Private_Present (Node) then Write_Indent_String ("private "); Indent_Annull; end if; Sprint_Node (Unit (Node)); Sprint_Opt_Node_List (Following_Pragmas (Node)); when N_Component_Association => Sprint_Bar_List (Choices (Node)); Write_String (" => "); Sprint_Node (Expression (Node)); when N_Component_Clause => Write_Indent; Sprint_Node (Component_Name (Node)); Write_String (" at "); Sprint_Node (Position (Node)); Write_String (" range "); Sprint_Node (First_Bit (Node)); Write_String (" .. "); Sprint_Node (Last_Bit (Node)); Write_Char (';'); when N_Component_Declaration => if Write_Indent_Identifiers (Node) then Write_String (" : "); if Aliased_Present (Node) then Write_String ("aliased "); end if; Sprint_Node (Subtype_Indication (Node)); if Present (Expression (Node)) then Write_String (" := "); Sprint_Node (Expression (Node)); end if; Write_Char (';'); end if; when N_Component_List => if Null_Present (Node) then Indent_Begin; Write_Indent_String ("null"); Write_Char (';'); Indent_End; else Sprint_Indented_List (Component_Declarations (Node)); Sprint_Node (Variant_Part (Node)); end if; when N_Concat_Multiple => Do_Parens; declare Expr : Node_Id; begin Expr := First (Expressions (Node)); loop Sprint_Node (Expr); Expr := Next (Expr); exit when No (Expr); Write_String (" && "); end loop; end; when N_Conditional_Entry_Call => Write_Indent_String ("select"); Indent_Begin; Sprint_Node (Entry_Call_Alternative (Node)); Indent_End; Write_Indent_String ("else"); Sprint_Indented_List (Else_Statements (Node)); Write_Indent_String ("end select;"); when N_Constrained_Array_Definition => Write_String ("array "); Sprint_Paren_Comma_List (Discrete_Subtype_Definitions (Node)); Write_String (" of "); if Aliased_Present (Node) then Write_String ("aliased "); end if; Sprint_Node (Subtype_Indication (Node)); when N_Decimal_Fixed_Point_Definition => Write_String ("digits "); Sprint_Node (Digits_Expression (Node)); Write_String (" delta "); Sprint_Node (Delta_Expression (Node)); Sprint_Opt_Node (Real_Range_Specification (Node)); when N_Defining_Character_Literal => Write_Name (Chars (Node)); when N_Defining_Identifier => Write_Id (Node); when N_Defining_Operator_Symbol => Write_Name (Chars (Node)); when N_Defining_Program_Unit_Name => Sprint_Node (Name (Node)); Write_Char ('.'); Write_Id (Defining_Identifier (Node)); when N_Delay_Alternative => if Present (Condition (Node)) then Write_Indent; Write_String ("when "); Sprint_Node (Condition (Node)); Write_String (" => "); Indent_Annull; end if; Sprint_Node (Delay_Statement (Node)); Sprint_Node_List (Statements (Node)); when N_Delay_Relative_Statement => Write_Indent_String ("delay "); Sprint_Node (Expression (Node)); Write_Char (';'); when N_Delay_Until_Statement => Write_Indent_String ("delay until "); Sprint_Node (Expression (Node)); Write_Char (';'); when N_Delta_Constraint => Write_String ("delta "); Sprint_Node (Delta_Expression (Node)); Sprint_Opt_Node (Range_Constraint (Node)); when N_Derived_Type_Definition => if Abstract_Present (Node) then Write_String ("abstract "); end if; Write_String ("new "); Sprint_Node (Subtype_Indication (Node)); if Present (Record_Extension_Part (Node)) then Write_String (" with "); Sprint_Node (Record_Extension_Part (Node)); end if; when N_Designator => Sprint_Node (Name (Node)); Write_Char ('.'); Write_Id (Identifier (Node)); when N_Digits_Constraint => Write_String ("digits "); Sprint_Node (Digits_Expression (Node)); Sprint_Opt_Node (Range_Constraint (Node)); when N_Discriminant_Association => if List_Present (Selector_Names (Node)) then Sprint_Bar_List (Selector_Names (Node)); Write_String (" => "); end if; Sprint_Node (Expression (Node)); when N_Discriminant_Specification => if Write_Identifiers (Node) then Write_String (" : "); Sprint_Node (Discriminant_Type (Node)); if Present (Expression (Node)) then Write_String (" := "); Sprint_Node (Expression (Node)); end if; end if; when N_Elsif_Part => Write_Indent_String ("elsif "); Sprint_Node (Condition (Node)); Sprint_Indented_List (Then_Statements (Node)); when N_Empty => null; when N_Entry_Body => Write_Indent_String ("entry "); Write_Id (Defining_Identifier (Node)); Sprint_Node (Entry_Body_Formal_Part (Node)); Write_String (" when "); Sprint_Node (Condition (Node)); Write_String (" is"); Sprint_Indented_List (Declarations (Node)); Write_Indent_String ("begin"); Sprint_Node (Handled_Statement_Sequence (Node)); Write_Indent_String ("end "); Write_Id (Defining_Identifier (Node)); Write_Char (';'); when N_Entry_Body_Formal_Part => if Present (Entry_Index_Specification (Node)) then Write_String (" ("); Sprint_Node (Entry_Index_Specification (Node)); Write_Char (')'); end if; Write_Param_Specs (Node); when N_Entry_Call_Alternative => Sprint_Node (Entry_Call_Statement (Node)); Sprint_Node_List (Statements (Node)); when N_Entry_Call_Statement => Write_Indent; Sprint_Node (Name (Node)); Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node)); Write_Char (';'); when N_Entry_Declaration => Write_Indent_String ("entry "); Write_Id (Defining_Identifier (Node)); if Present (Discrete_Subtype_Definition (Node)) then Write_String (" ("); Sprint_Node (Discrete_Subtype_Definition (Node)); Write_String (")"); end if; Write_Param_Specs (Node); Write_Char (';'); when N_Entry_Index_Specification => Write_String ("for "); Write_Id (Defining_Identifier (Node)); Write_String (" in "); Sprint_Node (Discrete_Subtype_Definition (Node)); when N_Enumeration_Representation_Clause => Write_Indent_String ("for "); Write_Id (Identifier (Node)); Write_String (" use "); Sprint_Node (Array_Aggregate (Node)); Write_Char (';'); when N_Enumeration_Type_Definition => -- Skip attempt to print Literals field if it's not there and -- we are in package Standard (case of Character, which is -- handled specially (without an explicit literals list). if Sloc (Node) /= Standard_Location or else List_Present (Literals (Node)) then Sprint_Paren_Comma_List (Literals (Node)); end if; when N_Error => Write_String (""); when N_Exception_Declaration => if Write_Indent_Identifiers (Node) then Write_String (" : exception;"); end if; when N_Exception_Handler => Write_Indent_String ("when "); if Present (Choice_Parameter (Node)) then Sprint_Node (Choice_Parameter (Node)); Write_String (": "); end if; Sprint_Bar_List (Exception_Choices (Node)); Write_String (" => "); Sprint_Indented_List (Statements (Node)); when N_Exception_Renaming_Declaration => Write_Indent; Sprint_Node (Defining_Identifier (Node)); Write_String (" : exception renames "); Sprint_Node (Name (Node)); Write_Char (';'); when N_Exit_Statement => Write_Indent_String ("exit"); Sprint_Opt_Node (Name (Node)); if Present (Condition (Node)) then Write_String (" when "); Sprint_Node (Condition (Node)); end if; Write_Char (';'); when N_Explicit_Dereference => Do_Parens; Sprint_Node (Prefix (Node)); Write_String (".all"); when N_Expression_Actions => Write_Str (" ["); Sprint_Indented_List (Actions (Node)); Indent_Begin; Write_Indent; Sprint_Node (Expression (Node)); Indent_End; Write_Char (']'); when N_Extension_Aggregate => Do_Parens; Write_Char ('('); Sprint_Node (Expression (Node)); Write_String (" with "); if Null_Record_Present (Node) then Write_String ("null record"); else Sprint_Comma_List (Component_Associations (Node)); end if; Write_Char (')'); when N_Floating_Point_Definition => Write_String ("digits "); Sprint_Node (Digits_Expression (Node)); Sprint_Opt_Node (Real_Range_Specification (Node)); when N_Formal_Decimal_Fixed_Point_Definition => Write_String ("delta <> digits <>"); when N_Formal_Derived_Type_Definition => Write_String ("new "); Sprint_Node (Subtype_Mark (Node)); if Private_Present (Node) then Write_String (" with private"); end if; when N_Formal_Discrete_Type_Definition => Write_String ("<>"); when N_Formal_Floating_Point_Definition => Write_String ("digits <>"); when N_Formal_Modular_Type_Definition => Write_String ("mod <>"); when N_Formal_Object_Declaration => if Write_Indent_Identifiers (Node) then Write_String (" : "); if In_Present (Node) then Write_String ("in "); end if; if Out_Present (Node) then Write_String ("out "); end if; Sprint_Node (Subtype_Mark (Node)); if Present (Expression (Node)) then Write_String (" := "); Sprint_Node (Expression (Node)); end if; Write_Char (';'); end if; when N_Formal_Ordinary_Fixed_Point_Definition => Write_String ("delta <>"); when N_Formal_Package_Declaration => Write_Indent_String ("with package "); Write_Id (Defining_Identifier (Node)); Write_String (" is new "); Sprint_Node (Name (Node)); Write_String (" (<>);"); when N_Formal_Private_Type_Definition => if Abstract_Present (Node) then Write_String ("abstract "); end if; if Tagged_Present (Node) then Write_String ("tagged "); end if; if Limited_Present (Node) then Write_String ("limited "); end if; Write_String ("private"); when N_Formal_Signed_Integer_Type_Definition => Write_String ("range <>"); when N_Formal_Subprogram_Declaration => Write_Indent_String ("with "); Sprint_Node (Specification (Node)); if Box_Present (Node) then Write_String (" is <>"); elsif Present (Name (Node)) then Write_String (" is "); Sprint_Node (Name (Node)); end if; Write_Char (';'); when N_Formal_Type_Declaration => Write_Indent_String ("type "); Write_Id (Defining_Identifier (Node)); if List_Present (Discriminant_Specifications (Node)) then Sprint_Paren_Comma_List (Discriminant_Specifications (Node)); elsif Has_Unknown_Discriminants (Node) then Write_String ("(<>)"); end if; Write_String (" is "); Sprint_Node (Formal_Type_Definition (Node)); Write_Char (';'); when N_Freeze_Entity => if not Debug_Flag_O then Write_Indent; Write_Rewrite_String ("{"); Write_String ("freeze "); Write_Id (Entity (Node)); Write_Char (';'); Write_Rewrite_String ("}"); end if; when N_Full_Type_Declaration => Write_Indent_String ("type "); Write_Id (Defining_Identifier (Node)); Sprint_Opt_Paren_Comma_List (Discriminant_Specifications (Node)); Write_String (" is "); Sprint_Node (Type_Definition (Node)); Write_Char (';'); when N_Function_Call => Sprint_Node (Name (Node)); Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node)); when N_Function_Instantiation => Write_Indent_String ("function "); Sprint_Node (Defining_Unit_Name (Node)); Write_String (" is new "); Sprint_Node (Name (Node)); Sprint_Opt_Paren_Comma_List (Generic_Associations (Node)); when N_Function_Specification => Write_String ("function "); Sprint_Node (Defining_Unit_Name (Node)); Write_Param_Specs (Node); Write_String (" return "); Sprint_Node (Subtype_Mark (Node)); when N_Generic_Association => if Present (Selector_Name (Node)) then Sprint_Node (Selector_Name (Node)); Write_String (" => "); end if; Sprint_Node (Explicit_Generic_Actual_Parameter (Node)); when N_Generic_Function_Renaming_Declaration => Write_Indent_String ("generic function "); Sprint_Node (Defining_Unit_Name (Node)); Write_String (" renames "); Sprint_Node (Name (Node)); Write_Char (';'); when N_Generic_Package_Declaration => Write_Indent_String ("generic "); Sprint_Indented_List (Generic_Formal_Declarations (Node)); Write_Indent; Sprint_Node (Specification (Node)); Write_Char (';'); when N_Generic_Package_Renaming_Declaration => Write_Indent_String ("generic package "); Sprint_Node (Defining_Unit_Name (Node)); Write_String (" renames "); Sprint_Node (Name (Node)); Write_Char (';'); when N_Generic_Procedure_Renaming_Declaration => Write_Indent_String ("generic procedure "); Sprint_Node (Defining_Unit_Name (Node)); Write_String (" renames "); Sprint_Node (Name (Node)); Write_Char (';'); when N_Generic_Subprogram_Declaration => Write_Indent_String ("generic "); Sprint_Indented_List (Generic_Formal_Declarations (Node)); Write_Indent; Sprint_Node (Specification (Node)); Write_Char (';'); when N_Goto_Statement => Write_Indent_String ("goto "); Sprint_Node (Name (Node)); Write_Char (';'); when N_Handled_Sequence_Of_Statements => Sprint_Indented_List (Statements (Node)); if List_Present (Exception_Handlers (Node)) then Write_Indent_String ("exception"); Indent_Begin; Sprint_Node_List (Exception_Handlers (Node)); Indent_End; end if; if Present (Identifier (Node)) then Write_Indent_String ("at end"); Indent_Begin; Write_Indent; Sprint_Node (Identifier (Node)); Write_Char (';'); Indent_End; end if; when N_Identifier => Do_Parens; Write_Id (Node); when N_If_Statement => Write_Indent_String ("if "); Sprint_Node (Condition (Node)); Write_String (" then"); Sprint_Indented_List (Then_Statements (Node)); Sprint_Opt_Node_List (Elsif_Parts (Node)); if List_Present (Else_Statements (Node)) then Write_Indent_String ("else"); Sprint_Indented_List (Else_Statements (Node)); end if; Write_Indent_String ("end if;"); when N_Implicit_Label_Declaration => if not Debug_Flag_O then Write_Indent; Write_Rewrite_String ("{"); Write_Id (Defining_Identifier (Node)); Write_String (" : label"); Write_Rewrite_String ("}"); end if; when N_Implicit_Type => if not Debug_Flag_O then Write_Indent; Write_Rewrite_String ("{"); Write_String ("implicit "); Write_Implicit_Def (Defining_Identifier (Node)); Write_Rewrite_String ("}"); end if; when N_Incomplete_Type_Declaration => Write_Indent_String ("type "); Write_Id (Defining_Identifier (Node)); if List_Present (Discriminant_Specifications (Node)) then Sprint_Paren_Comma_List (Discriminant_Specifications (Node)); elsif Has_Unknown_Discriminants (Node) then Write_String ("(<>)"); end if; Write_Char (';'); when N_Index_Or_Discriminant_Constraint => Sprint_Paren_Comma_List (Constraints (Node)); when N_Indexed_Component => Do_Parens; Sprint_Node (Prefix (Node)); Sprint_Opt_Paren_Comma_List (Expressions (Node)); when N_Integer_Literal => Do_Parens; Write_Uint (Intval (Node)); when N_Iteration_Scheme => if Present (Condition (Node)) then Write_String ("while "); Sprint_Node (Condition (Node)); else Write_String ("for "); Sprint_Node (Loop_Parameter_Specification (Node)); end if; Write_Char (' '); when N_Label => Write_Indent_String ("<<"); Write_Id (Identifier (Node)); Write_String (">>"); when N_Loop_Parameter_Specification => Write_Id (Defining_Identifier (Node)); Write_String (" in "); if Reverse_Present (Node) then Write_String ("reverse "); end if; Sprint_Node (Discrete_Subtype_Definition (Node)); when N_Loop_Statement => Write_Indent; if Present (Identifier (Node)) and then (not Has_Created_Identifier (Node) or else not Debug_Flag_O) then Write_Rewrite_String ("{"); Write_Id (Identifier (Node)); Write_String (" : "); Write_Rewrite_String ("}"); Sprint_Node (Iteration_Scheme (Node)); Write_String ("loop"); Sprint_Indented_List (Statements (Node)); Write_Indent_String ("end loop "); Write_Rewrite_String ("{"); Write_Id (Identifier (Node)); Write_Rewrite_String ("}"); Write_Char (';'); else Sprint_Node (Iteration_Scheme (Node)); Write_String ("loop"); Sprint_Indented_List (Statements (Node)); Write_Indent_String ("end loop;"); end if; when N_Modular_Type_Definition => Write_String ("mod "); Sprint_Node (Expression (Node)); when N_Null => Do_Parens; Write_String ("null"); when N_Null_Statement => Write_Indent_String ("null;"); when N_Number_Declaration => if Write_Indent_Identifiers (Node) then Write_String (" : constant "); Write_String (" := "); Sprint_Node (Expression (Node)); end if; when N_Object_Declaration => if Write_Indent_Identifiers (Node) then Write_String (" : "); if Aliased_Present (Node) then Write_String ("aliased "); end if; if Constant_Present (Node) then Write_String ("constant "); end if; Sprint_Node (Object_Definition (Node)); if Present (Expression (Node)) then Write_String (" := "); Sprint_Node (Expression (Node)); end if; Write_Char (';'); end if; when N_Object_Renaming_Declaration => Write_Indent; Sprint_Node (Defining_Identifier (Node)); Write_String (" : "); Sprint_Node (Subtype_Mark (Node)); Write_String (" renames "); Sprint_Node (Name (Node)); Write_Char (';'); when N_Op_Abs => Do_Parens; Write_String ("abs "); Sprint_Node (Right_Opnd (Node)); when N_Op_Add => Do_Parens; Sprint_Node (Left_Opnd (Node)); Write_String (" + "); Sprint_Node (Right_Opnd (Node)); when N_Op_And => Do_Parens; Sprint_Node (Left_Opnd (Node)); Write_String (" and "); Sprint_Node (Right_Opnd (Node)); when N_Op_And_Then => Do_Parens; Sprint_Node (Left_Opnd (Node)); Write_String (" and then "); Sprint_Node (Right_Opnd (Node)); when N_Op_Concat => Do_Parens; Sprint_Node (Left_Opnd (Node)); Write_String (" & "); Sprint_Node (Right_Opnd (Node)); when N_Op_Divide => Do_Parens; Sprint_Node (Left_Opnd (Node)); Write_String (" / "); Sprint_Node (Right_Opnd (Node)); when N_Op_Eq => Do_Parens; Sprint_Node (Left_Opnd (Node)); Write_String (" = "); Sprint_Node (Right_Opnd (Node)); when N_Op_Expon => Do_Parens; Sprint_Node (Left_Opnd (Node)); Write_String (" ** "); Sprint_Node (Right_Opnd (Node)); when N_Op_Ge => Do_Parens; Sprint_Node (Left_Opnd (Node)); Write_String (" >= "); Sprint_Node (Right_Opnd (Node)); when N_Op_Gt => Do_Parens; Sprint_Node (Left_Opnd (Node)); Write_String (" > "); Sprint_Node (Right_Opnd (Node)); when N_Op_In => Do_Parens; Sprint_Node (Left_Opnd (Node)); Write_String (" in "); Sprint_Node (Right_Opnd (Node)); when N_Op_Le => Do_Parens; Sprint_Node (Left_Opnd (Node)); Write_String (" <= "); Sprint_Node (Right_Opnd (Node)); when N_Op_Lt => Do_Parens; Sprint_Node (Left_Opnd (Node)); Write_String (" < "); Sprint_Node (Right_Opnd (Node)); when N_Op_Minus => Do_Parens; Write_Char ('-'); Sprint_Node (Right_Opnd (Node)); when N_Op_Mod => Do_Parens; Sprint_Node (Left_Opnd (Node)); Write_String (" mod "); Sprint_Node (Right_Opnd (Node)); when N_Op_Multiply => Do_Parens; Sprint_Node (Left_Opnd (Node)); Write_String (" * "); Sprint_Node (Right_Opnd (Node)); when N_Op_Ne => Do_Parens; Sprint_Node (Left_Opnd (Node)); Write_String (" /= "); Sprint_Node (Right_Opnd (Node)); when N_Op_Not => Do_Parens; Write_String ("not "); Sprint_Node (Right_Opnd (Node)); when N_Op_Not_In => Do_Parens; Sprint_Node (Left_Opnd (Node)); Write_String (" not in "); Sprint_Node (Right_Opnd (Node)); when N_Op_Or => Do_Parens; Sprint_Node (Left_Opnd (Node)); Write_String (" or "); Sprint_Node (Right_Opnd (Node)); when N_Op_Or_Else => Do_Parens; Sprint_Node (Left_Opnd (Node)); Write_String (" or else "); Sprint_Node (Right_Opnd (Node)); when N_Op_Plus => Do_Parens; Write_Char ('+'); Sprint_Node (Right_Opnd (Node)); when N_Op_Rem => Do_Parens; Sprint_Node (Left_Opnd (Node)); Write_String (" rem "); Sprint_Node (Right_Opnd (Node)); when N_Op_Subtract => Do_Parens; Sprint_Node (Left_Opnd (Node)); Write_String (" - "); Sprint_Node (Right_Opnd (Node)); when N_Op_Xor => Do_Parens; Sprint_Node (Left_Opnd (Node)); Write_String (" xor "); Sprint_Node (Right_Opnd (Node)); when N_Operator_Symbol => Get_Name_String (Chars (Node)); for I in 1 .. Name_Len loop Write_Char (Name_Buffer (I)); end loop; when N_Ordinary_Fixed_Point_Definition => Write_String ("delta "); Sprint_Node (Delta_Expression (Node)); Sprint_Opt_Node (Real_Range_Specification (Node)); when N_Others_Choice => Write_String ("others"); when N_Package_Body => Write_Indent_String ("package body "); Sprint_Node (Defining_Unit_Name (Node)); Write_String (" is"); Sprint_Indented_List (Declarations (Node)); if Present (Handled_Statement_Sequence (Node)) then Write_Indent_String ("begin"); Sprint_Node (Handled_Statement_Sequence (Node)); end if; Write_Indent_String ("end "); Sprint_Node (Defining_Unit_Name (Node)); Write_Char (';'); when N_Package_Body_Stub => Write_Indent_String ("package_body "); Sprint_Node (Defining_Identifier (Node)); Write_String (" is separate;"); when N_Package_Declaration => Write_Indent; Sprint_Node (Specification (Node)); Write_Char (';'); when N_Package_Instantiation => Write_Indent_String ("package "); Sprint_Node (Defining_Unit_Name (Node)); Write_String (" is new "); Sprint_Node (Name (Node)); Sprint_Opt_Paren_Comma_List (Generic_Associations (Node)); when N_Package_Renaming_Declaration => Write_Indent_String ("package "); Sprint_Node (Defining_Unit_Name (Node)); Write_String (" renames "); Sprint_Node (Name (Node)); Write_Char (';'); when N_Package_Specification => Write_String ("package "); Sprint_Node (Defining_Unit_Name (Node)); Write_String (" is"); Sprint_Indented_List (Visible_Declarations (Node)); if List_Present (Private_Declarations (Node)) then Write_Indent_String ("private"); Sprint_Indented_List (Private_Declarations (Node)); end if; Write_Indent_String ("end "); Sprint_Node (Defining_Unit_Name (Node)); when N_Parameter_Association => Sprint_Node (Selector_Name (Node)); Write_String (" =>"); Sprint_Node (Actual_Parameter (Node)); when N_Parameter_Specification => if Write_Identifiers (Node) then Write_String (" : "); if In_Present (Node) then Write_String ("in "); end if; if Out_Present (Node) then Write_String ("out "); end if; Sprint_Node (Parameter_Type (Node)); if Present (Expression (Node)) then Write_String (" := "); Sprint_Node (Expression (Node)); end if; end if; when N_Parenthesized_Expression => Do_Parens; Write_Char ('('); Sprint_Node (Expression (Node)); Write_Char (')'); when N_Pragma => Write_Indent_String ("pragma "); Write_Id (Identifier (Node)); if List_Present (Pragma_Argument_Associations (Node)) then Sprint_Opt_Paren_Comma_List (Pragma_Argument_Associations (Node)); end if; Write_Char (';'); when N_Pragma_Argument_Association => if Present (Identifier (Node)) then Write_Id (Identifier (Node)); Write_String (" => "); end if; Sprint_Node (Expression (Node)); when N_Private_Type_Declaration => Write_Indent_String ("type "); Write_Id (Defining_Identifier (Node)); if List_Present (Discriminant_Specifications (Node)) then Sprint_Paren_Comma_List (Discriminant_Specifications (Node)); elsif Has_Unknown_Discriminants (Node) then Write_String ("(<>)"); end if; Write_String (" is "); if Tagged_Present (Node) then Write_String ("tagged "); end if; if Limited_Present (Node) then Write_String ("limited "); end if; Write_String ("private;"); when N_Private_Extension_Declaration => Write_Indent_String ("type "); Write_Id (Defining_Identifier (Node)); if List_Present (Discriminant_Specifications (Node)) then Sprint_Paren_Comma_List (Discriminant_Specifications (Node)); elsif Has_Unknown_Discriminants (Node) then Write_String ("(<>)"); end if; Write_String (" is new "); Sprint_Node (Subtype_Indication (Node)); Write_String (" with private;"); when N_Procedure_Call_Statement => Write_Indent; Sprint_Node (Name (Node)); Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node)); Write_Char (';'); when N_Procedure_Instantiation => Write_Indent_String ("procedure "); Sprint_Node (Defining_Unit_Name (Node)); Write_String (" is new "); Sprint_Node (Name (Node)); Sprint_Opt_Paren_Comma_List (Generic_Associations (Node)); when N_Procedure_Specification => Write_String ("procedure "); Sprint_Node (Defining_Unit_Name (Node)); Write_Param_Specs (Node); when N_Protected_Body => Write_Indent_String ("protected body "); Write_Id (Defining_Identifier (Node)); Write_String (" is"); Sprint_Indented_List (Declarations (Node)); Write_Indent_String ("end "); Write_Id (Defining_Identifier (Node)); Write_Char (';'); when N_Protected_Body_Stub => Write_Indent_String ("protected body "); Write_Id (Defining_Identifier (Node)); Write_String (" is separate;"); when N_Protected_Definition => Sprint_Indented_List (Visible_Declarations (Node)); if List_Present (Private_Declarations (Node)) then Write_Indent_String ("private"); Sprint_Indented_List (Private_Declarations (Node)); end if; Write_Indent_String ("end "); Write_Id (Defining_Identifier (Parent (Node))); when N_Protected_Type_Declaration => Write_Indent_String ("protected type "); Write_Id (Defining_Identifier (Node)); Sprint_Opt_Paren_Comma_List (Discriminant_Specifications (Node)); Write_String (" is"); Sprint_Node (Protected_Definition (Node)); Write_Char (';'); when N_Qualified_Expression => Do_Parens; Sprint_Node (Subtype_Mark (Node)); Write_String ("'"); Sprint_Node (Expression (Node)); when N_Raise_Statement => Write_Indent_String ("raise "); Sprint_Node (Name (Node)); Write_Char (';'); when N_Range => Sprint_Node (Low_Bound (Node)); Write_String (" .. "); Sprint_Node (High_Bound (Node)); when N_Range_Constraint => Write_String ("range "); Sprint_Node (Range_Expression (Node)); when N_Real_Literal => Do_Parens; Write_Real_Value (Node); when N_Real_Range_Specification => Write_String ("range "); Sprint_Node (Low_Bound (Node)); Write_String (" .. "); Sprint_Node (High_Bound (Node)); when N_Record_Definition => if Abstract_Present (Node) then Write_String ("abstract "); end if; if Tagged_Present (Node) then Write_String ("tagged "); end if; if Limited_Present (Node) then Write_String ("limited "); end if; if Null_Present (Node) then Write_String ("null record"); else Write_String ("record"); if not Debug_Flag_O and then List_Present (Implicit_Types (Node)) then Sprint_Indented_List (Implicit_Types (Node)); end if; Sprint_Node (Component_List (Node)); Write_Indent_String ("end record"); end if; when N_Record_Representation_Clause => Write_Indent_String ("for "); Sprint_Node (Identifier (Node)); Write_String (" use record "); if Present (Mod_Clause (Node)) then Sprint_Node (Mod_Clause (Node)); end if; Sprint_Indented_List (Component_Clauses (Node)); Write_Indent_String ("end record;"); when N_Reference => Sprint_Node (Expression (Node)); Write_String ("'reference"); when N_Requeue_Statement => Write_Indent_String ("requeue "); Sprint_Node (Name (Node)); if Abort_Present (Node) then Write_String (" with abort"); end if; Write_Char (';'); when N_Return_Statement => if Present (Expression (Node)) then Write_Indent_String ("return "); Sprint_Node (Expression (Node)); Write_Char (';'); else Write_Indent_String ("return;"); end if; when N_Selective_Accept => Write_Indent_String ("select"); declare Alt_Node : Node_Id; begin Alt_Node := First (Selective_Accept_Alternatives (Node)); loop Indent_Begin; Sprint_Node (Alt_Node); Indent_End; Alt_Node := Next (Alt_Node); exit when Alt_Node = Empty; Write_Indent_String ("or"); end loop; end; if List_Present (Else_Statements (Node)) then Write_Indent_String ("else"); Sprint_Indented_List (Else_Statements (Node)); end if; Write_Indent_String ("end select;"); when N_Signed_Integer_Type_Definition => Write_String ("range "); Sprint_Node (Low_Bound (Node)); Write_String (" .. "); Sprint_Node (High_Bound (Node)); when N_Single_Protected_Declaration => Write_Indent_String ("protected "); Write_Id (Defining_Identifier (Node)); if Present (Protected_Definition (Node)) then Write_String (" is"); Sprint_Node (Protected_Definition (Node)); end if; Write_Char (';'); when N_Single_Task_Declaration => Write_Indent_String ("task "); Write_Id (Defining_Identifier (Node)); if Present (Task_Definition (Node)) then Write_String (" is"); Sprint_Node (Task_Definition (Node)); end if; Write_Char (';'); when N_Selected_Component | N_Expanded_Name => Do_Parens; Sprint_Node (Prefix (Node)); Write_Char ('.'); Sprint_Node (Selector_Name (Node)); when N_Slice => Do_Parens; Sprint_Node (Prefix (Node)); Write_String (" ("); Sprint_Node (Discrete_Range (Node)); Write_Char (')'); when N_String_Literal => Do_Parens; Write_String_Table_Entry (Strval (Node)); when N_Subprogram_Body => Write_Indent; Write_Indent; Sprint_Node (Specification (Node)); Write_String (" is"); Sprint_Indented_List (Declarations (Node)); Write_Indent_String ("begin"); Sprint_Node (Handled_Statement_Sequence (Node)); Write_Indent_String ("end "); Sprint_Node (Defining_Unit_Name (Specification (Node))); Write_Char (';'); if Is_List_Member (Node) and then Present (Next (Node)) and then Nkind (Next (Node)) /= N_Subprogram_Body then Write_Indent; end if; when N_Subprogram_Body_Stub => Write_Indent; Sprint_Node (Specification (Node)); Write_String (" is separate;"); when N_Subprogram_Declaration => Write_Indent; Sprint_Node (Specification (Node)); Write_Char (';'); when N_Subprogram_Renaming_Declaration => Write_Indent; Sprint_Node (Specification (Node)); Write_String (" ranames "); Sprint_Node (Name (Node)); Write_Char (';'); when N_Subtype_Declaration => Write_Indent_String ("subtype "); Write_Id (Defining_Identifier (Node)); Write_String (" is "); Sprint_Node (Subtype_Indication (Node)); Write_Char (';'); when N_Subtype_Indication => Sprint_Node (Subtype_Mark (Node)); Write_Char (' '); Sprint_Node (Constraint (Node)); when N_Subunit => Write_Indent_String ("separate ("); Sprint_Node (Name (Node)); Write_Char (')'); Write_Eol; Sprint_Node (Proper_Body (Node)); when N_Task_Body => Write_Indent_String ("task body "); Write_Id (Defining_Identifier (Node)); Write_String (" is"); Sprint_Indented_List (Declarations (Node)); Write_Indent_String ("begin"); Sprint_Node (Handled_Statement_Sequence (Node)); Write_Indent_String ("end "); Write_Id (Defining_Identifier (Node)); Write_Char (';'); when N_Task_Body_Stub => Write_Indent_String ("task body "); Write_Id (Defining_Identifier (Node)); Write_String (" is separate;"); when N_Task_Definition => Sprint_Indented_List (Visible_Declarations (Node)); if List_Present (Private_Declarations (Node)) then Write_Indent_String ("private"); Sprint_Indented_List (Private_Declarations (Node)); end if; Write_Indent_String ("end "); Write_Id (Defining_Identifier (Parent (Node))); when N_Task_Type_Declaration => Write_Indent_String ("task type "); Write_Id (Defining_Identifier (Node)); Sprint_Opt_Paren_Comma_List (Discriminant_Specifications (Node)); Write_String (" is"); Sprint_Node (Task_Definition (Node)); Write_Char (';'); when N_Terminate_Alternative => if Present (Condition (Node)) then Write_Indent; Write_String ("when "); Sprint_Node (Condition (Node)); Write_String (" => terminate;"); else Write_String ("terminate;"); end if; Sprint_Node_List (Statements (Node)); when N_Timed_Entry_Call => Write_Indent_String ("select"); Indent_Begin; Sprint_Node (Entry_Call_Alternative (Node)); Indent_End; Write_Indent_String ("or"); Indent_Begin; Sprint_Node (Delay_Alternative (Node)); Indent_End; Write_Indent_String ("end select;"); when N_Triggering_Alternative => Sprint_Node (Triggering_Statement (Node)); Sprint_Node_List (Statements (Node)); when N_Type_Conversion => Do_Parens; Sprint_Node (Subtype_Mark (Node)); if Unchecked_Conversion (Node) then Write_String ("!("); else Write_String (" ("); end if; Sprint_Node (Expression (Node)); Write_Char (')'); when N_Unconstrained_Array_Definition => Write_String ("array ("); declare Node1 : Node_Id := First (Subtype_Marks (Node)); begin loop Sprint_Node (Node1); Write_String (" range <>"); Node1 := Next (Node1); exit when Node1 = Empty; Write_String (", "); end loop; end; Write_String (") of "); if Aliased_Present (Node) then Write_String ("aliased "); end if; Sprint_Node (Subtype_Indication (Node)); when N_Unused_At_Start | N_Unused_At_End => Write_Indent_String ("***** Error, unused node encountered *****"); Write_Eol; when N_Use_Package_Clause => Write_Indent_String ("use "); Sprint_Comma_List (Names (Node)); Write_Char (';'); when N_Use_Type_Clause => Write_Indent_String ("use type "); Sprint_Comma_List (Subtype_Marks (Node)); Write_Char (';'); when N_Variant => Write_Indent_String ("when "); Sprint_Bar_List (Discrete_Choices (Node)); Write_String (" => "); Sprint_Node (Component_List (Node)); when N_Variant_Part => Indent_Begin; Write_Indent_String ("case "); Sprint_Node (Name (Node)); Write_String (" is "); Sprint_Indented_List (Variants (Node)); when N_With_Clause => if First_Name (Node) or else not Debug_Flag_O then Write_Indent_String ("with "); else Write_String (", "); end if; Sprint_Node (Name (Node)); if Last_Name (Node) or else not Debug_Flag_O then Write_Char (';'); end if; end case; if Paren_Flag then Write_Char (')'); end if; end Sprint_Node_Actual; ---------------------- -- Sprint_Node_List -- ---------------------- procedure Sprint_Node_List (List : List_Id) is Node : Node_Id; begin if Is_Non_Empty_List (List) then Node := First (List); loop Sprint_Node (Node); Node := Next (Node); exit when Node = Empty; end loop; end if; end Sprint_Node_List; --------------------- -- Sprint_Opt_Node -- --------------------- procedure Sprint_Opt_Node (Node : Node_Id) is begin if Present (Node) then Write_Char (' '); Sprint_Node (Node); end if; end Sprint_Opt_Node; -------------------------- -- Sprint_Opt_Node_List -- -------------------------- procedure Sprint_Opt_Node_List (List : List_Id) is begin if List_Present (List) then Sprint_Node_List (List); end if; end Sprint_Opt_Node_List; --------------------------------- -- Sprint_Opt_Paren_Comma_List -- --------------------------------- procedure Sprint_Opt_Paren_Comma_List (List : List_Id) is begin if List_Present (List) then Write_Char (' '); Sprint_Paren_Comma_List (List); end if; end Sprint_Opt_Paren_Comma_List; ----------------------------- -- Sprint_Paren_Comma_List -- ----------------------------- procedure Sprint_Paren_Comma_List (List : List_Id) is begin if Is_Non_Empty_List (List) then Write_Char ('('); Sprint_Comma_List (List); Write_Char (')'); end if; end Sprint_Paren_Comma_List; ----------------- -- Write_Ekind -- ----------------- procedure Write_Ekind (E : Entity_Id) is Ucase : Boolean; S : constant String := Entity_Kind'Image (Ekind (E)); begin Ucase := True; for I in S'First + 2 .. S'Last loop if Ucase then Write_Char (Fold_Upper (To_Char (S (I)))); else Write_Char (Fold_Lower (To_Char (S (I)))); end if; Ucase := (S (I) = '_'); end loop; end Write_Ekind; -------------- -- Write_Id -- -------------- procedure Write_Id (Id : Node_Id) is begin Write_Name (Chars (Id)); end Write_Id; ----------------------- -- Write_Identifiers -- ----------------------- function Write_Identifiers (Node : Node_Id) return Boolean is begin -- If we are printing the original tree, and this is not the first -- defining identifier in the list, then we must output a comma to -- separate this name from the list. if Debug_Flag_O and then Prev_Ids (Node) then Write_String (", "); end if; Sprint_Node (Defining_Identifier (Node)); -- The remainder of the declaration must be printed unless we are -- printing the original tree and this is not the last identifier return not Debug_Flag_O or else not More_Ids (Node); end Write_Identifiers; ------------------------ -- Write_Implicit_Def -- ------------------------ procedure Write_Implicit_Def (E : Entity_Id) is Ind : Node_Id; begin case Ekind (E) is when E_Array_Subtype => Write_String ("subtype "); Write_Id (E); Write_String (" is "); Write_Id (Base_Type (E)); Write_String (" ("); Ind := First_Index (E); while Present (Ind) loop Sprint_Node (Ind); Ind := Next_Index (Ind); if Present (Ind) then Write_String (", "); end if; end loop; Write_String (");"); when E_Integer_Subtype | E_Enumeration_Subtype => Write_String ("subtype "); Write_Id (E); Write_String (" is "); Write_Id (Etype (E)); Write_String (" range "); Sprint_Node (Scalar_Range (E)); Write_String (";"); when others => Write_String ("type "); Write_Id (E); Write_String (" is <"); Write_Ekind (E); Write_String (">;"); end case; end Write_Implicit_Def; ------------------ -- Write_Indent -- ------------------ procedure Write_Indent is begin if Indent_Annull_Flag then Indent_Annull_Flag := False; else Write_Eol; for I in 1 .. Indent loop Write_Char (' '); end loop; end if; end Write_Indent; ------------------------------ -- Write_Indent_Identifiers -- ------------------------------ function Write_Indent_Identifiers (Node : Node_Id) return Boolean is begin -- We need to start a new line for every node, except in the case -- where we are printing the original tree and this is not the first -- defining identifier in the list. if not Debug_Flag_O or else not Prev_Ids (Node) then Write_Indent; -- If printing original tree and this is not the first defining -- identifier in the list, then the previous call to this procedure -- printed only the name, and we add a comma to separate the names. else Write_String (", "); end if; Sprint_Node (Defining_Identifier (Node)); -- The remainder of the declaration must be printed unless we are -- printing the original tree and this is not the last identifier return not Debug_Flag_O or else not More_Ids (Node); end Write_Indent_Identifiers; ------------------------- -- Write_Indent_String -- ------------------------- procedure Write_Indent_String (S : String) is begin Write_Indent; Write_String (S); end Write_Indent_String; ----------------------- -- Write_Param_Specs -- ----------------------- procedure Write_Param_Specs (N : Node_Id) is Specs : List_Id; Spec : Node_Id; begin Specs := Parameter_Specifications (N); if List_Present (Specs) then Write_String (" ("); Spec := First (Specs); loop Sprint_Node (Spec); Spec := Next (Spec); exit when Spec = Empty; -- Add semicolon, unless we are printing original tree and the -- next specification is part of a list (but not the first -- element of that list) if not Debug_Flag_O or else not Prev_Ids (Spec) then Write_String ("; "); end if; if Column > 70 then Write_Indent_String (" "); end if; end loop; Write_Char (')'); end if; end Write_Param_Specs; ---------------------- -- Write_Real_Value -- ---------------------- procedure Write_Real_Value (Node : Node_Id) is begin if Decimal (Node) then Write_Uint (Numerator (Node)); Write_String (".0"); if Denominator (Node) /= Uint_0 then Write_String ("E"); Write_Uint (Denominator (Node)); end if; else Write_Char ('['); Write_Uint (Numerator (Node)); Write_String (" / "); Write_Uint (Denominator (Node)); Write_Char (']'); end if; end Write_Real_Value; -------------------------- -- Write_Rewrite_String -- -------------------------- procedure Write_Rewrite_String (S : String) is begin if not Debug_Flag_G then Write_String (S); end if; end Write_Rewrite_String; ---------------- -- Write_Uint -- ---------------- procedure Write_Uint (U : Uint) is begin Get_Name_String (UI_Image (U)); for I in 1 .. Name_Len loop Write_Char (Name_Buffer (I)); end loop; end Write_Uint; end Sprint; Write_String (", "); end if; Sprint_Node (Name (Node)); if Last_Name (Node) or else not Debug_Flag_O then Write_Char (';'); end if; end case; if Paren_Flag then Write_Char (')'); end if; end Sprint_Node_Actual; ---------------------- -- Sprint_Node_List -- ---------------------- procedure Sprint_Node_List (List : List_Id) is Node : Nodgnat-1.67-src/src/stand.ads 444 10015 7640 27700 5506244433 10746 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S T A N D -- -- -- -- S p e c -- -- -- -- $Revision: 1.32 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This package contains the declarations of entities in package Standard, -- and the routine for creating the tree representation of Standard with Types; use Types; with Namet; use Namet; pragma Elaborate (Namet); package Stand is type Standard_Entity_Type is ( -- This enumeration type contains an entry for each name in Standard -- Package names S_Standard, S_Ascii, -- Types defined in package Standard S_Boolean, S_Character, S_String, S_Duration, S_Short_Short_Integer, S_Short_Integer, S_Integer, S_Long_Integer, S_Long_Long_Integer, S_Short_Float, S_Float, S_Long_Float, S_Long_Long_Float, -- Enumeration literals for type Boolean S_False, S_True, -- Subtypes declared in package Standard S_Natural, S_Positive, -- Exceptions declared in package Standard S_Constraint_Error, S_Numeric_Error, S_Program_Error, S_Storage_Error, S_Tasking_Error, -- Constants defined in package Ascii (with value in hex). -- First the thirty-two C0 control characters) S_NUL, -- 16#00# S_SOH, -- 16#01# S_STX, -- 16#02# S_ETX, -- 16#03# S_EOT, -- 16#04# S_ENQ, -- 16#05# S_ACK, -- 16#06# S_BEL, -- 16#07# S_BS, -- 16#08# S_HT, -- 16#09# S_LF, -- 16#0A# S_VT, -- 16#0B# S_FF, -- 16#0C# S_CR, -- 16#0D# S_SO, -- 16#0E# S_SI, -- 16#0F# S_DLE, -- 16#10# S_DC1, -- 16#11# S_DC2, -- 16#12# S_DC3, -- 16#13# S_DC4, -- 16#14# S_NAK, -- 16#15# S_SYN, -- 16#16# S_ETB, -- 16#17# S_CAN, -- 16#18# S_EM, -- 16#19# S_SUB, -- 16#1A# S_ESC, -- 16#1B# S_FS, -- 16#1C# S_GS, -- 16#1D# S_RS, -- 16#1E# S_US, -- 16#1F# -- Here are the ones for Colonel Whitaker's O26 keypunch! S_Exclam, -- 16#21# S_Quotation, -- 16#22# S_Sharp, -- 16#23# S_Dollar, -- 16#24# S_Percent, -- 16#25# S_Ampersand, -- 16#26# S_Colon, -- 16#3A# S_Semicolon, -- 16#3B# S_Query, -- 16#3F# S_At_Sign, -- 16#40# S_L_Bracket, -- 16#5B# S_Back_Slash, -- 16#5C# S_R_Bracket, -- 16#5D# S_Circumflex, -- 16#5E# S_Underline, -- 16#5F# S_Grave, -- 16#60# S_LC_A, -- 16#61# S_LC_B, -- 16#62# S_LC_C, -- 16#63# S_LC_D, -- 16#64# S_LC_E, -- 16#65# S_LC_F, -- 16#66# S_LC_G, -- 16#67# S_LC_H, -- 16#68# S_LC_I, -- 16#69# S_LC_J, -- 16#6A# S_LC_K, -- 16#6B# S_LC_L, -- 16#6C# S_LC_M, -- 16#6D# S_LC_N, -- 16#6E# S_LC_O, -- 16#6F# S_LC_P, -- 16#70# S_LC_Q, -- 16#71# S_LC_R, -- 16#72# S_LC_S, -- 16#73# S_LC_T, -- 16#74# S_LC_U, -- 16#75# S_LC_V, -- 16#76# S_LC_W, -- 16#77# S_LC_X, -- 16#78# S_LC_Y, -- 16#79# S_LC_Z, -- 16#7A# S_L_BRACE, -- 16#7B# S_BAR, -- 16#7C# S_R_BRACE, -- 16#7D# S_TILDE, -- 16#7E# -- And one more control character, all on its own S_DEL); -- 16#7F# subtype S_Types is Standard_Entity_Type range S_Boolean .. S_Long_Long_Float; subtype S_Exceptions is Standard_Entity_Type range S_Constraint_Error .. S_Tasking_Error; subtype S_Ascii_Names is Standard_Entity_Type range S_NUL .. S_DEL; type Standard_Entity_Array_Type is array (Standard_Entity_Type) of Node_Id; Standard_Entity : Standard_Entity_Array_Type; -- This array contains pointers to the Defining Identifier nodes -- for each of the entities defined in Standard_Entities_Type. It -- is initialized by the Create_Standard procedure. Standard_Package_Node : Node_Id; -- Points to the N_Package_Declaration node for standard. Also -- initialized by the Create_Standard procedure. -- The following Entities are the pointers to the Defining Identifier -- nodes for some visible entities defined in Standard_Entities_Type. SE : Standard_Entity_Array_Type renames Standard_Entity; Standard_Standard : Entity_Id renames SE (S_Standard); Standard_Ascii : Entity_Id renames SE (S_Ascii); Standard_Character : Entity_Id renames SE (S_Character); Standard_String : Entity_Id renames SE (S_String); Standard_Boolean : Entity_Id renames SE (S_Boolean); Standard_False : Entity_Id renames SE (S_False); Standard_True : Entity_Id renames SE (S_True); Standard_Duration : Entity_Id renames SE (S_Duration); Standard_Natural : Entity_Id renames SE (S_Natural); Standard_Positive : Entity_Id renames SE (S_Positive); Standard_Constraint_Error : Entity_Id renames SE (S_Constraint_Error); Standard_Numeric_Error : Entity_Id renames SE (S_Numeric_Error); Standard_Program_Error : Entity_Id renames SE (S_Program_Error); Standard_Storage_Error : Entity_Id renames SE (S_Storage_Error); Standard_Tasking_Error : Entity_Id renames SE (S_Tasking_Error); Standard_Short_Float : Entity_Id renames SE (S_Short_Float); Standard_Float : Entity_Id renames SE (S_Float); Standard_Long_Float : Entity_Id renames SE (S_Long_Float); Standard_Long_Long_Float : Entity_Id renames SE (S_Long_Long_Float); Standard_Short_Integer : Entity_Id renames SE (S_Short_Integer); Standard_Short_Short_Integer : Entity_Id renames SE (S_Short_Short_Integer); Standard_Integer : Entity_Id renames SE (S_Integer); Standard_Long_Integer : Entity_Id renames SE (S_Long_Integer); Standard_Long_Long_Integer : Entity_Id renames SE (S_Long_Long_Integer); Standard_Longest_Runtime_Integer : Entity_Id renames Standard_Long_Long_Integer; Standard_Longest_Runtime_Real : Entity_Id renames Standard_Long_Long_Float; procedure Create_Standard; -- This procedure creates the tree for package standard, and initializes -- the Standard_Entities array and Standard_Package_Node. Only the -- syntactic representation is created (as though the parser had parsed -- a copy of the source of Standard) and then semantic information is -- added as it would be by the semantic phases of the compiler. The -- tree is in the standard format defined by Syntax_Info, except that -- all Sloc values are set to Standard_Location. The semantics info is -- in the format given by Entity_Info. Create_Standard also initializes -- the following global variables: Last_Standard_Node_Id : Node_Id; -- Highest Node_Id value used by Standard Last_Standard_List_Id : List_Id; -- Highest List_Id value used by Standard (including those used by -- normal list headers, element list headers, and list elements) Last_Standard_Name_Id : Name_Id; -- Highest Name_Id value used by Standard (includes all the predefined -- names for pragmas, attributes etc defined in Snames package). Last_Standard_String_Id : String_Id; -- Highest String_Id value used by Standard Last_Standard_Uint : Uint; -- Highest Uint table entry value used by Standard ------------------------------------- -- Semantic Phase Special Entities -- ------------------------------------- -- The semantic phase needs a number of entities for internal processing -- that are logically at the level of Standard, and hence defined in this -- package. However, they are never directly visible to a program, and -- are not chained on to the Decls list of Standard. The names of all -- these types are relevant only in certain debugging and error message -- situations. They are all of the form "" to clearly -- distinguish them from any program identifiers. Standard_Void_Type : Entity_Id; -- This is a type used to represent the return type of procedures Standard_Exception_Type : Entity_Id; -- This is a type used to represent the Etype of exceptions. Standard_A_String : Entity_Id; -- An access to String type used for building elements of tables -- carrying the enumeration literal names. Any_Id : Entity_Id; -- Used to represent some unknown identifier. Avoids cascaded errors Any_Type : Entity_Id; -- Used to represent some unknown type. Avoids cascaded errors Any_Access : Entity_Id; -- Used to resolve the overloaded literal NULL. Any_Boolean : Entity_Id; -- The context type of conditions in IF and WHILE statements. Any_Character : Entity_Id; -- Any_Character is used to label character literals, which in general -- will not have an explicit declaration (this is true of the predefined -- character types). Any_Integer : Entity_Id; -- Used to represent some unknown integer type. Avoids cascaded errors Any_String : Entity_Id; -- The type Any_String is used for string literals before type -- resolution. It corresponds to array (Positive range <>) of Char -- but the component type is compatible with any character type, -- not just Standard_Character. Any_Composite : Entity_Id; -- The type Any_Composite is used for aggregates before type resolution. -- It is compatible with any array or non-limited record type. Universal_Integer : Entity_Id; -- Entity for universal integer type Universal_Real : Entity_Id; -- Entity for universal real type end Stand; -- 16#1E# S_US, -- 16#1F# -- Hergnat-1.67-src/src/stand.adb 444 10015 7640 66273 5506244434 10736 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S T A N D -- -- -- -- B o d y -- -- -- -- $Revision: 1.79 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Csets; use Csets; with Einfo; use Einfo; with Nmake; use Nmake; with Opt; use Opt; with Ttypes; use Ttypes; with Stringt; use Stringt; with Sinfo; use Sinfo; with Snames; use Snames; with Uintp; use Uintp; package body Stand is -- WARNING! If any change is made to this module which would affect the format -- of library information, then the following standard version string must be -- updated so that previously compiled library modules will be recognized as -- obsolete and rejected by the library manager. ----------------------- -- Local Subprograms -- ----------------------- function Identifier_For (S : Standard_Entity_Type) return Node_Id; -- Returns an identifier node with the same name as the defining -- identifier corresponding to the given Standard_Entity_Type value procedure Make_Name (Id : Entity_Id; Nam : String); -- Make an entry in the names table for Nam, and set as Chars field of Id procedure Create_Operators; -- Make entries for each of the predefined operators in Standard ---------------------- -- Create_Standard -- ---------------------- procedure Create_Standard is -- The AST for the package Standard is prefixed to all compilations. -- Several entities required by semantic analysis are denoted by global -- variables that are initialized to point to the corresponding -- occurences in STANDARD. The visible entities of STANDARD are -- created here. The private entities defined in STANDARD are created -- by Initialize_Standard in the semantics module. Decl_S : List_Id; -- list of declarations in Standard Decl_A : List_Id; -- list of declarations in Ascii Decl : Node_Id; -- node for full type declaration Pspec : Node_Id; -- node for package specification node Tdef_Node : Node_Id; -- node for type definition Ident_Node : Node_Id; -- identifier node Ccode : Char_Code; -- character code value, used for values in Ascii E_Id : Entity_Id; -- temporary entity id R_Node : Node_Id; -- range node to hold bounds of scalar types B_Node : Node_Id; -- to hold each bound. Uint_31 : Uint := UI_From_Int (31); -- Procedure to set bounds for integer type or subtype. Id is the entity -- whose bounds and type are to be set. The Typ parameter is the Etype -- value for the entity (which will be the same as Id for all predefined -- integer base types. The third and fourth parameters are the bounds. procedure Set_Integer_Bounds (Id : Entity_Id; Typ : Entity_Id; Lb, Hb : Uint) is L, H : Node_Id; -- to hold literal values of bounds R : Node_Id; -- Range specification begin L := Make_Integer_Literal (Standard_Location, Lb); Set_Etype (L, Typ); Set_Is_Evaluated (L, True); Set_Is_Static (L, True); H := Make_Integer_Literal (Standard_Location, Hb); Set_Etype (H, Typ); Set_Is_Evaluated (H, True); Set_Is_Static (H, True); R := New_Node (N_Range, Standard_Location); Set_Low_Bound (R, L); Set_High_Bound (R, H); Set_Scalar_Range (Id, R); end Set_Integer_Bounds; -- Procedure to declare given entity as an exception procedure Build_Exception (S : Standard_Entity_Type) is begin Set_Ekind (Standard_Entity (S), E_Exception); Set_Etype (Standard_Entity (S), Standard_Exception_Type); Set_Is_Public (Standard_Entity (S)); Decl := Make_Exception_Declaration (Standard_Location, Defining_Identifier => Standard_Entity (S)); Append (Decl, Decl_S); end Build_Exception; -- Procedure to build standard predefined integer base type. The first -- parameter is the entity for the type, and the second parameter is -- the size in bits. procedure Build_Integer_Type (E : Entity_Id; Siz : Int) is Lbound : Uint; Ubound : Uint; begin Ubound := UI_Difference (UI_Power (Siz - 1), Uint_1); if Ones_Complement then Lbound := UI_Negate (Ubound); else Lbound := UI_Negate (UI_Power (Siz - 1)); end if; Set_Type_Definition (Parent (E), Make_Signed_Integer_Type_Definition (Standard_Location, Low_Bound => Make_Integer_Literal (Standard_Location, Lbound), High_Bound => Make_Integer_Literal (Standard_Location, Ubound))); Set_Ekind (E, E_Integer_Type); Set_Etype (E, E); Set_Esize (E, UI_From_Int (Siz)); Set_Integer_Bounds (E, E, Lbound, Ubound); end Build_Integer_Type; -- Procedure to build standard predefined float base type. The first -- parameter is the entity for the type, and the second parameter -- is the size in bits. The third parameter is the digits value. procedure Build_Float_Type (E : Entity_Id; Siz : Int; Digs : Int) is begin Set_Type_Definition (Parent (E), Make_Floating_Point_Definition (Standard_Location, Digits_Expression => Make_Integer_Literal (Standard_Location, Intval => UI_From_Int (Digs)))); Set_Ekind (E, E_Float_Type); Set_Etype (E, E); Set_Esize (E, UI_From_Int (Siz)); end Build_Float_Type; -- Start of processing for Create_Standard begin Decl_S := New_List; -- First step is to create defining identifiers for each entity for S in Standard_Entity_Type loop declare S_Name : constant String := Standard_Entity_Type'Image (S); -- Name of entity (note we skip S_ at the start) Ident_Node : Node_Id; -- Defining identifier node begin Ident_Node := Extend_Node (New_Node (N_Defining_Identifier, Standard_Location)); Make_Name (Ident_Node, S_Name (3 .. S_Name'Length)); Standard_Entity (S) := Ident_Node; end; end loop; -- Create package declaration node for package Standard Standard_Package_Node := New_Node (N_Package_Declaration, Standard_Location); Pspec := New_Node (N_Package_Specification, Standard_Location); Set_Specification (Standard_Package_Node, Pspec); Set_Defining_Unit_Name (Pspec, Standard_Standard); Set_Visible_Declarations (Pspec, Decl_S); Set_Ekind (Standard_Standard, E_Package); -- Create type declaration nodes for standard types for S in S_Types loop Decl := New_Node (N_Full_Type_Declaration, Standard_Location); Set_Defining_Identifier (Decl, Standard_Entity (S)); Append (Decl, Decl_S); end loop; -- Create type definition node for type Boolean. The Size is set to -- 1 as required by Ada/9X and current ARG interpretations for Ada/83. Tdef_Node := New_Node (N_Enumeration_Type_Definition, Standard_Location); Set_Literals (Tdef_Node, New_List); Append (Standard_False, Literals (Tdef_Node)); Append (Standard_True, Literals (Tdef_Node)); Set_Type_Definition (Parent (Standard_Boolean), Tdef_Node); Set_Ekind (Standard_Boolean, E_Boolean_Type); Set_First_Literal (Standard_Boolean, Standard_False); Set_Etype (Standard_Boolean, Standard_Boolean); Set_Esize (Standard_Boolean, UI_From_Int (1)); Set_Ekind (Standard_True, E_Enumeration_Literal); Set_Etype (Standard_True, Standard_Boolean); Set_Enumeration_Pos (Standard_True, Uint_1); Set_Enumeration_Rep (Standard_True, Uint_1); Set_Ekind (Standard_False, E_Enumeration_Literal); Set_Etype (Standard_False, Standard_Boolean); Set_Enumeration_Pos (Standard_False, Uint_0); Set_Enumeration_Rep (Standard_False, Uint_0); -- For the bounds of Boolean, we create a range node corresponding to -- range False .. True -- where the occurrences of the literals must point to the -- corresponding definition. R_Node := New_Node (N_Range, Standard_Location); B_Node := New_Node (N_Identifier, Standard_Location); Set_Chars (B_Node, Chars (Standard_False)); Set_Entity (B_Node, Standard_False); Set_Etype (B_Node, Standard_Boolean); Set_Low_Bound (R_Node, B_Node); B_Node := New_Node (N_Identifier, Standard_Location); Set_Chars (B_Node, Chars (Standard_True)); Set_Entity (B_Node, Standard_True); Set_Etype (B_Node, Standard_Boolean); Set_High_Bound (R_Node, B_Node); Set_Scalar_Range (Standard_Boolean, R_Node); -- Create type definition nodes for predefined integer types Build_Integer_Type (Standard_Short_Short_Integer, Standard_Short_Short_Integer_Size); Build_Integer_Type (Standard_Short_Integer, Standard_Short_Integer_Size); Build_Integer_Type (Standard_Integer, Standard_Integer_Size); Build_Integer_Type (Standard_Long_Integer, Standard_Long_Integer_Size); Build_Integer_Type (Standard_Long_Long_Integer, Standard_Long_Long_Integer_Size); -- Create type definition nodes for predefined float types Build_Float_Type (Standard_Short_Float, Standard_Short_Float_Size, Standard_Short_Float_Digits); Build_Float_Type (Standard_Float, Standard_Float_Size, Standard_Float_Digits); Build_Float_Type (Standard_Long_Float, Standard_Long_Float_Size, Standard_Long_Float_Digits); Build_Float_Type (Standard_Long_Long_Float, Standard_Long_Long_Float_Size, Standard_Long_Long_Float_Digits); -- Create type definition node for type Character. The size is 8 bits. -- Note that we do not set the Literals field, since type Character is -- handled with special routines that do not need a literal list. Tdef_Node := New_Node (N_Enumeration_Type_Definition, Standard_Location); Set_Type_Definition (Parent (Standard_Character), Tdef_Node); Set_Ekind (Standard_Character, E_Character_Type); Set_Etype (Standard_Character, Standard_Character); Set_Esize (Standard_Character, UI_From_Int (Standard_Character_Size)); -- Create the bounds for type Character. R_Node := New_Node (N_Range, Standard_Location); -- Low bound for type Character (Standard.Nul) B_Node := New_Node (N_Character_Literal, Standard_Location); Set_Chars (B_Node, No_Name); Set_Char_Literal_Value (B_Node, 16#00#); Set_Entity (B_Node, Empty); Set_Etype (B_Node, Standard_Character); Set_Low_Bound (R_Node, B_Node); -- High bound for type Character B_Node := New_Node (N_Character_Literal, Standard_Location); Set_Chars (B_Node, No_Name); Set_Char_Literal_Value (B_Node, 16#FF#); Set_Entity (B_Node, Empty); Set_Etype (B_Node, Standard_Character); Set_High_Bound (R_Node, B_Node); Set_Scalar_Range (Standard_Character, R_Node); -- Create type definition node for type String Tdef_Node := New_Node (N_Unconstrained_Array_Definition, Standard_Location); Set_Subtype_Indication (Tdef_Node, Identifier_For (S_Character)); Set_Subtype_Marks (Tdef_Node, New_List); Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node)); Set_Type_Definition (Parent (Standard_String), Tdef_Node); Set_Ekind (Standard_String, E_String_Type); Set_Etype (Standard_String, Standard_String); Set_Component_Type (Standard_String, Standard_Character); -- Set index_type of String E_Id := First (Subtype_Marks (Type_Definition (Parent (Standard_String)))); Set_First_Index (Standard_String, E_Id); Set_Entity (E_Id, Standard_Positive); Set_Etype (E_Id, Standard_Positive); -- Create subtype declaration for Natural Decl := New_Node (N_Subtype_Declaration, Standard_Location); Set_Defining_Identifier (Decl, Standard_Natural); Append (Decl, Decl_S); Set_Ekind (Standard_Natural, E_Integer_Subtype); Set_Etype (Standard_Natural, Standard_Integer); Set_Esize (Standard_Natural, Esize (Standard_Integer)); Set_Integer_Bounds (Id => Standard_Natural, Typ => Standard_Integer, Lb => Uint_0, Hb => Intval (High_Bound (Scalar_Range (Standard_Integer)))); -- Create subtype declaration for Positive Decl := New_Node (N_Subtype_Declaration, Standard_Location); Set_Defining_Identifier (Decl, Standard_Positive); Append (Decl, Decl_S); Set_Ekind (Standard_Positive, E_Integer_Subtype); Set_Etype (Standard_Positive, Standard_Integer); Set_Esize (Standard_Positive, Esize (Standard_Integer)); Set_Integer_Bounds (Id => Standard_Positive, Typ => Standard_Integer, Lb => Uint_1, Hb => Intval (High_Bound (Scalar_Range (Standard_Integer)))); -- Create subtype declaration for Duration Decl := New_Node (N_Subtype_Declaration, Standard_Location); Set_Defining_Identifier (Decl, Standard_Duration); Append (Decl, Decl_S); Set_Ekind (Standard_Duration, E_Float_Subtype); Set_Etype (Standard_Duration, Standard_Float); Set_Esize (Standard_Duration, Esize (Standard_Float)); -- Create declaration for package Ascii Decl := New_Node (N_Package_Declaration, Standard_Location); Append (Decl, Decl_S); Pspec := New_Node (N_Package_Specification, Standard_Location); Set_Specification (Decl, Pspec); Set_Defining_Unit_Name (Pspec, Standard_Entity (S_Ascii)); Set_Ekind (Standard_Entity (S_Ascii), E_Package); Decl_A := New_List; -- for ASCII declarations Set_Visible_Declarations (Pspec, Decl_A); -- Create control character definitions in package ASCII. Note that -- the character literal entries created here correspond to literal -- values that are impossible in the source, but can be represented -- internally with no difficulties. Ccode := 16#00#; for S in S_Ascii_Names loop Decl := New_Node (N_Object_Declaration, Standard_Location); Set_Constant_Present (Decl, True); declare A_Char : Entity_Id := Standard_Entity (S); begin Set_Ekind (A_Char, E_Constant); Set_Etype (A_Char, Standard_Character); Set_Scope (A_Char, Standard_Entity (S_Ascii)); Set_Is_Directly_Visible (A_Char, False); Set_Is_Public (A_Char); Append_Entity (A_Char, Standard_Entity (S_Ascii)); Set_Defining_Identifier (Decl, A_Char); end; Set_Object_Definition (Decl, Identifier_For (S_Character)); Set_Expression (Decl, New_Node (N_Character_Literal, Standard_Location)); Set_Chars (Expression (Decl), No_Name); Set_Etype (Expression (Decl), Standard_Character); Set_Char_Literal_Value (Expression (Decl), Ccode); Append (Decl, Decl_A); -- Increment character code, dealing with non-contiguities Ccode := Ccode + 1; if Ccode = 16#20# then Ccode := 16#21#; elsif Ccode = 16#27# then Ccode := 16#3A#; elsif Ccode = 16#3C# then Ccode := 16#3F#; elsif Ccode = 16#41# then Ccode := 16#5B#; end if; end loop; -- Create semantic phase entities Standard_Void_Type := Extend_Node (New_Node (N_Defining_Identifier, Standard_Location)); Set_Ekind (Standard_Void_Type, E_Void); Set_Etype (Standard_Void_Type, Standard_Void_Type); Set_Esize (Standard_Void_Type, Uint_0); Set_Scope (Standard_Void_Type, Standard_Standard); Make_Name (Standard_Void_Type, "_void_type"); -- The type field of packages is set to void Set_Etype (Standard_Standard, Standard_Void_Type); Set_Etype (Standard_Ascii, Standard_Void_Type); Standard_A_String := Extend_Node (New_Node (N_Defining_Identifier, Standard_Location)); Set_Ekind (Standard_A_String, E_Access_Type); Set_Directly_Designated_Type (Standard_A_String, Standard_String); Set_Scope (Standard_A_String, Standard_Standard); Set_Etype (Standard_A_String, Standard_A_String); Make_Name (Standard_A_String, "_Access_String"); -- Note on type names. The type names for the following special types -- are constructed so that they will look reasonable in error messages -- such as "some integer type" expected here. The blanks would cause -- trouble in Gigi, but that's OK here, since none of these types -- should ever get through to Gigi! Any_Type := Extend_Node (New_Node (N_Defining_Identifier, Standard_Location)); Set_Ekind (Any_Type, E_Integer_Type); Set_Scope (Any_Type, Standard_Standard); Set_Etype (Any_Type, Any_Type); Set_Esize (Any_Type, Uint_0); Make_Name (Any_Type, "any type"); Any_Id := Extend_Node (New_Node (N_Defining_Identifier, Standard_Location)); Set_Ekind (Any_Id, E_Variable); Set_Scope (Any_Id, Standard_Standard); Set_Etype (Any_Id, Any_Type); Make_Name (Any_Id, "any id"); Any_Integer := Extend_Node (New_Node (N_Defining_Identifier, Standard_Location)); Set_Ekind (Any_Integer, E_Integer_Type); Set_Scope (Any_Integer, Standard_Standard); Set_Etype (Any_Integer, Standard_Longest_Runtime_Integer); Make_Name (Any_Integer, "some integer type"); Set_Esize (Any_Integer, Esize (Standard_Longest_Runtime_Integer)); Universal_Integer := Extend_Node (New_Node (N_Defining_Identifier, Standard_Location)); Set_Ekind (Universal_Integer, E_Integer_Type); Set_Scope (Universal_Integer, Standard_Standard); Set_Etype (Universal_Integer, Universal_Integer); Make_Name (Universal_Integer, "universal integer"); Universal_Real := Extend_Node (New_Node (N_Defining_Identifier, Standard_Location)); Set_Ekind (Universal_Real, E_Float_Type); Set_Scope (Universal_Real, Standard_Standard); Set_Etype (Universal_Real, Universal_Real); Make_Name (Universal_Real, "universal real"); Any_Access := Extend_Node (New_Node (N_Defining_Identifier, Standard_Location)); Set_Ekind (Any_Access, E_Access_Type); Set_Scope (Any_Access, Standard_Standard); Set_Etype (Any_Access, Any_Access); Make_Name (Any_Access, "some access type"); Any_Boolean := Extend_Node (New_Node (N_Defining_Identifier, Standard_Location)); Set_Ekind (Any_Boolean, E_Boolean_Type); Set_Scope (Any_Boolean, Standard_Standard); Set_Etype (Any_Boolean, Standard_Boolean); Make_Name (Any_Boolean, "some boolean type"); Any_Character := Extend_Node (New_Node (N_Defining_Identifier, Standard_Location)); Set_Ekind (Any_Character, E_Character_Type); Set_Scope (Any_Character, Standard_Standard); Set_Etype (Any_Character, Any_Character); Make_Name (Any_Character, "some character type"); Any_String := New_Copy (Standard_String); Set_Etype (Any_String, Any_String); Make_Name (Any_String, "some string type"); Any_Composite := Extend_Node (New_Node (N_Defining_Identifier, Standard_Location)); Set_Ekind (Any_Composite, E_Array_Type); Set_Scope (Any_Composite, Standard_Standard); Set_Etype (Any_Composite, Any_Composite); Make_Name (Any_Composite, "some composite type"); -- The name for the exception type avoids blanks, because this type -- name does get passed on to Gigi, and the assembler does not like -- blanks in the middle of names. Standard_Exception_Type := Extend_Node (New_Node (N_Defining_Identifier, Standard_Location)); Set_Ekind (Standard_Exception_Type, E_Exception_Type); Set_Etype (Standard_Exception_Type, Standard_Exception_Type); Set_Scope (Standard_Exception_Type, Standard_Standard); Make_Name (Standard_Exception_Type, "exception"); -- Create declarations of standard exceptions Build_Exception (S_Constraint_Error); Build_Exception (S_Program_Error); Build_Exception (S_Storage_Error); Build_Exception (S_Tasking_Error); -- Numeric_Error is a normal exception in Ada 83, but in Ada 9X -- it is a renaming of Constraint_Error if Ada_83 then Build_Exception (S_Numeric_Error); else Decl := New_Node (N_Exception_Renaming_Declaration, Standard_Location); E_Id := Standard_Entity (S_Numeric_Error); Set_Ekind (E_Id, E_Exception); Set_Etype (E_Id, Standard_Exception_Type); Set_Is_Public (E_Id); Set_Defining_Identifier (Decl, E_Id); Append (Decl, Decl_S); Ident_Node := New_Node (N_Identifier, Standard_Location); Set_Chars (Ident_Node, Chars (Standard_Entity (S_Constraint_Error))); Set_Entity (Ident_Node, Standard_Entity (S_Constraint_Error)); Set_Name (Decl, Ident_Node); end if; Create_Operators; -- Initialize visibility table with entities in Standard for E in Standard_Entity_Type loop Set_Name_Entity_Id (Chars (Standard_Entity (E)), Standard_Entity (E)); Set_Homonym (Standard_Entity (E), Empty); if E not in S_Ascii_Names then Set_Scope (Standard_Entity (E), Standard_Standard); Set_Is_Directly_Visible (Standard_Entity (E)); end if; end loop; -- Set global variables indicating last Id values and version Last_Standard_Node_Id := Last_Node_Id; Last_Standard_List_Id := Last_List_Id; Last_Standard_Name_Id := Last_Name_Id; Last_Standard_String_Id := Last_String_Id; Last_Standard_Uint := Last_Uint; end Create_Standard; ---------------------- -- Create_Operators -- ---------------------- -- Each operator has an abbreviated signature. The formals have the names -- LEFT and RIGHT. Their types are not actually used for resolution. procedure Create_Operators is Op_Node : Entity_Id; type Op_Names is array (Positive range <>) of Name_Id; -- Following list excludes concatenation which must be treated specially Binary_Ops : constant Op_Names (1 .. 16) := (Name_Op_And, Name_Op_Mod, Name_Op_Or, Name_Op_Rem, Name_Op_Xor, Name_Op_Eq, Name_Op_Ne, Name_Op_Lt, Name_Op_Le, Name_Op_Gt, Name_Op_Ge, Name_Op_Add, Name_Op_Subtract, Name_Op_Multiply, Name_Op_Divide, Name_Op_Expon); Unary_Ops : constant Op_Names (1 .. 4) := (Name_Op_Abs, Name_Op_Not, Name_Op_Add, Name_Op_Subtract); function New_Operator (Op : Name_Id) return Entity_Id is Ident_Node : Entity_Id; begin Ident_Node := Make_Defining_Identifier (Standard_Location, Op); Set_Ekind (Ident_Node, E_Operator); Set_Etype (Ident_Node, Universal_Integer); Set_Scope (Ident_Node, Standard_Standard); Set_Homonym (Ident_Node, Get_Name_Entity_Id (Op)); Set_Name_Entity_Id (Op, Ident_Node); Set_Is_Directly_Visible (Ident_Node); Set_Is_Intrinsic (Ident_Node); Append_Entity (Ident_Node, Standard_Standard); return Ident_Node; end New_Operator; function Make_Formal (Typ : Entity_Id; Formal_Name : String) return Entity_Id is Formal : Entity_Id; begin Formal := Extend_Node (New_Node (N_Defining_Identifier, Standard_Location)); Set_Ekind (Formal, E_In_Parameter); Set_Scope (Formal, Standard_Standard); Set_Etype (Formal, Typ); Make_Name (Formal, Formal_Name); return Formal; end Make_Formal; begin for I in Binary_Ops'range loop Op_Node := New_Operator (Binary_Ops (I)); Append_Entity (Make_Formal (Any_Type, "LEFT"), Op_Node); Append_Entity (Make_Formal (Any_Type, "RIGHT"), Op_Node); end loop; for I in Unary_Ops'range loop Op_Node := New_Operator (Unary_Ops (I)); Append_Entity (Make_Formal (Any_Type, "RIGHT"), Op_Node); end loop; -- For concatenation, we create an operator for each one-dimensional -- array type. This simplifies the resolution of the component- -- component concatenation operation. Op_Node := New_Operator (Name_Op_Concat); Set_Etype (Op_Node, Standard_String); Append_Entity (Make_Formal (Standard_String, "LEFT"), Op_Node); Append_Entity (Make_Formal (Standard_String, "RIGHT"), Op_Node); end Create_Operators; --------------------- -- Identifier_For -- --------------------- function Identifier_For (S : Standard_Entity_Type) return Node_Id is Ident_Node : Node_Id; begin Ident_Node := New_Node (N_Identifier, Standard_Location); Set_Chars (Ident_Node, Chars (Standard_Entity (S))); return Ident_Node; end Identifier_For; --------------- -- Make_Name -- --------------- procedure Make_Name (Id : Entity_Id; Nam : String) is begin for I in 1 .. Nam'Length loop Name_Buffer (Int (I)) := Fold_Lower (To_Char (Nam (Nam'First + (I - 1)))); end loop; Name_Len := Nam'Length; Set_Chars (Id, Name_Find); end Make_Name; end Stand; r_Type); Set_Scope (Any_Integer, Standard_Standard); Set_Etype (Any_Integer, Standard_Longest_Runtime_Integer); Make_Name (Any_Integer, "some integer type"); Set_Esize (Any_Integer, Esize (Standard_Longest_Runtime_Integer)); Universal_Integer := Extend_Node (New_Node (N_Defining_Identignat-1.67-src/src/stringt.ads 444 10015 7640 14305 5506244434 11325 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S T R I N G T -- -- -- -- S p e c -- -- -- -- $Revision: 1.12 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Alloc; use Alloc; with Types; use Types; with Table; package Stringt is -- This package contains routines for handling the strings table which is -- used to store string constants encountered in the source, and also those -- additional string constants generated by compile time concatenation and -- other similar processing. -- A string constant in this table consists of a series of Char_Code values, -- so that 16-bit character codes can be properly handled if this feature -- is implemented in the scanner. -- There is no guarantee that hashing is used in the implementation, although -- it maybe. This means that the caller cannot count on having the same Id -- value for two identical strings stored separately. -------------------------------------- -- String Table Access Subprograms -- -------------------------------------- procedure Initialize_Stringt; -- Initializes the strings table for a new compilation function Last_String_Id return String_Id; pragma Inline (Last_String_Id); -- String_Id of last currently allocated string procedure Start_String; -- Sets up for storing a new string in the table. To store a string, a -- call is first made to Start_String, then successive calls are -- made to Store_String_Character to store the characters of the string. -- Finally, a call to End_String terminates the entry and returns it Id. procedure Store_String_Char (C : Char_Code); -- Store next character of string, see description above for Start_String procedure Unstore_String_Char; -- Undoes effect of previous Store_String_Char call, used in some error -- situations of unterminated string constants. function End_String return String_Id; pragma Inline (End_String); -- Terminates current string and returns its Id function String_Length (Id : String_Id) return Int; pragma Inline (String_Length); -- Returns length of previously stored string function Get_String_Char (Id : String_Id; Index : Int) return Char_Code; -- Obtains the specified character from a stored string. The lower bound -- of stored strings is always 1, so the range is 1 .. String_Length (Id). procedure Write_String_Table_Entry (Id : String_Id); -- Writes a string value with enclosing quotes to the current file using -- routines in package Output. Does not write an end of line character. -- This procedure is used for debugging purposes. 7-bit ASCII graphics -- (except for double quote and left brace) are output literally. The -- double quote appears as two successive double quotes. All other codes, -- including the code for left brace, are output as a decimal code value -- enclosed in braces. For example, the string created by the folding of -- "A" & Ascii.LF & "Hello" will print as "A{12}Hello". ----------------------------- -- Private Part Subpackage -- ----------------------------- -- The following package contains the definition of the data structure -- used by the implementation of the Strings package. Logically it really -- corresponds to the private part, hence the name. The reason that it -- is defined as a sub-package is to allow special access from clients -- that need to see the internals of the data structures. package Stringt_Private_Part is -- The following table stores the sequence of character codes for the -- stored string constants. The entries are referenced from the -- separate Strings table. package String_Chars is new Table ( Component_Type => Char_Code, Index_Type => Int, Low_Bound => 0, Initial => Alloc_String_Chars_Initial, Increment => Alloc_String_Chars_Increment, Table_Name => "String_Chars"); -- The String_Id values reference entries in the Strings table, which -- contains String_Entry records that record the length of each stored -- string and its starting location in the String_Chars table. type String_Entry is record String_Index : Int; Length : Int; end record; package Strings is new Table ( Component_Type => String_Entry, Index_Type => String_Id, Low_Bound => First_String_Id, Initial => Alloc_Strings_Initial, Increment => Alloc_Strings_Increment, Table_Name => "Strings"); end Stringt_Private_Part; end Stringt; nent concatenation operation. Op_Node := New_Operator (Name_Op_Concat); Set_Etype (Op_Node, Standard_String); Append_Entity (Make_Formal (Standard_String, "LEFT"), Op_Node); Append_Entity (Make_Formal (Standard_String, "RIGHT"), Op_Node); end Create_Operators; ---------------------gnat-1.67-src/src/stringt.adb 444 10015 7640 11170 5506244435 11302 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S T R I N G T -- -- -- -- B o d y -- -- -- -- $Revision: 1.12 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Debug; use Debug; with Output; use Output; package body Stringt is use Stringt_Private_Part; -- We are allowed to see our own private data! ------------------------ -- Initialize_Stringt -- ------------------------ procedure Initialize_Stringt is begin String_Chars.Init; Strings.Init; end Initialize_Stringt; -------------------- -- Last_String_Id -- -------------------- function Last_String_Id return String_Id is begin return Strings.Last; end Last_String_Id; ------------------ -- Start_String -- ------------------ procedure Start_String is begin Strings.Increment_Last; Strings.Table (Strings.Last).String_Index := String_Chars.Last + 1; Strings.Table (Strings.Last).Length := 0; end Start_String; ----------------------- -- Store_String_Char -- ----------------------- procedure Store_String_Char (C : Char_Code) is begin String_Chars.Increment_Last; String_Chars.Table (String_Chars.Last) := C; Strings.Table (Strings.Last).Length := Strings.Table (Strings.Last).Length + 1; end Store_String_Char; ------------------------- -- Unstore_String_Char -- ------------------------- procedure Unstore_String_Char is begin String_Chars.Decrement_Last; Strings.Table (Strings.Last).Length := Strings.Table (Strings.Last).Length - 1; end Unstore_String_Char; ---------------- -- End_String -- ---------------- function End_String return String_Id is begin return Strings.Last; end End_String; ------------------- -- String_Length -- ------------------- function String_Length (Id : String_Id) return Int is begin return Strings.Table (Id).Length; end String_Length; --------------------- -- Get_String_Char -- --------------------- function Get_String_Char (Id : String_Id; Index : Int) return Char_Code is begin pragma Assert (Id in Strings.First .. Strings.Last and then Index in 1 .. Strings.Table (Id).Length); return String_Chars.Table (Strings.Table (Id).String_Index + Index - 1); end Get_String_Char; ------------------------------ -- Write_String_Table_Entry -- ------------------------------ procedure Write_String_Table_Entry (Id : String_Id) is C : Char_Code; begin Write_Char ('"'); for I in 1 .. String_Length (Id) loop C := Get_String_Char (Id, I); if Char'Val (C) = '"' then Write_String (""""""); elsif C in 16#20# .. 16#7A# or else C in 16#7C# .. 16#7E# then Write_Char (Char'Val (C)); else Write_Char ('{'); Write_Int (Int (C)); Write_Char ('}'); end if; end loop; Write_Char ('"'); end Write_String_Table_Entry; end Stringt; tringt; -------------------- -- Last_String_Id -- -------------------- function Last_String_Id return String_Id is begin return Strings.Last; end Last_String_Id; ------------------ -- Start_String -- ------------------ procedure Start_String is begin Strings.Increment_Last; Strings.Table (Strings.Last).String_Index := String_Chars.Lastgnat-1.67-src/src/switch.ads 444 10015 7640 6162 5506244435 11117 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S W I T C H -- -- -- -- S p e c -- -- -- -- $Revision: 1.6 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This package scans switches. Note that the body of Usage must be -- coordinated with the switches that are recognized by this package. -- The Usage package also acts as the official documentation for the -- switches that are recognized. In addition, package Debug documents -- the otherwise undocumented debug switches that are also recognized. package Switch is -- Note: the switch character is / in MS_DOS mode, and - in normal mode. -- In MS_DOS mode the - is allowed as an alternative switch, but in normal -- (Unix) mode, the / is not recognized since it is a directory character. -- Note: In GNAT, the case of switches is not significant, so switch -- characters, or letters appearing in the parameter to a switch, may -- be either upper case or lower case. ----------------- -- Subprograms -- ----------------- procedure Scan_Switches (Switch_Chars : String); -- Procedure to scan out switches stored in the given string. The first -- character is known to be a valid switch character, and there are no -- blanks or other switch terminator characters in the string, so the -- entire string should consist of valid switch characters, except that -- an optional terminating Ascii.NUL character is allowed. A bad switch -- causes a fatal error exit and control does not return. end Switch; Part Subpackage -- ----------------------------- -- The following package contains the definition of the data structure -- used by the implementation of the Strings package. Logically it really -- corresponds to the private part, hence the name. The reason that it -- is defined as a sub-package is to allow special access from clients -- that need to see the internals of tgnat-1.67-src/src/switch.adb 444 10015 7640 31302 5506244436 11111 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S W I T C H -- -- -- -- B o d y -- -- -- -- $Revision: 1.41 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Option switch scanning for both the compiler and the binder -- Note: this version of the package should be usable in both Unix and DOS with Debug; use Debug; with Osint; use Osint; with Opt; use Opt; with Output; use Output; with Sysid; use Sysid; with Types; use Types; package body Switch is Bad_Switch : exception; -- Exception raised if bad switch encountered ------------------- -- Scan_Switches -- ------------------- procedure Scan_Switches (Switch_Chars : String) is Ptr : Integer := Switch_Chars'First; Max : Integer := Switch_Chars'Last; C : Character; Switches : String (Switch_Chars'range); -- Copy of switches which is actually scanned. In MS/DOS mode, this -- string is folded to lower case so that upper case switches are -- recognized as equivalent to the lower case switches. function Scan_Int return Pos; -- Scan positive integer parameter for switch. On entry, Ptr points -- just past the switch character, on exit it points past the last -- digit of the integer value. -------------- -- Scan_Int -- -------------- function Scan_Int return Pos is Val : Int := 0; begin if Ptr > Max or else Switches (Ptr) not in '0' .. '9' then raise Bad_Switch; end if; while Ptr <= Max and then Switches (Ptr) in '0' .. '9' loop Val := Val * 10 + Character'Pos (Switches (Ptr)) - Character'Pos ('0'); Ptr := Ptr + 1; if Val > 999 then raise Bad_Switch; end if; end loop; return Val; end Scan_Int; ------------------- -- Scan_Switches -- ------------------- begin -- In MS/DOS mode, fold switch string to lower case for I in Switches'range loop if MS_DOS and then Switch_Chars (I) in 'A' .. 'Z' then Switches (I) := Character'Val (Character'Pos (Switch_Chars (I)) - 32); else Switches (I) := Switch_Chars (I); end if; end loop; -- Skip past the initial character (must be the switch character) if Ptr = Max then raise Bad_Switch; else Ptr := Ptr + 1; end if; -- Loop to scan through switches given in switch string while Ptr <= Max loop C := Switches (Ptr); -- Processing for -a switch if C = 'a' then Ptr := Ptr + 1; if Program = Compiler then Assertions_Enabled := True; elsif Program = Binder then All_Sources := True; Check_Source_Files := True; else raise Bad_Switch; end if; -- Processing for -b switch elsif C = 'b' then if Program = Compiler or else Program = Binder then Ptr := Ptr + 1; Brief_Output := True; else raise Bad_Switch; end if; -- Processing for -c switch elsif C = 'c' then Ptr := Ptr + 1; if Program = Compiler then Operating_Mode := Check_Semantics; elsif Program = Binder then Check_Only := True; else raise Bad_Switch; end if; -- Processing for -d switch elsif C = 'd' then -- Note: for the debug switch, the remaining characters in this -- switch field must all be debug flags, since all valid switch -- characters are also valid debug characters. -- Loop to scan out debug flags while Ptr < Max loop Ptr := Ptr + 1; C := Switches (Ptr); exit when C = Ascii.NUL or else C = '/' or else C = '-'; if C in '1' .. '9' or else C in 'a' .. 'z' then Set_Debug_Flag (To_Char (C)); else raise Bad_Switch; end if; end loop; return; -- Processing for -e switch elsif C = 'e' then Ptr := Ptr + 1; if Program = Compiler then Immediate_Errors := True; elsif Program = Binder then Elab_Dependency_Output := True; else raise Bad_Switch; end if; -- Processing for -f switch elsif C = 'f' then Ptr := Ptr + 1; if Program = Compiler then All_Errors_Mode := True; else raise Bad_Switch; end if; -- Processing for -g switch elsif C = 'g' then if Program = Compiler then Ptr := Ptr + 1; RM_Column_Check := True; GNAT_Style_Check := True; else raise Bad_Switch; end if; -- Processing for -i switch elsif C = 'i' then if Program = Compiler or else Program = Binder then if Ptr = Max then raise Bad_Switch; end if; Ptr := Ptr + 1; C := Switches (Ptr); if C = '1' or else C = '2' or else C = '3' or else C = '4' or else C = 'p' or else C = 'f' or else C = 'n' then Identifier_Character_Set := To_Char (C); Ptr := Ptr + 1; else raise Bad_Switch; end if; else raise Bad_Switch; end if; elsif C = 'k' then Ptr := Ptr + 1; if Program = Compiler then Maximum_File_Name_Length := Scan_Int; else raise Bad_Switch; end if; -- Processing for -l switch elsif C = 'l' then Ptr := Ptr + 1; if Program = Compiler then Full_List := True; elsif Program = Binder then Elab_Order_Output := True; else raise Bad_Switch; end if; -- Processing for -m switch elsif C = 'm' then Ptr := Ptr + 1; if Program = Compiler or else Program = Binder then Maximum_Errors := Scan_Int; else raise Bad_Switch; end if; -- Processing for -n switch elsif C = 'n' then Ptr := Ptr + 1; if Program = Compiler then Inline_Active := False; elsif Program = Binder then Bind_Main_Program := False; else raise Bad_Switch; end if; -- Processing for -o switch elsif C = 'o' then Ptr := Ptr + 1; if Program = Binder then Output_Filename_Present := True; else raise Bad_Switch; end if; -- Processing for -p switch elsif C = 'p' then Ptr := Ptr + 1; if Program = Compiler then Suppress_Options.Access_Checks := True; Suppress_Options.Accessibility_Checks := True; Suppress_Options.Discriminant_Checks := True; Suppress_Options.Division_Checks := True; Suppress_Options.Index_Checks := True; Suppress_Options.Length_Checks := True; Suppress_Options.Overflow_Checks := True; Suppress_Options.Range_Checks := True; Suppress_Options.Division_Checks := True; Suppress_Options.Length_Checks := True; Suppress_Options.Range_Checks := True; Suppress_Options.Storage_Checks := True; Suppress_Options.Tag_Checks := True; else raise Bad_Switch; end if; -- Processing for -r switch elsif C = 'r' then Ptr := Ptr + 1; if Program = Compiler then RM_Column_Check := True; else raise Bad_Switch; end if; -- Processing for -s switch elsif C = 's' then Ptr := Ptr + 1; if Program = Compiler then Operating_Mode := Check_Syntax; elsif Program = Binder then Check_Source_Files := True; else raise Bad_Switch; end if; -- Processing for -t switch elsif C = 't' then Ptr := Ptr + 1; if Program = Binder then Ignore_Time_Stamp_Errors := True; elsif Program = Compiler then Try_Semantics := True; else raise Bad_Switch; end if; -- Processing for -u switch elsif C = 'u' then Ptr := Ptr + 1; if Program = Compiler then List_Units := True; else raise Bad_Switch; end if; -- Processing for -v switch elsif C = 'v' then Ptr := Ptr + 1; if Program = Compiler or else Program = Binder then Verbose_Mode := True; else raise Bad_Switch; end if; -- Processing for -w switch elsif C = 'w' then Ptr := Ptr + 1; if Program = Compiler or else Program = Binder then C := Switches (Ptr); if C = 's' then Warning_Mode := Suppress; elsif C = 'e' then Warning_Mode := Treat_As_Error; else raise Bad_Switch; end if; Ptr := Ptr + 1; else raise Bad_Switch; end if; -- Processing for -83 switch elsif C = '8' then if Program = Compiler then if Ptr = Max then raise Bad_Switch; end if; Ptr := Ptr + 1; if Switches (Ptr) /= '3' then raise Bad_Switch; else Ptr := Ptr + 1; Ada_83_Switch := True; Ada_9X := False; Ada_83 := True; end if; else raise Bad_Switch; end if; -- Ignore extra switch character elsif C = '/' or else C = '-' then Ptr := Ptr + 1; -- Anything else is an error (illegal switch character) else raise Bad_Switch; end if; end loop; exception when Bad_Switch => Write_String ("Invalid switch"); Write_Eol; Exit_Program (E_Fatal); end Scan_Switches; end Switch; Brief_Output := True; else raise Bad_Switch; end if; -- Processing for -c switch elsif C = 'c' then Ptr := Ptr + 1; if Program = Compiler then Operating_Mode := Check_Semantics; elsif Program = Binder thengnat-1.67-src/src/system_environment.ads 444 10015 7640 4465 5506244436 13573 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S Y S T E M _ E N V I R O N M E N T -- -- -- -- S p e c -- -- (UNIX Version) -- -- -- -- $Revision: 1.4 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This package contains some functions to access arg. on the command line package System_Environment is function Arg_Count return Positive; pragma Interface (C, Arg_Count); -- Return the number of arg in the command line (equivalent to argc in C) type A_String is access String; function Arg_Value (Arg_Num : Natural) return A_String; -- Return the desired arg. from the command line (0 is the command name) end System_Environment; mpiler or else Program = Binder then C := Switches (Ptr); if C = 's' then Warning_Mode := Suppress; elsif C = 'e' then Wagnat-1.67-src/src/system_environment.adb 444 10015 7640 4761 5506244436 13551 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S Y S T E M _ E N V I R O N M E N T -- -- -- -- B o d y -- -- (UNIX Version) -- -- -- -- $Revision: 1.6 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This package contains some functions to access arg. on the command line with System; package body System_Environment is Args : array (0 .. Arg_Count - 1) of A_String; procedure Fill_Arg (A : System.Address; Arg_Num : Integer); pragma Interface (C, Fill_Arg); function Len_Arg (Arg_Num : Integer) return Integer; pragma Interface (C, Len_Arg); function Arg_Value (Arg_Num : Natural) return A_String is begin return Args (Arg_Num); end Arg_Value; begin for I in Args'range loop Args (I) := new String (1 .. Len_Arg (I)); Fill_Arg (Args (I).all'Address, I); end loop; end System_Environment; ¹n patches-gnat-1.67-src/src/a-ada.h 444 10015 7640 6122 5506244437 10237 /****************************************************************************/ /* */ /* GNAT COMPILER COMPONENTS */ /* */ /* A - A D A */ /* */ /* Header */ /* */ /* $Revision: 1.6 $ */ /* */ /* Copyright (c) 1992,1993, NYU, All Rights Reserved */ /* */ /* 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 */ /* Software Foundation; either version 2, or (at your option) any later */ /* version. GNAT is distributed in the hope that it will be useful, but */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- */ /* ABILITY 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 GNAT; see file COPYING. If not, write */ /* to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* */ /****************************************************************************/ /* This file contains some standard macros for performing Ada-like operations. These are used to aid in the translation of other headers. */ /* Inlined functions in header are preceded by INLINE, which is normally set to extern inline for GCC, but may be set to static for use in standard ANSI-C. */ #ifndef INLINE #ifdef __GNUC__ #define INLINE static inline #else #define INLINE static #endif #endif /* "const" is only in ANSI-C. */ #if ! defined(__STDC__) && ! defined(const) #define const #endif /* Define a macro to concatenate two strings. Write it for ANSI C and for traditional C. */ #ifdef __STDC__ #define CAT(A,B) A##B #else #define _ECHO(A) A #define CAT(A,B) ECHO(A)B #endif /* The following macro definition simulates the effect of a declaration of a subtype, where the first two parameters give the name of the type and subtype, and the third and fourth parameters give the subtype range. The effect is to compile a typedef defining the subtype as a synonym for the type, together with two constants defining the end points. */ #define SUBTYPE(SUBTYPE,TYPE,FIRST,LAST) \ typedef TYPE SUBTYPE; \ static const SUBTYPE CAT (SUBTYPE,__First) = FIRST; \ static const SUBTYPE CAT (SUBTYPE,__Last) = LAST; /* The following definitions provide the equivalent of the Ada IN and NOT IN operators, assuming that the subtype involved has been defined using the SUBTYPE macro defined above. */ #define IN(VALUE,SUBTYPE) \ (((VALUE) >= CAT (SUBTYPE,__First)) && ((VALUE) <= CAT (SUBTYPE,__Last))) #define NOTIN(VALUE,SUBTYPE) (! IN (VALUE, SUBTYPE)) /* Add prototype support. */ #ifndef PROTO #if defined (USE_PROTOTYPES) ? USE_PROTOTYPES : defined (__STDC__) #define PROTO(ARGS) ARGS #else #define PROTO(ARGS) () #endif #endif /* End of a-ada.h (tree transformer C header file) */ Ada_83_Switch := True; Ada_9X := False; Ada_83 := True; end if; else raise Bad_Switch; end if; -- Ignore extra switch character elsif C = '/' or else C = '-' then Ptr := Ptr + 1; -- Anything else is an error (illegal switch character) else raise Bad_Switch; egnat-1.67-src/src/sysid~u.ads 444 10015 7640 5354 5506244437 11340 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S Y S I D -- -- -- -- S p e c -- -- (UNIX Version) -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ package Sysid is -- This package contains the flag that shows what operating system is used MS_DOS : constant Boolean := False; -- This flag is True if operating under MS/DOS or an operating system that -- shares its conventions (such as OS/2). It affects the output format of -- library information files (CR/LF at end of lines, and EOF at end of -- file), the default character set (PC), and the output of the usage -- information (switch character displayed as slash instead of minus). -- Note that the handling of input files is not dependent on the setting -- of this flag. For input source and library information files, the line -- terminator may be either CR/LF or LF alone, and the EOF character is -- optional, but will be recognized as signalling the end of file (and -- no further information will be read) if it is encountered. end Sysid; -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You gnat-1.67-src/src/system.ads 444 10015 7640 7104 5506244437 11141 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S Y S T E M -- -- -- -- S p e c -- -- -- -- $Revision: 1.11 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; package System is -- pragma Pure (System); type Name is (GNAT); System_Name : constant Name := GNAT; -- System-Dependent Named Numbers Min_Int : constant := - (2#1#E63); Max_Int : constant := (2#1#E63) - 1; Max_Binary_Modulus : constant := 2#1#E32; Max_Nonbinary_Modulus : constant := 2#1#E16 - 1; Max_Base_Digits : constant := 15; Max_Digits : constant := 15; Max_Mantissa : constant := 31; Fine_Delta : constant := 2#1.0#E-31; Tick : constant := 1.0; -- Storage related Declarations type Address is private; Null_Address : constant Address; Storage_Unit : constant := 8; Word_Size : constant := 32; Memory_Size : constant := 2#1#E32; -- Address comparison function "<" (Left, Right : Address) return Boolean; function "<=" (Left, Right : Address) return Boolean; function ">" (Left, Right : Address) return Boolean; function ">=" (Left, Right : Address) return Boolean; function "=" (Left, Right : Address) return Boolean; pragma Import (Intrinsic, "<"); pragma Import (Intrinsic, "<="); pragma Import (Intrinsic, ">"); pragma Import (Intrinsic, ">="); pragma Import (Intrinsic, "="); -- Declarations for real time Annexe (Annexe H) subtype Any_Priority is Integer range 0 .. 31; subtype Priority is Any_Priority range 0 .. 30; subtype Interrupt_Priority is Any_Priority range 31 .. 31; Default_Priority : constant Priority := (Priority'First + Priority'Last) / 2; private type Address is mod 2#1#E32; Null_Address : constant Address := 0; end System; Write_String ("Invalid switch"); Write_Eol; Exit_Program (E_Fatal); end Scan_Switches; end Switch; Brief_Output := True; else raise Bad_Switch; end if; -- Processing for -c switch elsif C = 'c' then Ptr := Ptr + 1; if Program = Compiler then Operating_Mode := Check_Semantics; elsif Program = Binder thengnat-1.67-src/src/system-assertions.ads 444 10015 7640 4134 5506244440 13323 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- S Y S T E M . A S S E R T I O N S -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This module contains the definition of the exception that is raised -- when an assertion made using pragma Assert fails (i.e. the given -- expression evaluates to False. pragma Ada_9X; package System.Assertions is Assert_Failure : exception; -- Exception raised when assertion fails end System.Assertions; -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -gnat-1.67-src/src/table.ads 444 10015 7640 13475 5506244440 10726 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- T A B L E -- -- -- -- S p e c -- -- -- -- $Revision: 1.7 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Types; use Types; with Unchecked_Deallocation; generic type Component_Type is private; type Index_Type is range <>; Low_Bound : Index_Type; Initial : Pos; Increment : Pos; Table_Name : Str; package Table is -- This package provides an implementation of dynamically resizable one -- dimensional arrays. The idea is to mimic the normal Ada semantics for -- arrays as closely as possible with the one additional capability of -- dynamically modifying the value of the Last attribute. -- Component_Type and Index_Type specify the type of the array, Low_Bound -- is the lower bound. Index_type must be an integer type. The effect is -- roughly to declare: -- Table : array (Low_Bound .. <>) of Component_Type; -- The Initial and Increment values control the allocation of the table. -- When the table is first allocated, the Initial value controls the actual -- size of the allocated table. The Increment value is a percentage value -- used to determine the increase in the table size (e.g. 100 = increase -- table size by 100%, i.e. double it). The Table_Name parameter is simply -- use in debug output messages it has no other usage, and is not -- referenced in non-debugging mode. -- The Last and Set_Last subprograms provide control over the current -- logical allocation. They are quite efficient, so they can be used freely -- freely (expensive reallocation occurs only at major granularity chunks, -- controlled by the allocation parameters. type Table_Type is array (Index_Type range <>) of Component_Type; -- Type for the table type Table_Ptr is access Table_Type; -- The table is actually represented as a pointer to allow reallocation Table : Table_Ptr := null; -- The table itself. The lower bound is the value of Low_Bound. Logically -- the upper bound is the current value of Last (although the actual size -- of the allocated table may be larger than this). The program may only -- access and modify Table entries in the range First .. Last. procedure Init; -- This procedure allocates a new table of size Initial (freeing any -- previously allocated larger table). It is not necessary to call -- Init when a table is first instantiated (since the instantiation does -- the same initialization steps). However, it is harmless to do so, and -- Init is convenient in reestablishing a table for new use. function Last return Index_Type; pragma Inline (Last); -- Returns the current value of the last used entry in the table, which -- can then be used as a subscript for Table. Note that the only way to -- modify Last is to call the Set_Last procedure. Last must always be -- used to determine the logically last entry. First : constant Index_Type := Low_Bound; -- Export First as synonym for Low_Bound (to be parallel with use of Last) procedure Set_Last (New_Val : Index_Type); pragma Inline (Set_Last); -- This procedure sets Last to the indicated value. If necessary the -- table is reallocated to accomodate the new value (i.e. on return -- the allocated table has an upper bound of at least Last). If Set_Last -- reduces the size of the table, then logically entries are removed from -- the table. If Set_Last increases the size of the table, then new entries -- are logically added to the table. procedure Increment_Last; pragma Inline (Increment_Last); -- Adds 1 to Last (sane as, but faster than, Set_Last (Last + 1). procedure Decrement_Last; pragma Inline (Decrement_Last); -- Subtracts 1 from Last (same as, but faster than, Set_Last (Last - 1). function Copy return Table_Ptr; -- This function returns a copy of the current table contents. The length -- of the table is determined by the current value of Last. The current -- contents of the table, and the setting of Last, are not modified. procedure Free is new Unchecked_Deallocation (Table_Type, Table_Ptr); -- Procedure used to free a table obtained by the Copy function end Table; if Ptr = Max then raise Bad_Switch; end if; Ptr := Ptr + 1; C := Switches (Ptr); if C = '1' or else gnat-1.67-src/src/table.adb 444 10015 7640 11647 5506244440 10704 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- T A B L E -- -- -- -- B o d y -- -- -- -- $Revision: 1.10 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Debug; use Debug; with Output; use Output; package body Table is Last_Val : Int; -- Current value of Last. Note that we declare this in the body because -- we don't want the client to modify Last except through one of the -- official interfaces (since a modification to Last may require a -- reallocation of the table). Min : Int; -- Subscript of the minimum entry in the currently allocated table Max : Int; -- Subscript of the maximum entry in the currently allocated table Length : Int := 0; -- Number of entries in currently allocated table. The value of zero -- ensures that we initially allocate the table. procedure Reallocate; -- Reallocate and extend the existing table ---------- -- Init -- ---------- procedure Init is Old_Length : Int := Length; begin Min := Int (First); Last_Val := Min - 1; Max := Min + Initial - 1; Length := Max - Min + 1; -- If table is same size as before (happens when table is never -- expanded which is a common case), then simply reuse it, else free -- the old table and allocate a new one of the proper size. if Old_Length /= Length then Free (Table); Table := new Table_Type (Index_Type (Min) .. Index_Type (Max)); end if; end Init; ---------- -- Last -- ---------- function Last return Index_Type is begin return Index_Type (Last_Val); end Last; -------------- -- Set_Last -- -------------- procedure Set_Last (New_Val : Index_Type) is Old_Last : Int; begin if Int (New_Val) < Last_Val then Last_Val := Int (New_Val); else Old_Last := Last_Val; Last_Val := Int (New_Val); if Last_Val > Max then Reallocate; end if; end if; end Set_Last; -------------------- -- Increment_Last -- -------------------- procedure Increment_Last is begin Last_Val := Last_Val + 1; if Last_Val > Max then Reallocate; end if; end Increment_Last; -------------------- -- Decrement_Last -- -------------------- procedure Decrement_Last is begin Last_Val := Last_Val - 1; end Decrement_Last; ---------- -- Copy -- ---------- function Copy return Table_Ptr is begin return new Table_Type'(Table (First .. Last)); end Copy; ---------------- -- Reallocate -- ---------------- procedure Reallocate is Old_Table : Table_Ptr := Table; Old_Max : Int := Max; begin while Max < Last_Val loop Length := Length * (100 + Increment) / 100; Max := Min + Length - 1; end loop; Table := new Table_Type (Index_Type (Min) .. Index_Type (Max)); if Debug_Flag_D then Write_String ("--> Allocating new "); Write_Str (Table_Name); Write_String (" table, size = "); Write_Int (Max - Min + 1); Write_Eol; end if; for I in Min .. Old_Max loop Table (Index_Type (I)) := Old_Table (Index_Type (I)); end loop; Free (Old_Table); end Reallocate; begin Init; end Table; least Last). If Set_Last -- reduces the size of the table, then logically entries aregnat-1.67-src/src/tbuild.ads 444 10015 7640 21234 5506244441 11113 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- T B U I L D -- -- -- -- S p e c -- -- -- -- $Revision: 1.36 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Tbuild is -- This package contains various utility procedures to assist in -- building specific types of tree nodes. procedure Create_Raise_Expression (N : Node_Id; Excep_Id : Entity_Id); -- This procedure converts an expression node into the special -- N_Expression_Actions node whose statments part is a single -- statement consisting of raise the predefined exception Excep_Id. function Make_DT_Component (Loc : Source_Ptr; Typ : Entity_Id; I : Positive) return Node_Id; -- Gives a reference to the Ith component of the Dispatch Table of -- a given Tagged Type. -- -- I = 1 --> Inheritance_Depth -- I = 2 --> Tags (array of ancestors) -- I = 3, 4 --> predefined primitive -- function _Size (X : Typ) return Long_Long_Integer; -- function _Equality (X : Typ; Y : Typ'Class) return Boolean; -- I >= 5 --> User-Defined Primitive Operations -- function Make_DT_Access (Loc : Source_Ptr; Rec : Node_Id; Typ : Entity_Id) return Node_Id; -- Create an access to the Dispatch Table by using the Tag field -- of a tagged record : -- -- Acc_Dt (Rec.tag).all function Make_Unchecked_Type_Conversion (Sloc : Source_Ptr; Subtype_Mark : Node_Id; Expression : Node_Id; Parens : Boolean := False) return Node_Id; -- Same as Make_Type_Conversion but set the Unchecked Flag to True. function New_Constraint_Error (Loc : Source_Ptr) return Node_Id; -- This function builds a tree corresponding to the Ada statement -- "raise Constraint_Error" and returns the root of this tree, -- the N_Raise_Statement node. function New_External_Name (Related_Id : Name_Id; Suffix : Str; Index : Nat := 0; Prefix : Str := "") return Name_Id; -- Builds a new entry in the names table of the form -- -- [Prefix & "__" &] Related_Id & "___" & Suffix [& '_' & Index'Image] -- -- where Prefix__ is prepended only if Prefix is non-null, and Index'Image -- is appended only if Index is non-zero. The constructed name is stored -- using Find_Name so that it can be located using a subsequent Find_Name -- operation (i.e. it is properly hashed into the names table). The three -- underscores separating Related_Id and Suffix ensure that the name does -- not clash with any Ada identifier name, or with any generated public -- name (public names use double underscores for periods). The generated -- names are permitted, but not required, to be made public by setting the -- the Is_Public flag in the associated entity. Note: the reason that -- Prefix is last is that it is almost always omitted. The notable case -- of Prefix being non-null is when it is "ityp" for an implicit type. function New_Internal_Name (Id_Str : Str) return Name_Id; -- Returns a new name of the form x__y where x is the given string and y is -- a serial number so that names created by New_Internal_Name are unique. -- The double underscore guarantees that the resulting name does not -- clash with any Ada identifier. The name is entered into the names -- table using Name_Enter rather than Name_Find, because there can never -- be a need to locate the entry using the Name_Find procedure later on. -- Names created by New_Internal_Name must never have the Is_Public flag -- set. This is because there is no guarantee that the same serial number -- will be used when the same unit is included in different compilations. -- If a public name is required, New_External_Name must be used instead. function New_Occurrence_Of (Def_Id : Entity_Id; Loc : Source_Ptr) return Node_Id; -- New_Occurrence_Of creates an N_Identifier node which is an -- occurrence of the defining identifier which is passed as its -- argument. The Entity and Etype of the result are set from -- the given defining identifier. function New_Reference_To (Def_Id : Entity_Id; Loc : Source_Ptr) return Node_Id; -- This is like New_Occurrence_Of, but it does not set the Etype field. -- It is used from the expander, where Etype fields are generally not set, -- since they are set when the expanded tree is reanalyzed. procedure Raise_Warning (N : Node_Id; Excep_Id : Entity_Id; Reason : Str); -- This procedure posts a warning message on node N stating that -- exception Excep_Id will be raised at run-time. The Reason string, -- (which should end with the characters ?!, since these are warning -- messages that should appear unconditionally) is used to provide an -- additional message which precedes the main message. procedure Rewrite_Int_Literal (N : Node_Id; Val : Uint); -- Rewrite_Int_Literal replaces node N, which is an expression node of -- some integer type, with an N_Integer_Literal node whose Intval field -- is set to Val. The Is_Static field of the new N_Integer_Literal node -- is set using the previous value of the setting for N. The replacement -- uses the tree rewrite mechanism described in the tree package so that -- the original tree for the expression can still be recoverd with the -- Original_Node function. This procedure can be used for such things -- as compile-time expression evaluation and replacement of named -- numbers where the original tree needs to be preserved. procedure Rewrite_Real_Literal (N : Node_Id; Num, Den : Uint; Decimal_Flag : Boolean); -- Rewrite_Real_Literal replaces node N, which is an expression node of -- some real type, with an N_Real_Literal node whose Numerator and -- Denominator fields are set to Num and Den. The Is_Decimal field is -- set to Decimal_Flag. The Is_Static field of the new N_Real_Literal -- node is set using the previous value of the setting for N. The -- replacement uses the tree rewrite mechanism described in the tree -- package so that the original tree for the expression can still be -- recoverd with the Original_Node function. This procedure can be used -- for such things as compile-time expression evaluation and replacement -- of named numbers where the original tree needs to be preserved. procedure Rewrite_Enum_Literal (N : Node_Id; Val : Entity_Id); -- Rewrite_Enum_Literal replaces node N, which is some expression node -- with an N_Identifier node whose Entity field is set to Val. The -- Is_Static field of the new N_Integer_Literal node is set using the -- previous value of the setting for N. Val represents some defining -- occurrence of an enumeration literal. The replacement uses the tree -- rewrite mechanism described in the tree package so that the original -- tree for the expression can still be recoverd with the Original_Node -- function. This procedure can be used for such things as compile-time -- expression evaluation where the original tree needs to be preserved. end Tbuild; lse C = 'n' then Identifier_Character_Set := To_Char (C); Ptr := Ptr + 1; else raise Bad_Switch; end if; else raise Bad_Switch; end if; elsif C = 'k' then Ptr := Ptr + 1; gnat-1.67-src/src/tbuild.adb 444 10015 7640 24137 5506244441 11077 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- T B U I L D -- -- -- -- B o d y -- -- -- -- $Revision: 1.45 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Einfo; use Einfo; with Errout; use Errout; with Namet; use Namet; with Nmake; use Nmake; with Sinfo; use Sinfo; with Stand; use Stand; package body Tbuild is Serial : Nat := 0; -- A serial number used to make sure all created names are unique ----------------------- -- Local Subprograms -- ----------------------- procedure Add_Nat_To_Name_Buffer (V : Nat); -- Add decimal representation of given value to the end of the string -- currently stored in Name_Buffer, incrementing Name_Len as required. ---------------------------- -- Add_Nat_To_Name_Buffer -- ---------------------------- procedure Add_Nat_To_Name_Buffer (V : Nat) is begin if V >= 10 then Add_Nat_To_Name_Buffer (V / 10); end if; Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := Char'Val (Char'Pos ('0') + V rem 10); end Add_Nat_To_Name_Buffer; ----------------------------- -- Create_Raise_Expression -- ----------------------------- procedure Create_Raise_Expression (N : Node_Id; Excep_Id : Entity_Id) is Original_Node : Node_Id; Raise_Node : Node_Id; Ident_Node : Node_Id; Statement_List : List_Id; begin Original_Node := New_Copy (N); Change_Node (N, N_Expression_Actions); Set_Etype (N, Etype (Original_Node)); Set_Expression (N, Original_Node); Ident_Node := New_Node (N_Identifier, Sloc (N)); Set_Chars (Ident_Node, Chars (Excep_Id)); Set_Entity (Ident_Node, Excep_Id); Raise_Node := New_Node (N_Raise_Statement, Sloc (N)); Set_Name (Raise_Node, Ident_Node); Statement_List := New_List_1 (Raise_Node); Set_Actions (N, Statement_List); end Create_Raise_Expression; -------------------------- -- New_Constraint_Error -- -------------------------- function New_Constraint_Error (Loc : Source_Ptr) return Node_Id is Ident_Node : Node_Id; Raise_Node : Node_Id; begin Ident_Node := New_Node (N_Identifier, Loc); Set_Chars (Ident_Node, Chars (Standard_Entity (S_Constraint_Error))); Set_Entity (Ident_Node, Standard_Entity (S_Constraint_Error)); Raise_Node := New_Node (N_Raise_Statement, Loc); Set_Name (Raise_Node, Ident_Node); return Raise_Node; end New_Constraint_Error; ----------------------- -- Make_DT_Component -- ----------------------- function Make_DT_Component (Loc : Source_Ptr; Typ : Entity_Id; I : Positive) return Node_Id is X : Node_Id; begin X := First_Component (Designated_Type (Etype (Access_Disp_Table (Typ)))); for J in 2 .. I loop X := Next_Component (X); end loop; return New_Reference_To (X, Loc); end Make_DT_Component; -------------------- -- Make_DT_Access -- -------------------- function Make_DT_Access (Loc : Source_Ptr; Rec : Node_Id; Typ : Entity_Id) return Node_Id is begin return Make_Unchecked_Type_Conversion (Loc, Subtype_Mark => New_Occurrence_Of ( Etype (Access_Disp_Table (Typ)), Loc), Expression => Make_Selected_Component (Loc, Prefix => New_Copy (Rec), Selector_Name => New_Reference_To (Tag_Component (Typ), Loc))); end Make_DT_Access; ------------------------------- -- Make_Unchecked_Conversion -- ------------------------------- function Make_Unchecked_Type_Conversion (Sloc : Source_Ptr; Subtype_Mark : Node_Id; Expression : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := Make_Type_Conversion (Sloc, Subtype_Mark, Expression, Parens); begin Set_Unchecked_Conversion (N, True); return N; end Make_Unchecked_Type_Conversion; ----------------------- -- New_External_Name -- ----------------------- function New_External_Name (Related_Id : Name_Id; Suffix : Str; Index : Nat := 0; Prefix : Str := "") return Name_Id is PL : constant Int := Prefix'Length; begin Get_Name_String (Related_Id); if PL > 0 then Name_Buffer (PL + 3 .. PL + 2 + Name_Len) := Name_Buffer (1 .. Name_Len); Name_Buffer (1 .. PL) := Prefix; Name_Buffer (PL + 1) := '_'; Name_Buffer (PL + 2) := '_'; Name_Len := Name_Len + PL + 2; end if; Name_Buffer (Name_Len + 1) := '_'; Name_Buffer (Name_Len + 2) := '_'; Name_Buffer (Name_Len + 3) := '_'; Name_Len := Name_Len + 3; Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix; Name_Len := Name_Len + Suffix'Length; if Index /= 0 then Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := '_'; Add_Nat_To_Name_Buffer (Index); end if; return Name_Find; end New_External_Name; ----------------------- -- New_Internal_Name -- ----------------------- function New_Internal_Name (Id_Str : Str) return Name_Id is Id_Len : constant Nat := Id_Str'Length; begin Name_Buffer (1 .. Id_Len) := Id_Str; Name_Buffer (Id_Len + 1) := '_'; Name_Buffer (Id_Len + 2) := '_'; Name_Len := Id_Len + 2; Serial := Serial + 1; Add_Nat_To_Name_Buffer (Serial); return Name_Enter; end New_Internal_Name; ----------------------- -- New_Occurrence_Of -- ----------------------- function New_Occurrence_Of (Def_Id : Entity_Id; Loc : Source_Ptr) return Node_Id is Occurrence : Node_Id; begin Occurrence := New_Node (N_Identifier, Loc); Set_Chars (Occurrence, Chars (Def_Id)); Set_Entity (Occurrence, Def_Id); Set_Etype (Occurrence, Etype (Def_Id)); return Occurrence; end New_Occurrence_Of; ---------------------- -- New_Reference_To -- ---------------------- function New_Reference_To (Def_Id : Entity_Id; Loc : Source_Ptr) return Node_Id is Occurrence : Node_Id; begin Occurrence := New_Node (N_Identifier, Loc); Set_Chars (Occurrence, Chars (Def_Id)); Set_Entity (Occurrence, Def_Id); return Occurrence; end New_Reference_To; ------------------- -- Raise_Warning -- ------------------- procedure Raise_Warning (N : Node_Id; Excep_Id : Entity_Id; Reason : Str) is begin Error_Msg_N (Reason, N); Error_Msg_NE ("& will be raised at runtime?!", N, Excep_Id); end Raise_Warning; ------------------------- -- Rewrite_Int_Literal -- ------------------------- procedure Rewrite_Int_Literal (N : Node_Id; Val : Uint) is Int_Literal_Node : Node_Id; begin Int_Literal_Node := New_Node (N_Integer_Literal, Sloc (N)); Set_Intval (Int_Literal_Node, Val); Set_Etype (Int_Literal_Node, Etype (N)); Set_Is_Evaluated (Int_Literal_Node, True); Set_Is_Static (Int_Literal_Node, Is_Static (N)); Rewrite_Substitute_Tree (N, Int_Literal_Node); end Rewrite_Int_Literal; ------------------------- -- Rewrite_Real_Literal -- ------------------------- procedure Rewrite_Real_Literal (N : Node_Id; Num, Den : Uint; Decimal_Flag : Boolean) is Real_Literal_Node : Node_Id; begin Real_Literal_Node := New_Node (N_Real_Literal, Sloc (N)); Set_Numerator (Real_Literal_Node, Num); Set_Denominator (Real_Literal_Node, Den); Set_Etype (Real_Literal_Node, Etype (N)); Set_Is_Evaluated (Real_Literal_Node, True); Set_Is_Static (Real_Literal_Node, Is_Static (N)); Set_Decimal (Real_Literal_Node, Decimal_Flag); Rewrite_Substitute_Tree (N, Real_Literal_Node); end Rewrite_Real_Literal; -------------------------- -- Rewrite_Enum_Literal -- -------------------------- procedure Rewrite_Enum_Literal (N : Node_Id; Val : Entity_Id) is Id_Node : Node_Id; begin Id_Node := New_Node (N_Identifier, Sloc (N)); Set_Entity (Id_Node, Val); Set_Chars (Id_Node, Chars (Val)); Set_Etype (Id_Node, Etype (N)); Set_Is_Evaluated (Id_Node, True); Set_Is_Static (Id_Node, Is_Static (N)); Rewrite_Substitute_Tree (N, Id_Node); end Rewrite_Enum_Literal; end Tbuild; - Local Subprograms -- ----------------------- procedure Add_Nat_To_Name_Buffer (V : Nat); -- Add decimal representation of given value to the end of the string -- currently stored in Name_Buffer, incrementing Name_Len as required. ---------------------------- -- Add_Nat_To_Name_Buffer -- ---------------------------- procedure Add_Nat_To_Name_Buffer (V : Nat) is begin if V >= gnat-1.67-src/src/treepr.ads 444 10015 7640 6667 5506244442 11127 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- T R E E P R -- -- -- -- S p e c -- -- -- -- $Revision: 1.8 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Treepr is -- This package provides printing routines for the abstract syntax tree -- These routines are intended only for debugging use. procedure Tree_Dump (S : Char); -- This routine is called from the GNAT main program to dump trees as -- requested by debug options. The argument indicates which stage it -- is called at and is 'P' for the call after the parser, and 'S' for -- the call after semantics. procedure Print_Tree_Node (N : Node_Id; Label : Str := ""); -- Prints a single tree node, without printing descendants. The Label -- string is used to preface each line of the printed output. procedure Print_Tree_List (L : List_Id); -- Prints a single node list, without printing the descendants of any -- of the nodes in the list procedure Print_Tree_Elist (E : Elist_Id); -- Prints a single node list, without printing the descendants of any -- of the nodes in the list procedure Print_Node_Subtree (N : Node_Id); -- Prints the subtree routed at a specified tree node, including all -- referenced descendants. procedure Print_List_Subtree (L : List_Id); -- Prints the subtree consisting of the given node list and all its -- referenced descendants. procedure Print_Elist_Subtree (E : Elist_Id); -- Prints the subtree consisting of the given element list and all its -- referenced descendants. procedure PN (N : Node_Id); -- Debugging procedure (to be called within gdb) -- same as Print_Tree_Node with Label = "" procedure PT (N : Node_Id); -- Debugging procedure (to be called within gdb) -- same as Print_Node_Subtree end Treepr; )))); for J in 2 .. I loop X := Next_Component (X); gnat-1.67-src/src/treepr.adb 444 10015 7640 114007 5506244443 11133 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- T R E E P R -- -- -- -- B o d y -- -- -- -- $Revision: 1.47 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Csets; use Csets; with Debug; use Debug; with Einfo; use Einfo; with Lib; use Lib; with Namet; use Namet; with Opt; use Opt; with Output; use Output; with Sinfo; use Sinfo; with Sinput; use Sinput; with Stand; use Stand; with Stringt; use Stringt; with Treeprs; use Treeprs; with Uintp; use Uintp; with Uname; use Uname; with Unchecked_Deallocation; package body Treepr is use Atree.Unchecked_Access; -- This module uses the unchecked access functions in package Atree -- since it does an untyped traversal of the tree (we do not want to -- count on the structure of the tree being correct in this routine!) ---------------------------------- -- Approach Used for Tree Print -- ---------------------------------- -- When a complete subtree is being printed, a trace phase first marks -- the nodes and lists to be printed. This trace phase allocates logical -- numbers corresponding to the order in which the nodes and lists will -- be printed. These logical numbers are recorded in the following tables. -- Note that the numbers start at one, so that an initial value of zero -- indicates that a node or list has not yet been visited. The reason -- for using these numbers rather than the node id values is that we -- print the nodes and lists in a logical order corresponding to the -- pointer link structure, and thus the List_Id and Node_Id values -- would be out of order and hard to find. type Node_Numbers_Type is array (Node_Id range <>) of Nat; type Access_Node_Numbers_Type is access Node_Numbers_Type; Node_Numbers : Access_Node_Numbers_Type; type List_Numbers_Type is array (List_Id range <>) of Nat; type Access_List_Numbers_Type is access List_Numbers_Type; List_Numbers : Access_List_Numbers_Type; Printing_Descendants : Boolean; -- True if descendants are being printed, False if not. In the false case, -- only node Id's are printed. In the true case, node numbers as well as -- node Id's are printed, as described above. type Phase_Type is (Marking, Printing); -- Type for Phase variable Phase : Phase_Type; -- When an entire tree is being printed, the traversal operates in two -- phases. The first phase marks the nodes in use by installing node -- numbers in the node number table. The second phase prints the nodes. -- This variable indicates the current phase. Next_Sequence_Number : Int; -- Number of last visited node or list. Used during the marking phase to -- set proper node numbers in the node number tables, and during the -- printing phase to make sure that a given node is not printed more than -- once (nodes are printed in order during the printing phase, that's the -- point of numbering them in the first place!) ---------------------- -- Local Procedures -- ---------------------- procedure Print_Init; -- Initialize for printing of tree with descendents procedure Print_Term; -- Clean up after printing of tree with descendents procedure Print_Char (C : Char); -- Print character C if currently in print phase, noop if in marking phase procedure Print_Entity_Kind (E : Entity_Id); -- Print entity kind name in mixed case if in print phase, noop if in -- marking phase. procedure Print_Name (N : Name_Id); -- Print name from names table if currently in print phase, noop if in -- marking phase. Note that the name is output in mixed case mode. procedure Print_Node_Kind (N : Node_Id); -- Print node kind name in mixed case if in print phase, noop if in -- marking phase. procedure Print_Str (S : Str); -- Print string S if currently in print phase, noop if in marking phase procedure Print_Int (I : Int); -- Print integer I if currently in print phase, noop if in marking phase procedure Print_Eol; -- Print end of line if currently in print phase, noop if in marking phase procedure Print_Node_Ref (N : Node_Id); -- Print "", "" or "Node #nnn" with additional information -- in the latter case, including the Id and the Nkind of the node. procedure Print_List_Ref (L : List_Id); -- Print "", or "" or "Node list #nnn" procedure Print_Elist_Ref (E : Elist_Id); -- Print "", or "" or "Element list #nnn" procedure Print_Field (Val : Int); -- Print representation of Field value (name, tree, string, uint, charcode) procedure Print_Flag (F : Boolean); -- Print True or False procedure Print_Node (N : Node_Id; Prefix_Str : Str; Prefix_Char : Char); -- This is the internal routine used to print a single node. Each line of -- output is preceded by Prefix_Str (which is used to set the indentation -- level and the bars used to link list elements). In addition, for lines -- other than the first, an additional character Prefix_Char is output. procedure Visit_Node (N : Node_Id; Prefix_Str : Str; Prefix_Char : Char); -- Called to process a single node in the case where descendents are to -- be printed before every line, and Prefix_Char added to all lines -- except the header line for the node. procedure Visit_List (L : List_Id; Prefix_Str : Str); -- Visit_List is called to process a list in the case where descendents -- are to be printed. Prefix_Str is to be added to all printed lines. procedure Visit_Elist (E : Elist_Id; Prefix_Str : Str); -- Visit_Elist is called to process an element list in the case where -- descendents are to be printed. Prefix_Str is to be added to all -- printed lines. --------------- -- Tree_Dump -- --------------- procedure Tree_Dump (S : Char) is Max_Unit : Unit_Number_Type; procedure Underline; -- Put underline under string we just printed procedure Underline is Col : constant Int := Column; begin Write_Eol; while Col > Column loop Write_Char ('-'); end loop; Write_Eol; end Underline; -- Start of processing for Tree_Dump begin if Debug_Flag_Y and then (S = 'S' or else Operating_Mode = Check_Syntax) then Write_Eol; Write_String ("Tree created for Standard (spec) "); if S = 'P' then Write_Str ("after parsing"); else Write_Str ("after semantics"); end if; Underline; Print_Node_Subtree (Standard_Package_Node); Write_Eol; end if; if (Debug_Flag_T and then (S = 'S' or else Operating_Mode = Check_Syntax)) or else (Debug_Flag_U and then (S = 'P' and then Operating_Mode /= Check_Syntax)) then if Debug_Flag_F then Max_Unit := File.Last; else Max_Unit := Main_Unit; end if; for U in Main_Unit .. Max_Unit loop if File.Table (U).Source /= null then Write_Eol; Write_String ("Tree created for "); Write_Unit_Name (File.Table (U).Unit_Name); if S = 'P' then Write_Str (" after parsing "); else Write_Str (" after semantics "); end if; Underline; Print_Node_Subtree (File.Table (U).Cunit); Write_Eol; end if; end loop; end if; end Tree_Dump; --------------------- -- Print_Tree_Node -- --------------------- procedure Print_Tree_Node (N : Node_Id; Label : Str := "") is begin Printing_Descendants := False; Phase := Printing; Print_Node (N, Label, ' '); end Print_Tree_Node; --------------------- -- Print_Tree_List -- --------------------- procedure Print_Tree_List (L : List_Id) is N : Node_Id; begin Printing_Descendants := False; Phase := Printing; Print_List_Ref (L); Print_Str (" List_Id = "); Print_Int (Int (L)); Print_Eol; N := First (L); if N = Empty then Print_Str (""); Print_Eol; else loop Print_Char ('|'); Print_Eol; exit when Next (N) = Empty; Print_Node (N, "", '|'); N := Next (N); end loop; Print_Node (N, "", ' '); Print_Eol; end if; end Print_Tree_List; --------------------- -- Print_Tree_Elist -- --------------------- procedure Print_Tree_Elist (E : Elist_Id) is M : Elmt_Id; begin Printing_Descendants := False; Phase := Printing; Print_Elist_Ref (E); Print_Eol; M := First_Elmt (E); if M = No_Elmt then Print_Str (""); Print_Eol; else loop Print_Char ('|'); Print_Eol; exit when Next_Elmt (M) = No_Elmt; Print_Node (Id_Of (M), "", '|'); M := Next_Elmt (M); end loop; Print_Node (Id_Of (M), "", ' '); Print_Eol; end if; end Print_Tree_Elist; ---------------- -- Print_Init -- ---------------- procedure Print_Init is begin Printing_Descendants := True; Write_Eol; -- Clear node and list numbers to zero (= unmarked) Node_Numbers := new Node_Numbers_Type (First_Node_Id .. Last_Node_Id); List_Numbers := new List_Numbers_Type (First_List_Id .. Last_List_Id); for I in Node_Numbers'range loop Node_Numbers (I) := 0; end loop; for I in List_Numbers'range loop List_Numbers (I) := 0; end loop; end Print_Init; ---------------- -- Print_Term -- ---------------- procedure Print_Term is procedure Free is new Unchecked_Deallocation (Node_Numbers_Type, Access_Node_Numbers_Type); procedure Free is new Unchecked_Deallocation (List_Numbers_Type, Access_List_Numbers_Type); begin Free (Node_Numbers); Free (List_Numbers); end Print_Term; ------------------------ -- Print_Node_Subtree -- ------------------------ procedure Print_Node_Subtree (N : Node_Id) is begin Print_Init; Next_Sequence_Number := 1; Phase := Marking; Visit_Node (N, "", ' '); Next_Sequence_Number := 1; Phase := Printing; Visit_Node (N, "", ' '); Print_Term; end Print_Node_Subtree; ------------------------ -- Print_List_Subtree -- ------------------------ procedure Print_List_Subtree (L : List_Id) is begin Print_Init; Next_Sequence_Number := 1; Phase := Marking; Visit_List (L, ""); Next_Sequence_Number := 1; Phase := Printing; Visit_List (L, ""); Print_Term; end Print_List_Subtree; ------------------------- -- Print_Elist_Subtree -- ------------------------- procedure Print_Elist_Subtree (E : Elist_Id) is begin Print_Init; Next_Sequence_Number := 1; Phase := Marking; Visit_Elist (E, ""); Next_Sequence_Number := 1; Phase := Printing; Visit_Elist (E, ""); Print_Term; end Print_Elist_Subtree; ---------------- -- Print_Char -- ---------------- procedure Print_Char (C : Char) is begin if Phase = Printing then Write_Char (C); end if; end Print_Char; ----------------------- -- Print_Entity_Kind -- ----------------------- procedure Print_Entity_Kind (E : Entity_Id) is Ucase : Boolean; S : constant String := Entity_Kind'Image (Ekind (E)); begin if Phase = Printing then Ucase := True; -- Note: the call to Fold_Upper in this loop is to get past the GNAT -- bug of 'Image returning lower case instead of upper case. for I in S'range loop if Ucase then Write_Char (Fold_Upper (To_Char (S (I)))); else Write_Char (Fold_Lower (To_Char (S (I)))); end if; Ucase := (S (I) = '_'); end loop; end if; end Print_Entity_Kind; --------------- -- Print_Int -- --------------- procedure Print_Int (I : Int) is begin if Phase = Printing then Write_Int (I); end if; end Print_Int; ---------------- -- Print_Name -- ---------------- procedure Print_Name (N : Name_Id) is Ucase : Boolean; begin if Phase = Printing then if N = No_Name then Print_Str (""); elsif N = Error_Name then Print_Str (""); else Get_Name_String (N); if Name_Buffer (1) /= '"' then Print_Char ('"'); Ucase := True; for I in 1 .. Name_Len loop if Ucase then Write_Char (Fold_Upper (Name_Buffer (I))); else Write_Char (Name_Buffer (I)); end if; Ucase := (Name_Buffer (I) = '_'); end loop; Print_Char ('"'); -- Operator case, output as is (in quotes all lower case) else Write_Name (N); end if; end if; end if; end Print_Name; --------------------- -- Print_Node_Kind -- --------------------- procedure Print_Node_Kind (N : Node_Id) is Ucase : Boolean; S : constant String := Node_Kind'Image (Nkind (N)); begin if Phase = Printing then Ucase := True; -- Note: the call to Fold_Upper in this loop is to get past the GNAT -- bug of 'Image returning lower case instead of upper case. for I in S'range loop if Ucase then Write_Char (Fold_Upper (To_Char (S (I)))); else Write_Char (Fold_Lower (To_Char (S (I)))); end if; Ucase := (S (I) = '_'); end loop; end if; end Print_Node_Kind; --------------- -- Print_Str -- --------------- procedure Print_Str (S : Str) is begin if Phase = Printing then Write_Str (S); end if; end Print_Str; --------------- -- Print_Eol -- --------------- procedure Print_Eol is begin if Phase = Printing then Write_Eol; end if; end Print_Eol; -------------------- -- Print_Node_Ref -- -------------------- procedure Print_Node_Ref (N : Node_Id) is begin if Phase /= Printing then return; end if; if N = Empty then Write_Str (""); elsif N = Error then Write_Str (""); else if Printing_Descendants then if Node_Numbers (N) /= 0 then Write_String ("Node"); Write_Str (" #"); Write_Int (Node_Numbers (N)); Write_Char (' '); end if; end if; Print_Node_Kind (N); if Nkind (N) in N_Has_Chars then Write_Char (' '); Print_Name (Chars (N)); end if; if Nkind (N) in N_Entity then Write_Str (" (Entity_Id = "); else Write_Str (" (Node_Id = "); end if; Write_Int (Int (N)); if Sloc (N) = Standard_Location then Write_Char ('s'); end if; Write_Char (')'); end if; end Print_Node_Ref; -------------------- -- Print_List_Ref -- -------------------- procedure Print_List_Ref (L : List_Id) is begin if Phase /= Printing then return; end if; if L = No_List then Write_Str (""); elsif Is_Empty_List (L) then Write_Str (" (List_Id = "); Write_Int (Int (L)); Write_Char (')'); else Write_Str ("List"); if Printing_Descendants then Write_Str (" #"); Write_Int (List_Numbers (L)); end if; Write_Str (" (List_Id = "); Write_Int (Int (L)); Write_Char (')'); end if; end Print_List_Ref; --------------------- -- Print_Elist_Ref -- --------------------- procedure Print_Elist_Ref (E : Elist_Id) is begin if Phase /= Printing then return; end if; if E = No_Elist then Write_Str (""); elsif Is_Empty_Elmt_List (E) then Write_Str ("Empty elist, (Elist_Id = "); Write_Int (Int (E)); Write_Char (')'); else Write_Str ("(Elist_Id = "); Write_Int (Int (E)); Write_Char (')'); if Printing_Descendants then Write_Str (" #"); Write_Int (List_Numbers (List_Id (Int (E) - Elist_Bias))); end if; end if; end Print_Elist_Ref; ----------------- -- Print_Field -- ----------------- procedure Print_Field (Val : Int) is begin if Phase /= Printing then return; end if; if Val in Node_Range then Print_Node_Ref (Node_Id (Val)); elsif Val in List_Range then Print_List_Ref (List_Id (Val)); elsif Val in Elist_Range then Print_Elist_Ref (Elist_Id (Val)); elsif Val in Names_Range then Print_Name (Name_Id (Val)); Write_Str (" (Name_Id = "); Write_Int (Val); Write_Char (')'); elsif Val in Strings_Range then Write_String_Table_Entry (String_Id (Val)); Write_Str (" (String_Id = "); Write_Int (Val); Write_Char (')'); elsif Val in Uint_Range then if Uint (Val) in Uint_Direct then Write_Int (Val - Int (Uint_Direct_Bias)); else Get_Name_String (UI_Image (Uint (Val))); Print_Str (Name_Buffer (1 .. Name_Len)); Write_Str (" (Uint = "); Write_Int (Val); Write_Char (')'); end if; elsif Val in Char_Code_Range then Write_Str ("Character code = "); declare C : Int := Val - Char_Code_Bias; begin Write_Int (C); if C in 16#20# .. 16#7E# or else C in 16#A0# .. 16#FF# then Write_Str (" ('"); Write_Char (Char'Val (C)); Write_Str ("')"); end if; end; else Print_Str ("****** Incorrect value = "); Print_Int (Val); end if; end Print_Field; ---------------- -- Print_Flag -- ---------------- procedure Print_Flag (F : Boolean) is begin if F then Print_Str ("True"); else Print_Str ("False"); end if; end Print_Flag; ---------------- -- Print_Node -- ---------------- procedure Print_Node (N : Node_Id; Prefix_Str : Str; Prefix_Char : Char) is F : Fchar; P : Int := Pchar_Pos (Nkind (N)); Field_To_Be_Printed : Boolean; Prefix_Str_Char : Str (Prefix_Str'First .. Prefix_Str'Last + 1); Nunit : Unit_Number_Type; begin if Phase /= Printing then return; end if; Prefix_Str_Char (Prefix_Str'range) := Prefix_Str; Prefix_Str_Char (Prefix_Str'Last + 1) := Prefix_Char; -- Print header line Print_Str (Prefix_Str); Print_Node_Ref (N); -- Print note if Analyzed flag set if Analyzed (N) then Print_Str (" (analyzed)"); end if; Print_Eol; if N = Empty then return; end if; if not Is_List_Member (N) then Print_Str (Prefix_Str); Print_Str (" Parent = "); Print_Node_Ref (Parent (N)); Print_Eol; end if; -- Print Sloc field if it is set if Sloc (N) /= No_Location then Print_Str (Prefix_Str_Char); Print_Str ("Sloc = "); if Sloc (N) = Standard_Location then Print_Str ("Standard_Location"); else Nunit := Get_Sloc_Unit_Number (Sloc (N)); Print_Int (Int (Sloc (N)) - Int (File.Table (Nunit).Source'First)); Print_Str (" (Line "); Print_Int (Int (Get_Line_Number (Sloc (N)))); Print_Str (", Col "); Print_Int (Int (Get_Col_Number (Sloc (N)))); if Nunit /= Main_Unit then Print_Str (" in file "); Get_Name_String (File.Table (Nunit).File_Name); Print_Str (Name_Buffer (1 .. Name_Len)); end if; Print_Char (')'); end if; Print_Eol; end if; -- Print Chars field if present if Nkind (N) in N_Has_Chars and then Chars (N) /= No_Name then Print_Str (Prefix_Str_Char); Print_Str ("Chars = "); Print_Name (Chars (N)); Write_Str (" (Name_Id = "); Write_Int (Int (Chars (N))); Write_Char (')'); Print_Eol; end if; -- Print entity information for entities if Nkind (N) in N_Entity then Print_Str (Prefix_Str_Char); Print_Str ("Ekind = "); Print_Entity_Kind (N); Print_Eol; end if; -- Print Left_Opnd if present if Nkind (N) in N_Binary_Op then Print_Str (Prefix_Str_Char); Print_Str ("Left_Opnd = "); Print_Node_Ref (Left_Opnd (N)); Print_Eol; end if; -- Print Right_Opnd if present if Nkind (N) in N_Op then Print_Str (Prefix_Str_Char); Print_Str ("Right_Opnd = "); Print_Node_Ref (Right_Opnd (N)); Print_Eol; end if; -- Print Entity field if operator (other cases of Entity -- are in the table, so are handled in the normal circuit) if Nkind (N) in N_Op and then Present (Entity (N)) then Print_Str (Prefix_Str_Char); Print_Str ("Entity = "); Print_Node_Ref (Entity (N)); Print_Eol; end if; -- Print Error_Posted flag if Error_Posted (N) then Print_Str (Prefix_Str_Char); Print_Str ("Error_Posted = True"); Print_Eol; end if; -- Print special fields if we have a subexpression if Nkind (N) in N_Subexpr then if Parens (N) then Print_Str (Prefix_Str_Char); Print_Str ("Parens = True"); Print_Eol; end if; if Has_No_Side_Effects (N) then Print_Str (Prefix_Str_Char); Print_Str ("Has_No_Side_Effects = True"); Print_Eol; end if; if Do_Range_Check (N) then Print_Str (Prefix_Str_Char); Print_Str ("Do_Range_Check = True"); Print_Eol; end if; if Is_Overloaded (N) then Print_Str (Prefix_Str_Char); Print_Str ("Is_Overloaded = True"); Print_Eol; end if; if Is_Evaluated (N) then Print_Str (Prefix_Str_Char); Print_Str ("Is_Evaluated = True"); Print_Eol; end if; if Is_Static (N) then Print_Str (Prefix_Str_Char); Print_Str ("Is_Static = True"); Print_Eol; end if; end if; -- Print Do_Overflow_Check field if present if Nkind (N) in N_Op and then Do_Overflow_Check (N) then Print_Str (Prefix_Str_Char); Print_Str ("Do_Overflow_Check = True"); Print_Eol; end if; -- Print Etype field if present if Nkind (N) in N_Has_Etype and then Present (Etype (N)) then Print_Str (Prefix_Str_Char); Print_Str ("Etype = "); Print_Node_Ref (Etype (N)); Print_Eol; end if; -- Loop to print other fields (those included in Pchars) while P < Pchar_Pos (Node_Kind'Succ (Nkind (N))) loop F := Pchars (P); P := P + 1; -- Check for case of False flag, which we never print, or -- an Empty field, which is also never printed case F is when F_Field1 => Field_To_Be_Printed := Field1 (N) /= Int (Empty); when F_Field2 => Field_To_Be_Printed := Field2 (N) /= Int (Empty); when F_Field3 => Field_To_Be_Printed := Field3 (N) /= Int (Empty); when F_Field4 => Field_To_Be_Printed := Field4 (N) /= Int (Empty); when F_Field5 => Field_To_Be_Printed := Field5 (N) /= Int (Empty); when F_Field6 => Field_To_Be_Printed := Field6 (N) /= Int (Empty); when F_Field7 => Field_To_Be_Printed := Field7 (N) /= Int (Empty); when F_Flag1 => Field_To_Be_Printed := Flag1 (N); when F_Flag2 => Field_To_Be_Printed := Flag2 (N); when F_Flag3 => Field_To_Be_Printed := Flag3 (N); when F_Flag4 => Field_To_Be_Printed := Flag4 (N); when F_Flag5 => Field_To_Be_Printed := Flag5 (N); when F_Flag6 => Field_To_Be_Printed := Flag6 (N); when F_Flag7 => Field_To_Be_Printed := Flag7 (N); when F_Flag8 => Field_To_Be_Printed := Flag8 (N); when F_Flag9 => Field_To_Be_Printed := Flag9 (N); when F_Flag10 => Field_To_Be_Printed := Flag10 (N); when F_Flag11 => Field_To_Be_Printed := Flag11 (N); when F_Flag12 => Field_To_Be_Printed := Flag12 (N); when F_Flag13 => Field_To_Be_Printed := Flag13 (N); when F_Flag14 => Field_To_Be_Printed := Flag14 (N); when F_Flag15 => Field_To_Be_Printed := Flag15 (N); when F_Flag16 => Field_To_Be_Printed := Flag16 (N); end case; -- Print field if it is to be printed if Field_To_Be_Printed then Print_Str (Prefix_Str_Char); while P < Pchar_Pos (Node_Kind'Succ (Nkind (N))) and then Pchars (P) not in Fchar loop Print_Char (Pchars (P)); P := P + 1; end loop; Print_Str (" = "); case F is when F_Field1 => Print_Field (Field1 (N)); when F_Field2 => Print_Field (Field2 (N)); when F_Field3 => Print_Field (Field3 (N)); when F_Field4 => Print_Field (Field4 (N)); when F_Field5 => Print_Field (Field5 (N)); when F_Field6 => Print_Field (Field6 (N)); when F_Field7 => Print_Field (Field7 (N)); when F_Flag1 => Print_Flag (Flag1 (N)); when F_Flag2 => Print_Flag (Flag2 (N)); when F_Flag3 => Print_Flag (Flag3 (N)); when F_Flag4 => Print_Flag (Flag4 (N)); when F_Flag5 => Print_Flag (Flag5 (N)); when F_Flag6 => Print_Flag (Flag6 (N)); when F_Flag7 => Print_Flag (Flag7 (N)); when F_Flag8 => Print_Flag (Flag8 (N)); when F_Flag9 => Print_Flag (Flag9 (N)); when F_Flag10 => Print_Flag (Flag10 (N)); when F_Flag11 => Print_Flag (Flag11 (N)); when F_Flag12 => Print_Flag (Flag12 (N)); when F_Flag13 => Print_Flag (Flag13 (N)); when F_Flag14 => Print_Flag (Flag14 (N)); when F_Flag15 => Print_Flag (Flag15 (N)); when F_Flag16 => Print_Flag (Flag16 (N)); end case; Print_Eol; -- Field is not to be printed (False flag field) else while P < Pchar_Pos (Node_Kind'Succ (Nkind (N))) and then Pchars (P) not in Fchar loop P := P + 1; end loop; end if; end loop; end Print_Node; ---------------- -- Visit_Node -- ---------------- procedure Visit_Node (N : Node_Id; Prefix_Str : Str; Prefix_Char : Char) is New_Prefix : Str (Prefix_Str'First .. Prefix_Str'Last + 2); -- Prefix string for printing referenced fields procedure Visit_Descendent (D : Int); -- This procedure tests the given value of one of the Fields referenced -- by the current node to determine whether to visit it recursively. -- The recursive visit is appropriate if N is a non-empty Node_Id value -- whose parent is either Empty or is the current node (if there is some -- other non-empty parent, we prefer to trace it from that parent). procedure Visit_Descendent (D : Int) is begin -- Case of descendent is a node if D in Node_Range then -- Don't bother about a descendent in Standard unless we are -- already printing Standard nodes to start with (the latter -- happens only when Treepr is used to print out the tree of -- Standard itself) if Sloc (Node_Id (D)) = Standard_Location and then Sloc (N) /= Standard_Location then return; -- Don't bother about a descendent in a different unit than -- the node we came from. Note that the df debugging switch -- is handled at the top level by GNAT. elsif Sloc (Node_Id (D)) /= Standard_Location and then Sloc (N) /= Standard_Location and then Get_Sloc_Unit_Number (Sloc (Node_Id (D))) /= Get_Sloc_Unit_Number (Sloc (N)) then return; -- Don't bother about Empty or Error descendents, or nodes which -- have a parent, but the parent isn't the node that we came -- from (as explained above, we prefer to list such nodes near -- their real parents). elsif D = Int (Empty) or else D = Int (Error) or else (Parent (Node_Id (D)) /= Empty and then Parent (Node_Id (D)) /= N) then return; -- Otherwise we can go ahead and visit the node else Visit_Node (Node_Id (D), New_Prefix, ' '); end if; -- Case of descendent is a list elsif D in List_Range then -- Don't bother with a missing list, or an empty list, or a list -- with a parent which is not the node we came from (see above) if D = Int (No_List) or else Is_Empty_List (List_Id (D)) or else (List_Parent (List_Id (D)) /= Empty and then List_Parent (List_Id (D)) /= N) then return; -- Otherwise, visit the referenced list else Visit_List (List_Id (D), New_Prefix); end if; -- Case of descendent is an element list elsif D in Elist_Range then -- Don't bother with a missing list, or an empty list, or a list -- with a parent which is not the node we came from (see above) if D = Int (No_Elist) or else Is_Empty_Elmt_List (Elist_Id (D)) or else (Elist_Parent (Elist_Id (D)) /= Empty and then Elist_Parent (Elist_Id (D)) /= N) then return; -- Otherwise, visit the referenced element list else Visit_Elist (Elist_Id (D), New_Prefix); end if; -- For all other kinds of descendents (strings, names, uints etc), -- there is nothing to visit (the contents of the field will be -- printed when we print the containing node, but what concerns -- us now is looking for descendents in the tree. else null; end if; end Visit_Descendent; -- Start of Visit_Node begin if N = Empty then return; end if; New_Prefix (Prefix_Str'range) := Prefix_Str; New_Prefix (Prefix_Str'Last + 1) := Prefix_Char; New_Prefix (Prefix_Str'Last + 2) := ' '; if Phase = Marking then if Node_Numbers (N) /= 0 then return; -- already visited else Node_Numbers (N) := Next_Sequence_Number; Next_Sequence_Number := Next_Sequence_Number + 1; end if; else -- Phase = Printing if Node_Numbers (N) < Next_Sequence_Number then return; -- already printed else Print_Node (N, Prefix_Str, Prefix_Char); Print_Str (Prefix_Str); Print_Char (Prefix_Char); Print_Eol; Next_Sequence_Number := Next_Sequence_Number + 1; end if; end if; -- For defining entities, visit only the descendents that are -- sinfo knows about (i.e. Etype in Field5). Do not visit any -- other stuff referenced only through entity fields. if Nkind (N) in N_Entity then Visit_Descendent (Int (Etype (N))); -- For all other nodes, visit all their descendents (for all other -- nodes, the Sinfo structure knows about all possible descendents) else Visit_Descendent (Field1 (N)); Visit_Descendent (Field2 (N)); Visit_Descendent (Field3 (N)); Visit_Descendent (Field4 (N)); Visit_Descendent (Field5 (N)); if Has_Extension (N) then Visit_Descendent (Field6 (N)); Visit_Descendent (Field7 (N)); Visit_Descendent (Field8 (N)); Visit_Descendent (Field9 (N)); Visit_Descendent (Field10 (N)); Visit_Descendent (Field11 (N)); Visit_Descendent (Field12 (N)); end if; end if; end Visit_Node; ---------------- -- Visit_List -- ---------------- procedure Visit_List (L : List_Id; Prefix_Str : Str) is N : Node_Id; begin if Phase = Marking then if List_Numbers (L) /= 0 then return; -- already visited end if; else -- Phase = Printing if List_Numbers (L) < Next_Sequence_Number then return; -- already printed end if; end if; Print_Str (Prefix_Str); Print_List_Ref (L); Print_Eol; Print_Str (Prefix_Str); Print_Str ("|List_Parent = "); Print_Node_Ref (List_Parent (L)); Print_Eol; if Phase = Marking then List_Numbers (L) := Next_Sequence_Number; end if; Next_Sequence_Number := Next_Sequence_Number + 1; N := First (L); if N = Empty then Print_Str (Prefix_Str); Print_Str ("(Empty list)"); Print_Eol; Print_Eol; else Print_Str (Prefix_Str); Print_Char ('|'); Print_Eol; while Next (N) /= Empty loop Visit_Node (N, Prefix_Str, '|'); N := Next (N); end loop; end if; Visit_Node (N, Prefix_Str, ' '); end Visit_List; ----------------- -- Visit_Elist -- ----------------- procedure Visit_Elist (E : Elist_Id; Prefix_Str : Str) is M : Elmt_Id; L : List_Id; N : Node_Id; begin L := List_Id (Int (E) - Elist_Bias); -- equivalent List_Id if Phase = Marking then if List_Numbers (L) /= 0 then return; -- already visited end if; else -- Phase = Printing if List_Numbers (L) < Next_Sequence_Number then return; -- already printed end if; end if; Print_Str (Prefix_Str); Print_Elist_Ref (E); Print_Eol; Print_Str (Prefix_Str); Print_Str ("|Elist_Parent = "); Print_Node_Ref (Elist_Parent (E)); Print_Eol; if Phase = Marking then List_Numbers (L) := Next_Sequence_Number; end if; Next_Sequence_Number := Next_Sequence_Number + 1; if Is_Empty_Elmt_List (E) then Print_Str (Prefix_Str); Print_Str ("(Empty element list)"); Print_Eol; Print_Eol; else if Phase = Printing then M := First_Elmt (E); while M /= No_Elmt loop N := Id_Of (M); Print_Str (Prefix_Str); Print_Str (" "); Print_Node_Ref (N); Print_Eol; M := Next_Elmt (M); end loop; Print_Str (Prefix_Str); Print_Eol; end if; M := First_Elmt (E); while M /= No_Elmt loop Visit_Node (Id_Of (M), Prefix_Str, ' '); M := Next_Elmt (M); end loop; end if; end Visit_Elist; -------------------------- -- Debugging procedures -- -------------------------- procedure PN (N : Node_Id) is begin Print_Tree_Node (N); end PN; procedure PT (N : Node_Id) is begin Print_Node_Subtree (N); end PT; end Treepr; -- already printing Standard nodes to start with (the latter -- happens only when Treepr is used to print out the tree of -- Standard itself) if Sloc (Node_Id (D)) = Standard_Location and then Sloc (N) /= Standard_Location then return; -- Don't bother about a descendent in a different unit than -- the node we came from. Note that the df debugging switch -- is handled at the top levgnat-1.67-src/src/treeprs.adt 444 10015 7640 11053 5506244443 11315 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- T R E E P R S -- -- -- -- T e m p l a t e -- -- -- -- $Revision: 1.4 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This file is a template used as input to the utility program xtreeprs.spt -- which reads this template, and the spec of Sinfo (sinfo.ads) and generates -- the spec for the Treeprs package (file treeprs.ads) -- This package contains the declaration of the string used by the Tree_Print -- package. It must be updated whenever the arrangements of the field names -- in package Sinfo is changed. The utility program XTREEPRS is used to -- do this update correctly using the template treeprs.adt as input. with Sinfo; use Sinfo; with Types; use Types; package Treeprs is -------------------------------- -- String Data for Node Print -- -------------------------------- -- String data for print out. The Pchars array is a long string with the -- the entry for each node type consisting of a single blank, followed by -- a series of entries, one for each Op or Flag field used for the node. -- Each entry has a single character which identifies the field, followed -- by the synonym name. The starting location for a given node type is -- found from the corresponding entry in the Pchars_Pos_Array. -- The following characters identify the field. These are characters -- which could never occur in a field name, so they also mark the -- end of the previous name. subtype Fchar is Char range '#' .. '9'; F_Field1 : constant Fchar := '#'; -- Char'Val (16#23#) F_Field2 : constant Fchar := '$'; -- Char'Val (16#24#) F_Field3 : constant Fchar := '%'; -- Char'Val (16#25#) F_Field4 : constant Fchar := '&'; -- Char'Val (16#26#) F_Field5 : constant Fchar := '''; -- Char'Val (16#27#) F_Field6 : constant Fchar := '('; -- Char'Val (16#28#) F_Field7 : constant Fchar := ')'; -- Char'Val (16#29#) F_Flag1 : constant Fchar := '*'; -- Char'Val (16#2A#) F_Flag2 : constant Fchar := '+'; -- Char'Val (16#2B#) F_Flag3 : constant Fchar := ','; -- Char'Val (16#2C#) F_Flag4 : constant Fchar := '-'; -- Char'Val (16#2D#) F_Flag5 : constant Fchar := '.'; -- Char'Val (16#2E#) F_Flag6 : constant Fchar := '/'; -- Char'Val (16#2F#) F_Flag7 : constant Fchar := '0'; -- Char'Val (16#30#) F_Flag8 : constant Fchar := '1'; -- Char'Val (16#31#) F_Flag9 : constant Fchar := '2'; -- Char'Val (16#32#) F_Flag10 : constant Fchar := '3'; -- Char'Val (16#33#) F_Flag11 : constant Fchar := '4'; -- Char'Val (16#34#) F_Flag12 : constant Fchar := '5'; -- Char'Val (16#35#) F_Flag13 : constant Fchar := '6'; -- Char'Val (16#36#) F_Flag14 : constant Fchar := '7'; -- Char'Val (16#37#) F_Flag15 : constant Fchar := '8'; -- Char'Val (16#38#) F_Flag16 : constant Fchar := '9'; -- Char'Val (16#39#) !!TEMPLATE INSERTION POINT end Treeprs; -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This file is a template used as input to the utility program xtreeprs.spt -- which reads this template, and the spec of Sinfo (sinfo.ads) and generates -- the spec for the Treeprs package (file treeprs.ads) -- This packagegnat-1.67-src/src/ttypes.ads 444 10015 7640 12600 5506244444 11160 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- T T Y P E S -- -- -- -- S p e c -- -- (32-bit Version) -- -- -- $Revision: 1.4 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This module contains values that describe the predefined (standard) -- target types that are provided. Note that it is essential that all -- references to Size values and other attributes of types use this -- package when talking about target types (rather than using the -- attributes directly which would give information about host types). package Ttypes is -- Note: GNAT always supplies all the following integer and float types, -- but depending on the machine, some of the types may be identical. For -- example, on some machines, Short_Float may be the same as Float, and -- Long_Long_Float may be the same as Long_Float. Standard_Short_Short_Integer_Size : constant := 8; -- Standard.Short_Short_Integer'Size Standard_Short_Short_Integer_Width : constant := 4; -- Standard.Short_Short_Integer'Width Standard_Short_Integer_Size : constant := 16; -- Standard.Short_Integer'Size Standard_Short_Integer_Width : constant := 6; -- Standard.Short_Integer'Width Standard_Integer_Size : constant := 32; -- Standard.Integer'Size Standard_Integer_Width : constant := 11; -- Standard.Integer'Width Standard_Long_Integer_Size : constant := 32; -- Standard.Long_Integer'Size Standard_Long_Integer_Width : constant := 11; -- Standard.Long_Integer'Width Standard_Long_Long_Integer_Size : constant := 64; -- Standard.Long_Long_Integer'Size Standard_Long_Long_Integer_Width : constant := 21; -- Standard.Long_Long_Integer'Width Standard_Short_Float_Size : constant := 32; -- Standard.Short_Float'Size Standard_Short_Float_Digits : constant := 6; -- Standard.Short_Float'Digits Standard_Float_Size : constant := 32; -- Standard.Float'Size Standard_Float_Digits : constant := 6; -- Standard.Float'Digits Standard_Long_Float_Size : constant := 64; -- Standard.Long_Float'Size Standard_Long_Float_Digits : constant := 15; -- Standard.Long_Float'Digits Standard_Long_Long_Float_Size : constant := 64; -- Standard.Long_Long_Float'Size Standard_Long_Long_Float_Digits : constant := 15; -- Standard.Long_Long_Float'Digits Standard_Character_Size : constant := 8; -- Standard.Character'Size System_Address_Size : constant := 32; -- System.Address'Size (also size of all thin pointers) System_Max_Binary_Modulus_Power : constant := 64; -- System.Max_Binary_Modulus := 2 ** System_Max_Binary_Modulus_Power System_Max_Nonbinary_Modulus_Power : constant := 32; -- System.Max_Nonbinary_Modulus := -- 2 ** System_Max_Nonbinary_Modulus_Power - 1 System_Storage_Unit : constant := 8; -- System.Storage_Unit System_Word_Size : constant := 32; -- System.Word_Size -- Note: there is no specific control over the representation of -- enumeration types. The convention used is that if an enumeration -- type has fewer than 2**(Character'Size) elements, then the size -- used is Character'Size, otherwise Integer'Size is used. Ones_Complement : constant Boolean := False; -- Set True if integers are represented in ones complement form. The -- current version of GCC does not support ones complement, so this -- constant will always be False, but we retain the control for -- possible future implementation end Ttypes; ), New_Prefix, ' '); end if; -- Case of descendent is a list elsif D in List_Range then gnat-1.67-src/src/ttypes.adt 444 10015 7640 12624 5506244444 11167 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- T T Y P E S -- -- -- -- T e m p l a t e -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This module contains values that describe the predefined (standard) -- target types that are provided. Note that it is essential that all -- references to Size values and other attributes of types use this -- package when talking about target types (rather than using the -- attributes directly which would give information about host types). package Ttypes is -- Note: GNAT always supplies all the following integer and float types, -- but depending on the machine, some of the types may be identical. For -- example, on some machines, Short_Float may be the same as Float, and -- Long_Long_Float may be the same as Long_Float. Standard_Short_Short_Integer_Size : constant := %cS; -- Standard.Short_Short_Integer'Size Standard_Short_Short_Integer_Width : constant := %cW; -- Standard.Short_Short_Integer'Width Standard_Short_Integer_Size : constant := %sS; -- Standard.Short_Integer'Size Standard_Short_Integer_Width : constant := %sW; -- Standard.Short_Integer'Width Standard_Integer_Size : constant := %iS; -- Standard.Integer'Size Standard_Integer_Width : constant := %iW; -- Standard.Integer'Width Standard_Long_Integer_Size : constant := %lS; -- Standard.Long_Integer'Size Standard_Long_Integer_Width : constant := %lW; -- Standard.Long_Integer'Width Standard_Long_Long_Integer_Size : constant := %LS; -- Standard.Long_Long_Integer'Size Standard_Long_Long_Integer_Width : constant := %LW; -- Standard.Long_Long_Integer'Width Standard_Short_Float_Size : constant := %FS; -- Standard.Short_Float'Size Standard_Short_Float_Digits : constant := %FD; -- Standard.Short_Float'Digits Standard_Float_Size : constant := %fS; -- Standard.Float'Size Standard_Float_Digits : constant := %fD; -- Standard.Float'Digits Standard_Long_Float_Size : constant := %dS; -- Standard.Long_Float'Size Standard_Long_Float_Digits : constant := %dD; -- Standard.Long_Float'Digits Standard_Long_Long_Float_Size : constant := %DS; -- Standard.Long_Long_Float'Size Standard_Long_Long_Float_Digits : constant := %DD; -- Standard.Long_Long_Float'Digits Standard_Character_Size : constant := %cS; -- Standard.Character'Size System_Address_Size : constant := %W; -- System.Address'Size (also size of all thin pointers) System_Max_Binary_Modulus_Power : constant := %LS; -- System.Max_Binary_Modulus := 2 ** System_Max_Binary_Modulus_Power System_Max_Nonbinary_Modulus_Power : constant := System_Max_Binary_Modulus_Power / 2; -- System.Max_Nonbinary_Modulus := -- 2 ** System_Max_Nonbinary_Modulus_Power - 1 System_Storage_Unit : constant := %U; -- System.Storage_Unit System_Word_Size : constant := %W; -- System.Word_Size -- Note: there is no specific control over the representation of -- enumeration types. The convention used is that if an enumeration -- type has fewer than 2**(Character'Size) elements, then the size -- used is Character'Size, otherwise Integer'Size is used. Ones_Complement : constant Boolean := False; -- Set True if integers are represented in ones complement form. The -- current version of GCC does not support ones complement, so this -- constant will always be False, but we retain the control for -- possible future implementation end Ttypes; end if; -- Case of descendent is a list elsif D in List_Range then gnat-1.67-src/src/types.ads 444 10015 7640 73710 5506244445 11006 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- T Y P E S -- -- -- -- S p e c -- -- -- -- $Revision: 1.28 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Unchecked_Deallocation; package Types is -- This package contains host independent type definitions which are used -- in more than one unit in the compiler. They are gathered here for easy -- reference, though in some cases the full description is found in the -- relevant module which implements the definition. The main reason that -- they are not in their "natural" specs is that this would cause a lot of -- inter-spec dependencies, and in particular some awkward circular -- dependencies would have to be dealt with. -- WARNING: There is a C version of this package. Any changes to this -- source file must be properly reflected in the C header file a-types.h -- Note: the declarations in this package reflect an expectation that the -- host machine has an efficient integer base type with a range at least -- 32 bits 1's complement. If there are any machines for which this is not -- a correct assumption, a significant number of changes will be required! ------------------------------- -- General Use Integer Types -- ------------------------------- type Model_Int is range -(2**31 - 1) .. +(2**31 - 1); -- Type used to establish appropriate bounds for reasonable sized integer Model_LB : constant := Model_Int'Pos (Model_Int'Base'First); Model_UB : constant := Model_Int'Pos (Model_Int'Base'Last); -- Machine bounds for reasonable sized integer. The integer type that we -- use is typically a 32-bit twos-complement integer, but we arrange the -- type declarations so that we can accomodate other possibilities, in -- particular 32-bit twos-complement with the most negative number missing -- as on the Rational implementation, or, if there exist any such beasts, -- 1's complement 32-bit machines. type Int is range Model_LB .. Model_UB; -- Signed 32-bit integer subtype Nat is Int range 0 .. Model_UB; -- Non-negative Int values subtype Pos is Int range 1 .. Model_UB; -- Positive Int values type Short is range -32768 .. +32767; for Short'Size use 16; -- 16-bit signed integer type Byte is range 0 .. 255; for Byte'Size use 8; -- 8-bit unsigned integer -------------------------------------- -- 8-Bit Character and String Types -- -------------------------------------- -- In Ada 9X, or an Ada 83 compiler which supported the 8-bit Character -- type, Char could be Character, and Str could be String, but we want -- to be able to compile on an Ada 83 compiler that has 7-bit Character. type Char is ( -- 8-bit character type NUL, -- 16#00#; SOH, -- 16#01#; STX, -- 16#02#; ETX, -- 16#03#; EOT, -- 16#04#; ENQ, -- 16#05#; ACK, -- 16#06#; BEL, -- 16#07#; BS, -- 16#08#; HT, -- 16#09#; LF, -- 16#0A#; VT, -- 16#0B#; FF, -- 16#0C#; CR, -- 16#0D#; SO, -- 16#0E#; SI, -- 16#0F#; DLE, -- 16#10#; DC1, -- 16#11#; DC2, -- 16#12#; DC3, -- 16#13#; DC4, -- 16#14#; NAK, -- 16#15#; SYN, -- 16#16#; ETB, -- 16#17#; CAN, -- 16#18#; EM, -- 16#19#; SUB, -- 16#1A#; ESC, -- 16#1B#; FS, -- 16#1C#; GS, -- 16#1D#; RS, -- 16#1E#; US, -- 16#1F#; ' ', -- 16#20#; '!', -- 16#21#; '"', -- 16#22#; '#', -- 16#23#; '$', -- 16#24#; '%', -- 16#25#; '&', -- 16#26#; ''', -- 16#27#; '(', -- 16#28#; ')', -- 16#29#; '*', -- 16#2A#; '+', -- 16#2B#; ',', -- 16#2C#; '-', -- 16#2D#; '.', -- 16#2E#; '/', -- 16#2F#; '0', -- 16#30#; '1', -- 16#31#; '2', -- 16#32#; '3', -- 16#33#; '4', -- 16#34#; '5', -- 16#35#; '6', -- 16#36#; '7', -- 16#37#; '8', -- 16#38#; '9', -- 16#39#; ':', -- 16#3A#; ';', -- 16#3B#; '<', -- 16#3C#; '=', -- 16#3D#; '>', -- 16#3E#; '?', -- 16#3F#; '@', -- 16#40#; 'A', -- 16#41#; 'B', -- 16#42#; 'C', -- 16#43#; 'D', -- 16#44#; 'E', -- 16#45#; 'F', -- 16#46#; 'G', -- 16#47#; 'H', -- 16#48#; 'I', -- 16#49#; 'J', -- 16#4A#; 'K', -- 16#4B#; 'L', -- 16#4C#; 'M', -- 16#4D#; 'N', -- 16#4E#; 'O', -- 16#4F#; 'P', -- 16#50#; 'Q', -- 16#51#; 'R', -- 16#52#; 'S', -- 16#53#; 'T', -- 16#54#; 'U', -- 16#55#; 'V', -- 16#56#; 'W', -- 16#57#; 'X', -- 16#58#; 'Y', -- 16#59#; 'Z', -- 16#5A#; '[', -- 16#5B#; '\', -- 16#5C#; ']', -- 16#5D#; '^', -- 16#5E#; '_', -- 16#5F#; '`', -- 16#60#; 'a', -- 16#61#; 'b', -- 16#62#; 'c', -- 16#63#; 'd', -- 16#64#; 'e', -- 16#65#; 'f', -- 16#66#; 'g', -- 16#67#; 'h', -- 16#68#; 'i', -- 16#69#; 'j', -- 16#6A#; 'k', -- 16#6B#; 'l', -- 16#6C#; 'm', -- 16#6D#; 'n', -- 16#6E#; 'o', -- 16#6F#; 'p', -- 16#70#; 'q', -- 16#71#; 'r', -- 16#72#; 's', -- 16#73#; 't', -- 16#74#; 'u', -- 16#75#; 'v', -- 16#76#; 'w', -- 16#77#; 'x', -- 16#78#; 'y', -- 16#79#; 'z', -- 16#7A#; '{', -- 16#7B#; '|', -- 16#7C#; '}', -- 16#7D#; '~', -- 16#7E#; DEL, -- 16#7F#; X_80, X_81, X_82, X_83, X_84, X_85, X_86, X_87, X_88, X_89, X_8A, X_8B, X_8C, X_8D, X_8E, X_8F, X_90, X_91, X_92, X_93, X_94, X_95, X_96, X_97, X_98, X_99, X_9A, X_9B, X_9C, X_9D, X_9E, X_9F, X_A0, X_A1, X_A2, X_A3, X_A4, X_A5, X_A6, X_A7, X_A8, X_A9, X_AA, X_AB, X_AC, X_AD, X_AE, X_AF, X_B0, X_B1, X_B2, X_B3, X_B4, X_B5, X_B6, X_B7, X_B8, X_B9, X_BA, X_BB, X_BC, X_BD, X_BE, X_BF, X_C0, X_C1, X_C2, X_C3, X_C4, X_C5, X_C6, X_C7, X_C8, X_C9, X_CA, X_CB, X_CC, X_CD, X_CE, X_CF, X_D0, X_D1, X_D2, X_D3, X_D4, X_D5, X_D6, X_D7, X_D8, X_D9, X_DA, X_DB, X_DC, X_DD, X_DE, X_DF, X_E0, X_E1, X_E2, X_E3, X_E4, X_E5, X_E6, X_E7, X_E8, X_E9, X_EA, X_EB, X_EC, X_ED, X_EE, X_EF, X_F0, X_F1, X_F2, X_F3, X_F4, X_F5, X_F6, X_F7, X_F8, X_F9, X_FA, X_FB, X_FC, X_FD, X_FE, X_FF); for Char'Size use 8; -- For a compiler supporting the Ada 9X 8-bit character type, this -- declaration may be replaced simply by "type Char is new Character". -- The size specification is merely for efficiency. subtype Graphic_Character is Char range ' ' .. '~'; -- Graphic characters, as defined in ARM subtype Line_Terminator is Char range LF .. CR; -- Line terminator characters (LF, VT, FF, CR) subtype Upper_Half_Character is Char range X_80 .. X_FF; -- Characters with the upper bit set type Str is array (Nat range <>) of Char; -- String type built on Char (note that zero is an OK index) type Str_Ptr is access Str; -- Pointer to string of Chars procedure Free is new Unchecked_Deallocation (Str, Str_Ptr); -- Procedure for freeing dynamically allocated Str values EOF : constant Char := SUB; -- The character SUB (16#1A#) is appended to the file text to mark the end -- of file. In addition, in MS/DOS mode only, if this character appears in -- the file text, then it is recognized as an end of file, and no data -- after the EOF character is accessed. function To_Char (C : Character) return Char; pragma Inline (To_Char); -- Convert from Character to Char ----------------------------------------- -- Types Used for Text Buffer Handling -- ----------------------------------------- type Text_Ptr is range Model_LB .. Model_UB; -- Type used for subscripts in text buffer type Text_Buffer is array (Text_Ptr range <>) of Char; -- Text buffer used to hold source file or library information file type Text_Buffer_Ptr is access Text_Buffer; -- Text buffers for input files are allocated dynamically and this type -- is used to reference these text buffers. procedure Free is new Unchecked_Deallocation (Text_Buffer, Text_Buffer_Ptr); -- Procedure for freeing dynamically allocated text buffers ------------------------------------------ -- Types Used for Source Input Handling -- ------------------------------------------ type Line_Number_Type is range 1 .. Model_UB; -- Line number type, used for storing line numbers type Column_Number_Type is range 0 .. 32767; -- Column number (assume that 2**15 is large enough!) subtype Source_Buffer is Text_Buffer; -- Type used to store text of a source file . The buffer for the main -- source (the source specified on the command line) has a lower bound -- starting at zero. Subsequent subsidiary sources have lower bounds -- which are one greater than the previous upper bound. subtype Source_Buffer_Ptr is Text_Buffer_Ptr; -- Pointer to source buffer subtype Source_Ptr is Text_Ptr; -- Type used to represent a source location, which is a subscript of a -- character in the source buffer. As noted above, diffferent source -- buffers have different ranges, so it is possible to tell from a -- Source_Ptr value which source it refers to. Note that negative numbers -- are allowed to accomodate the following special values. There is no -- loss of safety, since we can rely on the subscript check to ensure -- that correct Source_Ptr values are used in the appropriate context. No_Location : constant Source_Ptr := -1; -- Value used to indicate no source position set in a node Standard_Location : constant Source_Ptr := -2; -- Used for all nodes in the representation of package Standard ------------------------------------- -- Range Definitions for Tree Data -- ------------------------------------- -- The tree has fields that can hold any of the following types: -- Pointers to other tree nodes (type Node_Id) -- List pointers (type List_Id) -- Element list pointers (type Elist_Id) -- Element pointers (type Elmt_Id) -- Names (type Name_Id) -- Strings (type String_Id) -- Universal integers (type Uint) -- Character codes (type Char_Code stored with a bias) -- In most contexts, the strongly typed interface determines which of -- these types is present. However, there are some situations (involving -- untyped traversals of the tree), where it is convenient to be easily -- able to distinguish these values. The underlying representation in all -- cases is Int, and we ensure that the range of possible values for each -- of the above types is disjoint so that this distinction is possible. -- Note: it is also helpful for debugging purposes to make these ranges -- distinct. If a bug leads to misidentification of a value, then it will -- typically result in an out of range value and a Constraint_Error. List_Low_Bound : constant := -100_000_000; -- The List_Id values are subscripts into an array of list headers which -- has List_Low_Bound as its lower bound. This value is chosen so that all -- List_Id values are negative, and the value zero is in the range of both -- List_Id and Node_Id values (see further description below). List_High_Bound : constant := 0; -- Maximum List_Id subscript value. This allows up to 100 million list -- Id values, which is in practice infinite, and there is no need to -- check the range. The range overlaps the node range by one element -- (with value zero), which is used both for the Empty node, and for -- indicating no list. The fact that the same value is used is not -- crucial for the Ada code, but is useful in the conversion to C, -- where the type distinction disappears, and also generates better -- code in both cases for the test for empty. Node_Low_Bound : constant := 0; -- The tree Id values start at zero, because we use zero for Empty (to -- allow a zero test for Empty). Actual tree node subscripts start at 0 -- since Empty is a legitimate node value. Node_High_Bound : constant := 099_999_999; -- Maximum number of nodes that can be allocated is 100 million, which -- is in practice infinite, and there is no need to check the range. Elist_Low_Bound : constant := 100_000_000; -- Low bound of element list Id values. Element list headers are actually -- stored using the same array as normal list values, but a bias is added -- to stored values, to aid in type identification, as described above. Elist_High_Bound : constant := 199_999_999; -- Upper bound of element list Id values Elmt_Low_Bound : constant := 200_000_000; -- Low bound of element Id values. Element list elements are actually -- stored using the same array as normal list values, but a bias is added -- to stored values, to aid in type identification, as described above. Elmt_High_Bound : constant := 299_999_999; -- Upper bound of element list Id values Names_Low_Bound : constant := 300_000_000; -- Low bound for name Id values Names_High_Bound : constant := 399_999_999; -- Maximum number of names that can be allocated is 100 million, which is -- in practice infinite and there is no need to check the range. Strings_Low_Bound : constant := 400_000_000; -- Low bound for string Id values Strings_High_Bound : constant := 499_999_999; -- Maximum number of strings that can be allocated is 100 million, which -- is in practice infinite and there is no need to check the range. Uint_Low_Bound : constant := 500_000_000; -- Low bound for Uint values. Uint_High_Bound : constant := 599_999_999; -- Maximum number of Uint values stored is 100_000_000 which is in -- practice infinite so that no check is required. Char_Code_Bias : constant := 600_000_000; -- A bias value added to character code values stored in the tree which -- ensures that they have different values from any of the above types. -- The following subtype definitions are used to provide convenient names -- for membership tests on Int values to see what data type range they -- lie in. Such tests appear only in the lowest level packages. subtype List_Range is Int range List_Low_Bound .. List_High_Bound; subtype Node_Range is Int range Node_Low_Bound .. Node_High_Bound; subtype Elist_Range is Int range Elist_Low_Bound .. Elist_High_Bound; subtype Elmt_Range is Int range Elmt_Low_Bound .. Elmt_High_Bound; subtype Names_Range is Int range Names_Low_Bound .. Names_High_Bound; subtype Strings_Range is Int range Strings_Low_Bound .. Strings_High_Bound; subtype Uint_Range is Int range Uint_Low_Bound .. Uint_High_Bound; subtype Char_Code_Range is Int range Char_Code_Bias .. Char_Code_Bias + 2**16 - 1; ----------------------------- -- Types for Namet Package -- ----------------------------- -- Name_Id values are used to identify entries in the names table. Except -- for the special values No_Name, and Error_Name, they are subscript -- values for the Names table defined in package Namet. -- Note that with only a few exceptions, which are clearly documented, the -- type Name_Id should be regarded as a private type. In particular it is -- never appropriate to perform arithmetic operations using this type. type Name_Id is range Names_Low_Bound .. Names_High_Bound; -- Type used to identify entries in the names table No_Name : constant Name_Id := Names_Low_Bound; -- The special Name_Id value No_Name is used in the parser to indicate -- a situation where no name is present (e.g. on a loop or block). Error_Name : constant Name_Id := Names_Low_Bound + 1; -- The special Name_Id value Error_Name is used in the parser to -- indicate that some kind of error was encountered in scanning out -- the relevant name, so it does not have a representable label. First_Name_Id : constant Name_Id := Names_Low_Bound + 2; -- Subscript of first entry in names table ---------------------------- -- Types for Tree Package -- ---------------------------- -- Node_Id values are used to identify nodes in the tree. They are -- subscripts into the Node table declared in package Tree. Note that -- the special values Empty and Error are subscripts into this table, -- are package Tree for further details. type Node_Id is range Node_Low_Bound .. Node_High_Bound; -- Type used to identify nodes in the tree subtype Entity_Id is Node_Id; -- A synonym for node types, used in the entity package to refer to -- nodes that are entities (i.e. nodes with an Nkind of N_Defining_xxx) Empty : constant Node_Id := 0; -- Used to indicate null node. A node is actually allocated with this -- Id value, so that Nkind (Empty) = N_Empty. Error : constant Node_Id := 1; -- Used to indicate that there was an error in the source program. A node -- is actually allocated at this address, so that Nkind (Error) = N_Error. Empty_Or_Error : constant Node_Id := Error; -- Since Empty and Error are the first two Node_Id values, the test for -- N <= Error tests to see if N is Empty or Error. This definition provides -- convenient self-documentation for such tests. First_Node_Id : constant Node_Id := Empty; -- Subscript of first allocated node -- List_Id values are used to identify node lists in the tree. They are -- subscripts into the Lists table declared in package Tree. Note that -- the special value Error_List is a subscript in this table, but the -- value No_List is *not* a valid subscript, and any attempt to apply -- list operations to No_List will cause a (detected) error. type List_Id is range List_Low_Bound .. List_High_Bound; -- Type used to identify a node list No_List : constant List_Id := 0; -- Used to indicate absence of a list. Note that the value is the same -- as Empty, which is irrelevant for Ada (since generally we are strongly -- typed), but is useful in the conversion to C, where we lose the typing -- distinction. Error_List : constant List_Id := List_Low_Bound; -- Used to indicate that there was an error in the source program in a -- context which would normally require a list. This node appears to be -- an empty list to the list operations (a null list is actually allocated -- which has this Id value). First_List_Id : constant List_Id := Error_List; -- Subscript of first allocated list header -- Element list Id values are used to identify element lists stored in -- the tree (see package Tree for further details). They are formed by -- adding a bias (Element_List_Bias) to subscript values in the same -- array that is used for node list headers. type Elist_Id is range Elist_Low_Bound .. Elist_High_Bound; -- Type used to identify an element list No_Elist : constant Elist_Id := Elist_Low_Bound; -- Used to indicate absense of an element list Elist_Bias : constant := Elist_Low_Bound - List_Low_Bound; -- Bias added to subscript in list table to get Elist_Id value -- Element Id values are used to identify individual elements of an -- element list (see package Tree for further details). They are -- formed by adding a bias (Elmt_Bias) to subscript values in the same -- array that is used for node list headers. type Elmt_Id is range Elmt_Low_Bound .. Elmt_High_Bound; -- Type used to identify an element list Elmt_Bias : constant := Elmt_Low_Bound - List_Low_Bound; -- Bias added to subscript in list table to get Elmt_Id value No_Elmt : constant Elmt_Id := Elmt_Low_Bound; -- Used to represent empty element ------------------------------- -- Types for Stringt Package -- ------------------------------- -- String_Id values are used to identify entries in the strings table. -- They are subscripts into the strings table defined in package Strings. -- Note that with only a few exceptions, which are clearly documented, the -- type String_Id should be regarded as a private type. In particular it is -- never appropriate to perform arithmetic operations using this type. type String_Id is range Strings_Low_Bound .. Strings_High_Bound; -- Type used to identify entries in the strings table No_String : constant String_Id := Strings_Low_Bound; -- Used to indicate missing string Id. Note that the value zero is used -- to indicate a missing data value for all the Int types in this section. First_String_Id : constant String_Id := No_String + 1; -- First subscript allocated in string table ----------------------------- -- Types for Uintp Package -- ----------------------------- -- Uint values are used to represent universal integers -- Note that with only a few exceptions, which are clearly documented, -- the type Uint should be regarded as a private type. In particular it -- is never appropriate to perform arithmetic operations using this type, -- and the details of the representation should not be exploited. type Uint is range Uint_Low_Bound .. Uint_High_Bound; -- Type used for representation of universal integers No_Uint : constant Uint := Uint_Low_Bound; -- Used to indicate missing Uint value -- Uint values are represented as multiple precision integers stored in -- a multi-digit format using Base as the base. This value is chosen so -- that the product Base*Base is within the range of allowed Int values. Base : constant := 2 ** 15; -- Values in the range -(Base-1)..+(Base-1), i.e. one-digit values, -- are encoded directly as Uint values by adding a bias value: Uint_Direct_Bias : constant Uint := Uint_Low_Bound + Base; Uint_Direct_First : constant Uint := Uint_Direct_Bias - (Base - 1); Uint_Direct_Last : constant Uint := Uint_Direct_Bias + (Base - 1); -- These values define the bias used to store Uint values which are in -- the range -(Base-1)..+(Base-1), as well as the biased values for the -- first and last values in this range. subtype Uint_Direct is Uint range Uint_Direct_First .. Uint_Direct_Last; -- A subtype defining the range of Uint values used for direct -- representation of values using Uint_Direct_Bias. Uint_First_Entry : constant Uint := Uint_Direct_Last + 1; -- First subscript allocated in Uint table ------------------------- -- Character Code Type -- ------------------------- -- The type Char is used for character data internally in the compiler, -- but character codes in the source are represented by the Char_Code -- type. Each character literal in the source is interpreted as being one -- of the 2**16 possible Wide_Character codes, and a unique integer value -- is assigned, corresponding to the POS value in the Wide_Character type. -- String literals are similarly interpreted as a sequence of such codes. -- Note: for the moment, until we properly implement wide character, we -- use the values 0-255 to represent the natural character codes in the -- source input. This will change later on. For Latin-1, there will be -- a bias to the value, representing the starting position of Latin-1 in -- the 10646 BMP. For other codes (e.g. Latin-2), the coding will be quite -- different, since in this case the codes are not contiguous. -- Note: when character code values are stored in the tree, they are stored -- by adding a bias value (Char_Code_Bias) that results in values that can -- be distinguished from other types of values stored in the tree. type Char_Code is range 0 .. 2**16 - 1; for Char_Code'Size use 16; function Get_Char_Code (C : Char) return Char_Code; pragma Inline (Get_Char_Code); -- Function to obtain internal character code from source character. For -- the moment, the internal character code is simply the Pos value of the -- input source character, but this may change in the future when we -- implement the full 16-bit character support. --------------------------------------- -- Types used for Library Management -- --------------------------------------- type Unit_Number_Type is range Model_LB .. Model_UB; -- Unit number. The main source is unit 0, and subsidiary sources have -- non-zero numbers starting with 1. Unit numbers are used to index the -- file table in Lib. Main_Unit : constant Unit_Number_Type := 0; -- Unit number value for main unit No_Unit : constant Unit_Number_Type := -1; -- Special value used to signal no unit type Lines_Table_Type is array (Line_Number_Type range <>) of Source_Ptr; -- Type used for lines table. The entries are indexed by line number and -- the values are the starting Source_Ptr values for the start of line. type Lines_Table_Ptr is access Lines_Table_Type; -- Type used for pointers to line tables procedure Free_Lines is new Unchecked_Deallocation (Lines_Table_Type, Lines_Table_Ptr); -- Procedure for freeing dynamically allocated Lines_Tables Time_Stamp_Length : constant := 12; -- Length of time stamp value subtype Time_Stamp_Type is Str (1 .. Time_Stamp_Length); -- Type used to represent time stamp (see spec of Libfmt for details) subtype File_Name_Type is Name_Id; -- File names are stored in the names table and this synonym is used to -- indicate that a Name_Id value is being used to hold a simple file -- name (which does not include any directory information). No_File : constant File_Name_Type := File_Name_Type (No_Name); -- Constant used to indicate no file found subtype Unit_Name_Type is Name_Id; -- Unit names are stored in the names table and this synonym is used to -- indicate that a Name_Id value is being used to hold a unit name. ----------------------------------------------- -- Types used for Pragma Suppress Management -- ----------------------------------------------- -- The following record contains an entry for each recognized check name -- for pragma Suppress. It is used to represent current settings of scope -- based suppress actions from pragma Suppress or command line settings. type Suppress_Record is record Access_Checks : Boolean := False; Accessibility_Checks : Boolean := False; Discriminant_Checks : Boolean := False; Division_Checks : Boolean := False; Elaboration_Checks : Boolean := False; Index_Checks : Boolean := False; Length_Checks : Boolean := False; Overflow_Checks : Boolean := False; Range_Checks : Boolean := False; Storage_Checks : Boolean := False; Tag_Checks : Boolean := False; end record; -- To add a new check type to GNAT, the following steps are required: -- 1. Add an appropriate entry to the above record type -- 2. Add an entry to Snames spec and body for the new name -- 3. Add an entry to the definition of Check_Id in the Snames spec -- 4. Add a new entity flag definition in Einfo for the check -- 5. Add a new function to Sem.Util to handle the new check test -- 6. Add appropriate processing for pragma Suppress in Sem.Prag -- 7. Add a branch to the case statement in Sem.Ch8.Pop_Scope -- 8. Add a new Do_xxx_Check flag to Sinfo (if required) -- 9. Add appropriate checks for the new test end Types; s used for node list headers. type Elmt_Id is range gnat-1.67-src/src/types.adb 444 10015 7640 4262 5506244445 10741 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- T Y P E S -- -- -- -- B o d y -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ package body Types is ------------------- -- Get_Char_Code -- ------------------- function Get_Char_Code (C : Char) return Char_Code is begin return Char_Code'Val (Char'Pos (C)); end Get_Char_Code; ------------- -- To_Char -- ------------- function To_Char (C : Character) return Char is begin return Char'Val (Character'Pos (C)); end To_Char; end Types; pe Time_Stamp_Type is Str (1 .. Time_Stamp_Length); -- Type used to represent time stamp (see spec of Libfmt for details) subtype File_Name_Type is Name_Id; -- File names are stored in the names table and this synonym is used to -- indicate that a Name_Id value is being used to hold a simple file -- name (which dgnat-1.67-src/src/uintp.ads 444 10015 7640 25413 5506244446 10777 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- U I N T P -- -- -- -- S p e c -- -- -- -- $Revision: 1.14 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Alloc; use Alloc; with Types; use Types; with Table; package Uintp is -- Support for universal integer arithmetic -- WARNING: There is a C version of this package. Any changes to this -- source file must be properly reflected in the C header file sinfo.h -------------------- -- Uint Constants -- -------------------- -- Note: these are all in the directly represented range, so it is -- legitimate to use the = and /= operators directly on these values, -- rather than using the UI_Eq and UI_Ne functions Uint_0 : constant Uint := Uint_Direct_Bias; Uint_1 : constant Uint := Uint_Direct_Bias + 1; Uint_2 : constant Uint := Uint_Direct_Bias + 2; Uint_3 : constant Uint := Uint_Direct_Bias + 3; Uint_4 : constant Uint := Uint_Direct_Bias + 4; Uint_5 : constant Uint := Uint_Direct_Bias + 5; Uint_6 : constant Uint := Uint_Direct_Bias + 6; Uint_7 : constant Uint := Uint_Direct_Bias + 7; Uint_8 : constant Uint := Uint_Direct_Bias + 8; Uint_9 : constant Uint := Uint_Direct_Bias + 9; Uint_10 : constant Uint := Uint_Direct_Bias + 10; Uint_16 : constant Uint := Uint_Direct_Bias + 16; Uint_32 : constant Uint := Uint_Direct_Bias + 32; Uint_Minus_1 : constant Uint := Uint_Direct_Bias - 1; Uint_Minus_2 : constant Uint := Uint_Direct_Bias - 2; Uint_Minus_3 : constant Uint := Uint_Direct_Bias - 3; Uint_Minus_4 : constant Uint := Uint_Direct_Bias - 4; Uint_Minus_5 : constant Uint := Uint_Direct_Bias - 5; Uint_Minus_6 : constant Uint := Uint_Direct_Bias - 6; Uint_Minus_7 : constant Uint := Uint_Direct_Bias - 7; Uint_Minus_8 : constant Uint := Uint_Direct_Bias - 8; Uint_Minus_9 : constant Uint := Uint_Direct_Bias - 9; -- The constants in this table, initialized by UI_Initialize, represent -- the powers of 2 (i.e. UI_Power (N) contains the Uint value 2 ** N). -- These values are generally NOT in the directly represented range, -- so equality comparisons should use UI_Eq and UI_Ne, rather than -- using the = and /= operators directly. UI_Power : array (Int range 0 .. 64) of Uint; ----------------- -- Subprograms -- ----------------- function Last_Uint return Uint; pragma Inline (Last_Uint); -- Returns Uint value for last currently allocated entry in Uint table procedure Initialize_Uint; -- Initialize Uint tables function UI_Sum (Left, Right : Uint) return Uint; -- Returns sum of two universal integers. function UI_Difference (Left, Right : Uint) return Uint; pragma Inline (UI_Difference); -- Returns difference of two universal integers. function UI_Quotient (Left, Right : Uint) return Uint; -- Returns quotient of two universal integers. Fatal error if -- Right is zero. function UI_Product (Left, Right : Uint) return Uint; -- Returns product of two universal integers. function UI_Exponentiate (Left, Right : Uint) return Uint; -- Returns result of exponentiating two universal integers. -- Fatal error if Right is negative. function UI_Abs (Right : Uint) return Uint; pragma Inline (UI_Abs); -- Returns abs function of universal integer. function UI_Mod (Left, Right : Uint) return Uint; pragma Inline (UI_Mod); -- Returns mod function of two universal integers. function UI_Rem (Left, Right : Uint) return Uint; pragma Inline (UI_Rem); -- Returns rem function of two universal integers. function UI_Negate (Right : Uint) return Uint; pragma Inline (UI_Negate); -- Returns negative of universal integer. function UI_Eq (Left, Right : Uint) return Boolean; pragma Inline (UI_Eq); -- Compares universal integers for equality. function UI_Ne (Left, Right : Uint) return Boolean; pragma Inline (UI_Ne); -- Compares universal integers for inequality. function UI_Lt (Left, Right : Uint) return Boolean; -- Compares universal integers for less than. function UI_Le (Left, Right : Uint) return Boolean; pragma Inline (UI_Le); -- Compares universal integers for less than or equal. function UI_Gt (Left, Right : Uint) return Boolean; pragma Inline (UI_Gt); -- Compares universal integers for greater than. function UI_Ge (Left, Right : Uint) return Boolean; pragma Inline (UI_Ge); -- Compares universal integers for greater than or equal. function UI_Image (Input : Uint) return Name_Id; -- Returns Image of Universal Integer as a string in the names table function UI_From_Int (Input : Int) return Uint; -- Converts Int value to universal integer form. function UI_Is_In_Int_Range (Input : Uint) return Boolean; pragma Inline (UI_Is_In_Int_Range); -- Determines if universal integer is in Int range. function UI_To_Int (Input : Uint) return Int; -- Converts universal integer value to Int. Fatal error -- if value is not in appropriate range. function UI_Is_Zero (Input : Uint) return Boolean; pragma Inline (UI_Is_Zero); -- Determines if universal integer value is zero. function UI_Is_Negative (Input : Uint) return Boolean; pragma Inline (UI_Is_Negative); -- Determines if universal integer value is less than zero. function UI_Is_Positive (Input : Uint) return Boolean; pragma Inline (UI_Is_Positive); -- Determines if universal integer value is greater than zero. ----------------------------- -- Private Part Subpackage -- ----------------------------- -- The following package contains the definition of the data structure -- used by the implementation of the Uint package. Logically it really -- corresponds to the private part, hence the name. The reason that it -- is defined as a sub-package is to allow special access from clients -- that need to see the internals of the data structures. package Uintp_Private_Part is -- As described in Types, universal integer values are represented as -- multi-digit numbers using Base (=2**15, defined in Types) as the -- base for the representation, with the first digit (only) carrying -- the sign. One digit numbers are represented directly by adding the -- value Uint_Direct_Bias, so that they lie in the range: -- Uint_Direct_Bias - (Base - 1) .. Uint_Direct_Bias + (Base - 1) -- The definitions Uint_Direct_First and Uint_Direct_Last (defined in -- Types) define the limits of this range. -- Values outside this range (which have more than one digit) are stored -- using two tables. The secondary table Udigits contains sequences of -- Int values consisting of the digits of the number in a radix Base -- system. The digits are stored from most significant to least significant -- with the first digit only carrying the sign. -- There is one entry in the primary Uints table for each distinct Uint -- value. This table entry contains the length (number of digits) and -- a starting offset of the value in the Udigits table. -- Base is defined to allow the primitive operations (a0, b0, c0) -- defined in the section "The Classical Algorithms" (sec. 4.3.1) -- of Knuth's "The Art of Computer Programming", Vol. 2. It is these -- algorithms that are used in this package. -- Some subprograms defined in this package manipulate the Udigits -- table directly, while for others it is more convenient to work with -- locally defined arrays of the digits of the the Universal Integers. -- The type UI_Vector is defined for this purpose and some internal -- subprograms used for converting from one to the other are defined. type UI_Vector is array (Pos range <>) of Int; -- Vector containing the integer values of a Uint value -- Note: An earlier version of this package used pointers of arrays -- of Ints (dynamically allocated) for the Uint type. The change -- leads to a few less natural idioms used throughout this code, but -- eliminates all uses of the heap except for the table package itself. -- For example, Uint parameters are often converted to UI_Vectors for -- internal manipulation. This is done by creating the local UI_Vector -- using the function N_Digits on the Uint to find the size needed for -- the vector, and then calling Init_Operand to copy the values out -- of the table into the vector. type Uint_Entry is record Length : Pos; -- Length of entry in Udigits table in digits (i.e. in words) Loc : Int; -- Starting location in Udigits table of this Uint value end record; package Uints is new Table ( Component_Type => Uint_Entry, Index_Type => Uint, Low_Bound => Uint_First_Entry, Initial => Alloc_Uints_Initial, Increment => Alloc_Uints_Increment, Table_Name => "Uints"); package Udigits is new Table ( Component_Type => Int, Index_Type => Int, Low_Bound => 0, Initial => Alloc_Udigits_Initial, Increment => Alloc_Udigits_Increment, Table_Name => "Udigits"); end Uintp_Private_Part; end Uintp; nt_9 : constant Uint := Uint_Direct_Bias + 9; Uint_10 : constant Uint := Uint_Direct_Bias + 10; Uint_16 : constant Uint := Uint_Direct_Bias + 16; Uint_32 : constant Uint := Uint_Direct_Bias + 32; Uint_Minus_1 : constant Uint := Uingnat-1.67-src/src/uintp.adb 444 10015 7640 72472 5506244446 10765 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- U I N T P -- -- -- -- B o d y -- -- -- -- $Revision: 1.21 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Comperr; use Comperr; with Limits; use Limits; with Namet; use Namet; package body Uintp is use Uintp_Private_Part; -- We are allowed to see our own private data! function N_Digits (Input : Uint) return Int; pragma Inline (N_Digits); -- Returns number of "digits" in a Uint. procedure Init_Operand (UI : Uint; Vec : out UI_Vector); pragma Inline (Init_Operand); -- This procedure copies the digits from UI or the table into the -- vector parameter. The parameter should be of the correct -- size as determined by a previous call to N_Digits with UI. function Vector_To_Uint (In_Vec : UI_Vector; Negative : boolean) return Uint; -- Functions that calculate values in UI_Vectors, call this function -- to create and return the Uint value. Uint_Int_First, Uint_Int_Last : Uint; -- Uint values containing Int'First and Int'Last. Initialized in -- package initialization and used in UI_Is_In_Int_Range. Int1 : constant Int := 1; -- Needed to avoid some ambiguities --------------- -- Last_Uint -- --------------- function Last_Uint return Uint is begin return Uints.Last; end Last_Uint; --------------------- -- Initialize_Uint -- --------------------- procedure Initialize_Uint is begin Uints.Init; Udigits.Init; UI_Power (0) := Uint_1; for I in 1 .. UI_Power'Last loop UI_Power (I) := UI_Product (UI_Power (I - 1), Uint_2); end loop; end Initialize_Uint; --------------- -- N_Digits -- --------------- function N_Digits (Input : Uint) return Int is begin if Input <= Uint_Direct_Last then return 1; else return Uints.Table (Input).Length; end if; end N_Digits; ------------------- -- Init_Operand -- ------------------- procedure Init_Operand (UI : Uint; Vec : out UI_Vector) is Loc : Int; begin if UI <= Uint_Direct_Last then Vec (1) := Int (UI - Uint_Direct_Bias); else Loc := Uints.Table (UI).Loc; for I in 1 .. N_Digits (UI) loop Vec (I) := Udigits.Table (Loc + I - 1); end loop; end if; end Init_Operand; --------------------- -- Vector_To_Uint -- --------------------- function Vector_To_Uint (In_Vec : UI_Vector; Negative : Boolean) return Uint is Size : Int; begin -- The vector can contain leading zeros. These are not stored in the -- table, so loop through the vector looking for the first non-zero -- digit. for I in In_Vec'range loop if In_Vec (I) /= 0 then -- The length of the value is the length of the rest of the vector Size := In_Vec'Last - I + 1; if Size = 1 then if Negative then return Uint (Int (Uint_Direct_Bias) - In_Vec (I)); else return Uint (Int (Uint_Direct_Bias) + In_Vec (I)); end if; end if; -- The value takes more than one digit, so it is stored in the -- table. Expand the table to contain the count and digits. -- the index of the first new location is the return value. Uints.Increment_Last; Uints.Table (Uints.Last).Length := Size; Uints.Table (Uints.Last).Loc := Udigits.Last + 1; Udigits.Increment_Last; if Negative then Udigits.Table (Udigits.Last) := - In_Vec (I); else Udigits.Table (Udigits.Last) := + In_Vec (I); end if; for J in 2 .. Size loop Udigits.Increment_Last; Udigits.Table (Udigits.Last) := In_Vec (I + J - 1); end loop; return Uints.Last; end if; end loop; -- Dropped through loop only if vector contained all zeros return Uint_0; end Vector_To_Uint; ------------------ -- UI_From_Int -- ------------------ function UI_From_Int (Input : Int) return Uint is begin -- The case -Base < Input < Base is the usual and simple case. if -Base < Input and then Input < Base then return Uint (Int (Uint_Direct_Bias) + Input); -- For values of larger magnitude, compute digits into a vector and -- call Vector_To_Uint. else declare Max_For_Int : constant := 4; -- Base is defined so that 4 Uint digits is sufficient to hold -- the largest Int. V : UI_Vector (1 .. Max_For_Int); Temp_Integer : Int; Ret_Value : Uint; begin for I in V'range loop V (I) := 0; end loop; Temp_Integer := Input; for I in reverse V'range loop V (I) := abs (Temp_Integer rem Base); Temp_Integer := Temp_Integer / Base; end loop; return Vector_To_Uint (V, Input < 0); end; end if; end UI_From_Int; ---------------- -- UI_To_Int -- ---------------- function UI_To_Int (Input : Uint) return Int is begin if Input <= Uint_Direct_Last then return Int (Input - Uint_Direct_Bias); -- Case of input is more than one digit else declare In_Length : Int := N_Digits (Input); In_Vec : UI_Vector (1 .. In_Length); Ret_Int : Int; begin -- Uints of more than one digit could be outside the range for -- Ints. Caller should have checked for this if not certain. -- Fatal error to attempt to convert from value outside Int'range. pragma Assert (UI_Is_In_Int_Range (Input)); -- Otherwise, proceed ahead, we are OK Init_Operand (Input, In_Vec); Ret_Int := 0; -- Calculate -|Input| and then negates if value is positive. -- This handles our current definition of Int (based on -- 2s complement). Is it secure enough? for Idx in In_Vec'range loop Ret_Int := Ret_Int * Base - abs In_Vec (Idx); end loop; if In_Vec (1) < 0 then return Ret_Int; else return -Ret_Int; end if; end; end if; end UI_To_Int; --------------- -- UI_Image -- --------------- function UI_Image (Input : Uint) return Name_Id is procedure Set_Digits (U : Uint); -- Recursive procedure to set digits of non-negative Uint value procedure Set_Digits (U : Uint) is begin if UI_Ge (U, Uint_10) then Set_Digits (UI_Quotient (U, Uint_10)); end if; if Name_Len = Max_Name_Length - 6 then Name_Buffer (Name_Len + 1) := '.'; Name_Buffer (Name_Len + 2) := '.'; Name_Buffer (Name_Len + 3) := '.'; Name_Len := Name_Len + 3; elsif Name_Len < Max_Name_Length - 6 then Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := Char'Val (Char'Pos ('0') + UI_To_Int (UI_Rem (U, Uint_10))); end if; end Set_Digits; begin if UI_Is_Negative (Input) then Name_Len := 1; Name_Buffer (1) := '-'; Set_Digits (UI_Negate (Input)); else Name_Len := 0; Set_Digits (Input); end if; return Name_Find; end UI_Image; ------------------------- -- UI_Is_In_Int_Range -- ------------------------- function UI_Is_In_Int_Range (Input : Uint) return Boolean is begin return UI_Ge (Input, Uint_Int_First) and then UI_Le (Input, Uint_Int_Last); end UI_Is_In_Int_Range; ----------------- -- UI_Is_Zero -- ----------------- function UI_Is_Zero (Input : Uint) return Boolean is begin return Input = Uint_0; end UI_Is_Zero; --------------------- -- UI_Is_Negative -- --------------------- function UI_Is_Negative (Input : Uint) return Boolean is begin return Input < Uint_Direct_Bias or else (Input >= Uint_First_Entry and then Udigits.Table (Uints.Table (Input).Loc) < 0); end UI_Is_Negative; --------------------- -- UI_Is_Positive -- --------------------- function UI_Is_Positive (Input : Uint) return Boolean is begin if Input <= Uint_Direct_Bias then return False; elsif Input <= Uint_Direct_Last then return True; else return Udigits.Table (Uints.Table (Input).Loc) > 0; end if; end UI_Is_Positive; ------------ -- UI_Eq -- ------------ function UI_Eq (Left, Right : Uint) return Boolean is begin return not UI_Ne (Left, Right); end UI_Eq; ------------ -- UI_Ne -- ------------ function UI_Ne (Left, Right : Uint) return Boolean is Left_Loc : Int; Right_Loc : Int; Size : Int; begin Size := N_Digits (Left); if Size /= N_Digits (Right) then return True; elsif Size = 1 then return Left /= Right; else Left_Loc := Uints.Table (Left).Loc; Right_Loc := Uints.Table (Right).Loc; for I in 0 .. Size - 1 loop if Udigits.Table (Left_Loc + I) /= Udigits.Table (Right_Loc + I) then return True; end if; end loop; return False; end if; end UI_Ne; ------------ -- UI_Lt -- ------------ function UI_Lt (Left, Right : Uint) return Boolean is L_Length : constant Int := N_Digits (Left); R_Length : constant Int := N_Digits (Right); begin -- Quick processing for both arguments one digit long if L_Length = 1 and then R_Length = 1 then return Left < Right; -- At least one argument is more than one digit long else declare L_Vec : UI_Vector (1 .. L_Length); R_Vec : UI_Vector (1 .. R_Length); begin Init_Operand (Left, L_Vec); Init_Operand (Right, R_Vec); if L_Vec (1) < 0 then -- First argument negative, second argument non-negative if R_Vec (1) >= 0 then return True; -- Both arguments negative else if L_Length /= R_Length then return L_Length > R_Length; elsif L_Vec (1) /= R_Vec (1) then return L_Vec (1) < R_Vec (1); else for I in 2 .. L_Vec'Last loop if L_Vec (I) /= R_Vec (I) then return L_Vec (I) < R_Vec (I); end if; end loop; return False; end if; end if; else -- First argument non-negative, second argument negative if R_Vec (1) < 0 then return False; -- Both arguments non-negative else if L_Length /= R_Length then return L_Length < R_Length; else for I in L_Vec'range loop if L_Vec (I) /= R_Vec (I) then return L_Vec (I) < R_Vec (I); end if; end loop; return False; end if; end if; end if; end; end if; end UI_Lt; ------------ -- UI_Gt -- ------------ function UI_Gt (Left, Right : Uint) return Boolean is begin return UI_Lt (Right, Left); end UI_Gt; ------------ -- UI_Le -- ------------ function UI_Le (Left, Right : Uint) return Boolean is begin return not UI_Lt (Right, Left); end UI_Le; ------------ -- UI_Ge -- ------------ function UI_Ge (Left, Right : Uint) return Boolean is begin return not UI_Lt (Left, Right); end UI_Ge; ------------- -- UI_Abs -- ------------- function UI_Abs (Right : Uint) return Uint is begin if UI_Is_Negative (Right) then return UI_Negate (Right); else return Right; end if; end UI_Abs; ------------- -- UI_Rem -- ------------- function UI_Rem (Left, Right : Uint) return Uint is begin if N_Digits (Left) = 1 and then N_Digits (Right) = 1 then return UI_From_Int (UI_To_Int (Left) rem UI_To_Int (Right)); else return UI_Difference (Left, UI_Product (UI_Quotient (Left, Right), Right)); end if; end UI_Rem; ------------- -- UI_Mod -- ------------- function UI_Mod (Left, Right : Uint) return Uint is Urem : Uint := UI_Rem (Left, Right); begin if UI_Is_Negative (Left) = UI_Is_Negative (Right) or else UI_Is_Zero (Urem) then return Urem; else return UI_Sum (Right, Urem); end if; end UI_Mod; ---------------- -- UI_Negate -- ---------------- function UI_Negate (Right : Uint) return Uint is begin -- Quick processing for single digit case if Right <= Uint_Direct_Last then return Uint_Direct_Bias - (Right - Uint_Direct_Bias); -- Else copy the value to the end of the table, negating 1st digit else declare Length : Int := Uints.Table (Right).Length; Loc : Int := Uints.Table (Right).Loc; begin Uints.Increment_Last; Uints.Table (Uints.Last).Length := Length; Uints.Table (Uints.Last).Loc := Udigits.Last + 1; Udigits.Increment_Last; Udigits.Table (Udigits.Last) := - Udigits.Table (Loc); for Idx in 2 .. Length loop Udigits.Increment_Last; Udigits.Table (Udigits.Last) := Udigits.Table (Loc + Idx - 1); end loop; return Uints.Last; end; end if; end UI_Negate; -------------------- -- UI_Difference -- -------------------- function UI_Difference (Left, Right : Uint) return Uint is begin return UI_Sum (Left, UI_Negate (Right)); end UI_Difference; ------------- -- UI_Sum -- ------------- function UI_Sum (Left, Right : Uint) return Uint is begin -- First try simple case where Int "+" can be used; if Left <= Uint_Direct_Last and then Right <= Uint_Direct_Last then return (Left - Uint_Direct_Bias) + Right; -- Otherwise full circuit is needed else declare L_Length : Int := N_Digits (Left); R_Length : Int := N_Digits (Right); L_Vec : UI_Vector (1 .. L_Length); R_Vec : UI_Vector (1 .. R_Length); Sum_Length : Int; Tmp_Int, Carry, Borrow : Int; X_Bigger, Y_Bigger, Result_Negative : Boolean := False; begin Init_Operand (Left, L_Vec); Init_Operand (Right, R_Vec); -- Copy operands to vectors. -- At least one of them is more than 1 digit - so calculation is -- needed. -- Calculate number of digits sufficient to hold result. if L_Length > R_Length then Sum_Length := L_Length + 1; X_Bigger := True; else Sum_Length := R_Length + 1; if R_Length > L_Length then Y_Bigger := True; end if; end if; declare -- Make copies of the absolute values of L_Vec and R_Vec into -- X and Y both with lengths equal to the maximum possibly -- needed. This makes looping over the digits much simpler. X : UI_Vector (1 .. Sum_Length); Y : UI_Vector (1 .. Sum_Length); Tmp_UI : UI_Vector (1 .. Sum_Length); begin for I in 1 .. Sum_Length - L_Length loop X (I) := 0; end loop; X (Sum_Length - L_Length + 1) := abs L_Vec (1); for I in 2 .. L_Length loop X (I + (Sum_Length - L_Length)) := L_Vec (I); end loop; for I in 1 .. Sum_Length - R_Length loop Y (I) := 0; end loop; Y (Sum_Length - R_Length + 1) := abs R_Vec (1); for I in 2 .. R_Length loop Y (I + (Sum_Length - R_Length)) := R_Vec (I); end loop; if (L_Vec (1) < 0) = (R_Vec (1) < 0) then -- Same sign so just add Carry := 0; for I in reverse 1 .. Sum_Length loop Tmp_Int := X (I) + Y (I) + Carry; if Tmp_Int > Base then Tmp_Int := Tmp_Int - Base; Carry := 1; else Carry := 0; end if; X (I) := Tmp_Int; end loop; return Vector_To_Uint (X, L_Vec (1) < 0); else -- Find which one has bigger magnitude if not (X_Bigger or Y_Bigger) then for I in L_Vec'range loop if abs L_Vec (I) > abs R_Vec (I) then X_Bigger := True; exit; elsif abs R_Vec (I) > abs L_Vec (I) then Y_Bigger := True; exit; end if; end loop; end if; -- If they have identical magnitude, just return 0, else -- swap if necessary so that X had the bigger magnitude. -- Determine if result is negative at this time. Result_Negative := False; if not (X_Bigger or Y_Bigger) then return Uint_0; elsif Y_Bigger then if R_Vec (1) < 0 then Result_Negative := True; end if; Tmp_UI := X; X := Y; Y := Tmp_UI; else if L_Vec (1) < 0 then Result_Negative := True; end if; end if; -- Subtract Y from the bigger X Borrow := 0; for I in reverse 1 .. Sum_Length loop Tmp_Int := X (I) - Y (I) + Borrow; if Tmp_Int < 0 then Tmp_Int := Tmp_Int + Base; Borrow := -1; else Borrow := 0; end if; X (I) := Tmp_Int; end loop; return Vector_To_Uint (X, Result_Negative); end if; end; end; end if; end UI_Sum; ------------------ -- UI_Quotient -- ------------------ function UI_Quotient (Left, Right : Uint) return Uint is L_Length : Int := N_Digits (Left); R_Length : Int := N_Digits (Right); Q_Length : Int := L_Length - R_Length + 1; L_Vec : UI_Vector (1 .. L_Length); R_Vec : UI_Vector (1 .. R_Length); D : Int; Remainder : Int; Tmp_Divisor : Int; Carry : Int; Tmp_Int : Int; Tmp_Dig : Int; begin -- 0 divisors should be checked for outside of calls to this -- function - so this is considered an error in the compiler code. pragma Assert (not UI_Is_Zero (Right)); -- Some special cases that are simpler to compute than the general -- case are treated first. if L_Length = 1 and then R_Length = 1 then return UI_From_Int (UI_To_Int (Left) / UI_To_Int (Right)); elsif L_Length < R_Length then return Uint_0; end if; -- Copy operands into vectors Init_Operand (Left, L_Vec); Init_Operand (Right, R_Vec); if R_Length = 1 then -- In this case, each digit (from most to least significant) can -- simply be divided by the divisor, with the remainder carried -- to the next digit. Remainder := 0; Tmp_Divisor := abs R_Vec (1); declare Quotient : UI_Vector (1 .. L_Length); begin for J in L_Vec'range loop Tmp_Int := Remainder * Base + abs L_Vec (J); Quotient (J) := Tmp_Int / Tmp_Divisor; Remainder := Tmp_Int rem Tmp_Divisor; end loop; return Vector_To_Uint (Quotient, (L_Vec (1) < 0 xor R_Vec (1) < 0)); end; end if; -- The possible simple cases have been exhausted. Now turn to the -- algorithm D from the section of Knuth mentioned at the top of -- this package. declare Dividend : UI_Vector (1 .. L_Length + 1); Divisor : UI_Vector (1 .. R_Length); Quotient : UI_Vector (1 .. Q_Length); Divisor_Dig1, Divisor_Dig2 : Int; Q_Guess : Int; begin -- [ NORMALIZE ] (step D1 in the algorithm). First calculate the -- scale d, and then multiply Left and Right (u and v in the book) -- by d to get the dividend and divisor to work with. D := Base / (abs R_Vec (1) + 1); Dividend (1) := 0; Dividend (2) := abs L_Vec (1); for I in 3 .. L_Length + 1 loop Dividend (I) := L_Vec (I - 1); end loop; Divisor (1) := abs R_Vec (1); for I in 2 .. R_Length loop Divisor (I) := R_Vec (I); end loop; if D > 1 then -- Multiply Dividend by D Carry := 0; for J in reverse Dividend'range loop Tmp_Int := Dividend (J) * D + Carry; Dividend (J) := Tmp_Int rem Base; Carry := Tmp_Int / Base; end loop; -- Multiply Divisor by d. Carry := 0; for J in reverse Divisor'range loop Tmp_Int := Divisor (J) * D + Carry; Divisor (J) := Tmp_Int rem Base; Carry := Tmp_Int / Base; end loop; end if; -- Main loop of long division algorithm. Divisor_Dig1 := Divisor (1); Divisor_Dig2 := Divisor (2); for J in Quotient'range loop -- [ CALCULATE Q (hat) ] (step D3 in the algorithm). Tmp_Int := Dividend (J) * Base + Dividend (J + 1); -- Used in couple of places below. if Dividend (J) = Divisor_Dig1 then Q_Guess := Base - 1; else Q_Guess := Tmp_Int / Divisor_Dig1; end if; -- Initial guess. while Divisor_Dig2 * Q_Guess > (Tmp_Int - Q_Guess * Divisor_Dig1) * Base + Dividend (J + 2) loop Q_Guess := Q_Guess - 1; end loop; -- Refine the guess. -- [ MULTIPLY & SUBTRACT] (step D4). Q_Guess * Divisor is -- subtracted from the remaining dividend. Carry := 0; for K in reverse Divisor'range loop Tmp_Int := Dividend (J + K) - Q_Guess * Divisor (K) + Carry; Tmp_Dig := Tmp_Int rem Base; Carry := Tmp_Int / Base; if Tmp_Dig < 0 then Tmp_Dig := Tmp_Dig + Base; Carry := Carry - 1; end if; Dividend (J + K) := Tmp_Dig; end loop; Dividend (J) := Dividend (J) + Carry; -- [ TEST REMAINDER ] & [ ADD BACK ] (steps D5 and D6) -- Here there is a slight difference from the book: the last -- carry is always added in above and below (cancelling each -- other). In fact the dividend going negative is used as -- the test. -- If the Dividend went negative, then Q_Guess was off by -- one, so it is decremented, and the divisor is added back -- into the relevant portion of the dividend. if Dividend (J) < 0 then Q_Guess := Q_Guess - 1; Carry := 0; for K in reverse Divisor'range loop Tmp_Int := Dividend (J + K) + Divisor (K) + Carry; if Tmp_Int > Base then Tmp_Int := Tmp_Int - Base; Carry := 1; else Carry := 0; end if; Dividend (J + K) := Tmp_Int; end loop; Dividend (J) := Dividend (J) + Carry; end if; Quotient (J) := Q_Guess; -- Got the quotient digit; end loop; return Vector_To_Uint (Quotient, (L_Vec (1) < 0 xor R_Vec (1) < 0)); end; -- End of declare block end UI_Quotient; ----------------- -- UI_Product -- ----------------- function UI_Product (Left, Right : Uint) return Uint is L_Length : Int := N_Digits (Left); R_Length : Int := N_Digits (Right); L_Vec : UI_Vector (1 .. L_Length); R_Vec : UI_Vector (1 .. R_Length); begin if L_Length = 1 and then R_Length = 1 then return UI_From_Int (Int (Left - Uint_Direct_Bias) * Int (Right - Uint_Direct_Bias)); end if; -- Do the simple case. Init_Operand (Left, L_Vec); Init_Operand (Right, R_Vec); -- Copy operands into vectors. -- General case (Algorithm M in Knuth). declare Product : UI_Vector (1 .. L_Length + R_Length); Tmp_Sum, Carry : Int; begin for I in Product'range loop Product (I) := 0; end loop; for J in reverse R_Vec'range loop Carry := 0; for K in reverse L_Vec'range loop Tmp_Sum := abs (L_Vec (K) * R_Vec (J)) + Product (J + K) + Carry; Product (J + K) := Tmp_Sum rem Base; Carry := Tmp_Sum / Base; end loop; Product (J) := Carry; end loop; return Vector_To_Uint (Product, (L_Vec (1) < 0 xor R_Vec (1) < 0)); end; end UI_Product; ---------------------- -- UI_Exponentiate -- ---------------------- -- The exponentiation function is from 4.6.3 of the same volume of Knuth. function UI_Exponentiate (Left, Right : Uint) return Uint is N : Uint := Right; Squares : Uint := Left; Result : Uint := Uint_1; Uint_2 : Uint; begin -- Any value raised to power of 0 is 1 if UI_Is_Zero (Right) then return Uint_1; end if; -- Negative exponents not allowed for Integers pragma Assert (not UI_Is_Negative (Right)); -- 0 to any positive power is 0. if UI_Is_Zero (Left) then return Uint_0; end if; -- Any value raised to power of 1 is that value if Right = 1 then return Left; end if; -- Now do general case. Uint_2 := UI_From_Int (2); loop if UI_Eq (UI_Mod (N, Uint_2), Uint_1) then Result := UI_Product (Result, Squares); end if; N := UI_Quotient (N, Uint_2); if UI_Is_Zero (N) then return Result; end if; Squares := UI_Product (Squares, Squares); end loop; end UI_Exponentiate; begin Uint_Int_First := UI_From_Int (Int'First); Uint_Int_Last := UI_From_Int (Int'Last); end Uintp; o this is considered an error in the compiler code. pragma Assert (not UI_Is_Zero (Right)); -- Some special cases that are simpler to compute than the general -- case are treatgnat-1.67-src/src/uname.ads 444 10015 7640 15275 5506244447 10753 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- U N A M E -- -- -- -- S p e c -- -- -- -- $Revision: 1.12 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Uname is --------------------------- -- Unit Name Conventions -- --------------------------- -- Units are associated with a unique ASCII name as follows. First we -- have the fully expanded name of the unit, with lower case letters and -- periods. Following this is one of the following suffixes: -- %s for package/subprogram/generic declarations (specs) -- %b for package/subprogram bodies -- The general rule is that the active library (i.e. the units required -- by the current unit being compiled) cannot contain duplicate units, -- defined as units with identical names according to the above rule. -- Unit names are stored in the names table, and referred to by the -- corresponding Name_Id values. -- Types as a synonym for Name_Id and is used to indicate that a Name_Id -- holding a unit name (as defined here) is expected. -- Note: as far as possible the conventions for unit names are encapsulated -- in this package. The one exception is that package Fname, which provides -- conversion routines from unit names to file names must be aware of the -- precise conventions that are used. ------------------- -- Display Names -- ------------------- -- For display purposes, unit names are printed out with the suffix -- " (body)" for a body and " (spec)" for a spec. These formats are -- used for the Write_Unit_Name and Get_Unit_Name_String subprograms. ----------------- -- Subprograms -- ----------------- function Name_To_Unit_Name (N : Name_Id) return Unit_Name_Type; -- Given the Id of the Ada name of a unit, this function returns the -- corresponding unit name of the spec (by appending %s to the name). function Get_Unit_Name (N : Node_Id) return Unit_Name_Type; -- This procedure is passed one of the following nodes: -- N_Subprogram_Declaration (spec) cases -- N_Package_Declaration -- N_Generic_Declaration -- N_With_Clause -- N_Function_Instantiation -- N_Package_Instantiation -- N_Procedure_Instantiation -- N_Pragma (Elaborate case) -- N_Package_Body (body) cases -- N_Subprogram_Body -- N_Subprogram_Body_Stub (subunit) cases -- N_Package_Body_Stub -- N_Task_Body_Stub -- N_Protected_Body_Stub -- N_Subunit function Get_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type; -- Given the name of a body, this function returns the name of the -- corresponding spec, i.e. characters %b replaced by %s function Get_Body_Name (N : Unit_Name_Type) return Unit_Name_Type; -- Given the name of a spec, this function returns the name of the -- corresponding body, i.e. characters %s replaced by %b function Get_Parent_Body_Name (N : Unit_Name_Type) return Unit_Name_Type; -- Given the name of a subunit, returns the name of the parent body. function Get_Parent_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type; -- Given the name of a child unit spec or body, returns the unit name -- of the parent spec. Returns No_Name if the given name is not the name -- of a child unit. procedure Get_Unit_Name_String (N : Unit_Name_Type); -- Places the display name of the unit in Name_Buffer and sets Name_Len -- to the length of the stored name, i.e. it uses the same interface as -- the Get_Name_String routine in the Namet package. procedure Write_Unit_Name (N : Unit_Name_Type); -- Given a unit name, this procedure writes the display name to the -- standard output file. Name_Buffer and Name_Len are set as described -- above for the Get_Unit_Name_String call on return. function Is_Spec_Name (N : Unit_Name_Type) return Boolean; -- Returns True iff the given name is the unit name of a specification -- (i.e. if it ends with the characters %s). function Is_Body_Name (N : Unit_Name_Type) return Boolean; -- Returns True iff the given name is the unit name of a body (i.e. if -- it ends with the characters %b). function Is_Child_Name (N : Unit_Name_Type) return Boolean; -- Returns True iff the given name is a child unit name (of either a -- body or a spec). function Uname_Lt (Left, Right : Unit_Name_Type) return Boolean; function Uname_Gt (Left, Right : Unit_Name_Type) return Boolean; function Uname_Le (Left, Right : Unit_Name_Type) return Boolean; function Uname_Ge (Left, Right : Unit_Name_Type) return Boolean; -- These functions perform lexicographic ordering of unit names. The -- ordering is suitable for printing, and is not quite a straightforward -- comparison of the names, since the convention is that specs appear -- before bodies. Note that the standard = and /= operators work fine -- because all unit names are hashed into the name table, so if two names -- are the same, they always have the same Name_Id value. end Uname; COMPILER COMPONENTS -- -- -- -- U N A M E -- -- -- -- S pgnat-1.67-src/src/uname.adb 444 10015 7640 34011 5506244450 10711 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- U N A M E -- -- -- -- B o d y -- -- -- -- $Revision: 1.25 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Casing; use Casing; with Comperr; use Comperr; with Lib; use Lib; with Limits; use Limits; with Namet; use Namet; with Output; use Output; with Sinfo; use Sinfo; package body Uname is ----------------------- -- Name_To_Unit_Name -- ----------------------- function Name_To_Unit_Name (N : Name_Id) return Unit_Name_Type is begin Get_Name_String (N); Name_Buffer (Name_Len + 1) := '%'; Name_Buffer (Name_Len + 2) := 's'; return Name_Find; end Name_To_Unit_Name; ------------------- -- Get_Unit_Name -- ------------------- function Get_Unit_Name (N : Node_Id) return Unit_Name_Type is Unit_Name_Buffer : Str (1 .. Max_Name_Length); -- Buffer used to build name of unit. Note that we cannot use the -- Name_Buffer in package Name_Table because we use it to read -- component names. Unit_Name_Length : Int := 0; -- Length of name stored in Unit_Name_Buffer Node : Node_Id; -- Program unit node procedure Add_Char (C : Char) is -- Add a single character to stored unit name begin -- Should really check for max length exceeded here Unit_Name_Length := Unit_Name_Length + 1; Unit_Name_Buffer (Unit_Name_Length) := C; end Add_Char; procedure Add_Name (Name : Name_Id) is -- Add the characters of a names table entry to stored unit name begin Get_Name_String (Name); for I in 1 .. Name_Len loop Add_Char (Name_Buffer (I)); end loop; end Add_Name; function Get_Parent (Node : Node_Id) return Node_Id is -- Get parent compilation unit of a stub N : Node_Id := Node; begin while Nkind (N) /= N_Compilation_Unit loop N := Parent (N); end loop; return N; end Get_Parent; procedure Add_Node_Name (Node : Node_Id) is -- Recursive procedure adds characters associated with Node Kind : Node_Kind := Nkind (Node); begin -- Just ignore an error node (someone else will give a message) if Node = Error then return; -- Otherwise see what kind of node we have elsif Kind = N_Identifier or else Kind = N_Defining_Identifier then Add_Name (Chars (Node)); elsif Kind = N_Defining_Program_Unit_Name then Add_Node_Name (Name (Node)); Add_Char ('.'); Add_Node_Name (Defining_Identifier (Node)); elsif Kind = N_Selected_Component then Add_Node_Name (Prefix (Node)); Add_Char ('.'); Add_Node_Name (Selector_Name (Node)); elsif Kind in N_Subprogram_Specification or else Kind = N_Package_Specification then Add_Node_Name (Defining_Unit_Name (Node)); elsif Kind = N_Subprogram_Body or else Kind = N_Subprogram_Declaration or else Nkind (Node) = N_Package_Declaration or else Nkind (Node) in N_Generic_Declaration then Add_Node_Name (Specification (Node)); elsif Kind in N_Generic_Instantiation then Add_Node_Name (Defining_Unit_Name (Node)); elsif Kind = N_Package_Body then Add_Node_Name (Defining_Unit_Name (Node)); elsif Kind = N_Task_Body or else Kind = N_Protected_Body then Add_Node_Name (Defining_Identifier (Node)); elsif Kind = N_Package_Renaming_Declaration then Add_Node_Name (Defining_Unit_Name (Node)); elsif Kind = N_Subprogram_Renaming_Declaration then Add_Node_Name (Specification (Node)); elsif Kind = N_Subprogram_Body_Stub then Add_Node_Name (Get_Parent (Node)); Add_Char ('.'); Add_Node_Name (Specification (Node)); elsif Kind = N_Compilation_Unit then Add_Node_Name (Unit (Node)); elsif Kind = N_Package_Body_Stub then Add_Node_Name (Get_Parent (Node)); Add_Char ('.'); Add_Node_Name (Defining_Identifier (Node)); elsif Kind = N_Task_Body_Stub or else Kind = N_Protected_Body_Stub then Add_Node_Name (Get_Parent (Node)); Add_Char ('.'); Add_Node_Name (Defining_Identifier (Node)); elsif Kind = N_Subunit then Add_Node_Name (Name (Node)); Add_Char ('.'); Add_Node_Name (Proper_Body (Node)); elsif Kind = N_With_Clause then Add_Node_Name (Name (Node)); elsif Kind = N_Pragma then Add_Node_Name (Expression (First (Pragma_Argument_Associations (Node)))); else Compiler_Error; Write_Eol; Write_String (Node_Kind'Image (Kind)); Write_Eol; Compiler_Abort; end if; end Add_Node_Name; -- Start of processing for Get_Unit_Name begin Node := N; -- If we have Defining_Identifier, find the associated unit node if Nkind (Node) = N_Defining_Identifier then Node := Parent (Node); if Nkind (Node) = N_Defining_Program_Unit_Name then Node := Parent (Node); end if; end if; -- Node points to the unit, so get its name and add proper suffix Add_Node_Name (Node); Add_Char ('%'); if Nkind (Node) in N_Generic_Declaration or else Nkind (Node) = N_Subprogram_Declaration or else Nkind (Node) = N_Package_Declaration or else Nkind (Node) = N_With_Clause or else Nkind (Node) = N_Pragma or else Nkind (Node) in N_Generic_Instantiation or else Nkind (Node) = N_Package_Renaming_Declaration or else Nkind (Node) = N_Subprogram_Renaming_Declaration then Add_Char ('s'); elsif Nkind (Node) = N_Subprogram_Body or else Nkind (Node) = N_Package_Body or else Nkind (Node) = N_Subunit or else Nkind (Node) in N_Body_Stub then Add_Char ('b'); else Compiler_Error; Write_Eol; Write_String (Node_Kind'Image (Nkind (Node))); Write_Eol; Compiler_Abort; end if; Name_Buffer (1 .. Unit_Name_Length) := Unit_Name_Buffer (1 .. Unit_Name_Length); Name_Len := Unit_Name_Length; return Name_Find; end Get_Unit_Name; ------------------- -- Get_Body_Name -- ------------------- function Get_Body_Name (N : Unit_Name_Type) return Unit_Name_Type is begin Get_Name_String (N); pragma Assert (Name_Len > 2 and then Name_Buffer (Name_Len - 1) = '%' and then Name_Buffer (Name_Len) = 's'); Name_Buffer (Name_Len) := 'b'; return Name_Find; end Get_Body_Name; ------------------- -- Get_Spec_Name -- ------------------- function Get_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type is begin Get_Name_String (N); pragma Assert (Name_Len > 2 and then Name_Buffer (Name_Len - 1) = '%' and then Name_Buffer (Name_Len) = 'b'); Name_Buffer (Name_Len) := 's'; return Name_Find; end Get_Spec_Name; -------------------------- -- Get_Parent_Body_Name -- -------------------------- function Get_Parent_Body_Name (N : Unit_Name_Type) return Unit_Name_Type is begin Get_Name_String (N); while Name_Buffer (Name_Len) /= '.' loop pragma Assert (Name_Len > 1); -- not a child or subunit name Name_Len := Name_Len - 1; end loop; Name_Buffer (Name_Len) := '%'; Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := 'b'; return Name_Find; end Get_Parent_Body_Name; -------------------------- -- Get_Parent_Spec_Name -- -------------------------- function Get_Parent_Spec_Name (N : Unit_Name_Type) return Unit_Name_Type is begin Get_Name_String (N); while Name_Buffer (Name_Len) /= '.' loop if Name_Len = 1 then return No_Name; -- not a child or subunit name else Name_Len := Name_Len - 1; end if; end loop; Name_Buffer (Name_Len) := '%'; Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := 's'; return Name_Find; end Get_Parent_Spec_Name; -------------------------- -- Get_Unit_Name_String -- -------------------------- procedure Get_Unit_Name_String (N : Unit_Name_Type) is Unit_Is_Body : Boolean; begin Get_Name_String (N); Unit_Is_Body := Name_Buffer (Name_Len) = 'b'; Set_Casing (File.Table (Main_Unit).Identifier_Casing, Mixed_Case); if Unit_Is_Body then Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (body)"; else Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (spec)"; end if; for I in 1 .. Name_Len loop if Name_Buffer (I) = '-' then Name_Buffer (I) := '.'; end if; end loop; Name_Len := Name_Len + (7 - 2); end Get_Unit_Name_String; --------------------- -- Write_Unit_Name -- --------------------- procedure Write_Unit_Name (N : Unit_Name_Type) is begin Get_Unit_Name_String (N); Write_Str (Name_Buffer (1 .. Name_Len)); end Write_Unit_Name; ------------------ -- Is_Spec_Name -- ------------------ function Is_Spec_Name (N : Unit_Name_Type) return Boolean is begin Get_Name_String (N); return Name_Len > 2 and then Name_Buffer (Name_Len - 1) = '%' and then Name_Buffer (Name_Len) = 's'; end Is_Spec_Name; ------------------ -- Is_Body_Name -- ------------------ function Is_Body_Name (N : Unit_Name_Type) return Boolean is begin Get_Name_String (N); return Name_Len > 2 and then Name_Buffer (Name_Len - 1) = '%' and then Name_Buffer (Name_Len) = 'b'; end Is_Body_Name; ------------------- -- Is_Child_Name -- ------------------- function Is_Child_Name (N : Unit_Name_Type) return Boolean is J : Int; begin Get_Name_String (N); J := Name_Len; while Name_Buffer (J) /= '.' loop if J = 1 then return False; -- not a child or subunit name else J := J - 1; end if; end loop; return True; end Is_Child_Name; -------------- -- Uname_Lt -- -------------- function Uname_Lt (Left, Right : Unit_Name_Type) return Boolean is Left_Name : Str (1 .. Max_Name_Length); Left_Length : Int; Right_Name : Str renames Name_Buffer; Right_Length : Int renames Name_Len; I : Pos; begin if Left = Right then return False; end if; Get_Name_String (Left); Left_Name (1 .. Name_Len + 1) := Name_Buffer (1 .. Name_Len + 1); Left_Length := Name_Len; Get_Name_String (Right); I := 1; loop exit when Left_Name (I) = '%'; if Right_Name (I) = '%' then return False; -- left name is longer end if; pragma Assert (I <= Left_Length and then I <= Right_Length); if Left_Name (I) /= Right_Name (I) then return Left_Name (I) < Right_Name (I); -- parent names different end if; I := I + 1; end loop; -- Come here pointing to % in left name if Right_Name (I) /= '%' then return True; -- right name is longer end if; -- Here the parent names are the same and specs sort low. If neither is -- a spec, then we are comparing the same name and we want a result of -- False in any case. return Left_Name (I + 1) = 's'; end Uname_Lt; -------------- -- Uname_Gt -- -------------- function Uname_Gt (Left, Right : Unit_Name_Type) return Boolean is begin return Left /= Right and then not Uname_Lt (Left, Right); end Uname_Gt; -------------- -- Uname_Le -- -------------- function Uname_Le (Left, Right : Unit_Name_Type) return Boolean is begin return Left = Right or else Uname_Lt (Left, Right); end Uname_Le; -------------- -- Uname_Ge -- -------------- function Uname_Ge (Left, Right : Unit_Name_Type) return Boolean is begin return Left = Right or else Uname_Gt (Left, Right); end Uname_Ge; end Uname; uct'range loop Product (I) := 0; end loop; for J in reverse R_Vec'range loop Carry := 0; for K in reverse L_Vec'range loop Tmp_Sum := abs (L_Vec (K) * R_Vec (J)) + Product (J + K) + Carry; Product (J + K) := Tmp_Sum rem Base; Carry := Tmp_Sum / Base; end loop; Product (J) := Carry; end loop; return Vector_To_Uint (Product, (L_Vec (1) < 0 xorgnat-1.67-src/src/unchecked_conversion.ads 444 10015 7640 3776 5506244450 14021 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- U N C H E C K E D _ C O N V E R S I O N -- -- -- -- S p e c -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; generic type Source (<>) is limited private; type Target (<>) is limited private; function Unchecked_Conversion (Source_Object : Source) return Target; pragma Convention (Intrinsic, Unchecked_Conversion); _Bgnat-1.67-src/src/unchecked_conversion.adb 444 10015 7640 4602 5506244450 13765 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- U N C H E C K E D _ C O N V E R S I O N -- -- -- -- B o d y -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Obviously the body below is incorrect, since it is simply a checked -- conversion. Indeed it is not possible to write a correct body for -- this generic function in Ada. The approach we take is to provide this -- bogus body, which is read in as a generic template using the normal -- mechanisms, then there is a special circuit (in Sem_Ch11) which checks -- for unchecked conversion and sets the Unchecked_Conversion flag in the -- N_Conversion node in the template. function Unchecked_Conversion (Source_Object : Source) return Target is begin return Target (Source_Object); end Unchecked_Conversion; e_Len + 1; Name_Buffer (Name_Len) := 'b'; return Name_Find; end Get_Parent_Body_Name; --------------------gnat-1.67-src/src/unchecked_deallocation.ads 444 10015 7640 3750 5506244451 14263 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- U N C H E C K E D _ D E A L L O C A T I O N -- -- -- -- S p e c -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; generic type Object (<>) is limited private; type Name is access Object; procedure Unchecked_Deallocation (X : in out Name); -- pragma Convention (Intrinsic, Unchecked_Deallocation); vide this -- bogus bodygnat-1.67-src/src/unixlib.ads 444 10015 7640 10316 5506244451 11302 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- U N I X L I B -- -- -- -- S p e c -- -- -- -- $Revision: 1.11 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This package contains some interface functions to the Unix library with System; use System; with Types; use Types; package Unixlib is type Unix_FD is new Int; -- Unix file descriptor Unix_Standin : constant Unix_FD := 0; Unix_Standout : constant Unix_FD := 1; Unix_Standerr : constant Unix_FD := 2; -- File descriptors for standard input output files function Unix_File_Length (FD : Unix_FD) return Int; -- Get length of unix file from descriptor function Unix_File_Time_Stamp (FD : Unix_FD) return Time_Stamp_Type; -- Get time stamp of file from descriptor procedure Unix_Write (FD : Unix_FD; A : Address; N : Int); pragma Interface (C, Unix_Write); pragma Interface_Name (Unix_Write, "write"); -- Write N bytes from address A to file referenced by FD procedure Unix_Exit (Status : Int); pragma Interface (C, Unix_Exit); pragma Interface_Name (Unix_Exit, "exit"); -- Exit to Unix with given status code (program is terminated) procedure Unix_Abort; pragma Interface (C, Unix_Abort); pragma Interface_Name (Unix_Abort, "abort"); -- Exit to Unix signalling an abort (traceback or other appropriate -- diagnostic information should be given if possible, or entry made -- to the debugger if that is possible). function Unix_Read (FD : Unix_FD; A : Address; N : Int) return Int; pragma Interface (C, Unix_Read); pragma Interface_Name (Unix_Read, "read"); -- Read N bytes to address A from file referenced by FD. Returned value -- is count of bytes actually read, which can be less than N at EOF. function Unix_Open_Read (Name : Address) return Unix_FD; pragma Interface (C, Unix_Open_Read); pragma Interface_Name (Unix_Open_Read, "open_read"); -- Open file Name (NUL-terminated) for reading, returning file descriptor -- File descriptor returned is negative if file cannot be opened. function Unix_Create_File (Name : Address) return Unix_FD; pragma Interface (C, Unix_Create_File); pragma Interface_Name (Unix_Create_File, "open_create"); -- Creates new file with given name (NUL-terminated) for writing, returning -- file descriptor for subsequent use in Unix_Write calls. File desctiptor -- returned is negative if file cannot be successfully created. procedure Unix_Close (FD : Unix_FD); pragma Interface (C, Unix_Close); pragma Interface_Name (Unix_Close, "close"); -- Close file referenced by FD end Unixlib; and then Name_Buffer (Name_Len - 1) = '%' and then Name_Buffer (Name_Len) = 's'; end Is_Spec_Name; ------------------ -- Is_Body_Name -- ------------------ function Is_Body_Name (N : Unit_Name_Type) return Boolean is begin Get_Name_String (N); return Name_Len gnat-1.67-src/src/unchecked_deallocation.adb 444 10015 7640 4041 5506244451 14234 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- U N C H E C K E D _ D E A L L O C A T I O N -- -- -- -- B o d y -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ pragma Ada_9X; with System; procedure Unchecked_Deallocation (X : in out Name) is procedure Free (A : System.Address); pragma Import (C, Free); begin if X /= null then Free (X.all'Address); X := null; end if; end Unchecked_Deallocation; stant Unix_FD := 1; Unix_Standerr : constant Unix_FD := 2; -- File descriptors for standard input output files function Unix_File_Length (FD : Unix_FD) return Int; -- Get length of unix file from descriptor function Unix_File_Time_Stamp (FD : Unix_FD) return Time_Stamp_Type; -- Get time stamp of file from descriptor procedure Unix_Write (FD : Unix_FD; A : Address; N : Int); pragma Interface (C, Unix_Write); pragma Interface_Name (Unix_Write, gnat-1.67-src/src/unixlib.adb 444 10015 7640 5156 5506244452 11250 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- U N I X L I B -- -- -- -- B o d y -- -- -- -- $Revision: 1.9 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ package body Unixlib is ---------------------- -- Unix_File_Length -- ---------------------- function Unix_File_Length (FD : Unix_FD) return Int is function File_Length (FD : Unix_FD) return Int; pragma Interface (C, File_Length); pragma Interface_Name (File_Length, "file_length"); begin return File_Length (FD); end Unix_File_Length; --------------------------- -- Unix_File_Time_Stamp -- --------------------------- function Unix_File_Time_Stamp (FD : Unix_FD) return Time_Stamp_Type is Stamp : Time_Stamp_Type; procedure File_Time (FD : Unix_FD; Stamp : in out Time_Stamp_Type); pragma Interface (C, File_Time); pragma Interface_Name (File_Time, "file_time"); begin File_Time (FD, Stamp); return Stamp; end Unix_File_Time_Stamp; end Unixlib; ; pragma Interface (C, Unix_Exit); pragma Interface_Name (Unix_Exit, "exit"); -- Exit to Unix with given status code (program is terminated) procedure Unix_Abort; pragma Interface (C, Unix_Abort); pragma Interface_Name (Unix_Abort, "abort"); -- Exit to Unix signalling an abort (traceback or other appropriate -- diagnostic information should be given if possible, or entry gnat-1.67-src/src/usage.ads 444 10015 7640 3572 5506244452 10723 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- U S A G E -- -- -- -- S p e c -- -- -- -- $Revision: 1.3 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Procedure to generate screen of usage information if no file name present procedure Usage; ------ function Unix_File_Length (FD : Unix_FD) return Int is function File_Length (FD : Unix_FD) return Int; pragma gnat-1.67-src/src/usage.adb 444 10015 7640 13636 5506244452 10724 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- U S A G E -- -- -- -- B o d y -- -- -- -- $Revision: 1.27 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Opt; use Opt; with Osint; use Osint; with Output; use Output; with Sysid; use Sysid; with Types; use Types; procedure Usage is procedure Write_Switch_Character is begin if MS_DOS then Write_Char ('/'); else Write_Char ('-'); end if; end Write_Switch_Character; begin -- Usage line Write_String ("Usage: "); Write_Program_Name; Write_Char (' '); Write_String ("switches sfile"); Write_Eol; Write_Eol; -- Line for -a switch Write_String (" "); Write_Switch_Character; Write_String ("a Assertions enabled. Pragma Ass"); Write_String ("ert and pragma Debug to be activated"); Write_Eol; -- Line for -b switch Write_String (" "); Write_Switch_Character; Write_String ("b Generate brief messages to std"); Write_String ("err even if verbose mode set"); Write_Eol; -- Line for -c switch Write_String (" "); Write_Switch_Character; Write_String ("c Check syntax and semantics onl"); Write_String ("y (no code generation attempted)"); Write_Eol; -- Line for -e switch Write_String (" "); Write_Switch_Character; Write_String ("e Error messages generated immed"); Write_String ("iately, not saved up till end"); Write_Eol; -- Line for -f switch Write_String (" "); Write_Switch_Character; Write_String ("f Full errors. Normally only fir"); Write_String ("st error on each line is reported."); Write_Eol; -- Line for -g switch Write_String (" "); Write_Switch_Character; Write_String ("g GNAT style checks enabled"); Write_Eol; -- Line for -i switch Write_String (" "); Write_Switch_Character; Write_String ("ix Identifier char set (x=1/2/3/4/p"); Write_String ("/f/n) default = "); if MS_DOS then Write_String ("p (IBM/PC)"); else Write_String ("1 (Latin-1)"); end if; Write_Eol; -- Line for -k switch Write_String (" "); Write_Switch_Character; Write_String ("knnn Limit file names to nnn characters (k = krunch)"); Write_Eol; -- Line for -l switch Write_String (" "); Write_Switch_Character; Write_String ("l Output full source listing wi"); Write_String ("th embedded error messages"); Write_Eol; -- Line for -m switch Write_String (" "); Write_Switch_Character; Write_String ("mnnn Limit number of detected error"); Write_String ("s to nnn (1-999)"); Write_Eol; -- Line for -n switch Write_String (" "); Write_Switch_Character; Write_String ("n No inlining of subprograms ("); Write_String ("ignore pragma Inline)"); Write_Eol; -- Line for -p switch Write_String (" "); Write_Switch_Character; Write_String ("p Suppress all checks"); Write_Eol; -- Line for -r switch Write_String (" "); Write_Switch_Character; Write_String ("r Reference manual column layout"); Write_String (" required"); Write_Eol; -- Lines for -s switch Write_String (" "); Write_Switch_Character; Write_String ("s Syntax check only"); Write_Eol; -- Lines for -t switch Write_String (" "); Write_Switch_Character; Write_String ("t Try semantics, even if parse errors"); Write_Eol; -- Line for -u switch Write_String (" "); Write_Switch_Character; Write_String ("u List units for this compilation"); Write_Eol; -- Line for -v switch Write_String (" "); Write_Switch_Character; Write_String ("v Verbose mode. Full error outp"); Write_String ("ut with source lines to stdout"); Write_Eol; -- Lines for -w switch Write_String (" "); Write_Switch_Character; Write_String ("wx Warning mode. (x=s/e for supp"); Write_String ("ress/treat as error)"); Write_Eol; -- Line for -83 switch Write_String (" "); Write_Switch_Character; Write_String ("83 Enforce Ada 83 restrictions"); Write_Eol; -- Line for sfile Write_String (" sfile Source file names"); if MS_DOS then Write_String (" (wild cards allowed for multiple files)"); end if; Write_Eol; end Usage; ptor for subsequent use in Unix_Write calls. File desctiptor -- returned is negative if file cgnat-1.67-src/src/a-adaint.c 444 10015 7640 7226 5506244453 10751 /*****************************************************************************/ /* */ /* G N A T */ /* */ /* COMPILER COMPONENTS */ /* */ /* A D A I N T */ /* */ /* Specification */ /* */ /* Copyright (c) 1992, All Rights Reserved */ /* under standard GNU Public License. For */ /* details, see GNAT documentation. */ /* */ /* Written at New York University by the */ /* GNU/Ada development team. */ /* */ /* $Revision: 1.12 $ */ /* */ /*****************************************************************************/ /* This file contains thos routines named by "pragma interface_name" */ /* statements in the package unix_Library, which are not simply system */ /* or standard library calls. */ #include #include #include #include "config.h" /* this may define OS2 */ #ifndef O_BINARY #define O_BINARY 0 #endif int open_read(char *path) { return open(path, O_RDONLY | O_BINARY); } int open_create(char *path) { return open(path, O_WRONLY | O_CREAT | O_TRUNC, S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH); } long file_length(int fd) { /* Return the number of bytes in the named file. */ int ret; struct stat statbuf; ret = fstat(fd, &statbuf); if (ret || !S_ISREG(statbuf.st_mode)) return 0L; return (statbuf.st_size); } void file_time (int fd, char *stamp) { int ret; struct stat statbuf; char buf[13]; #ifndef OS2 ret = fstat (fd, &statbuf); /* Not doing anything with errors here! */ strftime (buf, 13, "%Y%m%d%H%M%S",localtime (&statbuf.st_mtime)); #else unsigned long Dos32QueryFileInfo () asm ("Dos32QueryFileInfo"); typedef struct _FDATE { unsigned short day : 5; unsigned short month : 4; unsigned short year : 7; } FDATE; typedef struct _FTIME { unsigned short twosecs : 5; unsigned short minutes : 6; unsigned short hours : 5; } FTIME; struct FILESTATUS { FDATE fdateCreation; FTIME ftimeCreation; FDATE fdateLastAccess; FTIME ftimeLastAccess; FDATE fdateLastWrite; FTIME ftimeLastWrite; unsigned long cbFile; unsigned long cbFileAlloc; unsigned short attrFile; } fs; ret = Dos32QueryFileInfo (fd, 1, (unsigned char *) &fs, sizeof (struct FILESTATUS)); sprintf (buf, "%4d%02d%02d%02d%02d", fs.fdateLastWrite.year + 1980, fs.fdateLastWrite.month, fs.fdateLastWrite.day, fs.ftimeLastWrite.hours, fs.ftimeLastWrite.minutes); #endif strncpy (stamp, buf, 12); } */ /* G N A T */ /* */ /* COMPILER COMPONENTS */ /* */ /* gnat-1.67-src/src/a-gtran3.c 444 10015 7640 220052 5506244455 10743 /****************************************************************************/ /* */ /* GNAT COMPILER COMPONENTS */ /* */ /* ADA CHAPTER 3: DECLARATIONS AND TYPES */ /* - GNAT SPECIFIC - */ /* */ /* Body */ /* */ /* $Revision: 1.127 $ */ /* */ /* Copyright (c) 1992,1993, NYU, All Rights Reserved */ /* */ /* 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 */ /* Software Foundation; either version 2, or (at your option) any later */ /* version. GNAT is distributed in the hope that it will be useful, but */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- */ /* ABILITY 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 GNAT; see file COPYING. If not, write */ /* to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* */ /****************************************************************************/ #include "config.h" #include "tree.h" #include "obstack.h" #include "flags.h" #include "convert.h" #include "a-ada.h" #include "a-types.h" #include "a-atree.h" #include "a-sinfo.h" #include "a-einfo.h" #include "a-namet.h" #include "a-string.h" #include "a-uint.h" #include "a-trans.h" #include "a-trans3.h" #include "a-trans4.h" #include "a-gtran3.h" #include "a-misc.h" #include "a-rtree.h" static tree maybe_placeholder PROTO((tree)); static tree elaborate_expression PROTO((gnat_tree, gnat_tree, char *, int)); static void components_to_record PROTO((tree, gnat_tree, tree, int)); static tree create_enum_initializer PROTO((gnat_tree, tree)); static char *get_operator_name PROTO((char *)); static char *qualified_overloaded_name PROTO((gnat_tree)); static char *qualified_name PROTO((gnat_tree)); static char *get_external_name PROTO((gnat_tree)); /* Given GNAT_ENTITY, an entity in the incoming GNAT tree, return a GCC type corresponding to that entity. GNAT_ENTITY is assumed to refer to an Ada type. */ tree gnat_to_gnu_type (gnat_entity) gnat_tree gnat_entity; { tree gnu_decl; /* Convert the ada entity type into a GCC TYPE_DECL node. */ gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0); if (TREE_CODE (gnu_decl) != TYPE_DECL) abort (); return TREE_TYPE (gnu_decl); } /* These two variables are used to defer recursively expanding incomplete types while we are processing a record. */ static int defer_incomplete_level = 0; static struct incomplete { struct incomplete *next; tree access_type; gnat_tree full_type; } *defer_incomplete_list = 0; /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada entity, this routine returns the equivalent GCC tree for that entity (an ..._DECL node) and associates the ..._DECL node with the input GNAT defining identifier. If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its initial value (in GCC tree form). This is optional for variables. DEFINITION is nonzero if this call is intended for a definition. This is used for separate compilation where it necessary to know whether an external declaration or a definition should be created if the GCC equivalent was not created previously. The value of 1 is normally used for a non-zero DEFINITION, but a value of 2 is used in special circumstances, defined in the code. */ tree gnat_to_gnu_entity (gnat_entity, gnu_expr, definition) gnat_tree gnat_entity; tree gnu_expr; int definition; { char *entity_name; tree gnu_type; /* Contains the gnu XXXX_DECL tree node which is equivalent to the input GNAT tree. This node will be associated with the GNAT node by calling the save_gnu_tree routine at the end of the `switch' statement. */ tree gnu_decl = 0; /* Nonzero if we have already saved gnu_decl as a gnat association. */ int saved = 0; /* Nonzero if we were already in permanent allocation. */ int was_permanent = ! allocation_temporary_p (); /* Nonzero if we were in momentary allocation. */ int was_momentary; Entity_Kind kind = Ekind (gnat_entity); /* If this is entity 0, something went badly wrong. */ if (gnat_entity == 0) abort (); /* If we've already processed this entity, return what we got last time. If we are defining the node, we should not have already processed it. In that case, we will abort below when we try to save a new GCC tree for this object. We make an exception here for subprograms since we may have processed both the spec and body, depending on the circumstances. This is a bit of a kludge, but we are only using the kludge to disable an error check, so it's not too bad. We also need to handle the case of getting VOID_TYPE when a Full_Declaration exists. */ if ((! definition || kind == E_Function || kind == E_Procedure) && present_gnu_tree (gnat_entity)) { gnu_decl = get_gnu_tree (gnat_entity); if (TREE_CODE (gnu_decl) == TYPE_DECL && TREE_CODE (TREE_TYPE (gnu_decl)) == VOID_TYPE && IN (Ekind (gnat_entity), Incomplete_Kind) && Present (Full_Declaration (gnat_entity))) { gnu_decl = get_gnu_tree (Full_Declaration (gnat_entity)); save_gnu_tree (gnat_entity, NULL_TREE, 0); save_gnu_tree (gnat_entity, gnu_decl, 0); } return gnu_decl; } /* Get the name of the entity and set up the line number and filename of the original definition for use in any decl we make. */ entity_name = Get_Name_String (Chars (gnat_entity)); set_lineno (gnat_entity, 0); /* If we are not defining this node, it is external and must be permanently allocated. If we are not already in permanent allocation, go there now. */ if (! definition && ! was_permanent) { push_obstacks_nochange (); end_temporary_allocation (); } /* Make sure objects we allocate aren't in the momentary obstack. */ was_momentary = suspend_momentary (); switch (kind) { case E_Constant: /* If this is a use of a deferred constant, get its full declaration. */ if (! definition && Present (Full_Declaration (gnat_entity))) return gnat_to_gnu_entity (Full_Declaration (gnat_entity), gnu_expr, definition); /* If we have an external constant that we are not defining, get the expression that is was defined to represent. We may throw that expression away later if it is not a constant. */ if (! definition && Present (Expression (Parent (gnat_entity)))) gnu_expr = gnat_to_gnu (Expression (Parent (gnat_entity))); /* Ignore deferred constant definitions; they are processed fully in the front-end. For deferred constant references, get the full definition. */ if (definition && gnu_expr == 0) return error_mark_node; else if (! definition && IN (Ekind (gnat_entity), Incomplete_Kind) && Present (Full_Declaration (gnat_entity))) return gnat_to_gnu_entity (Full_Declaration (gnat_entity), NULL_TREE, 0); goto object; case E_Component: case E_Discriminant: /* if the variable is an inherited record component (in the case of extended record types) just return the inherited entity, which must be a FIELD_DECL. */ if (Present (Original_Record_Component (gnat_entity)) && Original_Record_Component (gnat_entity) != gnat_entity) { gnu_decl = gnat_to_gnu_entity (Original_Record_Component (gnat_entity), gnu_expr, definition); if (TREE_CODE (gnu_decl) != FIELD_DECL) abort (); break; } goto object; case E_Loop_Parameter: case E_Out_Parameter: case E_Exception: case E_Variable: /* Simple variables, loop variables, OUT parameters, and exceptions. */ object: { tree gnu_type = gnat_to_gnu_type (Etype (gnat_entity)); int used_by_ref = 0; int const_flag = kind == E_Constant; tree gnu_size = NULL_TREE; /* If we get here, it means we have not yet done anything with this entity. If we are not defining it here, it must be external, otherwise we should have defined it already. Also, reject objects whose types are unconstrained arrays or VOID. */ if ((! definition && ! Is_Public (gnat_entity)) || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE || TREE_CODE (gnu_type) == VOID_TYPE) abort (); /* If we are defining the object, see if it has a Size value and validate it if so. */ if (definition && Has_Size_Clause (gnat_entity)) { gnu_size = UI_To_gnu (Esize (gnat_entity), sizetype); /* A size is not permitted for variable-sized objects. */ if (TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST) { post_error ("SIZE not permitted for variabled-sized &", gnat_entity); gnu_size = 0; } /* The specified size must be at least as large as that of the type for non-integral types and the precision for integers. */ else if ((INTEGRAL_TYPE_P (gnu_type) && (TREE_INT_CST_HIGH (gnu_size) != 0 || (TREE_INT_CST_LOW (gnu_size) < TYPE_PRECISION (gnu_type)))) || INT_CST_LT (gnu_size, TYPE_SIZE (gnu_type))) { post_error ("& cannot fit in the specified size", gnat_entity); gnu_size = 0; } } /* If we are defining the object and it has an Address clause we must get the address expression from the saved GCC tree for the object. */ if (definition && Has_Address_Clause (gnat_entity)) { tree gnu_address = get_gnu_tree (gnat_entity); save_gnu_tree (gnat_entity, NULL_TREE, 0); if (gnu_size) { post_error ("both SIZE and ADDRESS specified for &", gnat_entity); gnu_size = 0; } gnu_type = build_pointer_type (gnu_type); gnu_address = convert (gnu_type, gnu_address); used_by_ref = 1; const_flag = ! Is_Public (gnat_entity); /* If we don't have an initializing expression for the underlying variable, the initializing expression for the pointer is the specified address. Otherwise, we have to make a COMPOUND_EXPR to assign both the address and the initial value. */ if (gnu_expr == 0) gnu_expr = gnu_address; else gnu_expr = build (COMPOUND_EXPR, gnu_type, build_binary_op (MODIFY_EXPR, NULL_TREE, build_unary_op (INDIRECT_REF, NULL_TREE, gnu_address), gnu_expr), gnu_address); } /* See if this is a renaming. If it is, see what we are renaming. If what we are renaming is a decl, just return that decl for us as well. Otherwise, make this into a constant pointer to the object we are to rename. An initializer is invalid here. */ if (Present (Renamed_Object (gnat_entity))) { if (gnu_expr) abort (); gnu_decl = gnat_to_gnu (Renamed_Object (gnat_entity)); if (TREE_CODE_CLASS (TREE_CODE (gnu_decl)) == 'd') break; const_flag = 1; gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_decl); gnu_type = build_pointer_type (gnu_type); used_by_ref = 1; } /* If we are at top level and this object is of variable size, make the actual type a hidden pointer to the real type and make the initializer be a memory allocation and initialization. */ if (global_bindings_p () && TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST) { gnu_type = build_pointer_type (gnu_type); gnu_expr = build_allocator (TREE_TYPE (gnu_type), gnu_expr, Etype (gnat_entity), gnu_type); used_by_ref = 1; } /* If this is a pointer and it does not have an initializing expression, initialize it to NULL. */ if ((TREE_CODE (gnu_type) == POINTER_TYPE || TYPE_FAT_POINTER_P (gnu_type)) && gnu_expr == 0) gnu_expr = integer_zero_node; if (gnu_expr) gnu_expr = convert (gnu_type, gnu_expr); gnu_decl = create_var_decl (entity_name, global_bindings_p () || ! definition ? get_external_name (gnat_entity) : NULL_PTR, gnu_type, gnu_expr, const_flag, Is_Public (gnat_entity), !definition, kind == E_Exception, Is_Volatile (gnat_entity)); DECL_BY_REF_P (gnu_decl) = used_by_ref; if (gnu_size) DECL_SIZE (gnu_decl) = gnu_size; } break; case E_Named_Integer: case E_Named_Real: /* These should not be present in any part of the tree we look at. */ abort (); case E_Void: /* Return a TYPE_DECL for "void" that we previously made. */ gnu_decl = void_type_decl_node; break; case E_Character_Type: /* Strictly speaking, character types are enumeral types, not integer types. However, for the predefined character type, we do not list all the literals. So if the literals are not specified, make this an unsigned type. Otherwise, handle as a normal enumeration type. */ if (No (Literals (Type_Definition (Parent (gnat_entity))))) { gnu_type = make_unsigned_type (UI_To_Int (Esize (gnat_entity))); break; } /* ... fall through ... */ case E_Boolean_Type: case E_Enumeration_Type: { /* Here we have a list of enumeral constants in First_Literal. We make a CONST_DECL for each and build into GNU_LITERAL_LIST the list to be places into TYPE_FIELDS. Each node in the list is a TREE_LIST node whose TREE_VALUE is the literal name and whose TREE_PURPOSE is the value of the literal. Esize contains the number of bits needed to represent the enumeral type, Type_Low_Bound also points to the first literal and Type_High_Bound points to the last literal. */ gnat_tree gnat_literal; tree gnu_literal_list = NULL_TREE; /* Make a signed type if the representation of the first literal is negative; otherwise make an unsigned type. */ if (tree_int_cst_lt (UI_To_gnu (Enumeration_Rep (First_Literal (gnat_entity)), integer_type_node), integer_zero_node)) gnu_type = make_signed_type (UI_To_Int (Esize (gnat_entity))); else gnu_type = make_unsigned_type (UI_To_Int (Esize (gnat_entity))); TREE_SET_CODE (gnu_type, ENUMERAL_TYPE); for (gnat_literal = First_Literal (gnat_entity); Present (gnat_literal); gnat_literal = Next_Literal (gnat_literal)) { tree gnu_value = UI_To_gnu (Enumeration_Rep (gnat_literal), gnu_type); char *name = Get_Name_String (Chars (gnat_literal)); tree gnu_literal = create_var_decl (name, 0, gnu_type, gnu_value, 1, 0, 0, 0, 0); save_gnu_tree (gnat_literal, gnu_literal, 0); /* ??? If the literals name is a character literal, don't add it to the fields since it will confuse debuggers. */ if (name[0] != '\'') gnu_literal_list = tree_cons (DECL_NAME (gnu_literal), DECL_INITIAL (gnu_literal), gnu_literal_list); } TYPE_FIELDS (gnu_type) = nreverse (gnu_literal_list); /* We have to be very careful here that we don't get an infinite recursion when we get the bounds of this type, since those bounds are objects of this type. So set up a temporary definition now and update the precise type later. */ gnu_decl = create_type_decl (entity_name, gnu_type); save_gnu_tree (gnat_entity, gnu_decl, 0); saved = 1; TYPE_MIN_VALUE (gnu_type) = gnat_to_gnu (Type_Low_Bound (gnat_entity)); TYPE_MAX_VALUE (gnu_type) = gnat_to_gnu (Type_High_Bound (gnat_entity)); /* If we have an enumeration table and we are defining this type, declare the enumeration table. */ if (definition && Present (Lit_Name_Table (gnat_entity))) gnat_to_gnu_entity (Lit_Name_Table (gnat_entity), create_enum_initializer (gnat_entity, gnat_to_gnu_type (Etype (Lit_Name_Table (gnat_entity)))), 1); } break; case E_Integer_Type: /* For integer types, just make a signed type the appropriate number of bits. */ if (Esize (gnat_entity) == 0) abort (); gnu_type = make_signed_type (UI_To_Int (Esize (gnat_entity))); break; case E_Modular_Type: /* For modular types, make the unsigned type of the proper number of bits and then set up the modulus, if required. */ { int esize; enum machine_mode mode; tree gnu_modulus; if (Esize (gnat_entity) == 0) abort (); /* Find the smallest mode at least ESIZE bits wide and make a class using that mode. */ esize = UI_To_Int (Esize (gnat_entity)); for (mode = GET_CLASS_NARROWEST_MODE (MODE_INT); GET_MODE_BITSIZE (mode) < esize; mode = GET_MODE_WIDER_MODE (mode)) ; gnu_type = make_unsigned_type (GET_MODE_BITSIZE (mode)); /* Get the modulus in this type. If it overflows, assume it is because it is equal to 2**Esize. Note that there is no overflow checking done on unsigned type, so we detect the overflow by looking for a modulus of zero, which is otherwise invalid. */ gnu_modulus = UI_To_gnu (Modulus (gnat_entity), gnu_type); if (! integer_zerop (gnu_modulus)) { TYPE_MODULAR_P (gnu_type) = 1; TYPE_MODULUS (gnu_type) = gnu_modulus; } } break; case E_Integer_Subtype: case E_Enumeration_Subtype: case E_Modular_Subtype: /* For integral subtypes, we make a new INTEGER_TYPE. Note that we do not want to call build_range_type since we would like each subtype node to be distinct. This will be important when memory aliasing is implemented. The TREE_TYPE field of the INTEGER_TYPE we make points to the parent type; this fact is used by the arithmetic conversion functions. */ gnu_type = make_node (INTEGER_TYPE); TREE_TYPE (gnu_type) = gnat_to_gnu_type (Etype (gnat_entity)); TYPE_PRECISION (gnu_type) = UI_To_Int (Esize (gnat_entity)); TYPE_MIN_VALUE (gnu_type) = elaborate_expression (Type_Low_Bound (gnat_entity), gnat_entity, "L", definition); TYPE_MAX_VALUE (gnu_type) = elaborate_expression (Type_High_Bound (gnat_entity), gnat_entity, "U", definition); /* This shold be an unsigned type if the lower bound is constant and non-negative; a signed type otherwise. */ TREE_UNSIGNED (gnu_type) = (TREE_CODE (TYPE_MIN_VALUE (gnu_type)) == INTEGER_CST && TREE_INT_CST_HIGH (TYPE_MIN_VALUE (gnu_type)) >= 0); layout_type (gnu_type); break; case E_Fixed_Type: case E_Float_Type: /* We handle both floating types and fixed types as floating-point types. */ if (Esize (gnat_entity) == 0) abort (); gnu_type = make_node (REAL_TYPE); TYPE_PRECISION (gnu_type) = UI_To_Int (Esize (gnat_entity)); layout_type (gnu_type); break; case E_Decimal_Type: abort (); case E_Fixed_Subtype: case E_Float_Subtype: case E_Decimal_Subtype: /* For each of these subtypes, just use the base type for now. */ gnu_type = gnat_to_gnu_type (Etype (gnat_entity)); break; case E_Exception_Type: /* This is just a character. */ gnu_type = char_type_node; break; /* Array and String Types and Subtypes Unconstrained array types are represented by E_Array_Type and constrained array types are represented by E_Array_Subtype. There are no actual objects of an unconstrained array type; all we have are pointers to that type. The following fields are defined on array types and subtypes: Component_Type Component type of the array. Number_Dimensions Number of dimensions (an int). First_Index Type of first index. */ case E_String_Type: case E_Array_Type: { tree gnu_template_fields = NULL_TREE; tree gnu_template_type = make_node (RECORD_TYPE); tree gnu_ptr_template = build_pointer_type (gnu_template_type); tree gnu_fat_type = make_node (RECORD_TYPE); int ndim = Number_Dimensions (gnat_entity); tree *gnu_index_types = (tree *) alloca (ndim * sizeof (tree *)); int index; gnat_tree gnat_ind_subtype; tree gnu_template_reference; tree tem; /* Build the fat pointer type. Use a "void *" object instead of a pointer to the array type since we don't have the array type yet (it will reference the fat pointer via the bounds). */ tem = chainon (chainon (NULL_TREE, create_field_decl ("p_array", ptr_void_type_node, gnu_fat_type, 0)), create_field_decl ("p_template", gnu_ptr_template, gnu_fat_type, 0)); finish_record_type (gnu_fat_type, tem); /* Build a reference to the template from a PLACEHOLDER_EXPR that is the fat pointer. This will be used to access the individual fields once we build them. */ gnu_template_reference = build_unary_op (INDIRECT_REF, gnu_template_type, build (COMPONENT_REF, gnu_ptr_template, build (PLACEHOLDER_EXPR, gnu_fat_type), TREE_CHAIN (TYPE_FIELDS (gnu_fat_type)))); /* Now create the GCC type for each index and add the fields for that index to the template. */ for (index = 0, gnat_ind_subtype = First_Index (gnat_entity); index < ndim; index++, gnat_ind_subtype = Next_Index (gnat_ind_subtype)) { char field_name[10]; tree gnu_ind_subtype = gnat_to_gnu_type (Etype (gnat_ind_subtype)); tree gnu_min_field, gnu_max_field, gnu_min, gnu_max; /* Make the FIELD_DECLs for the minimum and maximum of this type and then make extractions of that field from the template. */ sprintf (field_name, "LB%d", index); gnu_min_field = create_field_decl (field_name, gnu_ind_subtype, gnu_template_type, 0); field_name[0] = 'U'; gnu_max_field = create_field_decl (field_name, gnu_ind_subtype, gnu_template_type, 0); gnu_template_fields = chainon (chainon (gnu_template_fields, gnu_min_field), gnu_max_field); /* We can't use build_component_ref here since the template type isn't complete yet. */ gnu_min = build (COMPONENT_REF, gnu_ind_subtype, gnu_template_reference, gnu_min_field); gnu_max = build (COMPONENT_REF, gnu_ind_subtype, gnu_template_reference, gnu_max_field); /* Make a range type with the new ranges, but using the Ada subtype. Then we convert to sizetype and handle the superflat case. */ gnu_ind_subtype = build_range_type (gnu_ind_subtype, gnu_min, gnu_max); gnu_min = convert (sizetype, gnu_min); gnu_max = size_binop (MAX_EXPR, convert (sizetype, gnu_max), size_binop (MINUS_EXPR, gnu_min, size_int (1))); gnu_index_types[index] = build_index_2_type (gnu_min, gnu_max); TYPE_INDEX_TYPE (gnu_index_types[index]) = gnu_ind_subtype; } /* Install all the fields into the template. */ finish_record_type (gnu_template_type, gnu_template_fields); /* Now make the array of arrays and update the pointer to the array in the fat pointer. Note that it is the first field. */ tem = gnat_to_gnu_type (Component_Type (gnat_entity)); /* If the component type is a RECORD_TYPE that has a self-referential size, make a new RECORD_TYPE whose size is the maximum. */ if (TREE_CODE (tem) == RECORD_TYPE && TREE_CODE (TYPE_SIZE (tem)) != INTEGER_CST && contains_placeholder_p (TYPE_SIZE (tem))) { int moment = suspend_momentary (); push_obstacks (TYPE_OBSTACK (tem), TYPE_OBSTACK (tem)); tem = copy_node (tem); TYPE_SIZE (tem) = max_size (TYPE_SIZE (tem), 1); pop_obstacks (); resume_momentary (moment); } for (index = ndim - 1; index >= 0; index--) tem = build_array_type (tem, gnu_index_types[index]); TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem); TYPE_FAT_POINTER_P (gnu_fat_type) = 1; /* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the corresponding fat pointer. */ gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE); TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_fat_type; TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type) = gnu_type; } break; case E_String_Subtype: case E_Array_Subtype: /* This is the actual data type for array variables. Multidimensional arrays are implemented in the gnu tree as arrays of arrays. Note that for the moment arrays which have sparse enumeration subtypes as index components create sparse arrays, which is obviously space inefficient but so much easier to code for now. Also note that the subtype never refers to the unconstrained array type, which is somewhat at variance with Ada semantics. First check to see if this is simply a renaming of the array type. If so, the result is the array type. */ if (! Is_Constrained (gnat_entity)) gnu_type = gnat_to_gnu_type (Etype (gnat_entity)); else { int index; int array_dim = Number_Dimensions (gnat_entity); gnat_tree gnat_ind_subtype; tree *gnu_index_type = (tree *) alloca (array_dim * sizeof (tree *)); /* First create the gnu types for each index. */ for (index = 0, gnat_ind_subtype = First_Index (gnat_entity); index < array_dim; index++, gnat_ind_subtype = Next_Index (gnat_ind_subtype)) { tree gnu_index_subtype = gnat_to_gnu_type (Etype (gnat_ind_subtype)); tree gnu_min = convert (sizetype, TYPE_MIN_VALUE (gnu_index_subtype)); tree gnu_max = convert (sizetype, TYPE_MAX_VALUE (gnu_index_subtype)); gnu_index_type[index] = build_index_2_type (gnu_min, size_binop (MAX_EXPR, gnu_max, size_binop (MINUS_EXPR, gnu_min, size_int (1)))); /* If TYPE_INDEX_TYPE is already set, it must be the proper type. This could only happen if this node was reused via the type hashing mechanism in tree.c. Don't set the index type again in case we are now in a different obstack from that of the actual type. We don't worry about the slight memory leak here. */ if (TYPE_INDEX_TYPE (gnu_index_type[index]) == 0) TYPE_INDEX_TYPE (gnu_index_type[index]) = gnu_index_subtype; } /* Then flatten: create the array of arrays. */ gnu_type = gnat_to_gnu_type (Component_Type (gnat_entity)); /* If the component type is a RECORD_TYPE that has a self-referential size, make a new RECORD_TYPE whose size is the maximum. */ if (TREE_CODE (gnu_type) == RECORD_TYPE && TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST && contains_placeholder_p (TYPE_SIZE (gnu_type))) { int moment = suspend_momentary (); push_obstacks (TYPE_OBSTACK (gnu_type), TYPE_OBSTACK (gnu_type)); gnu_type = copy_node (gnu_type); TYPE_SIZE (gnu_type) = max_size (TYPE_SIZE (gnu_type), 1); pop_obstacks (); resume_momentary (moment); } for (index = array_dim - 1; index >= 0; index --) gnu_type = build_array_type (gnu_type, gnu_index_type[index]); } break; case E_Slice_Subtype: /* This is an abbreviated way of making an array subtype. See a-einfo.h for details. */ { tree gnu_comp_type = gnat_to_gnu_type (Component_Type (gnat_entity)); tree gnu_min = maybe_variable (gnat_to_gnu (Low_Bound (Slice_Range (gnat_entity)))); tree gnu_max = maybe_variable (gnat_to_gnu (High_Bound (Slice_Range (gnat_entity)))); tree gnu_range_type = build_range_type (TREE_TYPE (gnu_min), gnu_min, gnu_max); tree gnu_index_min = convert (sizetype, gnu_min); tree gnu_index_max = size_binop (MAX_EXPR, convert (sizetype, gnu_max), size_binop (MINUS_EXPR, gnu_min, size_int (1))); tree gnu_index_type = build_index_2_type (gnu_index_min, gnu_index_max); /* If TYPE_INDEX_TYPE is already set, it must be the proper type. This could only happen if this node was reused via the type hashing mechanism in tree.c. Don't set the index type again in case we are now in a different obstack from that of the actual type. We don't worry about the slight memory leak here. */ if (TYPE_INDEX_TYPE (gnu_index_type) == 0) TYPE_INDEX_TYPE (gnu_index_type) = gnu_range_type; /* If the component type is a RECORD_TYPE that has a self-referential size, make a new RECORD_TYPE whose size is the maximum. */ if (TREE_CODE (gnu_comp_type) == RECORD_TYPE && TREE_CODE (TYPE_SIZE (gnu_comp_type)) != INTEGER_CST && contains_placeholder_p (TYPE_SIZE (gnu_comp_type))) { int moment = suspend_momentary (); push_obstacks (TYPE_OBSTACK (gnu_comp_type), TYPE_OBSTACK (gnu_comp_type)); gnu_type = copy_node (gnu_comp_type); TYPE_SIZE (gnu_comp_type) = max_size (TYPE_SIZE (gnu_comp_type), 1); pop_obstacks (); resume_momentary (moment); } gnu_type = build_array_type (gnu_comp_type, gnu_index_type); } break; case E_String_Literal_Subtype: /* Create the type for a string literal. */ { tree gnu_string_type = gnat_to_gnu_type (Etype (gnat_entity)); tree gnu_string_array_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type)))); tree gnu_string_index_type = TREE_TYPE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_string_array_type))); tree gnu_upper_bound = UI_To_gnu (String_Literal_Length (gnat_entity), gnu_string_index_type); tree gnu_range_type = build_range_type (gnu_string_index_type, convert (gnu_string_index_type, integer_one_node), gnu_upper_bound); tree gnu_index_type = build_index_2_type (convert (sizetype, TYPE_MIN_VALUE (gnu_range_type)), convert (sizetype, TYPE_MAX_VALUE (gnu_range_type))); if (TYPE_INDEX_TYPE (gnu_index_type) == 0) TYPE_INDEX_TYPE (gnu_index_type) = gnu_range_type; gnu_type = build_array_type (gnat_to_gnu_type (Component_Type (gnat_entity)), gnu_index_type); } break; case E_Enum_Table_Type: /* Create the type for an enumeration literal table. */ { tree gnu_high_bound = gnat_to_gnu (Table_High_Bound (gnat_entity)); tree gnu_range_type = build_range_type (TREE_TYPE (gnu_high_bound), convert (TREE_TYPE (gnu_high_bound), integer_zero_node), gnu_high_bound); tree gnu_index_type = build_index_2_type (convert (sizetype, TYPE_MIN_VALUE (gnu_range_type)), convert (sizetype, TYPE_MAX_VALUE (gnu_range_type))); if (TYPE_INDEX_TYPE (gnu_index_type) == 0) TYPE_INDEX_TYPE (gnu_index_type) = gnu_range_type; gnu_type = build_array_type (gnat_to_gnu_type (Component_Type (gnat_entity)), gnu_index_type); } break; /* Record Types and Subtypes The following fields are defined on record types: Has_Discriminants True if the record has discriminants First_Discriminant Points to head of list of discriminants First_Entity Points to head of list of fields Is_Tagged_Type True if the record is tagged Implementation of Ada records and discriminated records: A record type definition is transformed into the equivalent of a C struct definition. The fields that are the discriminants which are found in the Full_Type_Declaration node and the elements of the Component_List found in the Record_Type_Definition node. The Component_List can be a recursive structure since each Variant of the Variant_Part of the Component_List has a Component_List. Processing of a record type definition comprises starting the list of field declarations here from the discriminants and the calling the function components_to_record to add the rest of the fields from the component list and return the gnu type node. The function components_to_record will call itself recursively as it traverses the tree. */ case E_Record_Type: { gnat_tree gnat_impl_type; gnat_tree full_definition = Parent (gnat_entity); gnat_tree record_definition = Type_Definition (full_definition); gnat_tree gnat_field; tree gnu_field; char *field_id; tree gnu_field_type; tree gnu_field_list = NULL_TREE; int packed = Is_Packed (gnat_entity); /* If this is a record extension, go a level further to find the record definition */ if (Nkind (record_definition) == N_Derived_Type_Definition) record_definition = Record_Extension_Part (record_definition); /* Make a node for the record. If we are not defining the record, suppress expanding incomplete types and save the node as the type for GNAT_ENTITY.. */ gnu_type = make_node (RECORD_TYPE); if (! definition) { defer_incomplete_level++; gnu_decl = create_type_decl (entity_name, gnu_type); save_gnu_tree (gnat_entity, gnu_decl, 0); saved = 1; } /* Add the fields for the discriminants into the record. */ if (Has_Discriminants (gnat_entity)) { for (gnat_field = First_Discriminant (gnat_entity); Present (gnat_field); gnat_field = Next_Discriminant (gnat_field)) { field_id = Get_Name_String (Chars (gnat_field)); gnu_field_type = gnat_to_gnu_type (Etype (gnat_field)); gnu_field = create_field_decl (field_id, gnu_field_type, gnu_type, packed); DECL_DISCRIMINANT_P (gnu_field) = 1; /* Associate the FIELD_DECL node just created with the corresponding gnat defining identifier. */ save_gnu_tree (gnat_field, gnu_field, 0); gnu_field_list = chainon (gnu_field, gnu_field_list); } } /* Process any implicit type definitions used within this record. They may depend on the discriminants, and the following components may depend on them. */ if (definition && Present (Implicit_Types (record_definition))) for (gnat_impl_type = First (Implicit_Types (record_definition)); gnat_impl_type; gnat_impl_type = Next (gnat_impl_type)) gnat_to_code (gnat_impl_type); /* Add the listed fields into the record and finish up. */ components_to_record (gnu_type, Component_List (record_definition), gnu_field_list, packed); /* If it is a tagged record force the type to BLKmode to insure that these objects will always be placed in memory. ??? This is probably wrong and we need to understand precisely how we are using these types. */ if (Is_Tagged_Type (gnat_entity)) TYPE_MODE (gnu_type) = BLKmode; /* If we are not defining this record, re-enable processing of incomplete types. If there were no other disables and we have some to process, do so. */ if (! definition && --defer_incomplete_level == 0 && defer_incomplete_list != 0) { struct incomplete *p = defer_incomplete_list; defer_incomplete_list = 0; for (; p; p = p->next) { TREE_TYPE (p->access_type) = gnat_to_gnu_type (p->full_type); TYPE_POINTER_TO (TREE_TYPE (p->access_type)) = p->access_type; } } } break; case E_Record_Subtype: /* Create the gnu subtype from the gnu type by calling substitute_in_type for each discriminant expresion. This function returns a new tree from the type tree by substituting the discriminant expression for the subtype for the occurences of the discriminant in the base type definition. */ { gnat_tree gnat_discriminant_expr; gnat_tree gnat_field; gnu_type = TREE_TYPE ( gnat_to_gnu_entity (Base_Type (gnat_entity), NULL_TREE, 0)); if (Present (Discriminant_Constraint (gnat_entity))) for (gnat_field = First_Discriminant (Base_Type (gnat_entity)), gnat_discriminant_expr = First_Elmt (Discriminant_Constraint (gnat_entity)); Present (gnat_field); gnat_field = Next_Discriminant (gnat_field), gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr)) gnu_type = gnat_substitute_in_type (gnu_type, get_gnu_tree (gnat_field), elaborate_expression (Id_Of (gnat_discriminant_expr), gnat_entity, Get_Name_String (Chars (gnat_field)), definition)); } break; case E_Access_Type: case E_Anonymous_Access_Type: case E_Access_Subprogram_Type: case E_Access_Subtype: case E_Allocator_Type: case E_General_Access_Type: /* Get the type of the thing we are to point to and build a pointer to it. */ gnu_type = build_pointer_type (gnat_to_gnu_type (Directly_Designated_Type (gnat_entity))); /* If this is a reference (not a definition) to an incomplete type, save our current definition, evaluate the actual type, and replace the tentative type we made with the actual one. If we are to defer actually looking up the actual type, make an entry in the deferred list. */ if (! definition && (IN (Ekind (Directly_Designated_Type (gnat_entity)), Incomplete_Kind))) { /* It is possible that the above call to gnat_to_gnu_type resolved our type. If so, just return it. */ if (present_gnu_tree (gnat_entity)) return get_gnu_tree (gnat_entity); /* Otherwise, make our type and do the processing described above. */ gnu_decl = create_type_decl (entity_name, gnu_type); save_gnu_tree (gnat_entity, gnu_decl, 0); saved = 1; if (defer_incomplete_level == 0) { TREE_TYPE (gnu_type) = gnat_to_gnu_type (Full_Declaration (Directly_Designated_Type (gnat_entity))); TYPE_POINTER_TO (TREE_TYPE (gnu_type)) = gnu_type; } else { struct incomplete *p = (struct incomplete *) oballoc (sizeof (struct incomplete)); p->access_type = gnu_type; p->full_type = Full_Declaration (Directly_Designated_Type (gnat_entity)); p->next = defer_incomplete_list; defer_incomplete_list = p; } } break; /* Subprogram Entities The following access functions are defined for subprograms (functions or procedures): First_Formal The first formal parameter. Is_Imported Indicates that the subprogram has appeared in an INTERFACE or IMPORT pragma. For now we assume that the external language is C. Is_Inlined True if the subprogram is to be inlined. In addition for function subprograms we have: Etype Return type of the function. Each parameter is first checked by calling pass_by_ref on its type to determine if it is passed by reference. For parameters which are copied in, if they are Ada IN OUT or OUT parameters, their return value becomes part of a record which becomes the return type of the function (C function - note that this applies only to Ada procedures so there is no Ada return type). Additional code to store back the parameters will be generated on the caller side. This transformation is done here, not in the front-end. The intended result of the transformation can be seen from the equivalent source rewritings that follow: struct temp {int a,b}; procedure P (A,B: IN OUT ...) is temp P (int A,B) { .. .. end P; return {A,B}; } procedure call { temp t; P(X,Y); t = P(X,Y); X = t.a , Y = t.b; } For subprogram types we need to perform mainly the same conversions to GCC form that are needed for procedures and function declarations. The only difference is that at the end, we make a type declaration instead of a function declaration. */ case E_Subprogram_Type: case E_Function: case E_Procedure: { /* The first GCC parameter declaration (a PARM_DECL node). The PARM_DECL nodes are chained through the TREE_CHAIN field, so this actually is the head of this parameter list. */ tree gnu_param_list = NULL_TREE; /* The type returned by a function. If the subprogram is a procedure this type should be void_type_node. */ tree gnu_return_type = void_type_node; /* List of fields in return type of procedure with copy in copy out parameters. */ tree gnu_field_list = NULL_TREE; /* Non-null for subprograms containing parameters passed by copy in copy out (Ada IN OUT or OUT parameters not passed by reference), in which case it is the list of nodes used to specify the values of the in out/out parameters that are returned as a record upon procedure return. The TREE_PURPOSE of an element of this list is a field of the record and the TREE_VALUE is the PARM_DECL corresponding to that field. This list will be saved in the TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */ tree gnu_return_list = NULL_TREE; gnat_tree gnat_param; int inline_flag = Is_Inlined (gnat_entity); int public_flag = Is_Public (gnat_entity); int extern_flag = ((Is_Public (gnat_entity) && !definition) || Is_Imported (gnat_entity)); int pure_flag = Is_Pure (gnat_entity); int returns_unconstrained = 0; char *ext_name = NULL; int copy_in_copy_out_flag; int has_copy_in_out = 0; /* If the subprogram has an alias, it is probably inherited, so we can use the original one */ if (Present (Alias (gnat_entity))) { gnu_decl = gnat_to_gnu_entity (Alias (gnat_entity), gnu_expr, definition); break; } if (kind == E_Function || kind == E_Subprogram_Type) gnu_return_type = gnat_to_gnu_type (Etype (gnat_entity)); /* If we are supposed to return an unconstrained array, actually return a fat pointer and make a note of that. Return a pointer to an unconstrained record of variable size. */ if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE) { gnu_return_type = TREE_TYPE (gnu_return_type); returns_unconstrained = 1; } else if (TREE_CODE (TYPE_SIZE (gnu_return_type)) != INTEGER_CST && contains_placeholder_p (TYPE_SIZE (gnu_return_type))) { gnu_return_type = build_pointer_type (gnu_return_type); returns_unconstrained = 1; } /* Look at all our parameters and get the type of each. While doing this, build a copy-out structure if we need one. */ for (gnat_param = First_Formal (gnat_entity); Present (gnat_param); gnat_param = Next_Formal (gnat_param)) { char *param_name = Get_Name_String (Chars (gnat_param)); tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param)); tree gnu_param, gnu_field; int by_ref_p = 0; if (pass_by_ref (gnu_param_type)) { /* All parameters are passed by value by GCC. So to pass a parameter by reference we need to pass a pointer to it. */ gnu_param_type = build_pointer_type (gnu_param_type); copy_in_copy_out_flag = 0; by_ref_p = 1; } else copy_in_copy_out_flag = (Ekind (gnat_param) != E_In_Parameter); /* If this is an OUT parameter that isn't passed by reference and isn't a pointer, we don't make a PARM_DECL for it. Instead, it will be a VAR_DECL created when we process the procedure. */ if (Ekind (gnat_param) == E_Out_Parameter && ! by_ref_p && TREE_CODE (gnu_param_type) != POINTER_TYPE) gnu_param = 0; else { gnu_param = create_param_decl (param_name, gnu_param_type); DECL_BY_REF_P (gnu_param) = by_ref_p; save_gnu_tree (gnat_param, gnu_param, 0); gnu_param_list = chainon (gnu_param, gnu_param_list); } if (copy_in_copy_out_flag) { if (! has_copy_in_out) { if (TREE_CODE (gnu_return_type) != VOID_TYPE) abort (); gnu_return_type = make_node (RECORD_TYPE); has_copy_in_out = 1; } gnu_field = create_field_decl (param_name, gnu_param_type, gnu_return_type, 0); gnu_field_list = chainon (gnu_field, gnu_field_list); gnu_return_list = tree_cons (gnu_field, gnu_param, gnu_return_list); } } if (gnu_field_list != 0) finish_record_type (gnu_return_type, nreverse (gnu_field_list)); /* If we have a CICO list but it has only one entry, we convert this function into a function that simply returns that one object. */ if (list_length (gnu_return_list) == 1) gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_return_list)); /* Both lists ware built in reverse. */ gnu_param_list = nreverse (gnu_param_list); gnu_return_list = nreverse (gnu_return_list); gnu_type = create_subprog_type (gnu_return_type, gnu_param_list, gnu_return_list); TYPE_RETURNS_UNCONSTRAINED_P (gnu_type) = returns_unconstrained; /* Top-level or external functions need to have an assembler name. This is passed to create_subprog_decl through the ext_name argument. For Pragma Interface subprograms with no Pragma Interface_Name, the simple name already in entity_name is correct, and this is what is gotten when ext_name is NULL. If Interface_Name is specified, then the name is extracted from the N_String_Literal node containing the string specified in the Pragma. If there is no Pragma Interface, then the Ada fully qualified name (modified for overloading) is created by get_external_name. */ if (Present (Interface_Name (gnat_entity))) { String_Id gnat_string = Strval (Interface_Name (gnat_entity)); int length = String_Length (gnat_string); int i; ext_name = (char *) alloca (length + 1); for (i = 0; i < length; i++) ext_name[i] = Get_String_Char (gnat_string, i + 1); ext_name[i] = 0; } else if (Is_Imported (gnat_entity)) ; else if (global_bindings_p () || ! definition) ext_name = get_external_name (gnat_entity); /* If our name is that of an operator, and we don't have an external name, make an external name to be the converted name of the operator. Note that when we have an external name, get_external_name has already done this conversion. */ if (entity_name[0] == '"' && ext_name == 0) ext_name = get_operator_name (entity_name); if (kind == E_Subprogram_Type) gnu_decl = create_type_decl (entity_name, gnu_type); else gnu_decl = create_subprog_decl (entity_name, ext_name, gnu_type, gnu_param_list, inline_flag, public_flag, extern_flag, pure_flag); } break; case E_Incomplete_Type: case E_Private_Type: case E_Limited_Private_Type: case E_Limited_Type: /* If we are not defining this type, go directly to the full declaration. */ if (! definition) return gnat_to_gnu_entity (Full_Declaration (gnat_entity), NULL_TREE, 0); /* For incomplete types, make a dummy VOID_TYPE entry which will be replaced later. */ gnu_type = make_node (VOID_TYPE); /* Save this type as the full declaration's type so we can do any needed updates when we see it. */ if (Present (Full_Declaration (gnat_entity))) { gnu_decl = create_type_decl (entity_name, gnu_type); save_gnu_tree (Full_Declaration (gnat_entity), gnu_decl, 0); } break; case E_Class_Type: /* We consider a Class type as the Root type of the Class. This is a simple way to implement view-conversion. */ gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity), gnu_expr, 0); break; case E_Class_Subtype: /* a Class Subtype is a Class type with a particular size (it is used to allocate class-wide object as a copy of another object). The front-end provides a record equivalent type for it in field Equivalent_Type */ gnu_decl = gnat_to_gnu_entity (Equivalent_Type (gnat_entity), gnu_expr, 0); break; case E_Task_Type: case E_Task_Subtype: gnu_type = gnat_to_gnu_type (Task_Value_Type (gnat_entity)); break; case E_Protected_Type: abort (); case E_Label: gnu_decl = create_label_decl (entity_name); break; case E_Block: case E_Loop: /* Nothing at all to do here, so just return an ERROR_MARK and claim we've already saved it, so we don't try to. */ gnu_decl = error_mark_node; saved = 1; break; default: abort (); } if (gnu_decl == 0 && IN (kind, Type_Kind)) gnu_decl = create_type_decl (entity_name, gnu_type); /* If we haven't already, associate the ..._DECL node that we just made with the input GNAT entity node. */ if (! saved) save_gnu_tree (gnat_entity, gnu_decl, 0); /* Restore our previous allocation, if not previously permanent and we changed it. */ if (! definition && ! was_permanent) pop_obstacks (); resume_momentary (was_momentary); return gnu_decl; } /* Given GNAT_ENTITY, elaborate all expressions that are required to be elaborated at the point of its definition, but do nothing else. */ void elaborate_entity (gnat_entity) gnat_tree gnat_entity; { switch (Ekind (gnat_entity)) { case E_Integer_Subtype: case E_Modular_Subtype: case E_Enumeration_Subtype: /* We have to elaborate the expressions for the low and high bounds unless the expression is a discriminant. */ if (Nkind (Type_Low_Bound (gnat_entity)) != N_Identifier || Ekind (Entity (Type_Low_Bound (gnat_entity))) != E_Discriminant) elaborate_expression (Type_Low_Bound (gnat_entity), gnat_entity, "L", 1); if (Nkind (Type_High_Bound (gnat_entity)) != N_Identifier || Ekind (Entity (Type_High_Bound (gnat_entity))) != E_Discriminant) elaborate_expression (Type_High_Bound (gnat_entity), gnat_entity, "U", 1); break; case E_Record_Type: { gnat_tree full_definition = Parent (gnat_entity); gnat_tree record_definition = Type_Definition (full_definition); gnat_tree gnat_impl_type; /* If this is a record extension, go a level further to find the record definition */ if (Nkind (record_definition) == N_Derived_Type_Definition) record_definition = Record_Extension_Part (record_definition); if (Present (Implicit_Types (record_definition))) for (gnat_impl_type = First (Implicit_Types (record_definition)); gnat_impl_type; gnat_impl_type = Next (gnat_impl_type)) elaborate_entity (gnat_impl_type); } break; case E_Record_Subtype: if (Present (Discriminant_Constraint (gnat_entity))) { gnat_tree gnat_discriminant_expr; gnat_tree gnat_field; for (gnat_field = First_Discriminant (Base_Type (gnat_entity)), gnat_discriminant_expr = First_Elmt (Discriminant_Constraint (gnat_entity)); Present (gnat_field); gnat_field = Next_Discriminant (gnat_field), gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr)) elaborate_expression (Id_Of (gnat_discriminant_expr), gnat_entity, Get_Name_String (gnat_field), 1); } break; } } /* EXP may be a FIELD_DECL. If so, make the appropriate COMPONENT_REF involving a PLACEHOLDER_EXPR. This function must be called whenever we have something that is allowed to be a discriminant. */ static tree maybe_placeholder (exp) tree exp; { if (TREE_CODE (exp) == FIELD_DECL) return build (COMPONENT_REF, TREE_TYPE (exp), build (PLACEHOLDER_EXPR, DECL_CONTEXT (exp)), exp); return exp; } /* Called when we need to protect a variable object using a save_expr. */ tree maybe_variable (operand) tree operand; { if (TREE_CODE (operand) == INTEGER_CST) return operand; else if (TREE_CODE (operand) == UNCONSTRAINED_ARRAY_REF) return build1 (UNCONSTRAINED_ARRAY_REF, TREE_TYPE (operand), variable_size (TREE_OPERAND (operand, 0))); else return variable_size (operand); } /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a type definition (either a bound or a discriminant value) for GNAT_ENTITY, return the GCC tree to use for that expression. NAME is the qualification to use if an external name is appropriate and DEFINITION is nonzero if this is a definition of GNAT_ENTITY. */ static tree elaborate_expression (gnat_expr, gnat_entity, name, definition) gnat_tree gnat_expr; gnat_tree gnat_entity; char *name; int definition; { tree gnu_expr; /* If we already elaborated this expression (e.g., it was involved in the definition of a private type), use the old value. */ if (present_gnu_tree (gnat_expr)) return get_gnu_tree (gnat_expr); /* Otherwise, convert this tree to its GCC equivalant, handling any references to a discriminant. */ gnu_expr = maybe_placeholder (gnat_to_gnu (gnat_expr)); /* If this entity is defined at top level and a bound or discriminant value isn't a constant or a reference to a discriminant, replace the bound by a variable that will be initialized to contain the bound when the package containing the definition is elaborated. Note that we rely here on the fact that an expression cannot contain both the discriminant and some other variable. */ if ((Is_Public (gnat_entity) || global_bindings_p ()) && ! TREE_CONSTANT (gnu_expr) && ! contains_placeholder_p (gnu_expr)) gnu_expr = create_var_decl (create_concat_name (gnat_entity, name), NULL_PTR, TREE_TYPE (gnu_expr), gnu_expr, 0, Is_Public (gnat_entity), ! definition, 0, 0); else gnu_expr = maybe_variable (gnu_expr); /* Save the expression in case we try to elaborate this entity again. Since this is not a DECL, don't check it. */ save_gnu_tree (gnat_expr, gnu_expr, 1); return gnu_expr; } /* Given a GNU tree and a GNAT list of choices, generate an expression to test the value passed against the list of choices. */ tree choices_to_gnu (operand, choices) tree operand; gnat_tree choices; { gnat_tree choice; tree result = integer_zero_node; tree this_test, low, high; for (choice = First (choices); Present (choice); choice = Next (choice)) { switch (Nkind (choice)) { case N_Range: low = gnat_to_gnu (Low_Bound (choice)); high = gnat_to_gnu (High_Bound (choice)); /* There's no good type to use here, so we might as well use integer_type_node. */ this_test = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node, build_binary_op (GE_EXPR, integer_type_node, operand, low), build_binary_op (LE_EXPR, integer_type_node, operand, high)); break; case N_Identifier: /* This represents either a subtype range or an enumeration literal. Ekind says which. If an enumeration literal, fall through to the next case. */ if (Ekind (Entity (choice)) != E_Enumeration_Literal) { tree type = gnat_to_gnu_type (Entity (choice)); low = TYPE_MIN_VALUE (type); high = TYPE_MAX_VALUE (type); this_test = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node, build_binary_op (GE_EXPR, integer_type_node, operand, low), build_binary_op (LE_EXPR, integer_type_node, operand, high)); break; } /* ... fall through ... */ case N_Character_Literal: case N_Integer_Literal: this_test = build_binary_op (EQ_EXPR, integer_type_node, operand, gnat_to_gnu (choice)); break; case N_Others_Choice: this_test = integer_one_node; break; default: abort (); } result = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, result, this_test); } return result; } /* Return a GCC tree for a record type given a GNAT Component_List and a chain of GCC trees for fields that are in the record and have already been processed. When called from gnat_to_gnu_entity during the processing of a record type definition, the GCC nodes for the discriminants will be on the chain. The other calls to this function are recursive calls from itself for the Component_List of a variant and the chain is empty. PACKED is nonzero if this field is for a record with "pragma pack". The processing of the component list fills in the chain with all of the fields of the record and then the record type is created. */ static void components_to_record (record_type, component_list, gnu_field_list, packed) tree record_type; gnat_tree component_list; tree gnu_field_list; { gnat_tree component_decl; gnat_tree gnat_field; gnat_tree variant_part; /* For each variable within each component declaration create a GCC field and add it to the list. */ if (Present (Component_Declarations (component_list))) for (component_decl = First (Component_Declarations (component_list)); Present (component_decl); component_decl = Next (component_decl)) { gnat_tree gnat_field = Defining_Identifier (component_decl); char *field_id = Get_Name_String (Chars (gnat_field)); tree gnu_field_type = gnat_to_gnu_type (Etype (gnat_field)); tree gnu_field = create_field_decl (field_id, gnu_field_type, record_type, packed); /* If this is the _Parent field, we have two things to do. First, we put the first before any discriminants, instead of after them as is the case for all other fields. Second, we check for the case where the field is a self-referential type. If it is, it will be referencing discriminants that appear later in the record and hence depend on its size. In that case, go back to the base type of the field and replace all discriminants with a reference to the parent within RECORD_TYPE. */ if (Chars (gnat_field) == Name_uParent) { DECL_PARENT_P (gnu_field) = 1; gnu_field_list = chainon (gnu_field_list, gnu_field); if (! TREE_CONSTANT (TYPE_SIZE (gnu_field_type)) && contains_placeholder_p (TYPE_SIZE (gnu_field_type))) { gnat_tree gnat_base_type = Base_Type (Etype (gnat_field)); tree gnu_new_type = gnat_to_gnu_type (gnat_base_type); tree gnu_this_parent = build (COMPONENT_REF, NULL_TREE, build (PLACEHOLDER_EXPR, record_type), gnu_field); gnat_tree gnat_discrim; for (gnat_discrim = First_Discriminant (gnat_base_type); Present (gnat_discrim); gnat_discrim = Next_Discriminant (gnat_discrim)) { tree gnu_discrim = get_gnu_tree (gnat_discrim); gnu_new_type = substitute_in_type (gnu_new_type, gnu_discrim, build (COMPONENT_REF, TREE_TYPE (gnu_discrim), gnu_this_parent, gnu_discrim)); } /* Save the old type of the parent for when we make a subtype of this record type. Then set the new typoe for the field. */ TYPE_PARENT_SUBTYPE (record_type) = TREE_TYPE (gnu_field); TREE_TYPE (gnu_field) = TREE_TYPE (gnu_this_parent) = gnu_new_type; } } else gnu_field_list = chainon (gnu_field, gnu_field_list); save_gnu_tree (gnat_field, gnu_field, 0); } /* At the end of the component list there may be a variant part. We create a QUAL_UNION_TYPE for it since the variants are mutually exclusive and should go in the same memory. To do this we need to treat each variant as a record whose elements are created from the component list for the variant. So here we create the records from the lists for the variants and put them all into the QUAL_UNION_TYPE. */ variant_part = Variant_Part (component_list); if (Present (variant_part)) { tree gnu_discriminant = maybe_placeholder (gnat_to_gnu (Name (variant_part))); gnat_tree variant; tree gnu_field; tree gnu_union_type = make_node (QUAL_UNION_TYPE); tree gnu_union_field; tree gnu_variant_list = NULL_TREE; for (variant = First (Variants (variant_part)); Present (variant); variant = Next (variant)) { tree gnu_variant_type = make_node (RECORD_TYPE); components_to_record (gnu_variant_type, Component_List (variant), NULL_TREE, packed); gnu_field = create_field_decl (NULL, gnu_variant_type, gnu_union_type, packed); /* The last choice should always be "Others". */ DECL_QUALIFIER (gnu_field) = (Present (Next (variant)) ? choices_to_gnu (gnu_discriminant, Discrete_Choices (variant)) : integer_one_node); gnu_variant_list = chainon (gnu_field, gnu_variant_list); } finish_record_type (gnu_union_type, nreverse (gnu_variant_list)); gnu_union_field = create_field_decl (NULL, gnu_union_type, record_type, packed); gnu_field_list = chainon (gnu_union_field, gnu_field_list); } finish_record_type (record_type, nreverse (gnu_field_list)); } /* Create a CONSTRUCTOR for the enumeration literal table of GNAT_ENUM_TYPE. The GCC type of the literal table is GNU_TABLE_TYPE. */ static tree create_enum_initializer (gnat_enum_type, gnu_table_type) gnat_tree gnat_enum_type; tree gnu_table_type; { tree gnu_a_string_type = TREE_TYPE (gnu_table_type); tree gnu_char_type = TREE_TYPE (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_a_string_type)))); tree gnu_char_domain_type = TYPE_DOMAIN (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_a_string_type)))); tree gnu_size_1 = size_int (1); tree gnu_list = NULL_TREE; gnat_tree gnat_literal; /* Make a STRING_CST for each literal and add it to the CONSTRUCTOR. */ for (gnat_literal = First_Literal (gnat_enum_type); Present (gnat_literal); gnat_literal = Next_Literal (gnat_literal)) { char *name = Get_Name_String (Chars (gnat_literal)); int length = strlen (name); tree gnu_lit_range = build_range_type (gnu_char_domain_type, convert (gnu_char_domain_type, integer_one_node), convert (gnu_char_domain_type, build_int_2 (length, 0))); tree gnu_lit_index = build_index_2_type (convert (sizetype, TYPE_MIN_VALUE (gnu_lit_range)), convert (sizetype, TYPE_MAX_VALUE (gnu_lit_range))); tree gnu_lit_type = build_array_type (gnu_char_type, gnu_lit_index); tree gnu_literal = build_string (length, name); if (TYPE_INDEX_TYPE (gnu_lit_index) == 0) TYPE_INDEX_TYPE (gnu_lit_index) = gnu_lit_range; TREE_TYPE (gnu_literal) = gnu_lit_type; gnu_list = tree_cons (NULL_TREE, convert (gnu_a_string_type, build_unary_op (ADDR_EXPR, NULL_TREE, gnu_literal)), gnu_list); } return build_constructor (gnu_table_type, nreverse (gnu_list)); } /* Given a type T, a FIELD_DECL F, and a replacement value R, return a new type with all size expressions that contain F updated by replacing F with R. This is identical to GCC's substitute_in_type except that it knows about TYPE_INDEX_TYPE. */ tree gnat_substitute_in_type (t, f, r) tree t, f, r; { switch (TREE_CODE (t)) { case POINTER_TYPE: case VOID_TYPE: return t; case INTEGER_TYPE: case ENUMERAL_TYPE: case BOOLEAN_TYPE: case CHAR_TYPE: if ((TREE_CODE (TYPE_MIN_VALUE (t)) != INTEGER_CST && contains_placeholder_p (TYPE_MIN_VALUE (t))) || (TREE_CODE (TYPE_MAX_VALUE (t)) != INTEGER_CST && contains_placeholder_p (TYPE_MAX_VALUE (t)))) { tree new; new = build_range_type (t, substitute_in_expr (TYPE_MIN_VALUE (t), f, r), substitute_in_expr (TYPE_MAX_VALUE (t), f, r)); if (TYPE_INDEX_TYPE (t)) TYPE_INDEX_TYPE (new) = gnat_substitute_in_type (TYPE_INDEX_TYPE (t), f, r); return new; } return t; case REAL_TYPE: if ((TREE_CODE (TYPE_MIN_VALUE (t)) != INTEGER_CST && contains_placeholder_p (TYPE_MIN_VALUE (t))) || (TREE_CODE (TYPE_MAX_VALUE (t)) != INTEGER_CST && contains_placeholder_p (TYPE_MAX_VALUE (t)))) { t = build_type_copy (t); TYPE_MIN_VALUE (t) = substitute_in_expr (TYPE_MIN_VALUE (t), f, r); TYPE_MAX_VALUE (t) = substitute_in_expr (TYPE_MAX_VALUE (t), f, r); } return t; case COMPLEX_TYPE: return build_complex_type (gnat_substitute_in_type (TREE_TYPE (t), f, r)); case OFFSET_TYPE: case METHOD_TYPE: case REFERENCE_TYPE: case FILE_TYPE: case SET_TYPE: case STRING_TYPE: case FUNCTION_TYPE: case LANG_TYPE: /* Don't know how to do these yet. */ abort (); case ARRAY_TYPE: t = build_array_type (gnat_substitute_in_type (TREE_TYPE (t), f, r), gnat_substitute_in_type (TYPE_DOMAIN (t), f, r)); TYPE_SIZE (t) = 0; layout_type (t); return t; case RECORD_TYPE: case UNION_TYPE: case QUAL_UNION_TYPE: { tree new = copy_node (t); tree field; tree last_field = 0; tree parent_subtype = 0; /* If we have a parent subtype, substitute into that. */ if (TYPE_PARENT_SUBTYPE (t)) parent_subtype = gnat_substitute_in_type (TYPE_PARENT_SUBTYPE (t), f, r); /* Start out with no fields, make new fields, and chain them in. */ TYPE_FIELDS (new) = 0; TYPE_SIZE (new) = 0; for (field = TYPE_FIELDS (t); field; field = TREE_CHAIN (field)) { tree new_field = copy_node (field); /* If this is a PARENT field and the parent subtype now has a non-self-referential length, use it as the type of this field. Then show we no longer need to worry about a parent subtype. */ if (DECL_PARENT_P (field) && parent_subtype != 0 && (TREE_CONSTANT (TYPE_SIZE (parent_subtype)) || ! contains_placeholder_p (TYPE_SIZE (parent_subtype)))) { TREE_TYPE (new_field) = parent_subtype; parent_subtype = 0; } else TREE_TYPE (new_field) = gnat_substitute_in_type (TREE_TYPE (new_field), f, r); /* If this is an anonymous field and the type of this field is a UNION_TYPE or RECORD_TYPE with no elements, ignore it. If the type just has one element, treat that as the field. But don't do this if we are processing a QUAL_UNION_TYPE. */ if (TREE_CODE (t) != QUAL_UNION_TYPE && DECL_NAME (new_field) == 0 && (TREE_CODE (TREE_TYPE (new_field)) == UNION_TYPE || TREE_CODE (TREE_TYPE (new_field)) == RECORD_TYPE)) { if (TYPE_FIELDS (TREE_TYPE (new_field)) == 0) continue; if (TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new_field))) == 0) new_field = TYPE_FIELDS (TREE_TYPE (new_field)); } DECL_CONTEXT (new_field) = new; DECL_SIZE (new_field) = 0; if (TREE_CODE (t) == QUAL_UNION_TYPE) { /* Do the substitution inside the qualifier and if we find that this field will not be present, omit it. */ DECL_QUALIFIER (new_field) = substitute_in_expr (DECL_QUALIFIER (field), f, r); if (integer_zerop (DECL_QUALIFIER (new_field))) continue; } if (last_field == 0) TYPE_FIELDS (new) = new_field; else TREE_CHAIN (last_field) = new_field; last_field = new_field; /* If this is a qualified type and this field will always be present, we are done. */ if (TREE_CODE (t) == QUAL_UNION_TYPE && integer_onep (DECL_QUALIFIER (new_field))) break; } /* If this used to be a qualified union type, but we now know what field will be present, make this a normal union. */ if (TREE_CODE (new) == QUAL_UNION_TYPE && (TYPE_FIELDS (new) == 0 || integer_onep (DECL_QUALIFIER (TYPE_FIELDS (new))))) TREE_SET_CODE (new, UNION_TYPE); TYPE_PARENT_SUBTYPE (new) = parent_subtype; layout_type (new); return new; } } } /* The external name of an entity is the: fully qualified name for true external objects (qualified_name) qualified name & '__' & number for overloaded subprograms (the complete signature function is here but not used for now). */ static struct obstack ext_name_obstack; static char *ext_name_firstobj; /* Return a string representing the external name to be used for GNAT_ENTITY. */ static char * get_external_name (gnat_entity) gnat_tree gnat_entity; { return (Has_Homonym (gnat_entity) ? qualified_overloaded_name (gnat_entity) : qualified_name (gnat_entity)); } void ob_init () { if (!ext_name_firstobj) { gcc_obstack_init (&ext_name_obstack); ext_name_firstobj = obstack_alloc (&ext_name_obstack, 1); } else obstack_free (&ext_name_obstack, ext_name_firstobj); } /* Compute the assembler name to use for NAME, which might start with a quote. We use an symbolic form of the operator concatenated with whatever follows the trailing quote. */ static char * get_operator_name (name) char *name; { char *opname; char *full_name; if (*name != '"') return name; switch (*++name) { case '+': opname = "_pls"; break; case '-': opname = "_mns"; break; case '*': if (name[1] == '*') opname = "_pow"; else opname = "_mul"; break; case '/': if (name[1] == '=') opname = "_ne"; else opname = "_div"; break; case '&': opname = "_cat"; break; case '=': opname = "_eq"; break; case '<': if (name[1] == '=') opname = "_le"; else opname = "_lt"; break; case '>': if (name[1] == '=') opname = "_ge"; else opname = "_gt"; break; case 'a': if (name[1] == 'b') opname = "_abs"; else opname = "_and"; break; case 'm': opname = "_mod"; break; case 'n': opname = "_not"; break; case 'o': opname = "_or"; break; case 'r': opname = "_rem"; break; case 'x': opname = "_xor"; break; default: abort (); } /* Skip to trailing '"'. */ while (*name++ != '"') ; /* If there's nothing else, we are done. Otherwise concatenate OPNAME to what's left of NAME. */ if (*name == 0) return opname; full_name = (char *) oballoc (strlen (opname) + strlen (name) + 1); strcpy (full_name, opname); strcat (full_name, name); return full_name; } void compute_qualified_name (gnat_tree gnat_entity) { char *name; /* If the entity is a child package, its name is not a Defining_Identifier, but a Defining_Program_Unit_Name, which does not have a chars field. Its simple name is the final identifier, which is the name to use. */ if (Nkind (gnat_entity) == N_Defining_Program_Unit_Name) gnat_entity = Defining_Identifier (gnat_entity); /* The scope of Standard is Standard itself. */ if (Scope (Scope (gnat_entity)) != Scope (gnat_entity)) { compute_qualified_name (Scope (gnat_entity)); obstack_grow (&ext_name_obstack, "__", 2); } /* Now get the name of the entity, converting names of operators into a form valid for the assembler. */ name = Get_Name_String (Chars (gnat_entity)); if (name[0] == '"') name = get_operator_name (name); obstack_grow (&ext_name_obstack, name, strlen (name)); } char * qualified_name (gnat_entity) gnat_tree gnat_entity; { ob_init (); /* if this is a a main subprogram, we prepend a prefix to avoid clashes with external C names as main or C library names */ if (Scope (Scope (gnat_entity)) == Scope (gnat_entity) && Is_Subprogram (gnat_entity)) obstack_grow (&ext_name_obstack, "_ada_", 5); compute_qualified_name (gnat_entity); obstack_1grow (&ext_name_obstack, 0); return (char *) obstack_base (&ext_name_obstack); } char * qualified_overloaded_name (gnat_entity) gnat_tree gnat_entity; { gnat_tree e; int number; char buf[10]; for (e = Homonym (gnat_entity), number = 1; (Present (e)); e = Homonym (e)) if (Scope (e) == Scope (gnat_entity)) number ++; sprintf (buf, "%d", number); ob_init (); compute_qualified_name (gnat_entity); if (number != 1) { obstack_grow (&ext_name_obstack, "__", 2); obstack_grow (&ext_name_obstack, buf, strlen (buf)); } obstack_1grow (&ext_name_obstack, 0); return (char *) obstack_base (&ext_name_obstack); } char * qualified_signature (gnat_entity) gnat_tree gnat_entity; { gnat_tree gnat_param; ob_init (); compute_qualified_name (gnat_entity); for (gnat_param = First_Formal (gnat_entity); Present (gnat_param); gnat_param = Next_Formal (gnat_param)) { obstack_grow (&ext_name_obstack, "__", 2); compute_qualified_name (Etype (gnat_param)); } obstack_1grow (&ext_name_obstack, 0); return (char *) obstack_base (&ext_name_obstack); } /* Return a name for GNAT_ENTITY concatenated with "._" and STRING. */ char * create_concat_name (gnat_entity, string) gnat_tree gnat_entity; char *string; { ob_init (); compute_qualified_name (gnat_entity); obstack_grow (&ext_name_obstack, "___", 3); obstack_grow (&ext_name_obstack, string, strlen (string)); obstack_1grow (&ext_name_obstack, 0); return (char *) obstack_base (&ext_name_obstack); } e, substitute into that. */ if (TYPE_PARENT_SUBTYPE (t)) parent_subtype = gnat_substitute_in_type (TYPE_PARENT_SUBTYPE (t), f, r); /* Start out with no fields, make new fields, and chain them in. */ TYPE_FIELDS (new) = 0; TYPE_SIZE (new) = 0; for (field = TYPE_FIELDS (t); field; field = TREE_CHAIN (field)) { tree new_field = copy_node (field); /* If this is a PARENT field and the parent subtype now has a non-selgnat-1.67-src/src/a-gtran3.h 444 10015 7640 7144 5506244455 10715 /****************************************************************************/ /* */ /* GNAT COMPILER COMPONENTS */ /* */ /* ADA CHAPTER 3: DECLARATIONS AND TYPES */ /* - GNAT SPECIFIC - */ /* */ /* Specification */ /* */ /* $Revision: 1.15 $ */ /* */ /* Copyright (c) 1992,1993, NYU, All Rights Reserved */ /* */ /* 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 */ /* Software Foundation; either version 2, or (at your option) any later */ /* version. GNAT is distributed in the hope that it will be useful, but */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- */ /* ABILITY 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 GNAT; see file COPYING. If not, write */ /* to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* */ /****************************************************************************/ /* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada entity, this routine returns the equivalent GCC tree for that entity (an ..._DECL node) and associates the ..._DECL node with the input GNAT defining identifier. If GNAT_ENTITY is a variable or a constant declaration, GNU_EXPR gives its initial value (in GCC tree form). This is optional for variables. DEFINITION is nonzero if this call is intended for a definition. This is used for separate compilation where it necessary to know whether an external declaration or a definition should be created if the GCC equivalent was not created previously. The value of 1 is normally used for a non-zero DEFINITION, but a value of 2 is used in special circumstances, defined in the code. */ extern tree gnat_to_gnu_entity PROTO((gnat_tree, tree, int)); /* Given GNAT_ENTITY, an entity in the incoming GNAT tree, return a GCC type corresponding to that entity. GNAT_ENTITY is assumed to refer to an Ada type. */ extern tree gnat_to_gnu_type PROTO((gnat_tree)); /* Given GNAT_ENTITY, elaborate all expressions that are required to be elaborated at the point of its definition, but do nothing else. */ extern void elaborate_entity PROTO((gnat_tree)); /* Called when we need to protect a variable object using a save_expr. */ extern tree maybe_variable PROTO((tree)); /* Given a GNU tree and a GNAT list of choices, generate an expression to test the value passed against the list of choices. */ extern tree choices_to_gnu PROTO((tree, gnat_tree)); /* Create the call to the record initialization routine. */ extern tree create_rec_init_call PROTO((tree, gnat_tree)); /* Given a type T, a FIELD_DECL F, and a replacement value R, return a new type with all size expressions that contain F updated by replacing F with R. This is identical to GCC's substitute_in_type except that it knows about TYPE_INDEX_TYPE. */ extern tree gnat_substitute_in_type PROTO((tree, tree, tree)); /* Return a name for GNAT_ENTITY concatenated with two underscores and STRING. */ extern char *create_concat_name PROTO((gnat_tree, char *)); ))) TREE_SET_CODE (new, UNION_TYPE); TYPE_PARENT_SUBTYPE (new) = parent_subtype; layout_type (new); return new; } } } /* The external name of an entity is the: fully qualified name for true external objects (qualified_name) qualified name & '__' & number for overloaded subprograms (the complete signature function is here but not used for now). */ static struct obstack ext_namegnat-1.67-src/src/a-misc.c 444 10015 7640 31475 5506244456 10472 /****************************************************************************/ /* */ /* GNAT COMPILER COMPONENTS */ /* */ /* MISCELLANEOUS */ /* */ /* Body */ /* */ /* $Revision: 1.40 $ */ /* */ /* Copyright (c) 1992,1993, NYU, All Rights Reserved */ /* */ /* 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 */ /* Software Foundation; either version 2, or (at your option) any later */ /* version. GNAT is distributed in the hope that it will be useful, but */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- */ /* ABILITY 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 GNAT; see file COPYING. If not, write */ /* to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* */ /****************************************************************************/ #include "config.h" #include #include #include "tree.h" #include "rtl.h" #include "expr.h" #include "a-ada.h" #include "a-types.h" #include "a-atree.h" #include "a-sinfo.h" #include "a-einfo.h" #include "a-namet.h" #include "a-string.h" #include "a-uint.h" #include "a-trans.h" #include "a-trans3.h" #include "a-trans4.h" #include "a-misc.h" #include "a-rtree.h" #include "flags.h" extern char *xmalloc (); extern char *main_input_filename; /* Tables describing GCC tree codes used only by GNAT. Table indexed by tree code giving a string containing a character classifying the tree code. Possibilities are t, d, s, c, r, <, 1 and 2. See cp-tree.def for details. */ #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE, char *gnat_tree_code_type[] = { "x", #include "a-tree.def" }; #undef DEFTREECODE /* Table indexed by tree code giving number of expression operands beyond the fixed part of the node structure. Not used for types or decls. */ #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH, int gnat_tree_code_length[] = { 0, #include "a-tree.def" }; #undef DEFTREECODE /* Names of tree components. Used for printing out the tree and error messages. */ #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME, char *gnat_tree_code_name[] = { "@@dummy", #include "a-tree.def" }; #undef DEFTREECODE /* some functions to interface with the front end and pass parameters and switches */ static int front_argc = 1; static char *front_argv[100]; /* predefined exceptions */ char constraint_error; char numeric_error; char program_error; char storage_error; char tasking_error; /* Variables for exception processing. */ char * __gnat_exception; size_t *__gnat_jmpbuf; int arg_count (void) { return front_argc; } int len_arg (arg_num) int arg_num; { if (arg_num < front_argc - 1) return strlen (front_argv[arg_num]); else return strlen (input_filename); } int fill_arg (a, i) char * a; int i; { if (i < front_argc - 1) strncpy (a, front_argv[i], strlen(front_argv[i])); else strncpy (a, input_filename, strlen (input_filename)); } /* This function is called by the exception mechanism. It calls abort if there is no handler for the exception so that the debugger can get control with a stackframe that is intact */ void catch_except (ptr, i) void *ptr; int i; { extern char debug__get_debug_flag_k (); /* extern Boolean errout__errors_detected; extern errout__finalize_error_output (); */ /* if an exception handler is active and the -dk debug switch is not set, then just branch to the exception handler */ if (ptr && !debug__get_debug_flag_k ()) longjmp (ptr, i); /* if no exception handler, or if -dk switch set, and this is a predefined exception, then give appropriate message and abort */ else { if (__gnat_exception == &constraint_error) printf ("\nraised Constraint_Error\n"); else if (__gnat_exception == &numeric_error) printf ("\nraised Numeric_Error\n"); else if (__gnat_exception == &program_error) printf ("\nraised Program_Error\n"); else if (__gnat_exception == &storage_error) printf ("\nraised Storage_Error\n"); else if (__gnat_exception == &tasking_error) printf ("\nraised Tasking_Error\n"); /* if not predefined exception, then go handle it if there is an exception handler active, else print message and abort */ else if (!ptr) printf ("\nraised unhandled exception\n"); else longjmp (ptr, i); /* here is the abort call for the case of a standard exception with the -dk debug flag set, or for any exception if no exception handler is active */ abort (); } } /* Raise constraint error. */ void __gnat_raise_constraint () { __gnat_exception = &constraint_error; catch_except (__gnat_jmpbuf, 1); } /* Root node of the tree read in. Used only by yyparse. */ gnat_tree gnat_root; /* Global Variables Expected by gcc: */ char *language_string = "GNU Ada"; int current_function_returns_null; int flag_traditional; /* Used by dwarfout.c. */ /* Routines Expected by gcc: */ /* For most front-ends, this is the parser for the language. For us, we process the GNAT tree. */ int yyparse () { /* Make up what Gigi uses as a jmpbuf. */ size_t jmpbuf[100]; /* Set up to catch unhandled exceptions. */ if (setjmp (jmpbuf)) abort (); __gnat_jmpbuf = jmpbuf; /* let's call the front-end elaboration procedures */ ada__bind (); /* call the front end */ _ada_gnat1drv (); return 0; } /* Decode all the language specific options that cannot be decoded by GCC. The option decoding phase of GCC calls this routine on the flags that it cannot decode. This routine returns 1 if it is successful, otherwise it returns 0. */ int lang_decode_option (p) char *p; { if (strncasecmp (p, "-gnat", 5)) /* we assume for the moment that all front end options are passed with "gnat" prefix */ return 0; else { front_argv[front_argc] = (char *) malloc (strlen (p) - 4); front_argv[front_argc][0] = '-'; strcpy (front_argv[front_argc] + 1, p + 5); front_argc ++; return 1; } } /* Perform all the initialization steps that are language-specific. */ void lang_init () { extern char **save_argv; /* init variables to simulate command line args for gnat */ front_argv [0] = save_argv[0]; /* take the exec name from gcc (toplev) */ front_argc ++; /* the last argument is the filename */ main_input_filename = input_filename; } /* Perform all the finalization steps that are language-specific. */ void lang_finish () {} /* Return a short string identifying this language to the debugger. */ char * lang_identify () { return "ada"; } /* If DECL has a cleanup, build and return that cleanup here. This is a callback called by expand_expr. */ tree maybe_build_cleanup (decl) tree decl; { /* There are no cleanups in C. */ return NULL_TREE; } /* Print any language-specific compilation statistics. */ void print_lang_statistics () {} /* Hooks for print-tree.c: */ void print_lang_decl (file, node, indent) FILE *file; tree node; int indent; {} void print_lang_type (file, node, indent) FILE *file; tree node; int indent; { /* Print the two fields we added to the tree. */ if (TREE_CODE (node) == INTEGER_TYPE && TYPE_INDEX_TYPE (node)) print_node (file, "index type", TYPE_INDEX_TYPE (node), indent + 4); else if (TREE_CODE (node) == FUNCTION_TYPE && TYPE_CI_CO_LIST (node)) print_node (file, "ci_co_list", TYPE_CI_CO_LIST (node), indent + 4); } void print_lang_identifier (file, node, indent) FILE *file; tree node; int indent; {} /* Expands GNAT-specific GCC tree nodes. The only ones we support here are TRANSFORM_EXPR and UNCHECKED_CONVERT_EXPR. */ static rtx gnat_expand_expr (exp, target, tmode, modifier) tree exp; rtx target; enum machine_mode tmode; enum expand_modifier modifier; { tree type = TREE_TYPE (exp); /* Update EXP to be the new expression to expand. */ switch (TREE_CODE (exp)) { case TRANSFORM_EXPR: /* If we will ignore our result, just generate code. Otherwise, expand it. */ if (target == const0_rtx || TREE_CODE (type) == VOID_TYPE) { gnat_to_code (TREE_COMPLEXITY (exp)); return target; } exp = gnat_to_gnu (TREE_COMPLEXITY (exp)); /* If convert was called on this TRANSFORM_EXPR, it will now have a type, so we must do the conversion now. */ if (type != error_mark_node) exp = convert (type, exp); break; case UNCHECKED_CONVERT_EXPR: /* If the input and output are both the same mode (usually BLKmode), just return the expanded input since we want just the bits. */ if (TYPE_MODE (type) == TYPE_MODE (TREE_TYPE (TREE_OPERAND (exp, 0)))) exp = TREE_OPERAND (exp, 0); /* If either mode is BLKmode, memory will be involved, so do this via pointer punning. */ else if (TYPE_MODE (type) == BLKmode || TYPE_MODE (TREE_TYPE (TREE_OPERAND (exp, 0))) == BLKmode) exp = build_unary_op (INDIRECT_REF, NULL_TREE, convert (build_pointer_type (type), build_unary_op (ADDR_EXPR, NULL_TREE, TREE_OPERAND (exp, 0)))); /* Otherwise make a union of the two types, convert to the union, and extract the other value. */ else { /* Note that copy_node puts objects in current_obstack and we take advantage of that here since we want these objects to all be in the momentary obstack. */ tree in_type = TREE_TYPE (TREE_OPERAND (exp, 0)); tree union_type = copy_node (unchecked_union_node); tree in_field = create_field_decl ("in", in_type, union_type, 0); tree out_field = create_field_decl ("out", type, union_type, 0); finish_record_type (union_type, chainon (chainon (NULL_TREE, in_field), out_field)); exp = build (COMPONENT_REF, type, build1 (CONVERT_EXPR, union_type, TREE_OPERAND (exp, 0)), out_field); } break; default: abort (); } return expand_expr (exp, target, tmode, modifier); } /* Make a TRANSFORM_EXPR to later expand GNAT_NODE into an object of GNU_TYPE. */ tree make_transform_expr (gnat_node, gnu_type) gnat_tree gnat_node; tree gnu_type; { tree gnu_result = build (TRANSFORM_EXPR, gnu_type); TREE_SIDE_EFFECTS (gnu_result) = 1; TREE_COMPLEXITY (gnu_result) = gnat_node; return gnu_result; } /* Performs whatever initialization steps needed by the language-dependent lexical analyzer. Define the additional tree codes here. This isn't the best place to put it, but it's where g++ does it. */ void init_lex () { lang_expand_expr = gnat_expand_expr; tree_code_type = (char **) realloc (tree_code_type, sizeof (char *) * LAST_GNAT_TREE_CODE); tree_code_length = (int *) realloc (tree_code_length, sizeof (int) * LAST_GNAT_TREE_CODE); tree_code_name = (char **) realloc (tree_code_name, sizeof (char *) * LAST_GNAT_TREE_CODE); bcopy ((char *) gnat_tree_code_type, (char *) (tree_code_type + (int) LAST_AND_UNUSED_TREE_CODE), ((LAST_GNAT_TREE_CODE - (int) LAST_AND_UNUSED_TREE_CODE) * sizeof (char *))); bcopy ((char *)gnat_tree_code_length, (char *) (tree_code_length + (int) LAST_AND_UNUSED_TREE_CODE), ((LAST_GNAT_TREE_CODE - (int) LAST_AND_UNUSED_TREE_CODE) * sizeof (int))); bcopy ((char *) gnat_tree_code_name, (char *) (tree_code_name + (int) LAST_AND_UNUSED_TREE_CODE), ((LAST_GNAT_TREE_CODE - (int) LAST_AND_UNUSED_TREE_CODE) * sizeof (char *))); } /* Sets some debug flags for the parsed. It does nothing here. */ void set_yydebug (value) int value; {} /* Utility Routines needed by the Tree Translator: */ /* GNU_TYPE is the type of a subprogram parameter. Determine from the type if it should be passed by reference. */ int pass_by_ref (gnu_type) tree gnu_type; { /* Otherwise, we pass only BLKmode and unconstrained objects by reference. */ return (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE || TYPE_MODE (gnu_type) == BLKmode); } program_error) printf ("\nraised Program_Error\n"); else if (__gnat_exception == &storage_error) printf ("\nraised Storage_Error\n"); else if (__gnat_exception == &tasking_error) gnat-1.67-src/src/a-misc.h 444 10015 7640 7310 5506244456 10446 /****************************************************************************/ /* */ /* GNAT COMPILER COMPONENTS */ /* */ /* MISCELLANEOUS */ /* */ /* Specification */ /* */ /* $Revision: 1.13 $ */ /* */ /* Copyright (c) 1992,1993, NYU, All Rights Reserved */ /* */ /* 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 */ /* Software Foundation; either version 2, or (at your option) any later */ /* version. GNAT is distributed in the hope that it will be useful, but */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- */ /* ABILITY 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 GNAT; see file COPYING. If not, write */ /* to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* */ /****************************************************************************/ /* Variables expected by the gcc back-end for reference or merely linking purposes: */ /* A string identifing the compiler. */ extern char *language_string; /* The gcc back-end sets this in jump.c. */ extern int current_function_returns_null; /* Ada language-specific GC tree codes. */ #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) SYM, enum gnat_tree_code { __DUMMY = LAST_AND_UNUSED_TREE_CODE, #include "a-tree.def" LAST_GNAT_TREE_CODE }; #undef DEFTREECODE /* Routines expected by the gcc back-end for call-back or merely linking purposes. They must have exactly the same prototype and name as expected by GCC. */ /* Decode all the language specific options that cannot be decoded by GCC. The option decoding phase of GCC calls this routine on the flags that it cannot decode. This routine returns 1 if it is successful, otherwise it returns 0. */ extern int lang_decode_option PROTO((char *)); /* Perform all the initialization steps that are language-specific. */ extern void lang_init PROTO((void)); /* Perform all the finalization steps that are language-specific. */ extern void lang_finish PROTO((void)); /* Print any language-specific compilation statistics. */ extern void print_lang_statistics PROTO((void)); /* Return a short string identifying this language to the debugger. */ extern char *lang_identify PROTO((void)); #ifdef BUFSIZ /* Hooks for `print_node'. */ extern void print_lang_decl PROTO((FILE *, tree, int)); extern void print_lang_type PROTO((FILE *, tree, int)); extern void print_lang_identifier PROTO((FILE *, tree, int)); #endif /* Performs whatever initialization steps needed by the language-dependent lexical analyzer. */ extern void init_lex PROTO((void)); /* Sets some debug flags for the parser. It does nothing here. */ extern void set_yydebug PROTO((int)); /* Utility routines created for the tree translator's sake. Their prototypes can be changed as desired. */ /* Make a TRANSFORM_EXPR to later expand GNAT_NODE into an object of GNU_TYPE. */ extern tree make_transform_expr PROTO((gnat_tree, tree)); /* GNU_TYPE is the type of a subprogram parameter. Determine from the type if it should be passed by reference. */ extern int pass_by_ref PROTO((tree)); /* elaboration routines for the front end */ extern void elab_all_gnat PROTO((void)); f ("\nraised unhandled exception\n"); else longjmp (ptr, i); /* here is the abort call for the case of a standard exception with the -dk debug flag set, or for any exception if no exception handler is active */ abort (); } } /* Raise constraint error. */ void __gnat_raise_constraignat-1.67-src/src/a-namet.h 444 10015 7640 15403 5506244457 10642 /****************************************************************************/ /* */ /* GNAT COMPILER COMPONENTS */ /* */ /* N A M E T */ /* */ /* Specification */ /* */ /* $Revision: 1.12 $ */ /* */ /* Copyright (c) 1992,1993, NYU, All Rights Reserved */ /* */ /* 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 */ /* Software Foundation; either version 2, or (at your option) any later */ /* version. GNAT is distributed in the hope that it will be useful, but */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- */ /* ABILITY 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 GNAT; see file COPYING. If not, write */ /* to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* */ /****************************************************************************/ /* This is the C file that corresponds to the Ada package specification Namet. It was created manually from files namet.ads and namet.adb. This package contains routines for handling the names table. The table is used to store character strings for identifiers and operator symbols. The forms of the entries are as follows: Identifiers Upper case letters folded to lower case. Character set encoding and folding conventions are the same as the source program. Operator symbols Stored with surrounding quotes. All letters are lower case. The names are hashed so that a given name appears only once in the table. Note: character literals are not hashed into this table, since they can be represented directly using the appropriate Char_Code value. A tree node pointer is stored with each names table entry which is used to point to a chain of linked entities. The management of this chain used for visibility and identification processing, is fully described in the Entity_Table package. */ /* Structure defining a names table entry. */ struct Name_Entry { Int Name_Chars_Index; /* Starting location of char in Name_Chars table. */ Short Name_Len; /* Length of this name in characters. */ Byte Byte_Info; /* Byte value associated with this name */ Byte Spare; /* Unused */ Name_Id Hash_Link; /* Link to next entry in names table for same hash code. Not accessed by C routines. */ Int Int_Info; /* Int value associated with this name */ }; /* Pointer to names table vector. This pointer is passed to the tree transformer and stored in a global location for access from here after subtracting Names_First_Entry so that Name_Id values can be used as subscripts into this table. */ extern struct Name_Entry *Names_Ptr; /* Pointer to name characters table. This pointer is passed to the tree transformer and stored in a global location for access from here. */ extern char *Name_Chars_Ptr; /* The only function defined in the C header is Get_Name_String which returns a null terminated C string for the specified name. All the other subprograms in the Ada version have to do with building the names table or manipulating it in the semantic routines. */ INLINE char * Get_Name_String (Id) Name_Id Id; { return Name_Chars_Ptr + Names_Ptr [Id].Name_Chars_Index + 1; } /* Define the function to return one of the numeric values below. Note that it actually returns a char since an enumeration value of less than 256 entries is represented that way in Ada. The operand is a Chars field value. */ #define Get_Attribute_Id snames__get_attribute_id extern char Get_Attribute_Id PROTO ((int)); /* Define the numeric values for the attributes. */ #define Attr_Access 0 #define Attr_Address 1 #define Attr_Adjacent 2 #define Attr_Aft 3 #define Attr_Alignment 4 #define Attr_Bit_Order 5 #define Attr_Body_Version 6 #define Attr_Callable 7 #define Attr_Caller 8 #define Attr_Ceiling 9 #define Attr_Component_Size 10 #define Attr_Compose 11 #define Attr_Constrained 12 #define Attr_Copy_Sign 13 #define Attr_Count 14 #define Attr_Delta 15 #define Attr_Denorm 16 #define Attr_Digits 17 #define Attr_Emax 18 #define Attr_Epsilon 19 #define Attr_Exponent 20 #define Attr_External_Tag 21 #define Attr_First 22 #define Attr_First_Bit 23 #define Attr_Floor 24 #define Attr_Fore 25 #define Attr_Fraction 26 #define Attr_Identity 27 #define Attr_Image 28 #define Attr_Input 29 #define Attr_Large 30 #define Attr_Last 31 #define Attr_Last_Bit 32 #define Attr_Leading_Part 33 #define Attr_Length 34 #define Attr_Machine 35 #define Attr_Machine_Emax 36 #define Attr_Machine_Emin 37 #define Attr_Machine_Mantissa 38 #define Attr_Machine_Overflows 39 #define Attr_Machine_Radix 40 #define Attr_Machine_Rounds 41 #define Attr_Mantissa 42 #define Attr_Max 43 #define Attr_Max_Size_In_Storage_Elements 44 #define Attr_Min 45 #define Attr_Model 46 #define Attr_Model_Emax 47 #define Attr_Model_Emin 48 #define Attr_Model_Epsilon 49 #define Attr_Model_Large 50 #define Attr_Model_Mantissa 51 #define Attr_Model_Small 52 #define Attr_Output 53 #define Attr_Pos 54 #define Attr_Position 55 #define Attr_Pred 56 #define Attr_Range 57 #define Attr_Read 58 #define Attr_Remainder 59 #define Attr_Round 60 #define Attr_Rounding 61 #define Attr_Safe_Emax 62 #define Attr_Safe_First 63 #define Attr_Safe_Large 64 #define Attr_Safe_Last 65 #define Attr_Safe_Small 66 #define Attr_Scale 67 #define Attr_Signed_Zeros 68 #define Attr_Size 69 #define Attr_Small 70 #define Attr_Storage_Pool 71 #define Attr_Storage_Size 72 #define Attr_Succ 73 #define Attr_Tag 74 #define Attr_Terminated 75 #define Attr_Truncation 76 #define Attr_Unbiased_Rounding 77 #define Attr_Unchecked_Access 78 #define Attr_Val 79 #define Attr_Valid 80 #define Attr_Value 81 #define Attr_Version 82 #define Attr_Wide_Image 83 #define Attr_Wide_Value 84 #define Attr_Width 85 #define Attr_Write 86 #define Attribute_Base 87 #define Attribute_Class 88 #define Attribute_Standard_Access 89 /* End of a-namet.h (C version of Namet package specification and body) */ T (node)) print_node (file, "ci_co_list", TYPE_CI_CO_LIST (node), indent + 4); } void print_lang_identifier (file, node, indent) FILE *file; tree node; int indent; {} /* Expands GNAT-specific GCC tree nodes. The only ones we suppognat-1.67-src/src/a-rtree.h 444 10015 7640 2765 5506244457 10646 /****************************************************************************/ /* */ /* GNAT COMPILER COMPONENTS */ /* */ /* R T R E E */ /* */ /* Spec */ /* */ /* $Revision: 1.9 $ */ /* */ /* Copyright (c) 1992,1993, NYU, All Rights Reserved */ /* */ /* 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 */ /* Software Foundation; either version 2, or (at your option) any later */ /* version. GNAT is distributed in the hope that it will be useful, but */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- */ /* ABILITY 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 GNAT; see file COPYING. If not, write */ /* to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* */ /****************************************************************************/ struct Needed_File_Info { int File_Name; int First_Sloc; int Last_Sloc; int Last_Line; }; extern int max_gnat_nodes; extern struct Needed_File_Info *File_Info_Ptr; extern Tree_Id read_gnat_tree PROTO((char * )); are as follgnat-1.67-src/src/a-string.h 444 10015 7640 7234 5506244460 11021 /****************************************************************************/ /* */ /* GNAT COMPILER COMPONENTS */ /* */ /* S T R I N G S _ T A B L E */ /* */ /* Specification */ /* */ /* $Revision: 1.4 $ */ /* */ /* Copyright (c) 1992,1993, NYU, All Rights Reserved */ /* */ /* 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 */ /* Software Foundation; either version 2, or (at your option) any later */ /* version. GNAT is distributed in the hope that it will be useful, but */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- */ /* ABILITY 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 GNAT; see file COPYING. If not, write */ /* to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* */ /****************************************************************************/ /* This file is the C file that corresponds to the Ada package spec */ /* Strings_Table. It was created manually from strings.ada, strings_.ada */ /* Note: only the access functions are provided, since the tree transformer */ /* is not allowed to modify the tree or its auxiliary structures. */ /* This package contains routines for handling the strings table which is */ /* used to store string constants encountered in the source, and also those */ /* additional string constants generated by compile time concatenation and */ /* other similar processing. */ /* A string constant in this table consists of a series of Char_Code values, */ /* so that 16-bit character codes can be properly handled if this feature */ /* is implemented in the scanner. */ /* There is no guarantee that hashing is used in the implementation. This */ /* means that the caller cannot count on having the same Id value for two */ /* identical strings stored separately. */ /* The String_Id values reference entries in the Strings table, which */ /* contains String_Entry records that record the length of each stored */ /* string and its starting location in the String_Chars table. */ struct String_Entry { Int String_Index; Int Length; }; extern struct String_Entry *Strings_Ptr; /* Pointer to string entry vector. This pointer is passed to the tree */ /* transformer and stored in a global location for access from here */ /* after subtracting String_First_Entry, so that String_Id values can be */ /* used as subscripts into the vector. */ extern Char_Code *String_Chars_Ptr; /* Pointer to name characters table. This pointer is passed to the tree */ /* transformer and stored in a global location for access from here. The */ /* String_Index values are subscripts into this array. */ /* String_Length returns the length of the specified string */ INLINE Int String_Length (String_Id Id) { return Strings_Ptr [Id].Length; } /* Get_String_Char obtains the specified character from a stored string. */ /* The lower bound of stored strings is always 1, so the range of values */ /* is 1 to String_Length (Id). */ INLINE Char_Code Get_String_Char (String_Id Id, Int Index) { return String_Chars_Ptr [Strings_Ptr [Id].String_Index + Index - 1]; } /* End of a-string.h (C version of Stringt package spec and body) */ is represented that way in Ada. The operand is a Chars field value. */ #define Get_Attribute_Id snames__get_attribute_id extern char Get_Attribute_Id PROTO ((int)); /* Define the numeric values for the attributes. */ #define Attr_Access 0 #define Attr_Address 1 #define Attr_Adjacent 2 #define Attr_Aft 3 #define Attr_gnat-1.67-src/src/a-trans3.c 444 10015 7640 132734 5506244461 10765 /****************************************************************************/ /* */ /* GNAT COMPILER COMPONENTS */ /* */ /* ADA CHAPTER 3: DECLARATIONS AND TYPES */ /* - GNU SPECIFIC - */ /* */ /* Body */ /* */ /* $Revision: 1.61 $ */ /* */ /* Copyright (c) 1992,1993, NYU, All Rights Reserved */ /* */ /* 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 */ /* Software Foundation; either version 2, or (at your option) any later */ /* version. GNAT is distributed in the hope that it will be useful, but */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- */ /* ABILITY 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 GNAT; see file COPYING. If not, write */ /* to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* */ /****************************************************************************/ #include "config.h" #include "tree.h" #include "flags.h" #include "a-ada.h" #include "a-types.h" #include "a-atree.h" #include "a-sinfo.h" #include "a-einfo.h" #include "a-namet.h" #include "a-string.h" #include "a-uint.h" #include "a-trans.h" #include "a-gtran3.h" #include "a-trans3.h" #include "a-trans4.h" #include "a-misc.h" #include "a-rtree.h" #include "convert.h" #undef NULL #define NULL 0 /* Global Variables for the various types we create. */ tree error_mark_node; tree integer_type_node; tree unsigned_type_node; tree char_type_node; tree void_type_node; tree void_type_decl_node; tree ptr_void_type_node; tree void_ftype; tree ptr_void_ftype; tree malloc_decl; tree jmpbuf_type; tree jmpbuf_ptr_type; tree jmpbuf_decl; tree excptr_decl; tree longjmp_decl; tree setjmp_decl; tree raise_constraint_decl; tree unchecked_union_node; tree integer_zero_node; tree integer_one_node; tree null_pointer_node; tree current_function_decl = NULL; static int contains_placeholder_except_p PROTO((tree, tree)); /* Routines to Associate and Retrieve GCC Nodes with Gnat Nodes: */ /* Associates a GNAT tree node to a GCC tree node. It is used in `save_gnu_tree', `get_gnu_tree' and `present_gnu_tree'. See documentation of `save_gnu_tree' for more info. */ static tree *associate_gnat_to_gnu; /* Initialize the association of GNAT nodes to GCC trees. */ void init_gnat_to_gnu () { gnat_tree gnat_node; associate_gnat_to_gnu = (tree *) xmalloc (max_gnat_nodes * sizeof (tree)); for (gnat_node = 0; gnat_node < max_gnat_nodes; gnat_node++) associate_gnat_to_gnu [gnat_node] = NULL_TREE; associate_gnat_to_gnu -= First_Node_Id; } /* GNAT_DEFINING_IDENTIFIER is a GNAT tree node for a defining identifier. GNU_DECL is the GCC tree which is to be associated with GNAT_DEFINING_IDENTIFIER. Such gnu tree node is always an ..._DECL node. If NO_CHECK is nonzero, the latter check is suppressed. If GNU_DECL is zero, a previous association is to be reset. */ void save_gnu_tree (gnat_defining_identifier, gnu_decl, no_check) gnat_tree gnat_defining_identifier; tree gnu_decl; int no_check; { if (gnu_decl && (associate_gnat_to_gnu [gnat_defining_identifier] || (! no_check && TREE_CODE_CLASS (TREE_CODE (gnu_decl)) != 'd'))) abort (); associate_gnat_to_gnu [gnat_defining_identifier] = gnu_decl; } /* GNAT_DEFINING_IDENTIFIER is a GNAT tree node for a defining identifier. Return the ..._DECL node that was associated with it. If there is no tree node associated with GNAT_DEFINING_IDENTIFIER, abort. */ tree get_gnu_tree (gnat_defining_identifier) gnat_tree gnat_defining_identifier; { if (! associate_gnat_to_gnu [gnat_defining_identifier]) abort (); return associate_gnat_to_gnu [gnat_defining_identifier]; } /* Return nonzero if a GCC tree has been associated with GNAT_DEFINING_IDENTIFIER. */ int present_gnu_tree (gnat_defining_identifier) gnat_tree gnat_defining_identifier; { return (associate_gnat_to_gnu [gnat_defining_identifier] != NULL_TREE); } /* For each binding contour we allocate a binding_level structure which records the entities defined or declared in that contour. Contours include: the global one one for each subprogram definition one for each compound statement (declare block) Binding contours are used to create GCC tree BLOCK nodes. */ struct binding_level { /* A chain of ..._DECL nodes for all variables, constants, functions, parameters and type declarations. These ..._DECL nodes are chained through the TREE_CHAIN field. Note that these ..._DECL nodes are stored in the reverse of the order supplied to be compatible with the back-end. */ tree names; /* For each level (except the global one), a chain of BLOCK nodes for all the levels that were entered and exited one level down from this one. */ tree blocks; /* The back end may need, for its own internal processing, to create a BLOCK node. This field is set aside for this purpose. If this field is non-null when the level is popped, i.e. when poplevel is invoked, we will use such block instead of creating a new one from the 'names' field, that is the ..._DECL nodes accumulated so far. Typically the routine 'pushlevel' will be called before setting this field, so that if the front-end had inserted ..._DECL nodes in the current block they will not be lost. */ tree block_created_by_back_end; /* The binding level containing this one (the enclosing binding level). */ struct binding_level *level_chain; }; /* The binding level currently in effect. */ static struct binding_level *current_binding_level = NULL; /* A chain of binding_level structures awaiting reuse. */ static struct binding_level *free_binding_level = NULL; /* The outermost binding level. This binding level is created when the compiler is started and it will exist through the entire compilation. */ static struct binding_level *global_binding_level; /* Binding level structures are initialized by copying this one. */ static struct binding_level clear_binding_level = {NULL, NULL, NULL, NULL}; /* Return non-zero if we are currently in the global binding level. */ int global_bindings_p () { return current_binding_level == global_binding_level ? -1 : 0; } /* Return the list of declarations in the current level. Note that this list is in reverse order (it has to be so for back-end compatibility). */ tree getdecls () { return current_binding_level->names; } /* Nonzero if the current level needs to have a BLOCK made. */ int kept_level_p () { return (current_binding_level->names != 0); } /* Enter a new binding level. The input parameter is ignored, but has to be specified for back-end compatibility. */ void pushlevel (ignore) int ignore; { struct binding_level *newlevel = NULL; /* Reuse a struct for this binding level, if there is one. */ if (free_binding_level) { newlevel = free_binding_level; free_binding_level = free_binding_level->level_chain; } else newlevel = (struct binding_level *) xmalloc (sizeof (struct binding_level)); *newlevel = clear_binding_level; /* Add this level to the front of the chain (stack) of levels that are active. */ newlevel->level_chain = current_binding_level; current_binding_level = newlevel; } /* Exit a binding level. Pop the level off, and restore the state of the identifier-decl mappings that were in effect when this level was entered. If KEEP is nonzero, this level had explicit declarations, so and create a "block" (a BLOCK node) for the level to record its declarations and subblocks for symbol table output. If FUNCTIONBODY is nonzero, this level is the body of a function, so create a block as if KEEP were set and also clear out all label names. If REVERSE is nonzero, reverse the order of decls before putting them into the BLOCK. */ tree poplevel (keep, reverse, functionbody) int keep; int reverse; int functionbody; { /* Points to a GCC BLOCK tree node. This is the BLOCK node construted for the binding level that we are about to exit and which is returned by this routine. */ tree block_node = NULL_TREE; tree decl_chain; tree decl_node; tree subblock_chain = current_binding_level->blocks; tree subblock_node; tree block_created_by_back_end; /* Reverse the list of XXXX_DECL nodes if desired. Note that the ..._DECL nodes chained through the `names' field of current_binding_level are in reverse order except for PARM_DECL node, which are explicitely stored in the right order. */ decl_chain = (reverse) ? nreverse (current_binding_level->names) : current_binding_level->names; /* Output any nested inline functions within this block which must be compiled because their address is needed. */ for (decl_node = decl_chain; decl_node; decl_node = TREE_CHAIN (decl_node)) if ((TREE_CODE (decl_node) == FUNCTION_DECL) && ! TREE_ASM_WRITTEN (decl_node) && (DECL_INITIAL (decl_node) != 0) && TREE_ADDRESSABLE (decl_node)) { push_function_context (); output_inline_function (decl_node); pop_function_context (); } block_created_by_back_end = current_binding_level->block_created_by_back_end; if (block_created_by_back_end != 0) { block_node = block_created_by_back_end; /* Check if we are about to discard some information that was gathered by the front-end. Nameley check if the back-end created a new block without calling pushlevel first. To understand why things are lost just look at the next case (i.e. no block created by back-end. */ if ((keep || functionbody) && (decl_chain || subblock_chain)) abort (); } /* If there were any declarations in the current binding level, or if this binding level is a function body, or if there are any nested blocks then create a BLOCK node to record them for the life of this function. */ else if (keep || functionbody) block_node = build_block (keep ? decl_chain : 0, 0, subblock_chain, 0, 0); /* Record the BLOCK node just built as the subblock its enclosing scope. */ for (subblock_node = subblock_chain; subblock_node; subblock_node = TREE_CHAIN (subblock_node)) BLOCK_SUPERCONTEXT (subblock_node) = block_node; /* Clear out the meanings of the local variables of this level. */ for (subblock_node = decl_chain; subblock_node; subblock_node = TREE_CHAIN (subblock_node)) if (DECL_NAME (subblock_node) != 0) /* If the identifier was used or addressed via a local extern decl, don't forget that fact. */ if (DECL_EXTERNAL (subblock_node)) { if (TREE_USED (subblock_node)) TREE_USED (DECL_NAME (subblock_node)) = 1; if (TREE_ADDRESSABLE (subblock_node)) TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (subblock_node)) = 1; } { /* Pop the current level, and free the structure for reuse. */ struct binding_level *level = current_binding_level; current_binding_level = current_binding_level->level_chain; level->level_chain = free_binding_level; free_binding_level = level; } if (functionbody) { /* This is the top level block of a function. The ..._DECL chain stored in BLOCK_VARS are the function's parameters (PARM_DECL nodes). Don't leave them in the BLOCK because they are found in the FUNCTION_DECL instead. */ DECL_INITIAL (current_function_decl) = block_node; BLOCK_VARS (block_node) = 0; } else if (block_node) { if (block_created_by_back_end == NULL) current_binding_level->blocks = chainon (current_binding_level->blocks, block_node); } /* If we did not make a block for the level just exited, any blocks made for inner levels (since they cannot be recorded as subblocks in that level) must be carried forward so they will later become subblocks of something else. */ else if (subblock_chain) current_binding_level->blocks = chainon (current_binding_level->blocks, subblock_chain); if (block_node) TREE_USED (block_node) = 1; return block_node; } /* Insert BLOCK at the end of the list of subblocks of the current binding level. This is used when a BIND_EXPR is expanded, to handle the BLOCK node inside the BIND_EXPR. */ void insert_block (block) tree block; { TREE_USED (block) = 1; current_binding_level->blocks = chainon (current_binding_level->blocks, block); } /* Set the BLOCK node for the innermost scope (the one we are currently in). */ void set_block (block) tree block; { current_binding_level->block_created_by_back_end = block; } /* Records a ..._DECL node DECL as belonging to the current lexical scope. Returns the ..._DECL node. */ tree pushdecl (decl) tree decl; { /* External objects aren't nested, other objects may be. */ if (DECL_EXTERNAL (decl)) DECL_CONTEXT (decl) = 0; else DECL_CONTEXT (decl) = current_function_decl; /* Put the declaration on the list. The list of declarations is in reverse order. The list will be reversed later if necessary. This needs to be this way for compatibility with the back-end. Don't put TYPE_DECLs for UNCONSTRAINED_ARRAY_TYPE into the list. They will cause trouble with the debugger and aren't needed anyway. */ if (TREE_CODE (decl) != TYPE_DECL || TREE_CODE (TREE_TYPE (decl)) != UNCONSTRAINED_ARRAY_TYPE) { TREE_CHAIN (decl) = current_binding_level->names; current_binding_level->names = decl; } /* For the declartion of a type, set its name if it either is not already set or is an implicit type name. We'd rather have the type named with a real name and all the pointer types to the same object have the same POINTER_TYPE node. Code in this function in c-decl.c makes a copy of the type node here, but that may cause us trouble with incomplete types, so let's not try it (at least for now). */ if (TREE_CODE (decl) == TYPE_DECL && (TYPE_NAME (TREE_TYPE (decl)) == 0 || 0 == strncmp (IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl))), "ityp__", 6))) TYPE_NAME (TREE_TYPE (decl)) = DECL_NAME (decl); return decl; } /* Create the predefined scalar types such as `integer_type_node' needed in the gcc back-end and initialize the global binding level. */ void init_decl_processing () { tree endlink; /* The structure `tree_identifier' is the GCC tree data structure that holds IDENTIFIER_NODE nodes. We need to call `set_identifier_size' to tell GCC that we have not added any language specific fields to IDENTIFIER_NODE nodes. */ set_identifier_size (sizeof (struct tree_identifier)); lineno = 0; /* incomplete_decl_finalize_hook is defined in toplev.c. It needs to be set by each front end to the appropriate routine that handles incomplete VAR_DECL nodes. This routine will be invoked by compile_file when a VAR_DECL node of DECL_SIZE zero is encountered. */ incomplete_decl_finalize_hook = finish_incomplete_decl; /* Make the binding_level structure for global names. */ current_function_decl = 0; current_binding_level = 0; free_binding_level = 0; pushlevel (0); global_binding_level = current_binding_level; /* In Ada, we use a signed type for SIZETYPE. Use the signed type corresponding to the size of Pmode. */ sizetype = type_for_size (GET_MODE_BITSIZE (Pmode), 0); pushdecl (build_decl (TYPE_DECL, get_identifier (SIZE_TYPE), sizetype)); integer_type_node = type_for_size (INT_TYPE_SIZE, 0) ; pushdecl (build_decl (TYPE_DECL, get_identifier ("int"), integer_type_node)); unsigned_type_node = type_for_size (INT_TYPE_SIZE, 1); pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"), unsigned_type_node)); char_type_node = type_for_size (CHAR_TYPE_SIZE, 1); pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"), char_type_node)); error_mark_node = make_node (ERROR_MARK); TREE_TYPE (error_mark_node) = error_mark_node; integer_zero_node = build_int_2 (0, 0); integer_one_node = build_int_2 (1, 0); size_zero_node = build_int_2 (0, 0); TREE_TYPE (size_zero_node) = sizetype; size_one_node = build_int_2 (1, 0); TREE_TYPE (size_one_node) = sizetype; void_type_node = make_node (VOID_TYPE); layout_type (void_type_node); TYPE_ALIGN (void_type_node) = BITS_PER_UNIT; void_type_decl_node = pushdecl (build_decl (TYPE_DECL, get_identifier ("void"), void_type_node)); ptr_void_type_node = build_pointer_type (void_type_node); null_pointer_node = build_int_2 (0, 0); TREE_TYPE (null_pointer_node) = ptr_void_type_node; layout_type (TREE_TYPE (null_pointer_node)); void_ftype = build_function_type (void_type_node, NULL_TREE); ptr_void_ftype = build_pointer_type (void_ftype); /* Now declare runtime functions. */ endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE); /* malloc is a function declaration tree for a function to allocate memory. */ malloc_decl = create_subprog_decl ("malloc", NULL_PTR, build_function_type (ptr_void_type_node, tree_cons (NULL_TREE, sizetype, endlink)), NULL_TREE, 0, 1, 1, 0); /* Make the types and global variables used for exception processing. We assume here that a jmp_buf is no more than 100 size_t entries. */ jmpbuf_type = build_array_type (sizetype, build_index_type (build_int_2 (100, 0))); pushdecl (build_decl (TYPE_DECL, get_identifier ("jmpbuf_t"), jmpbuf_type)); jmpbuf_ptr_type = build_pointer_type (jmpbuf_type); /* __gnat_jmpbuf is a pointer to the current jmpbuf. */ jmpbuf_decl = create_var_decl ("__gnat_jmpbuf", NULL_PTR, jmpbuf_ptr_type, NULL_TREE, 0, 1, 0, 0, 0); /* An exception is a single byte. __gnat_exception points to the current exception. */ excptr_decl = create_var_decl ("__gnat_exception", NULL_PTR, build_pointer_type (char_type_node), NULL_TREE, 0, 1, 0, 0, 0); /* longjmp is a function that returns void. Its first operand is a pointer to a jmpbuf and its second operand is an integer. */ longjmp_decl = create_subprog_decl /* longjmp is called by catch_except, unless for some exceptions ("longjmp", NULL_PTR, */ ("catch_except", NULL_PTR, build_function_type (void_type_node, tree_cons (NULL_TREE, jmpbuf_ptr_type, tree_cons (NULL_TREE, integer_type_node, endlink))), NULL_TREE, 0, 1, 1, 0); build_pointer_type (longjmp_decl); /* Indicate that longjmp never returns. */ TREE_THIS_VOLATILE (longjmp_decl) = 1; TREE_SIDE_EFFECTS (longjmp_decl) = 1; /* setjmp returns an integer and has one operand, which is a pointer to a jmpbuf. */ setjmp_decl = create_subprog_decl ("setjmp", NULL_PTR, build_function_type (integer_type_node, tree_cons (NULL_TREE, jmpbuf_ptr_type, endlink)), NULL_TREE, 0, 1, 1, 0); /* __gnat_raise_constraint takes no operands and never returns. */ raise_constraint_decl = create_subprog_decl ("__gnat_raise_constraint", NULL_PTR, build_function_type (void_type_node, endlink), NULL_TREE, 0, 1, 1, 0); TREE_THIS_VOLATILE (raise_constraint_decl) = 1; TREE_SIDE_EFFECTS (raise_constraint_decl) = 1; /* Make a UNION_TYPE that will be copied to form a union to be used to do an unchecked conversion. */ unchecked_union_node = make_node (UNION_TYPE); } /* This routine is called in tree.c to print an error message for invalid use of an incomplete type. */ void incomplete_type_error (dont_care_1, dont_care_2) tree dont_care_1, dont_care_2; { abort (); } /* This function is called indirectly from toplev.c to handle incomplete declarations, i.e. VAR_DECL nodes whose DECL_SIZE is zero. To be precise, compile_file in toplev.c makes an indirect call through the function pointer incomplete_decl_finalize_hook which is initialized to this routine in init_decl_processing. */ void finish_incomplete_decl (dont_care) tree dont_care; { abort (); } /* Given a record type (RECORD_TYPE) and a chain of FIELD_DECL nodes (FIELDLIST), finish constructing the record or union type. */ void finish_record_type (record_type, fieldlist) tree record_type; tree fieldlist; { TYPE_FIELDS (record_type) = fieldlist; TYPE_STUB_DECL (record_type) = pushdecl (build_decl (TYPE_DECL, NULL_TREE, record_type)); layout_type (record_type); rest_of_type_compilation (record_type, global_bindings_p ()); } /* Return a FUNCTION_TYPE node. RETURN_TYPE is the type returned by the subprogram. If it is void_type_node, then we are dealing with a procedure, otherwise we are dealing with a function. PARAM_DECL_LIST is a list of PARM_DECL nodes that are the subprogram arguments. CICO_LIST is the copy-in/copy-out list to be stored into TYPE_CICO_LIST. */ tree create_subprog_type (return_type, param_decl_list, cico_list) tree return_type; tree param_decl_list; tree cico_list; { /* A chain of TREE_LIST nodes whose TREE_VALUEs are the data type nodes of the subprogram formal parameters. This list is generated by traversing th input list of PARM_DECL nodes. */ tree param_type_list = NULL; tree param_decl; tree type; for (param_decl = param_decl_list; param_decl; param_decl = TREE_CHAIN (param_decl)) param_type_list = tree_cons (NULL_TREE, TREE_TYPE (param_decl), param_type_list); /* The list of the function parameter types has to be terminated by the void type to signal to the back-end that we are not dealing with a variable parameter subprogram, but that the subprogram has a fixed number of parameters. */ param_type_list = tree_cons (NULL_TREE, void_type_node, param_type_list); /* The list of argument types has been created in reverse so nreverse it. */ param_type_list = nreverse (param_type_list); type = build_function_type (return_type, param_type_list); /* TYPE may have been shared since GCC hashes types. If it has a CICO_LIST or the new type should, make a copy of TYPE. */ if (TYPE_CI_CO_LIST (type) != 0 || cico_list != 0) { push_obstacks (TYPE_OBSTACK (type), TYPE_OBSTACK (type)); type = copy_node (type); pop_obstacks (); } TYPE_CI_CO_LIST (type) = cico_list; return type; } /* Return a TYPE_DECL node. TYPE_NAME gives the name of the type (a character string) and TYPE is a ..._TYPE node giving its data type. */ tree create_type_decl (type_name, type) char *type_name; tree type; { tree id_node = type_name ? get_identifier (type_name): NULL_TREE; tree type_decl = build_decl (TYPE_DECL, id_node, type); /* Add this decl to the current binding level. */ type_decl = pushdecl (type_decl); /* Pass type declaration information to the debugger unless this is an UNCONSTRAINED_ARRAY_TYPE, which the debugger does not support. */ if (TREE_CODE (type) != UNCONSTRAINED_ARRAY_TYPE) rest_of_decl_compilation (type_decl, NULL, global_bindings_p (), 0); return type_decl; } /* This listhead is used to record any global objects that need elaboration. TREE_PURPOSE is the variable to be elaborated and TREE_VALUE is the initial value to assign. */ static tree pending_elaborations; /* Returns a GCC VAR_DECL node. VAR_NAME gives the name of the variable (a character string). ASM_NAME is its assembler name (if provided). TYPE is its data type (a GCC ..._TYPE node). VAR_INIT is the GCC tree for an optional initial expression; NULL_TREE if none. CONST_FLAG is nonzero if this variable is constant. PUBLIC_FLAG is nonzero if this definition is to be made visible outside of the current compilation unit. This flag should be set when processing the variable definitions in a package specification. EXTERN_FLAG is nonzero when processing an external variable declaration (as opposed to a definition: no storage is to be allocated for the variable here). STATIC_FLAG is only relevant when not at top level. In that case it indicates whether to always allocate storage to the variable. VOLATILE_FLAG is true if the variable is to be treated as volatile. */ tree create_var_decl (var_name, asm_name, type, var_init, const_flag, public_flag, extern_flag, static_flag, volatile_flag) char *var_name; char *asm_name; tree type; tree var_init; int const_flag; int public_flag; int extern_flag; int static_flag; int volatile_flag; { tree id_node = get_identifier (var_name); tree var_decl = build_decl (const_flag && var_init && TREE_CONSTANT (var_init) ? CONST_DECL : VAR_DECL, id_node, type); /* If this is external, throw away any initializations unless this is a CONST_DECL (meaning we have a constant); they will be done elsewhere. If we are defining a global here, leave a constant initialization and save any variable elaborations for the elaboration routine. */ if (extern_flag && TREE_CODE (var_decl) != CONST_DECL) var_init = 0; if (global_bindings_p () && var_init != 0 && ! TREE_CONSTANT (var_init)) { add_pending_elaborations (var_decl, var_init); var_init = 0; } DECL_INITIAL (var_decl) = var_init; TREE_READONLY (var_decl) = const_flag; DECL_EXTERNAL (var_decl) = extern_flag; TREE_PUBLIC (var_decl) = public_flag || extern_flag; TREE_STATIC (var_decl) = (global_bindings_p () ? !extern_flag : static_flag || volatile_flag); TREE_CONSTANT (var_decl) = TREE_CODE (var_decl) == CONST_DECL; TREE_THIS_VOLATILE (var_decl) = TREE_SIDE_EFFECTS (var_decl) = volatile_flag; /* At the global binding level we need to allocate static storage for the variable if and only if its not external. If we are not at the top level we always allocate automatic storage. */ if (asm_name) DECL_ASSEMBLER_NAME (var_decl) = get_identifier (asm_name); /* If the type is a RECORD_TYPE and its size depends on a discriminant, the size to be used for the object is the maximum possible size. */ if (TREE_CODE (type) == RECORD_TYPE && ! TREE_CONSTANT (TYPE_SIZE (type)) && contains_placeholder_p (TYPE_SIZE (type))) DECL_SIZE (var_decl) = max_size (TYPE_SIZE (type), 1); /* Add this decl to the current binding level and generate any needed code and RTL. */ var_decl = pushdecl (var_decl); expand_decl (var_decl); expand_decl_init (var_decl); if (TREE_CODE (var_decl) != CONST_DECL) rest_of_decl_compilation (var_decl, 0, global_bindings_p (), 0); return var_decl; } /* Returns a FIELD_DECL node. FIELD_NAME the field name, FIELD_TYPE is its type, and RECORD_TYPE is the type of the parent. PACKED is nonzero if this field is in a record type with a "pragma pack". */ tree create_field_decl (field_name, field_type, record_type, packed) char *field_name; tree field_type; tree record_type; int packed; { tree field_id = field_name ? get_identifier (field_name): NULL_TREE; tree field_decl = build_decl (FIELD_DECL, field_id, field_type); DECL_CONTEXT (field_decl) = record_type; /* If this is to be packed and it is an integral type make a bit field whose width is the precision of the type. */ if (packed && INTEGRAL_TYPE_P (field_type) && TREE_CODE (TYPE_SIZE (field_type)) == INTEGER_CST) { DECL_BIT_FIELD (field_decl) = 1; DECL_PACKED (field_decl) = 1; DECL_FIELD_SIZE (field_decl) = TYPE_PRECISION (field_type); } else DECL_ALIGN (field_decl) = MAX (DECL_ALIGN (field_decl), packed ? BITS_PER_UNIT : TYPE_ALIGN (TREE_TYPE (field_decl))); /* If the type is a RECORD_TYPE and its size depends on a discriminant, the size to be used for the object is the maximum possible size. */ if (TREE_CODE (field_type) == RECORD_TYPE && ! TREE_CONSTANT (TYPE_SIZE (field_type)) && contains_placeholder_except_p (TYPE_SIZE (field_type), record_type)) DECL_SIZE (field_decl) = max_size (TYPE_SIZE (field_type), 1); return field_decl; } /* Returns a PARM_DECL node. PARAM_NAME is the name of the parameter, PARAM_TYPE is its type. */ tree create_param_decl (param_name, param_type) char *param_name; tree param_type; { tree param_id = get_identifier (param_name); tree param_decl = build_decl (PARM_DECL, param_id, param_type); DECL_ARG_TYPE (param_decl) = param_type; return param_decl; } /* Add some pending elaborations on the list . */ void add_pending_elaborations (var_decl, var_init) tree var_decl; tree var_init; { pending_elaborations = tree_cons (var_decl, var_init, pending_elaborations); } /* Obtain any pending elaborations and clear the old list. */ tree get_pending_elaborations () { /* Each thing added to the list went on the end; we want it on the beginning. */ tree result = nreverse (pending_elaborations); pending_elaborations = 0; return result; } /* Returns a LABEL_DECL node for LABEL_NAME. */ tree create_label_decl (label_name) char *label_name; { tree label_id = get_identifier (label_name); tree label_decl = build_decl (LABEL_DECL, label_id, void_type_node); DECL_CONTEXT (label_decl) = current_function_decl; DECL_MODE (label_decl) = VOIDmode; DECL_SOURCE_LINE (label_decl) = lineno; DECL_SOURCE_FILE (label_decl) = input_filename; return label_decl; } /* Returns a FUNCTION_DECL node. SUBPROG_NAME is the name of the subprogram, ASM_NAME is its assembler name, SUBPROG_TYPE is its type (a FUNCTION_TYPE node), PARAM_DECL_LIST is the list of the subprogram arguments (a list of PARM_DECL nodes chained through the TREE_CHAIN field). INLINE_FLAG, PUBLIC_FLAG, EXTERN_FLAG, and PURE_FLAG are used to set the appropriate fields in the FUNCTION_DECL. */ tree create_subprog_decl (subprog_name, asm_name, subprog_type, param_decl_list, inline_flag, public_flag, extern_flag, pure_flag) char *subprog_name; char *asm_name; tree subprog_type; tree param_decl_list; int inline_flag; int public_flag; int extern_flag; int pure_flag; { tree subprog_id = get_identifier (subprog_name); tree return_type = TREE_TYPE (subprog_type); tree subprog_decl = build_decl (FUNCTION_DECL, subprog_id, subprog_type); DECL_EXTERNAL (subprog_decl) = extern_flag; TREE_PUBLIC (subprog_decl) = public_flag; DECL_INLINE (subprog_decl) = inline_flag; TREE_READONLY (subprog_decl) = pure_flag; DECL_ARGUMENTS (subprog_decl) = param_decl_list; DECL_RESULT (subprog_decl) = build_decl (RESULT_DECL, 0, return_type); if (asm_name) DECL_ASSEMBLER_NAME (subprog_decl) = get_identifier (asm_name); /* Add this decl to the current binding level. */ subprog_decl = pushdecl (subprog_decl); /* Output the assembler code and/or RTL for the declaration. */ rest_of_decl_compilation (subprog_decl, 0, global_bindings_p (), 0); return subprog_decl; } /* Count how deep we are into nested functions. This is because we shouldn't call the backend function context routines unless we are in a nested function. */ static int function_nesting_depth; /* Set up the framework for generating code for SUBPROG_DECL, a subprogram body. This routine needs to be invoked before processing the declarations appearing in the subprogram. */ void begin_subprog_body (subprog_decl) tree subprog_decl; { tree param_decl_list; tree param_decl; tree next_param; if (function_nesting_depth++ != 0) push_function_context (); announce_function (subprog_decl); /* Make this field nonzero so further routines know that this is not tentative. error_mark_node is replaced below (in poplevel) with the adequate BLOCK. */ DECL_INITIAL (subprog_decl) = error_mark_node; /* This is a definition, not a reference. So clear DECL_EXTERNAL. */ DECL_EXTERNAL (subprog_decl) = 0; /* This function exists in static storage. This does not mean `static' in the C sense! */ TREE_STATIC (subprog_decl) = 1; /* Enter a new binding level. */ temporary_allocation (); current_function_decl = subprog_decl; pushlevel (0); make_function_rtl (subprog_decl); /* Push all the PARM_DECL nodes onto the current scope (i.e. the scope of the subprogram body) so that they can be recognized as local variables in the subprogram. The list of PARM_DECL nodes is stored in the right order in DECL_ARGUMENTS. Since ..._DECL nodes get stored in the reverse order in which they are transmitted to `pushdecl' we need to reverse the list of PARM_DECLs if we want it to be stored in the right order. The reason why we want to make sure the PARM_DECLs are stored in the correct order is that this list will be retrieved in a few lines with a call to `getdecl' to store it back into the DECL_ARGUMENTS field. */ param_decl_list = nreverse (DECL_ARGUMENTS (subprog_decl)); for (param_decl = param_decl_list; param_decl; param_decl = next_param) { next_param = TREE_CHAIN (param_decl); TREE_CHAIN (param_decl) = NULL; pushdecl (param_decl); } /* Store back the PARM_DECL nodes. They appear in the right order. */ DECL_ARGUMENTS (subprog_decl) = getdecls (); init_function_start (subprog_decl, input_filename, lineno); expand_function_start (subprog_decl, 0); } /* Finish the definition of the current subprogram and compile it all the way to assembler language output. */ void end_subprog_body (void) { poplevel (1, 0, 1); /* Mark the RESULT_DECL as being in this subprogram. */ DECL_CONTEXT (DECL_RESULT (current_function_decl)) = current_function_decl; expand_function_end (input_filename, lineno, 0); rest_of_compilation (current_function_decl); /* If we are not at the bottom of the function nesting stack, pop up to the containing function. Otherwise show we aren't in any function and switch back to permanent allocation. */ if (--function_nesting_depth != 0) pop_function_context (); else { current_function_decl = 0; permanent_allocation (); } } /* Return 1 if EXP contains a PLACEHOLDER_EXPR for any type other than T; i.e., if it represents a size or offset that depends on a field within a record other than the RECORD_TYPE denoted by T. If T is zero, return 1 for any PLACEHOLDER_EXPR. Note that we only allow such expressions within simple arithmetic or a COND_EXPR. */ static int contains_placeholder_except_p (exp, t) tree exp; tree t; { register enum tree_code code = TREE_CODE (exp); tree inner; /* If we have a WITH_RECORD_EXPR, it "cancels" any PLACEHOLDER_EXPR in it since it is supplying a value for it. */ if (code == WITH_RECORD_EXPR) return 0; switch (TREE_CODE_CLASS (code)) { case 'r': for (inner = TREE_OPERAND (exp, 0); TREE_CODE_CLASS (TREE_CODE (inner)) == 'r'; inner = TREE_OPERAND (inner, 0)) ; return (TREE_CODE (inner) == PLACEHOLDER_EXPR && TREE_TYPE (inner) != t); case '1': case '2': case '<': case 'e': switch (tree_code_length[(int) code]) { case 1: return contains_placeholder_except_p (TREE_OPERAND (exp, 0), t); case 2: return (code != RTL_EXPR && code != CONSTRUCTOR && ! (code == SAVE_EXPR && SAVE_EXPR_RTL (exp) != 0) && code != WITH_RECORD_EXPR && (contains_placeholder_except_p (TREE_OPERAND (exp, 0), t) || contains_placeholder_except_p (TREE_OPERAND (exp, 1), t))); case 3: return (code == COND_EXPR && (contains_placeholder_except_p (TREE_OPERAND (exp, 0), t) || contains_placeholder_except_p (TREE_OPERAND (exp, 1), t) || contains_placeholder_except_p (TREE_OPERAND (exp, 2), t))); } } return 0; } #ifndef MAX_BITS_PER_WORD #define MAX_BITS_PER_WORD BITS_PER_WORD #endif /* This variable keeps a table for types for each precision so that we only allocate each of them once. Signed and unsigned types are kept separate. Note that these types are only used when fold-const requests something special. Perhaps we should NOT share these types; we'll see how it goes later. */ static tree signed_and_unsigned_types[MAX_BITS_PER_WORD + 1][2]; /* Return an integer type with the number of bits of precision given by PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise it is a signed type. */ tree type_for_size (precision, unsignedp) unsigned precision; int unsignedp; { tree t; int moment; if (precision <= MAX_BITS_PER_WORD && signed_and_unsigned_types[precision][unsignedp] != 0) return signed_and_unsigned_types[precision][unsignedp]; /* Since we will keep these types around, they must be permanent. */ moment = suspend_momentary (); push_obstacks_nochange (); end_temporary_allocation (); if (unsignedp) t = signed_and_unsigned_types[precision][1] = make_unsigned_type (precision); else t = signed_and_unsigned_types[precision][0] = make_signed_type (precision); pop_obstacks (); resume_momentary (moment); return t; } /* Return a data type that has machine mode MODE. UNSIGNEDP selects an unsigned type; otherwise a signed type is returned. */ tree type_for_mode (mode, unsignedp) enum machine_mode mode; int unsignedp; { return type_for_size (GET_MODE_BITSIZE (mode), unsignedp); } /* Return the unsigned version of a TYPE_NODE, a scalar type. */ tree unsigned_type (type_node) tree type_node; { return type_for_size (TYPE_PRECISION (type_node), 1); } /* Return the signed version of a TYPE_NODE, a scalar type. */ tree signed_type (type_node) tree type_node; { return type_for_size (TYPE_PRECISION (type_node), 0); } /* Return a type the same as TYPE except unsigned or signed according to UNSIGNEDP. */ tree signed_or_unsigned_type (unsignedp, type) int unsignedp; tree type; { if (! INTEGRAL_TYPE_P (type) || TREE_UNSIGNED (type) == unsignedp) return type; else return type_for_size (TYPE_PRECISION (type), unsignedp); } /* EXP is an expression for the size of an object. If this size contains discriminant references, replace them with the maximum (if MAX_P) or minimum (if ! MAX_P) possible value of the discriminant. */ tree max_size (exp, max_p) tree exp; int max_p; { enum tree_code code = TREE_CODE (exp); tree type = TREE_TYPE (exp); switch (TREE_CODE_CLASS (code)) { case 'd': case 'c': return exp; case 'r': /* If this contains a PLACEHOLDER_EXPR, it is the thing we want to modify. Otherwise, we abort since it is something we can't handle. */ if (! contains_placeholder_p (exp)) abort (); type = TREE_TYPE (TREE_OPERAND (exp, 1)); return max_size (max_p ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type), 1); case '1': case '2': case '<': case 'e': switch (tree_code_length[(int) code]) { case 1: return fold (build1 (code, type, max_size (TREE_OPERAND (exp, 0), code == NEGATE_EXPR ? ! max_p : max_p))); case 2: if (code == RTL_EXPR) abort (); return fold (build (code, type, max_size (TREE_OPERAND (exp, 0), max_p), max_size (TREE_OPERAND (exp, 1), code == MINUS_EXPR ? ! max_p : max_p))); case 3: if (code == SAVE_EXPR) return exp; else if (code == COND_EXPR) return fold (build (MAX_EXPR, type, max_size (TREE_OPERAND (exp, 1), max_p), max_size (TREE_OPERAND (exp, 2), max_p))); } } abort (); } /* Convert a pointer to a constrained array into a pointer to an unconstrained array. This involves making a template. If ALLOCATE is nonzero, the template must be created using an allocator instead of in the current context's memory. */ tree convert_to_unconstrained (type, expr, allocate) tree type; tree expr; int allocate; { tree template_elts = NULL_TREE; tree template_type = TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type)))); tree template_cons, template_addr; tree field; tree array_type; /* If EXPR is a constant of zero, we make a fat pointer that has a null pointer to the template and array. */ if (integer_zerop (expr)) return build_constructor (type, tree_cons (TYPE_FIELDS (type), convert (TREE_TYPE (TYPE_FIELDS (type)), expr), tree_cons (TREE_CHAIN (TYPE_FIELDS (type)), convert (build_pointer_type (template_type), expr), NULL_TREE))); /* First make a the list for a CONSTRUCTOR for the template. Do down the field list of the template instead of the type chain because this array might be an Ada array of arrays and we can't tell where the nested arrays stop being the underlying object. */ for (array_type = TREE_TYPE (TREE_TYPE (expr)), field = TYPE_FIELDS (template_type); field; array_type = TREE_TYPE (array_type), field = TREE_CHAIN (TREE_CHAIN (field))) { tree min = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (array_type))); tree max = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (array_type))); /* If either MIN or MAX involve a PLACEHOLDER_EXPR, we must surround them with a WITH_RECORD_EXPR giving EXPR as the OBJECT. */ if (! TREE_CONSTANT (min) && contains_placeholder_p (min)) min = build (WITH_RECORD_EXPR, TREE_TYPE (min), min, expr); if (! TREE_CONSTANT (max) && contains_placeholder_p (max)) max = build (WITH_RECORD_EXPR, TREE_TYPE (max), max, expr); template_elts = tree_cons (field, min, tree_cons (TREE_CHAIN (field), max, template_elts)); } template_cons = build_constructor (template_type, template_elts); /* If the template needs to be allocated the heap, build a constructor for it. Otherwise, just take the address of the constructor. */ if (allocate) template_addr = build_allocator (template_type, template_cons, 0, build_pointer_type (template_type)); else template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template_cons); /* The result is a CONSTRUCTOR for the fat pointer. */ return build_constructor (type, tree_cons (TYPE_FIELDS (type), expr, tree_cons (TREE_CHAIN (TYPE_FIELDS (type)), template_addr, NULL_TREE))); } /* Create an expression whose value is that of EXPR, converted to type TYPE. The TREE_TYPE of the value is always TYPE. This function implements all reasonable conversions; callers should filter out those that are not permitted by the language being compiled. */ tree convert (type, expr) tree type, expr; { enum tree_code code = TREE_CODE (type); /* If EXPR is already the right type, we are done. */ if (type == TREE_TYPE (expr)) return expr; /* There are some special cases of expressions that we process specially. */ switch (TREE_CODE (expr)) { case ERROR_MARK: return expr; case TRANSFORM_EXPR: /* Just set its type here. We will do the actual conversion in gnat_expand_expr. */ TREE_TYPE (expr) = type; return expr; case STRING_CST: /* If we are converting a STRING_CST to another constrained array type, just make a new one in the proper type. */ if (TREE_CODE (type) != ARRAY_TYPE) break; expr = copy_node (expr); TREE_TYPE (expr) = type; return expr; case UNCONSTRAINED_ARRAY_REF: /* Convert this to the type of the inner array by getting the address of the array from the template. */ expr = build_unary_op (INDIRECT_REF, NULL_TREE, build_component_ref (TREE_OPERAND (expr, 0), get_identifier ("p_array"), NULL_TREE)); break; } /* Check for converting a pointer to a constrained array into a pointer to a constrained array. */ if (TYPE_FAT_POINTER_P (type) && (integer_zerop (expr) || (TREE_CODE (TREE_TYPE (expr)) == POINTER_TYPE && TREE_CODE (TREE_TYPE (TREE_TYPE (expr))) == ARRAY_TYPE))) return convert_to_unconstrained (type, expr, 0); if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (expr))) return fold (build1 (NOP_EXPR, type, expr)); switch (code) { case VOID_TYPE: return build1 (CONVERT_EXPR, type, expr); case INTEGER_TYPE: case ENUMERAL_TYPE: return fold (convert_to_integer (type, expr)); case POINTER_TYPE: return fold (convert_to_pointer (type, expr)); case REAL_TYPE: return fold (convert_to_real (type, expr)); case ARRAY_TYPE: case RECORD_TYPE: /* In these cases, assume the front-end has validated the conversion. If the conversion is valid, it will bit a bit-wise conversion, so it can be viewed as an unchecked conversion. */ return build1 (UNCHECKED_CONVERT_EXPR, type, expr); case UNCONSTRAINED_ARRAY_TYPE: /* In this case EXPR must be a constrained array. In that case, take its address, convert it to a fat pointer, and then dereference it. */ if (TREE_CODE (TREE_TYPE (expr)) != ARRAY_TYPE) abort (); return build_unary_op (INDIRECT_REF, NULL_TREE, convert_to_unconstrained (TREE_TYPE (type), build_unary_op (ADDR_EXPR, NULL_TREE, expr), 0)); default: abort (); } } ne mode MODE. UNSIGNEDP selects gnat-1.67-src/src/a-trans3.h 444 10015 7640 34530 5506244461 10745 /****************************************************************************/ /* */ /* GNAT COMPILER COMPONENTS */ /* */ /* ADA CHAPTER 3: DECLARATIONS AND TYPES */ /* - GNU SPECIFIC - */ /* */ /* Specification */ /* */ /* $Revision: 1.39 $ */ /* */ /* Copyright (c) 1992,1993, NYU, All Rights Reserved */ /* */ /* 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 */ /* Software Foundation; either version 2, or (at your option) any later */ /* version. GNAT is distributed in the hope that it will be useful, but */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- */ /* ABILITY 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 GNAT; see file COPYING. If not, write */ /* to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* */ /****************************************************************************/ /* Standard data type sizes. Most of these are not used. */ #ifndef CHAR_TYPE_SIZE #define CHAR_TYPE_SIZE BITS_PER_UNIT #endif #ifndef SHORT_TYPE_SIZE #define SHORT_TYPE_SIZE (BITS_PER_UNIT * MIN ((UNITS_PER_WORD + 1) / 2, 2)) #endif #ifndef INT_TYPE_SIZE #define INT_TYPE_SIZE BITS_PER_WORD #endif #ifndef LONG_TYPE_SIZE #define LONG_TYPE_SIZE BITS_PER_WORD #endif #ifndef LONG_LONG_TYPE_SIZE #define LONG_LONG_TYPE_SIZE (BITS_PER_WORD * 2) #endif #ifndef FLOAT_TYPE_SIZE #define FLOAT_TYPE_SIZE BITS_PER_WORD #endif #ifndef DOUBLE_TYPE_SIZE #define DOUBLE_TYPE_SIZE (BITS_PER_WORD * 2) #endif #ifndef LONG_DOUBLE_TYPE_SIZE #define LONG_DOUBLE_TYPE_SIZE (BITS_PER_WORD * 2) #endif /* The choice of SIZE_TYPE here is very problematic. We need a signed type whose bit width is Pmode. Assume "long" is such a type here. */ #undef SIZE_TYPE #define SIZE_TYPE "long int" /* Flags added to GCC type nodes. */ /* Nonzero if this type is a record corresponding to a fat pointer. */ #define TYPE_FAT_POINTER_P(NODE) TYPE_LANG_FLAG_0 (NODE) /* Nonzero if this is a modular type with a modulus that is not equal to two to the power of its mode's size. */ #define TYPE_MODULAR_P(NODE) TYPE_LANG_FLAG_1 (NODE) /* Nonzero if this is a FUNCTION_TYPE that denotes a function returning an unconstrained array or record. */ #define TYPE_RETURNS_UNCONSTRAINED_P(NODE) TYPE_LANG_FLAG_2 (NODE) /* This field is only defined for FUNCTION_TYPE nodes. If the Ada subprogram contains no parameters passed by copy in/copy out then this field is 0. Otherwise it points to a list of nodes used to specify the return values of the out (or in out) parameters that qualify to be passed by copy in copy out. It is a CONSTRUCTOR. For a full description of the cico parameter passing mechanism refer to the routine gnat_to_gnu_entity. */ #define TYPE_CI_CO_LIST(NODE) (tree) TYPE_LANG_SPECIFIC (NODE) /* For an INTEGER_TYPE with TYPE_MODULAR_P, this is the value of the modulus. */ #define TYPE_MODULUS(NODE) (tree) TYPE_LANG_SPECIFIC (NODE) /* For an INTEGER_TYPE that is the TYPE_DOMAIN of some ARRAY_TYPE, points to the type corresponding to the Ada index type. */ #define TYPE_INDEX_TYPE(NODE) (tree) TYPE_LANG_SPECIFIC (NODE) /* For a RECORD_TYPE that is a fat pointer, point to the type for the unconstrained object. */ #define TYPE_UNCONSTRAINED_ARRAY(NODE) (tree) TYPE_LANG_SPECIFIC (NODE) /* For a RECORD_TYPE that is not a fat pointer, point to the original subtype for the _parent field, if there was one. */ #define TYPE_PARENT_SUBTYPE(NODE) (tree) TYPE_LANG_SPECIFIC (NODE) /* Nonzero in a FIELD_DECL that represents a discriminant. */ #define DECL_DISCRIMINANT_P(NODE) DECL_LANG_FLAG_0 (NODE) /* Nonzero if this decl is always used by reference; i.e., an INDIRECT_REF is needed to access the object. */ #define DECL_BY_REF_P(NODE) DECL_LANG_FLAG_1 (NODE) /* Nonzero in a FIELD_DECL that is a parent field. */ #define DECL_PARENT_P(NODE) DECL_LANG_FLAG_2 (NODE) /* Variables expected by the GCC back-end. */ /* A node which has tree code ERROR_MARK, and whose type is itself. */ extern tree error_mark_node; /* Various standard data types and nodes. */ extern tree integer_type_node; extern tree unsigned_type_node; extern tree char_type_node; extern tree void_type_node; extern tree void_type_decl_node; extern tree integer_zero_node; extern tree integer_one_node; extern tree null_pointer_node; /* The FUNCTION_DECL node for the function currently being compiled, or 0 if between functions. */ extern tree current_function_decl; /* Variables created for the sole tree translator sake. Their names and types can be changed as desired. */ /* type declaration node <==> typedef void *T */ extern tree ptr_void_type_node; /* function type declaration -- void T() */ extern tree void_ftype; /* type declaration node <==> typedef void *T() */ extern tree ptr_void_ftype; /* A function declaration node for a run-time function for allocating memory. Ada allocators cause calls to this function to be generated. */ extern tree malloc_decl; /* Types and decls used by our temporary exception mechanism. See init_decl_processing for details. */ extern tree jmpbuf_type; extern tree jmpbuf_ptr_type; extern tree jmpbuf_decl; extern tree excptr_decl; extern tree longjmp_decl; extern tree setjmp_decl; extern tree raise_constraint_decl; extern tree unchecked_union_node; /* Routines expected by the gcc back-end. They must have exactly the same prototype and names as below. */ /* Returns non-zero if we are currently in the global binding level */ extern int global_bindings_p PROTO((void)); /* Returns the list of declarations in the current level. Note that this list is in reverse order (it has to be so for back-end compatibility). */ extern tree getdecls PROTO((void)); /* Nonzero if the current level needs to have a BLOCK made. */ extern int kept_level_p PROTO((void)); /* Enter a new binding level. The input parameter is ignored, but has to be specified for back-end compatibility. */ extern void pushlevel PROTO((int)); /* Exit a binding level. Pop the level off, and restore the state of the identifier-decl mappings that were in effect when this level was entered. If KEEP is nonzero, this level had explicit declarations, so and create a "block" (a BLOCK node) for the level to record its declarations and subblocks for symbol table output. If FUNCTIONBODY is nonzero, this level is the body of a function, so create a block as if KEEP were set and also clear out all label names. If REVERSE is nonzero, reverse the order of decls before putting them into the BLOCK. */ extern tree poplevel PROTO((int,int, int)); /* Insert BLOCK at the end of the list of subblocks of the current binding level. This is used when a BIND_EXPR is expanded, to handle the BLOCK node inside the BIND_EXPR. */ extern void insert_block PROTO((tree)); /* Set the BLOCK node for the innermost scope (the one we are currently in). */ extern void set_block PROTO((tree)); /* Records a ..._DECL node DECL as belonging to the current lexical scope. Returns the ..._DECL node. */ extern tree pushdecl PROTO((tree)); /* Create the predefined scalar types such as `integer_type_node' needed in the gcc back-end and initialize the global binding level. */ extern void init_decl_processing PROTO((void)); /* Return an integer type with the number of bits of precision given by PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise it is a signed type. */ extern tree type_for_size PROTO((unsigned, int)); /* Return a data type that has machine mode MODE. UNSIGNEDP selects an unsigned type; otherwise a signed type is returned. */ extern tree type_for_mode PROTO((enum machine_mode, int)); /* Return the unsigned version of a TYPE_NODE, a scalar type. */ extern tree unsigned_type PROTO((tree)); /* Return the signed version of a TYPE_NODE, a scalar type. */ extern tree signed_type PROTO((tree)); /* Return a type the same as TYPE except unsigned or signed according to UNSIGNEDP. */ extern tree signed_or_unsigned_type PROTO((int, tree)); /* This routine is called in tree.c to print an error message for invalid use of an incomplete type. */ extern void incomplete_type_error PROTO((tree, tree)); /* This function is called indirectly from toplev.c to handle incomplete declarations, i.e. VAR_DECL nodes whose DECL_SIZE is zero. To be precise, compile_file in toplev.c makes an indirect call through the function pointer incomplete_decl_finalize_hook which is initialized to this routine in init_decl_processing. */ extern void finish_incomplete_decl PROTO((tree)); /* Create an expression whose value is that of EXPR, converted to type TYPE. The TREE_TYPE of the value is always TYPE. This function implements all reasonable conversions; callers should filter out those that are not permitted by the language being compiled. */ extern tree convert PROTO((tree, tree)); /* Routines created solely for the tree translator's sake. Their prototypes can be changed as desired. */ /* GNAT_DEFINING_IDENTIFIER is a GNAT tree node for a defining identifier. GNU_DECL is the GCC tree which is to be associated with GNAT_DEFINING_IDENTIFIER. Such gnu tree node is always an ..._DECL node. If NO_CHECK is nonzero, the latter check is suppressed. If GNU_DECL is zero, a previous association is to be reset. */ extern void save_gnu_tree PROTO((gnat_tree, tree, int)); /* GNAT_DEFINING_IDENTIFIER is a GNAT tree node for a defining identifier. Return the ..._DECL node that was associated with it. If there is no tree node associated with GNAT_DEFINING_IDENTIFIER, abort. */ extern tree get_gnu_tree PROTO((gnat_tree)); /* Return nonzero if a GCC tree has been associated with GNAT_DEFINING_IDENTIFIER. */ extern int present_gnu_tree PROTO((gnat_tree)); /* Initialize tables for above routines. */ extern void init_gnat_to_gnu PROTO((void)); /* Given a record type (RECORD_TYPE) and a chain of FIELD_DECL nodes (FIELDLIST), finish constructing the record or union type. */ extern void finish_record_type PROTO((tree, tree)); /* Returns a FUNCTION_TYPE node. RETURN_TYPE is the type returned by the subprogram. If it is void_type_node, then we are dealing with a procedure, otherwise we are dealing with a function. PARAM_DECL_LIST is a list of PARM_DECL nodes that are the subprogram arguments. CICO_LIST is the copy-in/copy-out list to be stored into TYPE_CI_CO_LIST. */ extern tree create_subprog_type PROTO((tree, tree, tree)); /* Returns a TYPE_DECL node. TYPE_NAME gives the name of the type (a character string) and TYPE is a ..._TYPE node giving its data type. */ extern tree create_type_decl PROTO((char *, tree)); /* Returns a GCC VAR_DECL node. VAR_NAME gives the name of the variable (a character string). ASM_NAME is its assembler name (if provided). TYPE is its data type (a GCC ..._TYPE node). VAR_INIT is the GCC tree for an optional initial expression; NULL_TREE if none. CONST_FLAG is nonzero if this variable is constant. PUBLIC_FLAG is nonzero if this definition is to be made visible outside of the current compilation unit. This flag should be set when processing the variable definitions in a package specification. EXTERN_FLAG is nonzero when processing an external variable declaration (as opposed to a definition: no storage is to be allocated for the variable here). STATIC_FLAG is only relevant when not at top level. In that case it indicates whether to always allocate storage to the variable. VOLATILE_FLAG is true if the variable is to be treated as volatile. */ extern tree create_var_decl PROTO((char *, char *, tree, tree, int, int, int, int, int)); /* Obtain any pending elaborations and clear the old list. */ extern tree get_pending_elaborations PROTO((void)); /* Add some pending elaborations to the current list. */ extern void add_pending_elaborations PROTO ((tree, tree)); /* Returns a FIELD_DECL node. FIELD_NAME the field name, FIELD_TYPE is its type, and RECORD_TYPE is the type of the parent. PACKED is nonzero if this field is in a record type with a "pragma pack". */ extern tree create_field_decl PROTO((char *, tree, tree, int)); /* Returns a PARM_DECL node. PARAM_NAME is the name of the parameter, PARAM_TYPE is its type. */ extern tree create_param_decl PROTO((char *, tree)); /* Returns a FUNCTION_DECL node. SUBPROG_NAME is the name of the subprogram, ASM_NAME is its assembler name, SUBPROG_TYPE is its type (a FUNCTION_TYPE node), PARAM_DECL_LIST is the list of the subprogram arguments (a list of PARM_DECL nodes chained through the TREE_CHAIN field). INLINE_FLAG, PUBLIC_FLAG, EXTERN_FLAG, and PURE_FLAG are used to set the appropriate fields in the FUNCTION_DECL. */ extern tree create_subprog_decl PROTO((char *, char *, tree, tree, int, int, int, int)); /* Returns a LABEL_DECL node for LABEL_NAME. */ extern tree create_label_decl PROTO((char *)); /* Set up the framework for generating code for SUBPROG_DECL, a subprogram body. This routine needs to be invoked before processing the declarations appearing in the subprogram. */ extern void begin_subprog_body PROTO((tree)); /* Finish the definition of the current subprogram and compile it all the way to assembler language output. */ extern void end_subprog_body PROTO((void)); /* Convert a pointer to a constrained array into a pointer to an unconstrained array. This involves making a template. If ALLOCATE is nonzero, the template must be created using an allocator instead of in the current context's memory. */ extern tree convert_to_unconstrained PROTO((tree, tree, int)); /* EXP is an expression for the size of an object. If this size contains discriminant references, replace them with the maximum (if MAX_P) or minimum (if ! MAX_P) possible value of the discriminant. */ extern tree max_size PROTO((tree, int)); * Enter a new binding level. The input parameter is ignored, but has to be specified for back-end compatibility. */ extern void pushlevel PROTO((int)); /* Exit agnat-1.67-src/src/a-trans4.c 444 10015 7640 54516 5506244462 10750 /****************************************************************************/ /* */ /* GNAT COMPILER COMPONENTS */ /* */ /* ADA CHAPTER 4: NAMES AND EXPRESSIONS */ /* - GNU SPECIFIC - */ /* */ /* Body */ /* */ /* $Revision: 1.43 $ */ /* */ /* Copyright (c) 1992,1993, NYU, All Rights Reserved */ /* */ /* 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 */ /* Software Foundation; either version 2, or (at your option) any later */ /* version. GNAT is distributed in the hope that it will be useful, but */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- */ /* ABILITY 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 GNAT; see file COPYING. If not, write */ /* to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* */ /****************************************************************************/ #include "config.h" #include "tree.h" #include "flags.h" #include "a-ada.h" #include "a-types.h" #include "a-atree.h" #include "a-sinfo.h" #include "a-einfo.h" #include "a-namet.h" #include "a-string.h" #include "a-uint.h" #include "a-trans.h" #include "a-trans3.h" #include "a-trans4.h" #include "a-misc.h" /* Prepare expr to be an argument of a TRUTH_NOT_EXPR or other logical operation. This preparation consists of taking the ordinary representation of an expression expr and producing a valid tree boolean expression describing whether expr is nonzero. We could simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1), but we optimize comparisons, &&, ||, and !. The resulting type should always be the same as the input type. This function is simpler than the corresponding C version since the only possible operands will be things of Boolean type. */ tree truthvalue_conversion (expr) tree expr; { register enum tree_code code; tree type = TREE_TYPE (expr); switch (TREE_CODE (expr)) { case EQ_EXPR: case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR: case TRUTH_ANDIF_EXPR: case TRUTH_ORIF_EXPR: case TRUTH_AND_EXPR: case TRUTH_OR_EXPR: case TRUTH_XOR_EXPR: case ERROR_MARK: return expr; case COND_EXPR: /* Distribute the conversion into the arms of a COND_EXPR. */ return fold (build (COND_EXPR, type, TREE_OPERAND (expr, 0), truthvalue_conversion (TREE_OPERAND (expr, 1)), truthvalue_conversion (TREE_OPERAND (expr, 2)))); } return build_binary_op (NE_EXPR, type, expr, convert (type, integer_zero_node)); } /* We have a comparison or assignment operation on two array types, T1 and T2. Return the type that both operands should be converted to, if any. Otherwise return zero. */ static tree find_common_array_type (t1, t2) tree t1, t2; { /* If either type is non-BLKmode, use it. Note that we know that we will not have any alignment problems since if we did the non-BLKmode type could not have been used. */ if (TYPE_MODE (t1) != BLKmode) return t1; else if (TYPE_MODE (t2) != BLKmode) return t2; /* Otherwise, return the type that has a constant size. */ if (TREE_CONSTANT (TYPE_SIZE (t1))) return t1; else if (TREE_CONSTANT (TYPE_SIZE (t2))) return t2; /* In this case, both types have variable size. It's probably best to leave the "type mismatch" because changing it could case a bad self-referential reference. */ return 0; } /* Make a binary operation of kind OP_CODE. RESULT_TYPE is the type desired for the result. Usually the operation is to be performed in that type. For MODIFY_EXPR and ARRAY_REF, RESULT_TYPE may be 0 in which case the type to be used will be derived from the operands. This function is very much unlike the ones for C and C++ since we have already done any type conversion and matching required. All we have to do here is validate the work done by SEM and handle subtypes. */ tree build_binary_op (op_code, result_type, left_operand, right_operand) enum tree_code op_code; tree result_type; tree left_operand; tree right_operand; { tree left_type = TREE_TYPE (left_operand); tree right_type = TREE_TYPE (right_operand); tree left_base_type = left_type, right_base_type = right_type; tree operation_type = result_type; tree result; int has_side_effects = 0; int suppress_modulus = 0; /* Get the base types of both operands for integer and real types. */ if (TREE_CODE (left_base_type) == INTEGER_TYPE && TREE_TYPE (left_base_type) != 0) left_base_type = TREE_TYPE (left_base_type); if (TREE_CODE (right_base_type) == INTEGER_TYPE && TREE_TYPE (right_base_type) != 0) right_base_type = TREE_TYPE (right_base_type); switch (op_code) { case MODIFY_EXPR: if (operation_type == 0) operation_type = left_type; /* If we are copying one array to another, find the best type to use. */ if (TREE_CODE (left_type) == ARRAY_TYPE && TREE_CODE (right_type) == ARRAY_TYPE) { tree best_type = find_common_array_type (left_type, right_type); if (best_type && left_type != best_type) left_operand = convert (best_type, left_operand); if (best_type && right_type != best_type) right_operand = convert (best_type, right_operand); if (best_type) operation_type = best_type; } else if (TREE_TYPE (right_operand) != operation_type) right_operand = convert (operation_type, right_operand); has_side_effects = 1; suppress_modulus = 1; break; case ARRAY_REF: if (operation_type == 0) operation_type = TREE_TYPE (left_type); if (right_type != TYPE_DOMAIN (left_type)) right_operand = convert (TYPE_DOMAIN (left_type), right_operand); suppress_modulus = 1; break; case GE_EXPR: case LE_EXPR: case GT_EXPR: case LT_EXPR: if (TREE_CODE (left_type) == POINTER_TYPE) abort (); /* ... fall through ... */ case EQ_EXPR: case NE_EXPR: /* Unless the objects are arrays or records, the base types must be the same; convert both operands to the base types. If we have arrays, use the best type. */ if (left_base_type != right_base_type) { if (TREE_CODE (left_base_type) == ARRAY_TYPE && TREE_CODE (right_base_type) == ARRAY_TYPE) { tree best_type = find_common_array_type (left_type, right_type); if (best_type && left_type != best_type) left_operand = convert (best_type, left_operand); if (best_type && right_type != best_type) right_operand = convert (best_type, right_operand); } else if (TREE_CODE (left_base_type) == RECORD_TYPE && TREE_CODE (right_base_type) == RECORD_TYPE) { /* The only way these are permitted to be the same is if both types have the same name. In that case, one of them must not be self-referential. Use that one as the best type. Even better is if one is of fixed size. */ tree best_type = 0; if (TYPE_NAME (left_base_type) == 0 || TYPE_NAME (left_base_type) != TYPE_NAME (right_base_type)) abort (); if (TREE_CONSTANT (TYPE_SIZE (left_base_type))) best_type = left_base_type; else if (TREE_CONSTANT (TYPE_SIZE (right_base_type))) best_type = right_base_type; else if (! contains_placeholder_p (TYPE_SIZE (left_base_type))) best_type = left_base_type; else if (! contains_placeholder_p (TYPE_SIZE (right_base_type))) best_type = right_base_type; else abort (); left_operand = convert (best_type, left_operand); right_operand = convert (best_type, right_operand); } else abort (); } /* If we are comparing a fat pointer against zero, we need to just compare the template pointer. */ else if (TYPE_FAT_POINTER_P (left_base_type) && TREE_CODE (right_operand) == CONSTRUCTOR && integer_zerop (TREE_VALUE (TREE_OPERAND (right_operand, 1)))) { right_operand = build_component_ref (left_operand, NULL_TREE, TYPE_FIELDS (left_base_type)); left_operand = convert (TREE_TYPE (right_operand), integer_zero_node); } else { left_operand = convert (left_base_type, left_operand); right_operand = convert (right_base_type, right_operand); } suppress_modulus = 1; break; case PREINCREMENT_EXPR: case PREDECREMENT_EXPR: case POSTINCREMENT_EXPR: case POSTDECREMENT_EXPR: /* In these, the result type and the left operand type should be the same. Do the operation in that type and convert the right operand (which is an integer) to the left type. */ if (left_type != result_type) abort (); right_operand = convert (left_type, right_operand); has_side_effects = 1; break; case TRUTH_ANDIF_EXPR: case TRUTH_ORIF_EXPR: case TRUTH_AND_EXPR: case TRUTH_OR_EXPR: case TRUTH_XOR_EXPR: left_operand = truthvalue_conversion (left_operand); right_operand = truthvalue_conversion (right_operand); /* ... fall through ... */ default: /* The result type should be the same as the base types of the both operands (and they should be the same). Convert everything to the result type. */ if (result_type != left_base_type || left_base_type != right_base_type) abort (); left_operand = convert (result_type, left_operand); right_operand = convert (result_type, right_operand); } result = build (op_code, operation_type, left_operand, right_operand); TREE_SIDE_EFFECTS (result) = has_side_effects; if (result_type != 0 && result_type != operation_type) result = convert (result_type, result); result = fold (result); TREE_CONSTANT (result) = TREE_CONSTANT (left_operand) & TREE_CONSTANT (right_operand); /* If we are working with modular types, perform the MOD operation. */ if (! suppress_modulus && TYPE_MODULAR_P (result_type)) result = fold (build (TRUNC_MOD_EXPR, result_type, result, convert (result_type, TYPE_MODULUS (result_type)))); return result; } /* Similar, but for unary operations. */ tree build_unary_op (op_code, result_type, operand) enum tree_code op_code; tree result_type; tree operand; { tree type = TREE_TYPE (operand); tree base_type; tree result; int suppress_modulus = 0; int side_effects = 0; /* Get the base types of the operand for integer and real types. */ for (base_type = type; (INTEGRAL_TYPE_P (base_type) || FLOAT_TYPE_P (base_type)) && TREE_TYPE (base_type); base_type = TREE_TYPE (base_type)) ; switch (op_code) { case TRUTH_NOT_EXPR: if (result_type != base_type) abort (); result = invert_truthvalue (truthvalue_conversion (operand)); break; case ADDR_EXPR: if (TREE_CODE (operand) == INDIRECT_REF || TREE_CODE (operand) == UNCONSTRAINED_ARRAY_REF) result = TREE_OPERAND (operand, 0); else result = fold (build1 (op_code, build_pointer_type (type), operand)); TREE_CONSTANT (result) = staticp (operand) || TREE_CONSTANT (operand); suppress_modulus = 1; break; case INDIRECT_REF: /* If we want to refer to an entire unconstrained array, make up an expression to do so. This will never survive to the backend. */ if (TYPE_FAT_POINTER_P (type)) result = build1 (UNCONSTRAINED_ARRAY_REF, TYPE_UNCONSTRAINED_ARRAY (type), operand); else result = fold (build1 (op_code, TREE_TYPE (type), operand)); suppress_modulus = 1; side_effects = flag_volatile; break; default: if (result_type != base_type) abort (); result = fold (build1 (op_code, result_type, convert (result_type, operand))); } if (side_effects) TREE_SIDE_EFFECTS (result) = 1; if (result_type != 0 && TREE_TYPE (result) != result_type) result = convert (result_type, result); /* If we are working with modular types, perform the MOD operation. */ if (! suppress_modulus && TYPE_MODULAR_P (result_type)) result = fold (build (TRUNC_MOD_EXPR, result_type, result, convert (result_type, TYPE_MODULUS (result_type)))); return result; } /* Return a CONSTRUCTOR of TYPE whose list is LIST. */ tree build_constructor (type, list) tree type; tree list; { tree elmt; int allconstant = 1; tree result; for (elmt = list; elmt; elmt = TREE_CHAIN (elmt)) if (! TREE_CONSTANT (TREE_VALUE (elmt))) allconstant = 0; result = build (CONSTRUCTOR, type, NULL_TREE, list); TREE_CONSTANT (result) = allconstant; TREE_STATIC (result) = allconstant; return result; } /* Return a COMPONENT_REF to access a field that is given by COMPONENT, an IDENTIFIER_NODE giving the name of the field, FIELD, a FIELD_DECL, for the field, or both. We also handle the fact that we might have been passed a pointer to the actual record and know how to look for fields in variant parts. */ tree build_component_ref (record_variable, component, field) tree record_variable; tree component; tree field; { tree record_type = TREE_TYPE (record_variable); tree ref; /* Handle added pointer for pass-by-reference values. */ if (TREE_CODE (record_type) == POINTER_TYPE) { record_variable = build_unary_op (INDIRECT_REF, NULL_TREE, record_variable); record_type = TREE_TYPE (record_variable); } if ((TREE_CODE (record_type) != RECORD_TYPE && TREE_CODE (record_type) != UNION_TYPE && TREE_CODE (record_type) != QUAL_UNION_TYPE) || TYPE_SIZE (record_type) == 0) abort (); if (field == 0 || DECL_CONTEXT (field) != record_type) /* Check if there is a field with name COMPONENT in the record. */ { if (component == 0) abort (); /* ??? Explore later if we can use the TYPE_LANG_SPECIFIC optimization that appears in C version of this function. */ for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field)) { if (DECL_NAME (field) == component) break; else if (DECL_NAME (field) == 0) { tree field_ref = build_component_ref (record_variable, NULL_TREE, field); ref = build_component_ref (field_ref, component, NULL_TREE); if (ref != 0) return ref; } } } if (!field) return 0; ref = build (COMPONENT_REF, TREE_TYPE (field), record_variable, field); if (TREE_READONLY (record_variable) || TREE_READONLY (field)) TREE_READONLY (ref) = 1; if (TREE_THIS_VOLATILE (record_variable) || TREE_THIS_VOLATILE (field)) TREE_THIS_VOLATILE (ref) = 1; return ref; } /* a variation of the precedant function which looks in the field __parent if the field is not defined at this level */ tree build_tagged_component_ref (record_variable, component, field) tree record_variable; tree component; tree field; { tree local_field; tree parent_ref; static tree parent_comp = 0; tree comp_ref; if (!parent_comp) parent_comp = get_identifier (Get_Name_String (Name_uParent)); /* We first see if the field is present at this level. */ comp_ref = build_component_ref (record_variable, component, field); if (comp_ref) return comp_ref; /* If it is not present we look recursively in the parent. */ parent_ref = build_component_ref (record_variable, parent_comp, NULL_TREE); if (parent_ref) return build_tagged_component_ref (parent_ref, component, field); else /* The field was not found in the hierarchy. Should not happen. */ abort (); } /* Build a GCC tree to correspond to allocating an object of TYPE whose initial value is INIT, if INIT is nonzero. Convert the expression to RESULT_TYPE, which must be some type of pointer. Return the tree. GNAT_TYPE is the type of the underlying object in case we need to call a record initialization procedure. */ tree build_allocator (type, init, gnat_type, result_type) tree type; tree init; gnat_tree gnat_type; tree result_type; { tree size = TYPE_SIZE (type); tree ptr_type; tree result; /* If TYPE is an unconstrained array, it must be the case that INIT is nonzero and an UNCONSTRAINED_ARRAY_REF. Set SIZE to be the sum of the sizes of the object, it's template, and the fat pointer. Allocate the whole thing and fill in the parts. */ if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE) { tree fat_ptr_type = TYPE_POINTER_TO (type); tree array_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (fat_ptr_type))); tree template_type = TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (fat_ptr_type)))); tree fat_ptr_size = TYPE_SIZE (fat_ptr_type); tree template_size = TYPE_SIZE (template_type); tree storage; tree old_template_ptr, old_array_ptr, new_template_ptr, new_array_ptr; if (init == 0 || TREE_CODE (init) != UNCONSTRAINED_ARRAY_REF) abort (); size = size_binop (PLUS_EXPR, build (WITH_RECORD_EXPR, sizetype, TYPE_SIZE (array_type), TREE_OPERAND (init, 0)), size_binop (PLUS_EXPR, fat_ptr_size, template_size)); storage = build (CALL_EXPR, build_pointer_type (char_type_node), build_unary_op (ADDR_EXPR, NULL_TREE, malloc_decl), build_tree_list (NULL_TREE, size_binop (CEIL_DIV_EXPR, size, size_int (BITS_PER_UNIT))), NULL_TREE); TREE_SIDE_EFFECTS (storage) = 1; storage = save_expr (storage); /* Skip the fat pointer to get the template, then skip both to get the memory for the array. */ new_template_ptr = convert (build_pointer_type (template_type), build (PLUS_EXPR, TREE_TYPE (storage), storage, convert (TREE_TYPE (storage), size_in_bytes (fat_ptr_type)))); new_array_ptr = convert (build_pointer_type (array_type), build (PLUS_EXPR, TREE_TYPE (storage), storage, convert (TREE_TYPE (storage), size_binop (PLUS_EXPR, size_in_bytes (fat_ptr_type), size_in_bytes (template_type))))); old_template_ptr = build_component_ref (TREE_OPERAND (init, 0), get_identifier ("p_template"), NULL_TREE); old_array_ptr = build_component_ref (TREE_OPERAND (init, 0), get_identifier ("p_array"), NULL_TREE); result = build_unary_op (INDIRECT_REF, fat_ptr_type, convert (build_pointer_type (fat_ptr_type), storage)); result = build (COMPOUND_EXPR, fat_ptr_type, build_binary_op (MODIFY_EXPR, template_type, build_unary_op (INDIRECT_REF, NULL_TREE, new_template_ptr), build_unary_op (INDIRECT_REF, NULL_TREE, old_template_ptr)), result); result = build (COMPOUND_EXPR, fat_ptr_type, build_binary_op (MODIFY_EXPR, array_type, build_unary_op (INDIRECT_REF, NULL_TREE, new_array_ptr), build_unary_op (INDIRECT_REF, NULL_TREE, old_array_ptr)), result); return build_binary_op (MODIFY_EXPR, fat_ptr_type, result, build_constructor (fat_ptr_type, tree_cons (TYPE_FIELDS (fat_ptr_type), new_array_ptr, tree_cons (TREE_CHAIN (TYPE_FIELDS (fat_ptr_type)), new_template_ptr, NULL_TREE)))); } /* If TYPE is an discriminated record, allocate an object that is the maximum size of the record. Note that the record must have had default discriminant or this would not be valid Ada. */ if (TREE_CODE (size) != INTEGER_CST && contains_placeholder_p (size)) size = max_size (size, 1); /* Call the allocator and return an object whose type is a pointer to TYPE. Note that we pass the size in bytes and convert to sizetype. */ result = build (CALL_EXPR, build_pointer_type (type), build_unary_op (ADDR_EXPR, NULL_TREE, malloc_decl), chainon (NULL_TREE, build_tree_list (NULL_TREE, size_binop (CEIL_DIV_EXPR, convert (sizetype, size), size_int (BITS_PER_UNIT)))), NULL_TREE); TREE_SIDE_EFFECTS (result) = 1; /* If we have an initial value, put the new address into a SAVE_EXPR, assign the value, and return the address. Do this with a COMPOUND_EXPR. */ if (init) { result = save_expr (result); result = build (COMPOUND_EXPR, TREE_TYPE (result), build_binary_op (MODIFY_EXPR, type, build_unary_op (INDIRECT_REF, type, result), init), result); } /* If the result is not of the proper type, convert it. But check for converting a pointer to a constrained type into a pointer to an unconstrained type. In that case, we have to allocate the template from memory as well. */ if (TREE_TYPE (result) != result_type) { if (TYPE_FAT_POINTER_P (result_type) & TREE_CODE (TREE_TYPE (TREE_TYPE (result))) == ARRAY_TYPE) result = convert_to_unconstrained (result_type, result, 1); else result = convert (result_type, result); } return result; } /* Indicate that we need to make the address of EXPR_NODE and it therefore should not be allocated in a register. Return 1 if successful. */ int mark_addressable (tree expr_node) { while (1) switch (TREE_CODE (expr_node)) { case ADDR_EXPR: case COMPONENT_REF: case ARRAY_REF: case REALPART_EXPR: case IMAGPART_EXPR: expr_node = TREE_OPERAND (expr_node, 0); break; case CONSTRUCTOR: TREE_ADDRESSABLE (expr_node) = 1; return 1; case VAR_DECL: case CONST_DECL: case PARM_DECL: case RESULT_DECL: put_var_into_stack (expr_node); TREE_ADDRESSABLE (expr_node) = 1; return 1; case FUNCTION_DECL: TREE_ADDRESSABLE (expr_node) = 1; return 1; default: return 1; } } DECL_CONTEXT (field) != record_type) /* Check if there is a field with name COMPONENT in the record. */ { if (component == 0) abort (); /* ??? Explore latgnat-1.67-src/src/a-trans4.h 444 10015 7640 7164 5506244463 10733 /****************************************************************************/ /* */ /* GNAT COMPILER COMPONENTS */ /* */ /* ADA CHAPTER 4: NAMES AND EXPRESSIONS */ /* - GNU SPECIFIC - */ /* */ /* Specification */ /* */ /* $Revision: 1.16 $ */ /* */ /* Copyright (c) 1992,1993, NYU, All Rights Reserved */ /* */ /* 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 */ /* Software Foundation; either version 2, or (at your option) any later */ /* version. GNAT is distributed in the hope that it will be useful, but */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- */ /* ABILITY 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 GNAT; see file COPYING. If not, write */ /* to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* */ /****************************************************************************/ /* Prepare expr to be an argument of a TRUTH_NOT_EXPR or other logical operation. This preparation consists of taking the ordinary representation of an expression expr and producing a valid tree boolean expression describing whether expr is nonzero. We could simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1), but we optimize comparisons, &&, ||, and !. The resulting type should always be the same as the input type. This function is simpler than the corresponding C version since the only possible operands will be things of Boolean type. */ extern tree truthvalue_conversion PROTO((tree)); /* Make a binary operation of kind OP_CODE. RESULT_TYPE is the type desired for the result. Usually the operation is to be performed in that type. For MODIFY_EXPR and ARRAY_REF, RESULT_TYPE may be 0 in which case the type to be used will be derived from the operands. */ extern tree build_binary_op PROTO((enum tree_code, tree, tree, tree)); /* Similar, but make unary operation. */ extern tree build_unary_op PROTO((enum tree_code, tree, tree)); /* Return a CONSTRUCTOR of TYPE whose list is LIST. */ extern tree build_constructor PROTO((tree, tree)); /* Return a COMPONENT_REF to access a field that is given by COMPONENT, an IDENTIFIER_NODE giving the name of the field, FIELD, a FIELD_DECL, for the field, or both. */ extern tree build_component_ref PROTO((tree, tree, tree)); /* Same as build_component_Ref but looks in __Parent field for inherited fields */ extern tree build_tagged_component_ref PROTO((tree, tree, tree)); /* Build a GCC tree to correspond to allocating an object of TYPE whose initial value if INIT, if INIT is nonzero. Convert the expression to RESULT_TYPE, which must be some type of pointer. Return the tree. GNAT_TYPE is the type of the underlying object in case we need to call a record initialization procedure. */ extern tree build_allocator PROTO((tree, tree, gnat_tree, tree)); /* Indicate that we need to make the address of EXPR_NODE and it therefore should not be allocated in a register. Return 1 if successful. */ extern int mark_addressable PROTO((tree)); ; else /* The field was not found in the hierarchy. Should not happen. */ abort (); } /* Build a GCC tree to correspond to allocating an object of TYPE whose initial value is INIT, if INIT is nonzero. Convert the expression to RESULT_TYPE, which must be some type of pointer. Return the tree. GNAT_TYPE is the type of the underlying object in case we need to call a regnat-1.67-src/src/a-trans.c 444 10015 7640 264254 5506244465 10711 /****************************************************************************/ /* */ /* GNAT COMPILER COMPONENTS */ /* */ /* TREE TRANSFORMER */ /* */ /* Body */ /* */ /* $Revision: 1.128 $ */ /* */ /* Copyright (c) 1992,1993, NYU, All Rights Reserved */ /* */ /* 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 */ /* Software Foundation; either version 2, or (at your option) any later */ /* version. GNAT is distributed in the hope that it will be useful, but */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- */ /* ABILITY 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 GNAT; see file COPYING. If not, write */ /* to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* */ /****************************************************************************/ #include "config.h" #include "tree.h" #include "flags.h" #include "a-ada.h" #include "a-types.h" #include "a-atree.h" #include "a-sinfo.h" #include "a-einfo.h" #include "a-namet.h" #include "a-string.h" #include "a-uint.h" #include "a-trans.h" #include "a-trans3.h" #include "a-gtran3.h" #include "a-trans4.h" #include "a-misc.h" #include "a-rtree.h" int max_gnat_nodes; int number_names; struct Node *Nodes_Ptr; struct Name_Entry *Names_Ptr; struct String_Entry * Strings_Ptr; Char_Code * String_Chars_Ptr; struct List_Header *List_Headers_Ptr; char * Name_Chars_Ptr; struct Uint_Entry *Uints_Ptr; Int *Udigits_Ptr; Int Number_Units; struct Needed_File_Info *File_Info_Ptr; int **Lines_Ptrs; /* Offset from first sloc in file. Set in parallel with LINENO and CURRENT_FILE_NAME. */ int sloc_offset; /* Map GNAT tree codes to GCC tree codes for simple expressions. */ static enum tree_code gnu_codes[Number_Node_Kinds]; /* Structure used to record sequences of statements that need to be executed in the next elaboration procedure to be generated. */ struct elab_list { struct elab_list *next; gnat_tree block; }; /* Head and tail of statement list. */ static struct elab_list *first_to_elab, *last_to_elab; /* Head of GNAT tree. */ extern gnat_tree gnat_root; static tree tree_transform PROTO((gnat_tree)); static tree emit_check PROTO((tree, tree)); static tree emit_access_check PROTO((tree)); static tree emit_discriminant_check PROTO((tree, gnat_tree)); static tree emit_range_check PROTO((tree, gnat_tree)); static tree emit_index_check PROTO((tree, tree, tree, tree)); static tree assoc_to_constructor PROTO((gnat_tree, tree, tree)); static tree pos_to_constructor PROTO((gnat_tree, tree, gnat_tree)); static tree maybe_implicit_deref PROTO((tree)); static tree make_save_expr PROTO((tree)); static tree maybe_unconstrained_array PROTO((tree)); static void build_package_elab PROTO((gnat_tree, int, tree, gnat_tree)); static void build_subprogram_elab PROTO((gnat_tree)); /* This is the main program of the back-end. It sets up all the table structures and then generates code. */ void gigi (gnat_root, max_gnat_node, number_name, nodes_ptr, names_ptr, strings_ptr, string_chars_ptr, list_headers_ptr, name_chars_ptr, uints_ptr, udigits_ptr, number_units, file_info_ptr, lines_ptrs) gnat_tree gnat_root; int max_gnat_node; int number_name; struct Node *nodes_ptr; struct Name_Entry *names_ptr; struct String_Entry *strings_ptr; Char_Code *string_chars_ptr; struct List_Header *list_headers_ptr; char *name_chars_ptr; struct Uint_Entry *uints_ptr; Int *udigits_ptr; Int number_units; struct Needed_File_Info *file_info_ptr; int **lines_ptrs; { max_gnat_nodes = max_gnat_node; number_names = number_name; Nodes_Ptr = nodes_ptr - First_Node_Id; Names_Ptr = names_ptr - First_Name_Id; Strings_Ptr = strings_ptr - First_String_Id; String_Chars_Ptr = string_chars_ptr; List_Headers_Ptr = list_headers_ptr - First_List_Id; Name_Chars_Ptr = name_chars_ptr; Uints_Ptr = uints_ptr - Uint_First_Entry; Udigits_Ptr = udigits_ptr; Number_Units = number_units; File_Info_Ptr = file_info_ptr; Lines_Ptrs = lines_ptrs; if (Nkind (gnat_root) != N_Compilation_Unit) abort (); set_lineno (gnat_root, 0); /* Initialize ourselves. */ init_gnat_to_gnu (); init_code_table (); gnat_to_code (gnat_root); } /* This function is the driver of the GNAT to GCC tree transformation process. GNAT_NODE is the root of some gnat tree. It generates code for that part of the tree. */ void gnat_to_code (gnat_node) gnat_tree gnat_node; { tree gnu_root = tree_transform (gnat_node); /* This should just generate code, not return a value. If it returns a value, something is wrong. */ if (gnu_root != error_mark_node) abort (); } /* GNAT_NODE is the root of some GNAT tree. Return the root of the GCC tree corresponding to that GNAT tree. Normally, no code is generated; we just return an equivalent tree which is used elsewhere to generate code. */ tree gnat_to_gnu (gnat_node) gnat_tree gnat_node; { tree gnu_root = tree_transform (gnat_node); /* If we got no code as a result, something is wrong. */ if (gnu_root == error_mark_node) abort (); return gnu_root; } /* This function is the driver of the GNAT to GCC tree transformation process. It is the entry point of the tree transformer. GNAT_NODE is the root of some GNAT tree. Return the root of the corresponding GCC tree or error_mark_node to signal that there is no GCC tree to return. The latter is the case if only code generation actions have to be performed like in the case of if statements, loops, etc. This routine is wrapped in the above two routines for most purposes. */ static tree tree_transform (gnat_node) gnat_tree gnat_node; { /* If this node has a type, get the GCC equivalent. But don't do this for N_Expression_Actions because it might be defining the type in one of its Actions. */ tree gnu_result_type = ((Nkind (gnat_node) != N_Expression_Actions && IN (Nkind (gnat_node), N_Has_Etype)) ? gnat_to_gnu_type (Etype (gnat_node)) : void_type_node); tree gnu_result = error_mark_node; /* Default to no value. */ tree gnu_expr; enum tree_code gnu_code; gnat_tree gnat_temp; /* Set input_file_name and lineno from the Sloc in the GNAT tree. */ set_lineno (gnat_node, 0); /* If this is a subexpression we are to evaluate once, see if we already have and return the old value if so. */ if (IN (Nkind (gnat_node), N_Subexpr) && Evaluate_Once (gnat_node) && present_gnu_tree (gnat_node)) return get_gnu_tree (gnat_node); /* If this is a Statement and we are at top level, we add the statement as an elaboration for a null tree. That will cause it to be placed in the elaboration procedure. */ if (global_bindings_p () && (IN (Nkind (gnat_node), N_Statement) || Nkind (gnat_node) == N_Procedure_Call_Statement)) { add_pending_elaborations (NULL_TREE, make_transform_expr (gnat_node, error_mark_node)); return error_mark_node; } switch (Nkind (gnat_node)) { /********************************/ /* Chapter 2: Lexical Elements: */ /********************************/ case N_Identifier: case N_Expanded_Name: /* If the Etype of this node does not equal the Etype of the Entity, something is wrong with the entity map, probably in generic instantiation. However, this does not apply to types. Since we sometime have strange Ekind's, just do this test for objects. Also, if the Etype of the Entity is private, the Etype of the N_Identifier is allowed to be the full type. */ gnat_temp = Entity (gnat_node); if (Etype (gnat_node) != Etype (gnat_temp) && ! (IN (Ekind (Etype (gnat_temp)), Private_Kind) && (Etype (gnat_node) == Full_Declaration (Etype (gnat_temp)))) && (Ekind (gnat_temp) == E_Variable || Ekind (gnat_temp) == E_Component || Ekind (gnat_temp) == E_Constant || Ekind (gnat_temp) == E_Loop_Parameter || IN (Ekind (gnat_temp), Formal_Kind))) { post_error ("internal type mismatch~!", gnat_node); abort (); } gnu_result = gnat_to_gnu_entity (Entity (gnat_node), NULL_TREE, 0); /* The GNAT tree has the type of a function as the type of its result. */ if (TREE_CODE (TREE_TYPE (gnu_result)) == FUNCTION_TYPE) gnu_result_type = TREE_TYPE (gnu_result); /* Some objects (such as parameters passed by reference, globals of variable size, and renamed objects) actually represent the address of the object. In that case, we must do the dereference unless we have a fat pointer. Call fold here since GNU_RESULT may be a CONST_DECL. */ if (TREE_CODE_CLASS (TREE_CODE (gnu_result)) == 'd' && DECL_BY_REF_P (gnu_result)) gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, fold (gnu_result)); /* We always want to return the underlying INTEGER_CST for an enumeration literal to avoid the need to call fold in lots of places. */ if (TREE_CODE (gnu_result) == CONST_DECL) gnu_result = DECL_INITIAL (gnu_result); break; case N_Integer_Literal: gnu_result = UI_To_gnu (Intval (gnat_node), gnu_result_type); break; case N_Character_Literal: /* If a Entity is present, it means that this was one of the literals in a user-defined character type. In that case, just return the value in the CONST_DECL. Otherwise, use the character code. In that case, the base type should be an INTEGER_TYPE, but we won't bother checking for that. */ if (Present (Entity (gnat_node))) gnu_result = DECL_INITIAL (get_gnu_tree (Entity (gnat_node))); else gnu_result = build_int_2 (Char_Literal_Value (gnat_node), 0); break; case N_Real_Literal: { /* We want to avoid doing explicit host machine arithmetic. The best way to do this is when EXPON_EXPR is implemented, but the kludge that follows is the best way for now. */ tree gnu_numerator = UI_To_gnu (Numerator (gnat_node), gnu_result_type); tree gnu_denominator; if (Decimal (gnat_node)) { int exp_value = UI_To_Int (Denominator (gnat_node)); static int pow10s[] = {1, 10, 100, 1000, 10000, 100000, 1000000, 10000000, 100000000, 1000000000}; if (exp_value < sizeof pow10s / sizeof pow10s[0]) gnu_denominator = convert (gnu_result_type, build_int_2 (pow10s[exp_value], 0)); else { char *exponent = (char *) alloca (40); REAL_VALUE_TYPE value; sprintf (exponent, "1.0e%d", exp_value); value = REAL_VALUE_ATOF (exponent, TYPE_MODE (gnu_result_type)); gnu_denominator = build_real (gnu_result_type, value); } } else gnu_denominator = UI_To_gnu (Denominator (gnat_node), gnu_result_type); gnu_result = build_binary_op (RDIV_EXPR, gnu_result_type, gnu_numerator, gnu_denominator); break; } case N_String_Literal: { /* We assume here that all strings are of type standard.string. "Wierd" types of string have been converted to an aggregate by the expander and we won't worry about wide characters for now. */ String_Id gnat_string = Strval (gnat_node); int length = String_Length (gnat_string); char *string = (char *) alloca (length + 1); int i; /* Build the string with the characters in the literal and end it with a null. Note that Ada strings are 1-origin. */ for (i = 0; i < length; i++) string[i] = Get_String_Char (gnat_string, i + 1); string[i] = 0; gnu_result = build_string (length, string); /* Strings in GCC don't normally have types, but we want this to not be converted to the array type. */ TREE_TYPE (gnu_result) = gnu_result_type; } break; case N_Pragma: break; /**************************************/ /* Chapter 3: Declarations and Types: */ /**************************************/ case N_Implicit_Type: case N_Full_Type_Declaration: case N_Subtype_Declaration: case N_Incomplete_Type_Declaration: case N_Private_Type_Declaration: { gnat_tree gnat_entity = Defining_Identifier (gnat_node); tree gnu_old = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0; tree gnu_new; /* If we are to delay elaboration of this type, just do any elaborations needed for expressions within the declaration and make a VOID_TYPE entry for this node and its Full_Declaration (if any) in case something points to it. Don't do this if it has already been done (the only way that can happen is if the private completion is also delayed). */ if (Is_Delayed (gnat_entity)) { elaborate_entity (gnat_entity); if (gnu_old == 0) { char *entity_name = Get_Name_String (Chars (gnat_entity)); tree gnu_type = make_node (VOID_TYPE); tree gnu_decl = create_type_decl (entity_name, gnu_type); save_gnu_tree (gnat_entity, gnu_decl, 0); if (IN (Ekind (gnat_entity), Incomplete_Kind) && Present (Full_Declaration (gnat_entity))) save_gnu_tree (Full_Declaration (gnat_entity), gnu_decl, 0); } break; } /* If we saved away a VOID_TYPE for this node it means that this made the type that corresponds to the full type of an incomplete type. Clear that type for now and then update the type in the pointers. */ if (gnu_old != 0) { if (TREE_CODE (gnu_old) != TYPE_DECL || TREE_CODE (TREE_TYPE (gnu_old)) != VOID_TYPE) abort (); save_gnu_tree (gnat_entity, NULL_TREE, 0); } /* Now fully elaborate the type. */ gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 1); if (TREE_CODE (gnu_new) != TYPE_DECL) abort (); /* If we have an old type and we've made pointers to this type, update those pointers. */ if (gnu_old != 0 && TYPE_POINTER_TO (TREE_TYPE (gnu_old)) != 0) { TREE_TYPE (TYPE_POINTER_TO (TREE_TYPE (gnu_old))) = TREE_TYPE (gnu_new); TYPE_POINTER_TO (TREE_TYPE (gnu_new)) = TYPE_POINTER_TO (TREE_TYPE (gnu_old)); } } break; case N_Number_Declaration: /* These will get folded into the tree for us, so we can ignore them. */ break; case N_Object_Declaration: case N_Exception_Declaration: case N_Object_Renaming_Declaration: gnat_temp = Defining_Identifier (gnat_node); if (Present (Expression (gnat_node))) { gnu_expr = gnat_to_gnu (Expression (gnat_node)); if (Do_Range_Check (Expression (gnat_node))) gnu_expr = emit_range_check (gnu_expr, Etype (gnat_temp)); /* If this object has its elaboration delayed, we must force evaluation of GNU_EXPR right now and save it for when the object is frozen. */ if (Is_Delayed (gnat_temp)) { if ((Is_Public (gnat_temp) || global_bindings_p ()) && ! TREE_CONSTANT (gnu_expr)) gnu_expr = create_var_decl (create_concat_name (gnat_temp, "init"), NULL_PTR, TREE_TYPE (gnu_expr), gnu_expr, 0, Is_Public (gnat_temp), 0, 0, 0); else gnu_expr = maybe_variable (gnu_expr); save_gnu_tree (gnat_node, gnu_expr, 1); } } else gnu_expr = NULL_TREE; /* Note that we must call gnat_to_gnu each time in case we are initializing multiple variables, since it must have the same semantics as if they had separate initializations. */ if (! Is_Delayed (gnat_temp)) gnat_to_gnu_entity (gnat_temp, gnu_expr, 1); break; case N_Implicit_Label_Declaration: gnat_to_gnu_entity (Defining_Identifier (gnat_node), NULL_TREE, 1); break; case N_Subprogram_Renaming_Declaration: case N_Package_Renaming_Declaration: case N_Exception_Renaming_Declaration: /* These are fully handled in the front end. */ break; /*************************************/ /* Chapter 4: Names and Expressions: */ /*************************************/ case N_Explicit_Dereference: gnu_result = gnat_to_gnu (Prefix (gnat_node)); /* Emit access check if necessary */ if (Do_Access_Check (gnat_node)) gnu_result = emit_access_check (gnu_result); gnu_result = build_unary_op (INDIRECT_REF, gnu_result_type, gnu_result); break; case N_Indexed_Component: { tree gnu_array_object = gnat_to_gnu (Prefix (gnat_node)); tree gnu_type; /* Emit access check if necessary */ if (Do_Access_Check (gnat_node)) gnu_array_object = emit_access_check (gnu_array_object); gnu_array_object = maybe_implicit_deref (gnu_array_object); gnu_array_object = maybe_unconstrained_array (gnu_array_object); gnu_result = gnu_array_object; for (gnat_temp = First (Expressions (gnat_node)), gnu_type = TREE_TYPE (gnu_array_object); Present (gnat_temp); gnat_temp = Next (gnat_temp), gnu_type = TREE_TYPE (gnu_type)) { if (TREE_CODE (gnu_type) != ARRAY_TYPE) abort (); gnu_expr = gnat_to_gnu (gnat_temp); if (Do_Range_Check (gnat_temp)) gnu_expr = emit_index_check (gnu_array_object, gnu_expr, TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))), TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)))); gnu_result = build_binary_op (ARRAY_REF, NULL_TREE, gnu_result, gnu_expr); } } break; case N_Slice: gnu_result = gnat_to_gnu (Prefix (gnat_node)); /* Emit access check if necessary */ if (Do_Access_Check (gnat_node)) gnu_result = emit_access_check (gnu_result); /* Reference the desired first component of Prefix, where the first index is the low bound of our type. Then takes its address and convert it to a pointer to our type. Finally, indirectly reference that. Note that most of these operations are just performed to get the types correct and will go away. */ gnu_result = maybe_implicit_deref (gnu_result); gnu_result = maybe_unconstrained_array (gnu_result); gnu_result = build_binary_op (ARRAY_REF, NULL_TREE, gnu_result, TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type))); gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result); gnu_result = convert (build_pointer_type (gnu_result_type), gnu_result); gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result); break; case N_Selected_Component: { tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node)); gnat_tree gnat_field = Selector_Name (gnat_node); char *gnat_field_name = Get_Name_String (Chars (gnat_field)); tree gnu_field = gnat_to_gnu (gnat_field); gnat_tree gnat_pref_type = Etype (Prefix (gnat_node)); /* If there are discriminants, the prefix might be evaluated more than once, which is a problem if it has side-effects. */ if (Has_Discriminants (Prefix (gnat_node)) && TREE_SIDE_EFFECTS (gnu_prefix)) gnu_prefix = make_save_expr (gnu_prefix); /* emit access and discriminant check if necessary */ if (Do_Access_Check (gnat_node)) gnu_prefix = emit_access_check (gnu_prefix); if (Do_Discriminant_Check (gnat_node)) gnu_prefix = emit_discriminant_check (gnu_prefix, gnat_node); if (Is_Tagged_Type (gnat_pref_type) || (Is_Access_Type (gnat_pref_type) && Is_Tagged_Type (Designated_Type (gnat_pref_type)))) gnu_result = build_tagged_component_ref (gnu_prefix, get_identifier (gnat_field_name), gnu_field); else gnu_result = build_component_ref (gnu_prefix, get_identifier (gnat_field_name), gnu_field); if (gnu_result == 0) abort (); } break; case N_Attribute_Reference: { /* The attribute designator (like an enumeration value). */ int attribute = Get_Attribute_Id (Chars (Identifier (gnat_node))); tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node)); tree gnu_type = TREE_TYPE (gnu_prefix); /* Emit access check if necessary */ if (Do_Access_Check (gnat_node)) gnu_prefix = emit_access_check (gnu_prefix); switch (attribute) { case Attr_Pos: case Attr_Val: /* These are just conversions until we support representation clauses for enumerations, at which time we have to figure out what to really do. */ gnu_result = gnat_to_gnu (Expression (gnat_node)); break; case Attr_Pred: case Attr_Succ: /* These just add or subject the constant 1 until representations are supported. */ gnu_result = build_binary_op (attribute == Attr_Pred ? MINUS_EXPR : PLUS_EXPR, gnu_result_type, gnat_to_gnu (Expression (gnat_node)), convert (gnu_result_type, integer_one_node)); break; case Attr_Address: /* If we are taking 'Address of an unconstrained object, this is the pointer to the underlying array. */ if (TREE_CODE (gnu_prefix) == UNCONSTRAINED_ARRAY_REF) { tree gnu_fat_pointer = TREE_OPERAND (gnu_prefix, 0); tree gnu_fat_type = TREE_TYPE (gnu_fat_pointer); gnu_result = build_component_ref (gnu_fat_pointer, NULL_TREE, TYPE_FIELDS (gnu_fat_type)); break; } /* ... fall through ... */ case Attr_Access: mark_addressable (gnu_prefix); gnu_result = build_unary_op (ADDR_EXPR, gnu_result_type, gnu_prefix); break; case Attr_Size: if (TREE_CODE_CLASS (TREE_CODE (gnu_prefix)) == 'd' && TREE_CODE (gnu_prefix) != TYPE_DECL) gnu_result = DECL_SIZE (gnu_prefix); /* If this is an itegral type, return the precision, else the size. */ else if (INTEGRAL_TYPE_P (gnu_type)) gnu_result = build_int_2 (TYPE_PRECISION (gnu_type), 0); else gnu_result = max_size (TYPE_SIZE (gnu_type), 1); break; case Attr_First: case Attr_Last: if (INTEGRAL_TYPE_P (gnu_type)) { if (attribute == Attr_First) gnu_result = TYPE_MIN_VALUE (gnu_type); else gnu_result = TYPE_MAX_VALUE (gnu_type); break; } /* ... fall through ... */ case Attr_Length: { int Dimension = (Present (Expression (gnat_node)) ? UI_To_Int (Intval (Expression (gnat_node))) : 1); /* Make sure any implicit dereference gets done. */ gnu_prefix = maybe_implicit_deref (gnu_prefix); gnu_prefix = maybe_unconstrained_array (gnu_prefix); gnu_type = TREE_TYPE (gnu_prefix); for (; Dimension > 1; Dimension--) gnu_type = TREE_TYPE (gnu_type); if (TREE_CODE (gnu_type) != ARRAY_TYPE) abort (); if (attribute == Attr_First) gnu_result = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))); else if (attribute == Attr_Last) gnu_result = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))); else if (attribute == Attr_Length) gnu_result = size_binop (EASY_DIV_EXPR, TYPE_SIZE (gnu_type), TYPE_SIZE (TREE_TYPE (gnu_type))); /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are handling. Note that these attributes could not have been used on an unconstrained array type. */ if (TREE_CODE (gnu_result) != INTEGER_CST && contains_placeholder_p (gnu_result)) gnu_result = build (WITH_RECORD_EXPR, TREE_TYPE (gnu_result), gnu_result, gnu_prefix); break; } case Attr_Position: case Attr_First_Bit: case Attr_Last_Bit: { int bitsize, bitpos; tree offset; enum machine_mode mode; int unsignedp, volatilep; if (TREE_CODE (gnu_prefix) != COMPONENT_REF) abort (); get_inner_reference (gnu_prefix, &bitsize, &bitpos, &offset, &mode, &unsignedp, &volatilep); if (offset) offset = size_binop (PLUS_EXPR, offset, size_int (bitpos)); else offset = size_int (bitpos); if (attribute == Attr_Position) gnu_result = size_binop (TRUNC_DIV_EXPR, offset, size_int (BITS_PER_UNIT)); else if (attribute == Attr_First_Bit) gnu_result = offset; else if (attribute == Attr_Last_Bit) gnu_result = size_binop (PLUS_EXPR, offset, size_int (bitsize - 1)); } break; default: post_error ("unsupported attribute~!", gnat_node); abort (); } } break; case N_Aggregate: if (TREE_CODE (gnu_result_type) == RECORD_TYPE) gnu_result = assoc_to_constructor (First (Component_Associations (gnat_node)), gnu_result_type, NULL_TREE); else if (TREE_CODE (gnu_result_type) == ARRAY_TYPE) gnu_result = pos_to_constructor (First (Expressions (gnat_node)), gnu_result_type, Component_Type (Etype (gnat_node))); else abort (); break; case N_Null: gnu_result = null_pointer_node; break; case N_Type_Conversion: /* Get the operand expression. */ gnu_result = gnat_to_gnu (Expression (gnat_node)); /* If a range check is needed, emit code to generate it. */ if (Do_Range_Check (Expression (gnat_node))) gnu_result = emit_range_check (gnu_result, Entity (Subtype_Mark (gnat_node))); /* If this is an unchecked conversion, emit the apropriate operation. Otherwise, do the explicit conversion. Don't assume that the code on our exit will do it since there are many exceptions to doing conversion there, none of which apply here. */ if (Unchecked_Conversion (gnat_node)) gnu_result = build1 (UNCHECKED_CONVERT_EXPR, gnu_result_type, gnu_result); else gnu_result = convert (gnu_result_type, gnu_result); break; case N_Parenthesized_Expression: case N_Qualified_Expression: /* Just get the operand expression. The conversion at the end of this function will do the actual operation. */ gnu_result = gnat_to_gnu (Expression (gnat_node)); break; case N_Op_In: case N_Op_Not_In: { tree gnu_object = gnat_to_gnu (Left_Opnd (gnat_node)); gnat_tree gnat_range = Right_Opnd (gnat_node); tree gnu_low; tree gnu_high; /* GNAT_RANGE is either an N_Range node or an identifier denoting a subtype. */ if (Nkind (gnat_range) == N_Range) { gnu_low = gnat_to_gnu (Low_Bound (gnat_range)); gnu_high = gnat_to_gnu (High_Bound (gnat_range)); } else if (Nkind (gnat_range) == N_Identifier) { tree gnu_range_type = gnat_to_gnu_type (Entity (gnat_range)); gnu_low = TYPE_MIN_VALUE (gnu_range_type); gnu_high = TYPE_MAX_VALUE (gnu_range_type); } else abort (); /* If LOW and HIGH are identical, perform an equality test. Otherwise, ensure that GNU_OBJECT is only evaluated once and perform a full range test. */ if (operand_equal_p (gnu_low, gnu_high, 0)) gnu_result = build_binary_op (EQ_EXPR, gnu_result_type, gnu_object, gnu_low); else { gnu_object = make_save_expr (gnu_object); gnu_result = build_binary_op (TRUTH_ANDIF_EXPR, gnu_result_type, build_binary_op (GE_EXPR, gnu_result_type, gnu_object, gnu_low), build_binary_op (LE_EXPR, gnu_result_type, gnu_object, gnu_high)); } if (Nkind (gnat_node) == N_Op_Not_In) gnu_result = invert_truthvalue (gnu_result); } break; case N_Op_Divide: if (TREE_CODE (gnu_result_type) == REAL_TYPE) gnu_result = build_binary_op (RDIV_EXPR, gnu_result_type, gnat_to_gnu (Left_Opnd (gnat_node)), gnat_to_gnu (Right_Opnd (gnat_node))); else if (TREE_CODE (gnu_result_type) == INTEGER_TYPE) gnu_result = build_binary_op (TRUNC_DIV_EXPR, gnu_result_type, gnat_to_gnu (Left_Opnd (gnat_node)), gnat_to_gnu (Right_Opnd (gnat_node))); else abort (); break; case N_Op_Or: case N_Op_And: case N_Op_Xor: /* These can either be operations on booleans or on modular types. Fall through for boolean types since that's the way GNU_CODES is set up. */ if (TREE_CODE (gnu_result_type) == INTEGER_TYPE && TREE_UNSIGNED (gnu_result_type)) { enum tree_code code = (Nkind (gnat_node) == N_Op_Or ? BIT_IOR_EXPR : Nkind (gnat_node) == N_Op_And ? BIT_AND_EXPR : BIT_XOR_EXPR); gnu_result = build_binary_op (code, gnu_result_type, gnat_to_gnu (Left_Opnd (gnat_node)), gnat_to_gnu (Right_Opnd (gnat_node))); break; } /* ... fall through ... */ case N_Op_Eq: case N_Op_Ne: case N_Op_Lt: case N_Op_Le: case N_Op_Gt: case N_Op_Ge: case N_Op_Add: case N_Op_Subtract: case N_Op_Multiply: case N_Op_Mod: case N_Op_Rem: case N_Op_Expon: case N_Op_And_Then: case N_Op_Or_Else: { enum tree_code code = gnu_codes[Nkind (gnat_node)]; tree gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node)); tree gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node)); /* If this is a comparison operator, convert any references to an unconstrained array value into a reference to the actual array. */ if (TREE_CODE_CLASS (code) == '<') { gnu_lhs = maybe_unconstrained_array (gnu_lhs); gnu_rhs = maybe_unconstrained_array (gnu_rhs); } gnu_result = build_binary_op (code, gnu_result_type, gnu_lhs, gnu_rhs); } break; case N_Op_Plus: gnu_result = gnat_to_gnu (Right_Opnd (gnat_node)); break; case N_Op_Not: /* This case can apply to a boolean or a modular type. Fall through for a boolean operand since GNU_CODES is set up to handle this. */ if (TREE_CODE (gnu_result_type) == INTEGER_TYPE && TREE_UNSIGNED (gnu_result_type)) { gnu_result = build_unary_op (BIT_NOT_EXPR, gnu_result_type, gnat_to_gnu (Right_Opnd (gnat_node))); break; } /* ... fall through ... */ case N_Op_Minus: case N_Op_Abs: gnu_result = build_unary_op (gnu_codes[Nkind (gnat_node)], gnu_result_type, gnat_to_gnu (Right_Opnd (gnat_node))); break; case N_Allocator: { tree gnu_init = 0; gnat_tree gnat_type = 0; tree gnu_type; /* The Expression operand can either be an N_Identifier, which must represent a type, or an N_Qualified_Expression, which contains both the object type and an initial value for the object. */ if (Nkind (Expression (gnat_node)) == N_Identifier) { gnat_type = Entity (Expression (gnat_node)); gnu_type = gnat_to_gnu_type(gnat_type); } else if (Nkind (Expression (gnat_node)) == N_Qualified_Expression) { /* If might seem like we want the type to be obtaind from the Subtype_Mark, but, in fact, the type of the Expression is correct. */ gnu_init = gnat_to_gnu (Expression (Expression (gnat_node))); gnu_type = TREE_TYPE (gnu_init); } else abort (); return build_allocator (gnu_type, gnu_init, gnat_type, gnu_result_type); } break; case N_Expression_Actions: /* Start an expression statement, preform any actions specified in the node, expand our expression, and then end the statement. If we are not within any subprogram, we cannot actually generate RTL, so make a TRANSFORM_EXPR if there is anything unusual in the actions. Note that we don't know our own type in that case, but convert knows what to do. ??? There is a potential problem here if our type is declared inside this node and is used in the containing expression and this occurs at the global level and in a node that has nontrivial actions. I don't think that actually occurs, so we might be lucky. */ if (global_bindings_p ()) { for (gnat_temp = First (Actions (gnat_node)); gnat_temp; gnat_temp = Next (gnat_temp)) switch (Nkind (gnat_temp)) { case N_Implicit_Type: case N_Full_Type_Declaration: case N_Subtype_Declaration: case N_Number_Declaration: case N_Object_Declaration: case N_Exception_Declaration: break; default: return make_transform_expr (gnat_node, error_mark_node); } } gnu_result = expand_start_stmt_expr (); for (gnat_temp = First (Actions (gnat_node)); gnat_temp; gnat_temp = Next (gnat_temp)) gnat_to_code (gnat_temp); /* Now that we've defined any types in Actions, we get safely get our type. */ gnu_result_type = gnat_to_gnu_type (Etype (gnat_node)); expand_expr_stmt (gnat_to_gnu (Expression (gnat_node))); gnu_result = expand_end_stmt_expr (gnu_result); break; /***************************/ /* Chapter 5: Statements: */ /***************************/ case N_Label: expand_label (gnat_to_gnu (Identifier (gnat_node))); break; case N_Null_Statement: break; case N_Assignment_Statement: { /* Get the LHS and RHS of the statement and convert any reference to an unconstrained array into a reference to the underlying array. */ tree gnu_rhs = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node))); tree gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node))); /* If range check is needed, emit code to generate it */ if (Do_Range_Check (Expression (gnat_node))) gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node))); set_lineno (gnat_node, 1); expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs)); } break; case N_If_Statement: /* Start an IF statement giving the condition. */ gnu_expr = gnat_to_gnu (Condition (gnat_node)); set_lineno (gnat_node, 1); expand_start_cond (gnu_expr, 0); push_momentary (); /* Generate code for the statements to be executed if the condition is true. */ for (gnat_temp = First (Then_Statements (gnat_node)); Present (gnat_temp); gnat_temp = Next (gnat_temp)) { gnat_to_code (gnat_temp); clear_momentary(); } /* Generate each of the "else if" parts. */ if (Present (Elsif_Parts (gnat_node))) { for (gnat_temp = First (Elsif_Parts (gnat_node)); Present (gnat_temp); gnat_temp = Next (gnat_temp)) { gnat_tree gnat_statement; /* Set up the line numbers for each condition we test. */ set_lineno (gnat_node, 1); expand_start_elseif (gnat_to_gnu (Condition (gnat_temp))); for (gnat_statement = First (Then_Statements (gnat_temp)); Present (gnat_statement); gnat_statement = Next (gnat_statement)) { gnat_to_code (gnat_statement); clear_momentary (); } } } /* Finally, handle any statements in the "else" part. */ if (Present (Else_Statements (gnat_node))) { expand_start_else (); for (gnat_temp = First (Else_Statements (gnat_node)); Present (gnat_temp); gnat_temp = Next (gnat_temp)) { gnat_to_code (gnat_temp); clear_momentary (); } } pop_momentary (); expand_end_cond (); break; case N_Case_Statement: { gnat_tree gnat_when; gnat_tree gnat_choice; tree gnu_label; gnat_tree gnat_statement; gnu_expr = gnat_to_gnu (Expression (gnat_node)); set_lineno (gnat_node, 1); expand_start_case (1, gnu_expr, TREE_TYPE (gnu_expr), "case"); push_momentary(); for (gnat_when = First (Alternatives (gnat_node)); Present (gnat_when); gnat_when = Next (gnat_when)) { /* First compile all the different case choices for the current WHEN alternative. */ for (gnat_choice = First (Discrete_Choices (gnat_when)); Present (gnat_choice); gnat_choice = Next (gnat_choice)) { gnu_label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE); switch (Nkind (gnat_choice)) { case N_Range: pushcase_range (gnat_to_gnu (Low_Bound (gnat_choice)), gnat_to_gnu (High_Bound (gnat_choice)), convert, gnu_label, NULL_PTR); break; case N_Identifier: case N_Expanded_Name: /* This represents either a subtype range or a static value of some kind; Ekind says which. If a static value, fall through to the next case. */ if (IN (Ekind (Entity (gnat_choice)), Type_Kind)) { tree type = gnat_to_gnu_type (Entity (gnat_choice)); pushcase_range (fold (TYPE_MIN_VALUE (type)), fold (TYPE_MAX_VALUE (type)), convert, gnu_label, NULL_PTR); break; } /* ... fall through ... */ case N_Character_Literal: case N_Integer_Literal: pushcase (gnat_to_gnu (gnat_choice), convert, gnu_label, NULL_PTR); break; case N_Others_Choice: pushcase (NULL_TREE, convert, gnu_label, NULL_PTR); break; default: abort (); } } /* After compiling the choices attached to the WHEN compile the body of statements that have to be executed, should the "WHEN ... =>" be taken. */ for (gnat_statement = First (Statements (gnat_when)); Present (gnat_statement); gnat_statement = Next (gnat_statement)) { gnat_to_code (gnat_statement); clear_momentary (); } /* Communicate to GCC that we are done with the current WHEN, i.e. insert a "break" statement. */ set_lineno (gnat_node, 1); expand_exit_something (); } pop_momentary(); set_lineno (gnat_node, 1); expand_end_case (gnu_expr); } break; case N_Loop_Statement: { /* The loop variable in GCC form, if any. */ tree gnu_loop_var = NULL_TREE; /* PREINCREMENT_EXPR or PREDECREMENT_EXPR. */ enum tree_code gnu_update; /* Used if this is a named loop for so EXIT can work. */ struct nesting *loop_id; /* Condition to continue loop tested at top of loop. */ tree gnu_top_condition = integer_one_node; /* Similar, but tested at bottom of loop. */ tree gnu_bottom_condition = integer_one_node; gnat_tree gnat_statement; gnat_tree gnat_iter_scheme = Iteration_Scheme (gnat_node); int enclosing_if_p = 0; /* Set the condition that under which the loop should continue. For "LOOP .... END LOOP;" the condition is always true. */ if (No (gnat_iter_scheme)) ; /* The case "WHILE condition LOOP ..... END LOOP;" */ else if (Present (Condition (gnat_iter_scheme))) gnu_top_condition = gnat_to_gnu (Condition (gnat_iter_scheme)); else { /* We have an iteration scheme. */ gnat_tree gnat_loop_spec = Loop_Parameter_Specification (gnat_iter_scheme); gnat_tree gnat_loop_var = Defining_Identifier (gnat_loop_spec); gnat_tree gnat_type = Etype (gnat_loop_var); tree gnu_type = gnat_to_gnu_type (gnat_type); tree gnu_low = TYPE_MIN_VALUE (gnu_type); tree gnu_high = TYPE_MAX_VALUE (gnu_type); int reversep = Reverse_Present (gnat_loop_spec); tree gnu_first = reversep ? gnu_high : gnu_low; tree gnu_last = reversep ? gnu_low : gnu_high; enum tree_code end_code = reversep ? GE_EXPR : LE_EXPR; tree gnu_base_type = TREE_TYPE (gnu_type) ? TREE_TYPE (gnu_type) : gnu_type; tree gnu_limit = (reversep ? TYPE_MIN_VALUE (gnu_base_type) : TYPE_MAX_VALUE (gnu_base_type)); /* We know the loop variable will not overflow if GNU_LAST is a constant and is not equal to GNU_LIMIT. If it might overflow, we have to move the limit test to the end of the loop. In that case, we have to test for an empty loop outside the loop. */ if (TREE_CODE (gnu_last) != INTEGER_CST || TREE_CODE (gnu_limit) != INTEGER_CST || tree_int_cst_equal (gnu_last, gnu_limit)) { gnu_expr = build_binary_op (LE_EXPR, integer_type_node, gnu_low, gnu_high); set_lineno (gnat_node, 1); expand_start_cond (gnu_expr, 0); enclosing_if_p = 1; } /* Open a new nesting level that will surround the loop to declare the loop index variable. */ pushlevel (0); expand_start_bindings (0); /* Declare the loop index and set it to its initial value. */ gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1); /* Set either the top or bottom exit condition as appropriate depending on whether we know an overflow cannot occur or not. */ if (enclosing_if_p) gnu_bottom_condition = build_binary_op (NE_EXPR, integer_type_node, gnu_loop_var, gnu_last); else gnu_top_condition = build_binary_op (end_code, integer_type_node, gnu_loop_var, gnu_last); gnu_update = reversep ? PREDECREMENT_EXPR : PREINCREMENT_EXPR; } set_lineno (gnat_node, 1); if (gnu_loop_var) loop_id = expand_start_loop_continue_elsewhere (1); else loop_id = expand_start_loop (1); /* If the loop was named, have the name point to this loop. In this case, the association is not a ..._DECL node; in fact, it isn't a GCC tree node at all. Since this name is referenced inside the loop, do it before we process the statements of the loop. */ if (Present (Identifier (gnat_node))) save_gnu_tree (Entity (Identifier (gnat_node)), (tree) loop_id, 1); set_lineno (gnat_node, 1); expand_exit_loop_if_false (NULL_PTR, gnu_top_condition); push_momentary (); for (gnat_statement = First (Statements (gnat_node)); Present (gnat_statement); gnat_statement = Next (gnat_statement)) { gnat_to_code (gnat_statement); clear_momentary (); } pop_momentary (); set_lineno (gnat_node, 1); expand_exit_loop_if_false (NULL_PTR, gnu_bottom_condition); if (gnu_loop_var) { expand_loop_continue_here (); gnu_expr = build_binary_op (gnu_update, TREE_TYPE (gnu_loop_var), gnu_loop_var, convert (TREE_TYPE (gnu_loop_var), integer_one_node)); set_lineno (gnat_node, 1); expand_expr_stmt (gnu_expr); } set_lineno (gnat_node, 1); expand_end_loop (); if (gnu_loop_var) { /* Close the nesting level that sourround the loop that was used to declare the loop index variable. */ set_lineno (gnat_node, 1); expand_end_bindings (getdecls (), 1, 0); poplevel (1, 1, 0); } if (enclosing_if_p) { set_lineno (gnat_node, 1); expand_end_cond (); } } break; case N_Block_Statement: pushlevel (0); expand_start_bindings (0); /* Process the declarations inside the block statement. */ if (Present (Declarations (gnat_node))) for (gnat_temp = First (Declarations (gnat_node)); Present (gnat_temp); gnat_temp = Next (gnat_temp)) gnat_to_code (gnat_temp); gnat_to_code (Handled_Statement_Sequence (gnat_node)); set_lineno (gnat_node, 1); expand_end_bindings (getdecls (), 1, 0); poplevel (kept_level_p (), 1, 0); break; case N_Exit_Statement: { /* Which loop to exit, NULL if the current loop. */ struct nesting *loop_id = NULL_PTR; /* The GCC version of the optional GNAT condition node attached to the exit statement. Exit the loop if this is false. */ tree gnu_cond = integer_zero_node; if (Present (Name (gnat_node))) loop_id = (struct nesting *) get_gnu_tree (Entity (Name (gnat_node))); if (Present (Condition (gnat_node))) gnu_cond = invert_truthvalue (truthvalue_conversion (gnat_to_gnu (Condition (gnat_node)))); set_lineno (gnat_node, 1); expand_exit_loop_if_false (loop_id, gnu_cond); } break; case N_Return_Statement: { /* The gnu function type of the subprogram currently processed. */ tree gnu_subprog_type = TREE_TYPE (current_function_decl); /* The return value from the subprogram. */ tree gnu_ret_val = 0; /* If we are dealing with a "return;" from an Ada procedure with parameters passed by copy in copy out, we need to return a record containing the final values of these parameters. If the list contains only one entry, return just that entry. For a full description of the copy in copy out parameter mechanism, see the part of the gnat_to_gnu_entity routine dealing with the translation of subprograms. */ if (TYPE_CI_CO_LIST (gnu_subprog_type) != NULL_TREE) { if (list_length (TYPE_CI_CO_LIST (gnu_subprog_type)) == 1) gnu_ret_val = TREE_VALUE (TYPE_CI_CO_LIST (gnu_subprog_type)); else gnu_ret_val = build_constructor (TREE_TYPE (gnu_subprog_type), TYPE_CI_CO_LIST (gnu_subprog_type)); } /* If the Ada subprogram is a function, we just need to return the expression. If the subprogram returns an unconstrained array, we have to allocate a new version of the result and return it. */ else if (Present (Expression (gnat_node))) { gnu_ret_val = gnat_to_gnu (Expression (gnat_node)); if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type)) gnu_ret_val = build_allocator (TREE_TYPE (gnu_ret_val), gnu_ret_val, Etype (Expression (gnat_node)), TREE_TYPE (gnu_subprog_type)); } set_lineno (gnat_node, 1); if (gnu_ret_val) expand_return (build_binary_op (MODIFY_EXPR, NULL_TREE, DECL_RESULT (current_function_decl), gnu_ret_val)); else expand_null_return (); } break; case N_Goto_Statement: { tree gnu_label; gnu_label = gnat_to_gnu (Name (gnat_node)); TREE_USED (gnu_label) = 1; set_lineno (gnat_node, 1); expand_goto (gnu_label); break; } case N_Raise_Statement: { /* If an exception is specifed, set __gnat_exception to the address of the exception. Then do a longjmp through __gnat_jmpbuf. */ tree gnu_call = build (CALL_EXPR, void_type_node, build_unary_op (ADDR_EXPR, NULL_TREE, longjmp_decl), chainon (chainon (NULL_TREE, build_tree_list (NULL_TREE, jmpbuf_decl)), build_tree_list (NULL_TREE, integer_one_node)), NULL_TREE); TREE_SIDE_EFFECTS (gnu_call) = 1; if (Present (Name (gnat_node))) { gnu_expr = build_binary_op (MODIFY_EXPR, NULL_TREE, excptr_decl, build_unary_op (ADDR_EXPR, NULL_TREE, gnat_to_gnu (Name (gnat_node)))); set_lineno (gnat_node, 1); expand_expr_stmt (gnu_expr); } set_lineno (gnat_node, 1); expand_expr_stmt (gnu_call); } break; /****************************/ /* Chapter 6: Subprograms: */ /****************************/ case N_Subprogram_Declaration: gnat_to_code (Specification (gnat_node)); break; case N_Abstract_Subprogram_Declaration: break; case N_Function_Specification: case N_Procedure_Specification: /* Consider this a "definition" even though we won't actually be making code for the subprogram here. This is because if we see the spec and are actually generating code, we know the body must be in this same file. */ if (! Is_Delayed (Defining_Unit_Name (gnat_node))) gnat_to_gnu_entity (Defining_Unit_Name (gnat_node), NULL_TREE, 1); break; case N_Defining_Program_Unit_Name: /* For a child unit identifier go up a level to get the specificaton. */ gnat_to_code (Parent (gnat_node)); break; case N_Subprogram_Body: { /* Definining identifier of a parameter to the subprogram. */ gnat_tree gnat_param; /* The declared entity currently being processed in the declarative part of the subprogram body. */ gnat_tree gnat_entity; /* The defining identifier for the subprogram body. Note that if a specification has appeared before for this body, then the identifier occurring in that specification will also be a defining identifier and all the calls to this subprogram will point to that specification. */ gnat_tree gnat_subprog_id = (Present (Corresponding_Spec (gnat_node)) ? Corresponding_Spec (gnat_node) : Defining_Unit_Name (Specification (gnat_node))); /* The FUNCTION_DECL node corresponding to the subprogram spec. */ tree gnu_subprog_decl; /* The FUNCTION_TYPE node corresponding to the subprogram spec. */ tree gnu_subprog_type; tree gnu_cico_list; /* If this is a generic object, ignore it. */ if (Ekind (gnat_subprog_id) == E_Generic_Procedure || Ekind (gnat_subprog_id) == E_Generic_Function) break; gnu_subprog_decl = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1); gnu_subprog_type = TREE_TYPE (gnu_subprog_decl); begin_subprog_body (gnu_subprog_decl); set_lineno (gnat_node, 1); pushlevel (0); expand_start_bindings (0); /* See if there are any parameters for which we don't yet have GCC entities. These must be for OUT parameters for which we will be making VAR_DECL nodes here. Fill them in to TYPE_CI_CO_LIST, which must contain the empty entry as well. We can match up the entries because TYPE_CI_CO_LIST is in the order of the parameters. If we make any new nodes here, make sure that they are in the object that the function declaration's type is in because we will be using them in the context of the caller. */ push_obstacks (TYPE_OBSTACK (gnu_subprog_type), TYPE_OBSTACK (gnu_subprog_type)); gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type); for (gnat_param = First_Formal (gnat_subprog_id); Present (gnat_param); gnat_param = Next_Formal (gnat_param)) if (! present_gnu_tree (gnat_param)) { /* Skip any entries that have been already filled in; they must correspond to IN OUT parameters. */ for (; gnu_cico_list != 0 && TREE_VALUE (gnu_cico_list) != 0; gnu_cico_list = TREE_CHAIN (gnu_cico_list)) ; TREE_VALUE (gnu_cico_list) = gnat_to_gnu_entity (gnat_param, NULL_TREE, 1); } pop_obstacks (); /* Process the declarations inside the subprogram body. */ for (gnat_entity = First (Declarations (gnat_node)); Present (gnat_entity); gnat_entity = Next (gnat_entity)) gnat_to_code (gnat_entity); /* Generate the code of the subprogram itself. A return statement will be present and any OUT parameters will be handled there. */ gnat_to_code (Handled_Statement_Sequence (gnat_node)); set_lineno (gnat_node, 1); expand_end_bindings (getdecls (), 1, 0); poplevel (kept_level_p (), 1, 0); end_subprog_body (); /* Throw away any VAR_DECLs we made for OUT parameters; they must not be seen when we call this function and will be in unallocated memory anyway. Also throw away DECL_RTL in any PARM_DECLs unless this function was saved for inline, in which case the DECL_RTLs are in preserved memory. */ for (gnat_param = First_Formal (gnat_subprog_id); Present (gnat_param); gnat_param = Next_Formal (gnat_param)) { tree gnu_param = get_gnu_tree (gnat_param); if (TREE_CODE (gnu_param) == VAR_DECL) save_gnu_tree (gnat_param, NULL_TREE, 0); else if (TREE_CODE (gnu_param) == PARM_DECL && DECL_SAVED_INSNS (gnu_subprog_decl) == 0) DECL_RTL (gnu_param) = DECL_INCOMING_RTL (gnu_param) = 0; } /* Similarly, discard DECL_RTL of the return value. */ if (DECL_SAVED_INSNS (gnu_subprog_decl) == 0) DECL_RTL (DECL_RESULT (gnu_subprog_decl)) = DECL_INCOMING_RTL (DECL_RESULT (gnu_subprog_decl)) = 0; } break; case N_Function_Call: case N_Procedure_Call_Statement: { /* The GCC node corresponding to the GNAT subprogram name. This can either be a FUNCTION_DECL node if we are dealing with a standard subprogram call, or an indirect reference expression (an INDIRECT_REF node) pointing to a subprogram. */ tree gnu_subprog_node = gnat_to_gnu (Name (gnat_node)); /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */ tree gnu_subprog_type = TREE_TYPE (gnu_subprog_node); tree gnu_subprog_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_subprog_node); gnat_tree gnat_formal; gnat_tree gnat_actual; tree gnu_actual_list = NULL_TREE; tree gnu_subprog_call; if (TREE_CODE (gnu_subprog_type) != FUNCTION_TYPE) abort (); /* The only way we can be making a call via an access type is if Name is an explicit dereference. In that case, get the list of formal args from the type the access type is pointing to. Otherwise, get the formals from entity being called. */ if (Nkind (Name (gnat_node)) == N_Explicit_Dereference) gnat_formal = First_Formal (Etype (Name (gnat_node))); else gnat_formal = First_Formal (Entity (Name (gnat_node))); /* Create the list of the actual parameters as GCC expects it, namely a chain of TREE_LIST nodes in which the TREE_VALUE field of each node is a parameter-expression and the TREE_PURPOSE field is null. Skip OUT parameters that are not passed by reference. */ for (gnat_actual = First_Actual (gnat_node); Present (gnat_actual); gnat_formal = Next_Formal (gnat_formal), gnat_actual = Next_Actual (gnat_actual)) { tree gnu_actual = gnat_to_gnu (gnat_actual); tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal)); if (Do_Range_Check (gnat_actual)) gnu_actual = emit_range_check (gnu_actual, Etype (gnat_formal)); /* If we have not saved a GCC object for the formal, it means it is an OUT parameter not passed by reference. Otherwise, look at the PARM_DECL to see if it is passed by reference. */ if (present_gnu_tree (gnat_formal) && DECL_BY_REF_P (get_gnu_tree (gnat_formal))) { /* The symmetry of the paths to the type of an entity is broken here since arguments don't know that they will be passed by ref. */ gnu_formal_type = TREE_TYPE (get_gnu_tree (gnat_formal)); gnu_actual = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_actual); } else if (! present_gnu_tree (gnat_formal) || TREE_CODE (get_gnu_tree (gnat_formal)) != PARM_DECL) continue; gnu_actual_list = chainon (gnu_actual_list, build_tree_list (NULL_TREE, convert (gnu_formal_type, gnu_actual))); } gnu_subprog_call = build (CALL_EXPR, TREE_TYPE (gnu_subprog_type), gnu_subprog_addr, gnu_actual_list, NULL_TREE); TREE_SIDE_EFFECTS (gnu_subprog_call) = 1; /* If it is a function call, the result is the call expression. */ if (Nkind (gnat_node) == N_Function_Call) { gnu_result = gnu_subprog_call; /* If the function returns an unconstrained array, we have to de-dereference the pointer. */ if (TYPE_RETURNS_UNCONSTRAINED_P (gnu_subprog_type)) gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result); break; } /* If this is the case where the GNAT tree contains a procedure call but the Ada procedure has copy in copy out parameters, the special parameter passing mechanism must be used. */ else if (TYPE_CI_CO_LIST (gnu_subprog_type) != NULL_TREE) { /* List of FIELD_DECLs associated with the PARM_DECLs of the copy in copy out parameters. */ tree scalar_return_list = TYPE_CI_CO_LIST (gnu_subprog_type); int length = list_length (scalar_return_list); if (length > 1) gnu_subprog_call = save_expr (gnu_subprog_call); if (Nkind (Name (gnat_node)) == N_Explicit_Dereference) gnat_formal = First_Formal (Etype (Name (gnat_node))); else gnat_formal = First_Formal (Entity (Name (gnat_node))); for (gnat_actual = First_Actual (gnat_node); Present (gnat_actual); gnat_formal = Next_Formal (gnat_formal), gnat_actual = Next_Actual (gnat_actual)) /* If we are dealing with a copy in copy out parameter, we must retrieve its value from the record returned in the function call. */ if (!pass_by_ref (gnat_to_gnu_type (Etype (gnat_formal))) && Ekind (gnat_formal) != E_In_Parameter) { /* Get the value to assign to this OUT or IN OUT parameter. It is either the result of the function if there is only a single such parameter or the appropriate field from the record returned. */ tree gnu_result = length == 1 ? gnu_subprog_call : build_component_ref (gnu_subprog_call, NULL_TREE, TREE_PURPOSE (scalar_return_list)); /* If the actual is a conversion, get the inner expression, which will be the real destination, and convert the result to the type of the actual parameter. */ gnat_tree gnat_name = Nkind (gnat_actual) == N_Type_Conversion ? Expression (gnat_actual) : gnat_actual; tree gnu_actual = gnat_to_gnu (gnat_name); gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result); set_lineno (gnat_node, 1); expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_actual, gnu_result)); scalar_return_list = TREE_CHAIN (scalar_return_list); } break; } set_lineno (gnat_node, 1); expand_expr_stmt (gnu_subprog_call); } break; /*************************/ /* Chapter 7: Packages: */ /*************************/ case N_Package_Declaration: /* The only time we actually see this node is if it is not the top-level unit. So just expand the specification. */ gnat_to_code (Specification (gnat_node)); break; case N_Package_Specification: /* Process every declaration in the specification, both visible and private. */ if (Present (Visible_Declarations (gnat_node))) for (gnat_temp = First (Visible_Declarations (gnat_node)); Present (gnat_temp); gnat_temp = Next (gnat_temp)) gnat_to_code (gnat_temp); if (Present (Private_Declarations (gnat_node))) for (gnat_temp = First (Private_Declarations (gnat_node)); Present (gnat_temp); gnat_temp = Next (gnat_temp)) gnat_to_code (gnat_temp); break; case N_Package_Body: /* If this is the body of a generic package - do nothing */ if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package) break; /* The only time we get here is if we are not processing this package body at the top level. So just process all declarations and statements. Package declarations have the same persistence as those in the containing object, so don't push a binding level here. ??? This means that declarations and statements will be intermixed, which might be trouble when we deal with cleanups, but worry about it then. */ if (Present (Declarations (gnat_node))) for (gnat_temp = First (Declarations (gnat_node)); Present (gnat_temp); gnat_temp = Next (gnat_temp)) gnat_to_code (gnat_temp); /* If we are at the top level, record that we must generate code for any statements that actually belong in the body. Otherwise,e generate code now. */ if (Present (Handled_Statement_Sequence (gnat_node))) { if (global_bindings_p ()) { struct elab_list *p = (struct elab_list *) malloc (sizeof (struct elab_list)); p->next = 0; p->block = Handled_Statement_Sequence (gnat_node); if (first_to_elab) last_to_elab->next = p; else first_to_elab = p; last_to_elab = p; } else gnat_to_code (Handled_Statement_Sequence (gnat_node)); } break; /*********************************/ /* Chapter 8: Visibility Rules: */ /*********************************/ case N_Use_Package_Clause: case N_Use_Type_Clause: /* Nothing to do here - but these may appear in list of declarations */ break; /***********************/ /* Chapter 9: Tasks: */ /***********************/ case N_Task_Type_Declaration: break; case N_Single_Task_Declaration: gnat_to_gnu_entity (Defining_Identifier (gnat_node), NULL_TREE, 1); break; /***********************************************************/ /* Chapter 10: Program Structure and Compilation Issues: */ /***********************************************************/ case N_Compilation_Unit: /* If we have a package body, process and make an elaboration routine for the spec and then do the same for the body. */ if (Nkind (Unit (gnat_node)) == N_Package_Body) { first_to_elab = 0; gnat_to_code (Parent (Corresponding_Spec (Unit (gnat_node)))); build_package_elab (Corresponding_Spec (Unit (gnat_node)), 0, get_pending_elaborations (), 0); for (gnat_temp = First (Declarations (Unit (gnat_node))); Present (gnat_temp); gnat_temp = Next (gnat_temp)) gnat_to_code (gnat_temp); build_package_elab (Defining_Unit_Name (Unit (gnat_node)), 1, get_pending_elaborations (), Handled_Statement_Sequence (Unit (gnat_node))); } /* If we have a package spec, handle the declarations and elaboration function for it. */ else if (Nkind (Unit (gnat_node)) == N_Package_Declaration) { gnat_tree gnat_spec = Specification (Unit (gnat_node)); first_to_elab = 0; gnat_to_code (gnat_spec); build_package_elab (Defining_Unit_Name (gnat_spec), 0, get_pending_elaborations (), 0); } /* For library level subprogram bodies create (currently empty) elaboration functions for spec and body. */ else if (Nkind (Unit (gnat_node)) == N_Subprogram_Body) { build_subprogram_elab (Defining_Unit_Name ( Specification (Unit (gnat_node)))); gnat_to_code (Unit (gnat_node)); } /* Otherwise, process whatever unit we are called with. */ else gnat_to_code (Unit (gnat_node)); break; case N_Subprogram_Body_Stub: case N_Package_Body_Stub: /* Simply process whatever unit is being inserted. */ gnat_to_code (Library_Unit (gnat_node)); break; case N_Subunit: gnat_to_code (Proper_Body (gnat_node)); break; /***************************/ /* Chapter 11: Exceptions: */ /***************************/ case N_Handled_Sequence_Of_Statements: /* If there are exeption handlers, start a new binding level that we can exit (since each exception handler will do so). Then declare a variable to save the old __gnat_jmpbuf value and a variable for our jmpbuf. Call setjmp and handle each of the possible exceptions if it returns one. ??? We have a short-term kludge where we allow an N_Identifier of a procedure to be in Node1. In that case, exception handlers aren't allowed. We make an exception handler that calls the specified function and does a re-raise. We also put a call to that function as a cleanup action for that block. */ if (Present (Exception_Handlers (gnat_node)) || Present (Node1 (gnat_node))) { tree gnu_jmpsave_decl; tree gnu_jmpbuf_decl; tree gnu_cleanup_call = 0; tree gnu_cleanup_decl; tree gnu_call; int moment = suspend_momentary (); pushlevel (0); expand_start_bindings (1); gnu_jmpsave_decl = create_var_decl ("jmpbuf_save", NULL_PTR, jmpbuf_ptr_type, jmpbuf_decl, 0, 0, 0, 0, 0); gnu_jmpbuf_decl = create_var_decl ("jmp_buf", NULL_PTR, jmpbuf_type, NULL_PTR, 0, 0, 0, 0, 0); /* See if we are to call a function when exiting this block. */ if (Present (Node1 (gnat_node))) { gnu_cleanup_call = build (CALL_EXPR, void_type_node, build_unary_op (ADDR_EXPR, NULL_TREE, gnat_to_gnu (Node1 (gnat_node))), NULL_TREE, NULL_TREE); TREE_SIDE_EFFECTS (gnu_cleanup_call) = 1; gnu_cleanup_decl = create_var_decl ("cleanup", NULL_PTR, integer_type_node, NULL_PTR, 0, 0, 0, 0, 0); expand_decl_cleanup (gnu_cleanup_decl, gnu_cleanup_call); } /* When we exit this block, restore the saved value. */ expand_decl_cleanup (gnu_jmpsave_decl, build_binary_op (MODIFY_EXPR, NULL_TREE, jmpbuf_decl, gnu_jmpsave_decl)); resume_momentary (moment); /* Call setjmp and handle exceptions if it returns one. */ gnu_call = build (CALL_EXPR, integer_type_node, build_unary_op (ADDR_EXPR, NULL_TREE, setjmp_decl), chainon (NULL_TREE, build_tree_list (NULL_TREE, build_unary_op (ADDR_EXPR, NULL_TREE, gnu_jmpbuf_decl))), NULL_TREE); TREE_SIDE_EFFECTS (gnu_call) = 1; set_lineno (gnat_node, 1); expand_start_cond (gnu_call, 0); /* Restore our incoming longjmp value before we do anything. */ expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, jmpbuf_decl, gnu_jmpsave_decl)); /* If we have a cleanup to do, emit it now. */ if (gnu_cleanup_call) expand_expr_stmt (gnu_cleanup_call); /* Generate code for each exception handler. The code at N_Exception_Handler below does the real work. */ if (Present (Exception_Handlers (gnat_node))) for (gnat_temp = First (Exception_Handlers (gnat_node)); Present (gnat_temp); gnat_temp = Next (gnat_temp)) gnat_to_code (gnat_temp); /* If none of the exception handlers did anything, re-raise. */ gnu_call = build (CALL_EXPR, void_type_node, build_unary_op (ADDR_EXPR, NULL_TREE, longjmp_decl), chainon (chainon (NULL_TREE, build_tree_list (NULL_TREE, jmpbuf_decl)), build_tree_list (NULL_TREE, integer_one_node)), NULL_TREE); TREE_SIDE_EFFECTS (gnu_call) = 1; set_lineno (gnat_node, 1); expand_expr_stmt (gnu_call); /* End the "if" on setjmp. Note that we have arranged things so control never returns here. */ expand_end_cond (); /* This is now immediately before the body proper. Point __gnat_jmpbuf to our jmp_buf. */ expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, jmpbuf_decl, build_unary_op (ADDR_EXPR, NULL_TREE, gnu_jmpbuf_decl))); } /* Generate code for each statement in the block. */ push_momentary (); for (gnat_temp = First (Statements (gnat_node)); Present (gnat_temp); gnat_temp = Next (gnat_temp)) { gnat_to_code (gnat_temp); clear_momentary (); } pop_momentary (); /* If we have handlers, close the block we made. */ if (Present (Node1 (gnat_node)) || Present (Exception_Handlers (gnat_node))) { set_lineno (gnat_node, 1); expand_end_bindings (getdecls (), 1, 0); poplevel (kept_level_p (), 1, 0); } break; case N_Exception_Handler: { /* Unless this is "Others", make an "if" statement to select the proper exceptions. */ tree gnu_choice = integer_zero_node; for (gnat_temp = First (Exception_Choices (gnat_node)); gnat_temp; gnat_temp = Next (gnat_temp)) { if (Nkind (gnat_temp) == N_Others_Choice) gnu_choice = integer_one_node; else if (Nkind (gnat_temp) == N_Identifier || Nkind (gnat_temp) == N_Expanded_Name) { tree this_choice = build_binary_op (EQ_EXPR, integer_type_node, excptr_decl, build_unary_op (ADDR_EXPR, NULL_TREE, gnat_to_gnu (gnat_temp))); gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, gnu_choice, this_choice); } else abort (); } expand_start_cond (gnu_choice, 0); /* Generate code for the exception handler. */ push_momentary (); for (gnat_temp = First (Statements (gnat_node)); gnat_temp; gnat_temp = Next (gnat_temp)) { gnat_to_code (gnat_temp); clear_momentary (); } /* At the end of the handler, exit the block. We made this block in N_Handled_Sequence_Of_Statements. */ pop_momentary (); expand_exit_something (); expand_end_cond (); } break; /*******************************/ /* Chapter 12: Generic Units: */ /*******************************/ case N_Generic_Package_Declaration: case N_Generic_Subprogram_Declaration: case N_Package_Instantiation: case N_Procedure_Instantiation: case N_Function_Instantiation: /* These nodes can appear on a declaration list but there is nothing to to be done with them. */ break; /***************************************************/ /* Chapter 13: Representation Clauses and */ /* Implementation-Dependent Features: */ /***************************************************/ case N_Attribute_Definition_Clause: /* The only one we need deal with is for 'Address. For the others, SEM puts the information elsewhere. */ if (Get_Attribute_Id (Chars (Identifier (gnat_node))) != Attr_Address) break; /* Get the object being placed at a specified address and verify that it has not yet been elaborated. */ gnat_temp = Entity (Name (gnat_node)); if (! Is_Delayed (gnat_temp) || present_gnu_tree (gnat_temp)) abort (); /* Get the value to use as the address and save it as the equivalent for GNAT_TEMP. When the object is frozen, gnat_to_gnu_entity will do the right thing. */ gnu_expr = gnat_to_gnu (Expression (gnat_node)); save_gnu_tree (gnat_temp, gnu_expr, 1); break; case N_Enumeration_Representation_Clause: case N_Record_Representation_Clause: case N_At_Clause: /* We do nothing with these. SEM puts the information elsewhere. */ break; /***************************************************/ /* Added Nodes */ /***************************************************/ case N_Freeze_Entity: { gnat_tree gnat_entity = Entity (gnat_node); tree gnu_old = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0; tree gnu_new; tree gnu_init = (Nkind (Parent (gnat_entity)) == N_Object_Declaration && present_gnu_tree (Parent (gnat_entity))) ? get_gnu_tree (Parent (gnat_entity)) : NULL_TREE; /* If GNAT_ENTITY is not delayed, ignore this node. */ if (! Is_Delayed (gnat_entity)) break; /* If this entity has an Address representation clause, GNU_OLD is the address, so discard it here. */ if (Has_Address_Clause (gnat_entity)) gnu_old = 0; /* If we have a non-VOID_TYPE old tree, this node was never delayed as it should have been. */ if (gnu_old != 0 && ! (TREE_CODE (gnu_old) == TYPE_DECL && TREE_CODE (TREE_TYPE (gnu_old)) == VOID_TYPE)) abort (); /* Reset the saved tree, if any, and elaborate the object or type for real. If there is a full declaration, elaborate it and copy the type to GNAT_ENTITY. */ if (gnu_old != 0) { save_gnu_tree (gnat_entity, NULL_TREE, 0); if (IN (Ekind (gnat_entity), Incomplete_Kind) && Present (Full_Declaration (gnat_entity)) && present_gnu_tree (Full_Declaration (gnat_entity)) && get_gnu_tree (Full_Declaration (gnat_entity)) == gnu_old) save_gnu_tree (Full_Declaration (gnat_entity), NULL_TREE, 0); } if (IN (Ekind (gnat_entity), Incomplete_Kind) && Present (Full_Declaration (gnat_entity))) { gnu_new = gnat_to_gnu_entity (Full_Declaration (gnat_entity), NULL_TREE, 0); save_gnu_tree (gnat_entity, gnu_new, 0); } else gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1); /* If we've made any pointers to the old version of this type, we have to update them. */ if (gnu_old != 0 && TYPE_POINTER_TO (TREE_TYPE (gnu_old)) != 0) { TREE_TYPE (TYPE_POINTER_TO (TREE_TYPE (gnu_old))) = TREE_TYPE (gnu_new); TYPE_POINTER_TO (TREE_TYPE (gnu_new)) = TYPE_POINTER_TO (TREE_TYPE (gnu_old)); } } break; case N_Op_Concat: case N_Component_Association: case N_Extension_Aggregate: case N_Task_Body: default: post_error ("unsupported tree node~!", gnat_node); abort (); } /* Now convert the result to the proper type. If the type is void or if we have no result, return error_mark_node to show we have no result. If the type of the result is correct or if we have a label (which doesn't have any well-defined type), return our result. Also don't do the conversion if the "desired" type involves a PLACEHOLDER_EXPR in its size since those are the cases where the front end may have the type wrong due to "instantiating" the unconstrained record with discriminant values. Otherwise, convert the result to the proper type. */ if (TREE_CODE (gnu_result) == LABEL_DECL || (TYPE_SIZE (gnu_result_type) && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST && contains_placeholder_p (TYPE_SIZE (gnu_result_type)))) ; else if (gnu_result == error_mark_node || gnu_result_type == void_type_node) gnu_result = error_mark_node; else if (gnu_result_type != TREE_TYPE (gnu_result)) gnu_result = convert (gnu_result_type, gnu_result); /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on GNU_RESULT. */ while ((TREE_CODE (gnu_result) == NOP_EXPR || TREE_CODE (gnu_result) == NON_LVALUE_EXPR) && TREE_TYPE (TREE_OPERAND (gnu_result, 0)) == TREE_TYPE (gnu_result)) gnu_result = TREE_OPERAND (gnu_result, 0); /* If this is an expression we are to only evaluate once, make a SAVE_EXPR and store it. */ if (IN (Nkind (gnat_node), N_Subexpr) && Evaluate_Once (gnat_node)) { gnu_result = make_save_expr (gnu_result); save_gnu_tree (gnat_node, gnu_result, 1); } return gnu_result; } /* Emits an access check. GNU_EXPR is the expression that needs to be checked against the NULL pointer. */ static tree emit_access_check (gnu_expr) tree gnu_expr; { /* Checked expressions must be evaluated only once. */ gnu_expr = make_save_expr (gnu_expr); return emit_check (build_binary_op (EQ_EXPR, integer_type_node, gnu_expr, convert (TREE_TYPE (gnu_expr), integer_zero_node)), gnu_expr); } /* Emits a discriminant check. GNU_EXPR is the expression to be checked and GNAT_NODE a N_Selected_Component node. */ static tree emit_discriminant_check (gnu_expr, gnat_node) tree gnu_expr; gnat_tree gnat_node; { gnat_tree gnat_discr_fct = Discriminant_Checking_Func (Entity (Selector_Name (gnat_node))); tree gnu_discr_fct; gnat_tree gnat_discr; tree gnu_actual_list = NULL_TREE; tree gnu_cond; if (! Present (gnat_discr_fct)) return gnu_expr; /* abort (); */ gnu_discr_fct = gnat_to_gnu_entity (gnat_discr_fct, NULL_TREE, 0); /* Checked expressions must be evaluated only once. */ gnu_expr = make_save_expr (gnu_expr); /* Create the list of the actual parameters as GCC expects it. This list is the list of the discriminant fields of the record expression to be discriminant checked. For documentation on what is the GCC format for this list see under the N_Function_Call case */ for (gnat_discr = First_Discriminant (Etype (Entity (Prefix (gnat_node)))); Present (gnat_discr); gnat_discr = Next_Discriminant (gnat_discr)) { tree gnu_discr = gnat_to_gnu_entity (gnat_discr, NULL_TREE, 0); /* the IDENTIFIER_NODE whose name is that of the discriminant */ tree gnu_discr_id_node = get_identifier (Get_Name_String (Chars (gnat_discr))); gnu_actual_list = chainon (gnu_actual_list, build_tree_list (NULL_TREE, build_component_ref (gnu_expr, gnu_discr_id_node, gnu_discr))); } gnu_cond = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (gnu_discr_fct)), build_unary_op (ADDR_EXPR, NULL_TREE, gnu_discr_fct), gnu_actual_list, NULL_TREE); TREE_SIDE_EFFECTS (gnu_cond) = 1; return emit_check (gnu_cond, gnu_expr); } /* Emit code for a range check. GNU_EXPR is the expression to be checked, GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against which we have to check. */ static tree emit_range_check (gnu_expr, gnat_range_type) tree gnu_expr; gnat_tree gnat_range_type; { tree gnu_range_type = gnat_to_gnu_type (gnat_range_type); tree gnu_low = TYPE_MIN_VALUE (gnu_range_type); tree gnu_high = TYPE_MAX_VALUE (gnu_range_type); /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE, we can't do anything since we might be truncating the bounds. No check is needed in this case. */ if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr)) && (TYPE_PRECISION (TREE_TYPE (gnu_expr)) < TYPE_PRECISION (gnu_range_type))) return gnu_expr; /* Checked expressions must be evaluated only once. */ gnu_expr = make_save_expr (gnu_expr); /* There's no good type to use here, so we might as well use integer_type_node. */ return emit_check (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, build_binary_op (LT_EXPR, integer_type_node, gnu_expr, convert (TREE_TYPE (gnu_expr), gnu_low)), build_binary_op (GT_EXPR, integer_type_node, gnu_expr, convert (TREE_TYPE (gnu_expr), gnu_high))), gnu_expr); } /* Emit code for an index check. GNU_ARRAY_OBJECT is the array object which we are about to index, GNU_EXPR is the index expression to be checked, GNU_LOW and GNU_HIGH are the lower and upper bounds against which GNU_EXPR has to be checked. Note that for index checking we cannot use the emit_range_check function (although very similar code needs to be generated in both cases) since for index checking the array type against which we are checking the indeces may be unconstrained and consequently we need to retrieve the actual index bounds from the array object itself (GNU_ARRAY_OBJECT). The place where we need to do that is in subprograms having unconstrained array formal parameters */ static tree emit_index_check (gnu_array_object, gnu_expr, gnu_low, gnu_high) tree gnu_array_object; tree gnu_expr; tree gnu_low; tree gnu_high; { /* Checked expressions must be evaluated only once. */ gnu_expr = make_save_expr (gnu_expr); /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by the object we are handling. */ if (TREE_CODE (gnu_low) != INTEGER_CST && contains_placeholder_p (gnu_low)) gnu_low = build (WITH_RECORD_EXPR, TREE_TYPE (gnu_low), gnu_low, gnu_array_object); if (TREE_CODE (gnu_high) != INTEGER_CST && contains_placeholder_p (gnu_high)) gnu_high = build (WITH_RECORD_EXPR, TREE_TYPE (gnu_high), gnu_high, gnu_array_object); /* There's no good type to use here, so we might as well use integer_type_node. */ return emit_check (build_binary_op (TRUTH_ORIF_EXPR, integer_type_node, build_binary_op (LT_EXPR, integer_type_node, gnu_expr, convert (TREE_TYPE (gnu_expr), gnu_low)), build_binary_op (GT_EXPR, integer_type_node, gnu_expr, convert (TREE_TYPE (gnu_expr), gnu_high))), gnu_expr); } /* Given GNU_COND which contains the condition corresponding to an access, discriminant or range check, of value GNU_EXPR, build a COND_EXPR that returns GNU_EXPR if GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true. */ static tree emit_check (gnu_cond, gnu_expr) tree gnu_cond; tree gnu_expr; { tree gnu_call = build (CALL_EXPR, void_type_node, build_unary_op (ADDR_EXPR, NULL_TREE, raise_constraint_decl), NULL_TREE, NULL_TREE); TREE_SIDE_EFFECTS (gnu_call) = 1; /* Use an outer COMPOUND_EXPR to make sure that GNU_EXPR will get evaluated in front of the comparison in case it ends up being a SAVE_EXPR. */ return build (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_expr, build (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond, build (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_call, gnu_expr), gnu_expr)); } /* GNAT_ASSOC is a sub-part (possibly the front) of the Component_Associations of an N_Aggregate. GNU_TYPE is the GCC type of the corresponding record. GNU_SO_FAR is the part of the CONSTRUCTOR list before the variant, if any so far. This list must contain the discriminants. Return a CONSTRUCTOR to initialize the record. This function is called recursively to handle variant parts. We rely heavily on the fact that a variant must be the last thing in a record. We also assume that the front end has sorted all the fields and eliminated any multiple choices. These assumptions are verified. */ static tree assoc_to_constructor (gnat_assoc, gnu_type, gnu_so_far) gnat_tree gnat_assoc; tree gnu_type; tree gnu_so_far; { tree gnu_field, gnu_list; /* We test for GNU_FIELD being empty in the case where a variant was the last thing since we don't take things off GNAT_ASSOC in that case. We check GNAT_ASSOC in case we have a variant, but it has no fields. */ for (gnu_field = TYPE_FIELDS (gnu_type), gnu_list = NULL_TREE; gnu_field != 0 && Present (gnat_assoc); gnat_assoc = Next (gnat_assoc), gnu_field = TREE_CHAIN (gnu_field)) { gnat_tree gnat_field = First (Choices (gnat_assoc)); char *field_name = Get_Name_String (Chars (gnat_field)); tree gnu_expr; /* The expander is supposed to put a single component selector name in every record component association */ if (Next (gnat_field)) abort (); /* There are only two valid possibilities: GNU_FIELD is either an unnamed QUAL_UNION_TYPE that represents a variant part or it is the desired field. If it is a variant part, find the variant whose DECL_QUALIFIER is true. It might seem that we could just look for the variant with the proper-named field, but we might have an arbitrary number of nested variants before the first named field, so this is simpler. */ if (DECL_NAME (gnu_field) == 0 && TREE_CODE (TREE_TYPE (gnu_field)) == QUAL_UNION_TYPE) { tree gnu_variant; tree gnu_discrims = gnu_so_far ? gnu_so_far : gnu_list; for (gnu_variant = TYPE_FIELDS (TREE_TYPE (gnu_field)); gnu_variant; gnu_variant = TREE_CHAIN (gnu_variant)) { tree gnu_qual = DECL_QUALIFIER (gnu_variant); tree gnu_discrim; for (gnu_discrim = gnu_discrims; gnu_discrim; gnu_discrim = TREE_CHAIN (gnu_discrim)) if (DECL_DISCRIMINANT_P (TREE_PURPOSE (gnu_discrim))) gnu_qual = substitute_in_expr (gnu_qual, TREE_PURPOSE (gnu_discrim), TREE_VALUE (gnu_discrim)); /* If we found it, get the CONSTRUCTOR for the variant. Then surround it with a CONSTRUCTOR for the QUAL_UNION_TYPE. */ if (integer_onep (gnu_qual)) { tree gnu_inner = assoc_to_constructor (gnat_assoc, TREE_TYPE (gnu_variant), gnu_discrims); gnu_expr = build_constructor (TREE_TYPE (gnu_field), tree_cons (gnu_variant, gnu_inner, NULL_TREE)); break; } } } else if (0 == strcmp (field_name, IDENTIFIER_POINTER (DECL_NAME (gnu_field)))) { gnu_expr = gnat_to_gnu (Expression (gnat_assoc)); /* Before assigning a value in an aggregate make sure range checks are done if required */ if (Do_Range_Check (Expression (gnat_assoc))) gnu_expr = emit_range_check (gnu_expr, Etype (gnat_field)); } else abort (); /* Add the field and expression to the list. */ gnu_list = tree_cons (gnu_field, gnu_expr, gnu_list); } /* Return the final CONSTRUCTOR. We need not reverse the fields, but do so for cleanliness. */ return build_constructor (gnu_type, nreverse (gnu_list)); } /* Builds a possibly nested constructor for array aggregates. GNAT_EXPR is the first element of an array aggregate. It may itself be an aggregate (an array or record aggregate). GNU_ARRAY_TYPE is the gnu type corresponding to the array aggregate. GNAT_COMPONENT_TYPE is the type of the array component. It is needed for range checking. */ static tree pos_to_constructor (gnat_expr, gnu_array_type, gnat_component_type) gnat_tree gnat_expr; tree gnu_array_type; gnat_tree gnat_component_type; { tree gnu_expr; tree gnu_expr_list = NULL_TREE; for ( ; Present (gnat_expr); gnat_expr = Next (gnat_expr)) { /* if the expression is itself an array aggregate then build first the innermost constructor */ if (Nkind (gnat_expr) == N_Aggregate && TREE_CODE (TREE_TYPE (gnu_array_type)) == ARRAY_TYPE) gnu_expr = pos_to_constructor (First (Expressions (gnat_expr)), TREE_TYPE (gnu_array_type), gnat_component_type); else { gnu_expr = gnat_to_gnu (gnat_expr); /* before assigning the element to the array make sure it is in range */ if (Do_Range_Check (gnat_expr)) gnu_expr = emit_range_check (gnu_expr, gnat_component_type); } gnu_expr_list = tree_cons (NULL_TREE, gnu_expr, gnu_expr_list); } return build_constructor (gnu_array_type, nreverse (gnu_expr_list)); } /* EXP is to be treated as an array or record. Handle the cases when it is an access object and perform the required dereferences. */ static tree maybe_implicit_deref (exp) tree exp; { /* If the type is a pointer, dereference it. */ if (TREE_CODE (TREE_TYPE (exp)) == POINTER_TYPE || TYPE_FAT_POINTER_P (TREE_TYPE (exp))) exp = build_unary_op (INDIRECT_REF, NULL_TREE, exp); return exp; } /* Surround EXP with a SAVE_EXPR, but if it is an UNCONSTRAINED_ARRAY_REF, surround it's first operand instead. */ static tree make_save_expr (exp) tree exp; { if (TREE_CODE (exp) == UNCONSTRAINED_ARRAY_REF) return build1 (UNCONSTRAINED_ARRAY_REF, TREE_TYPE (exp), save_expr (TREE_OPERAND (exp, 0))); return save_expr (exp); } /* If EXP is an UNCONSTRAINED_ARRAY_REF, return an expression that refers to the underlying array. */ static tree maybe_unconstrained_array (exp) tree exp; { if (TREE_CODE (exp) == UNCONSTRAINED_ARRAY_REF) exp = build_unary_op (INDIRECT_REF, NULL_TREE, build_component_ref (TREE_OPERAND (exp, 0), get_identifier ("p_array"), NULL_TREE)); return exp; } /* GNAT_UNIT is the Defining_Identifier for some package, either a spec or a body, BODY_P says which. Make a function to be the elaboration routine for that object, perform the elaborations in GNU_ELAB_LIST, and then emit any statements in the global list FIRST_TO_ELAB followed by GNAT_STATEMENTS, which, if present, is a Handled_Sequence_Of_Statements. */ static void build_package_elab (gnat_unit, body_p, gnu_elab_list, gnat_statements) gnat_tree gnat_unit; int body_p; tree gnu_elab_list; gnat_tree gnat_statements; { tree gnu_decl; struct elab_list *elab; /* Set our file and line number to that of the object and set up the elaboration routine. */ gnu_decl = create_subprog_decl (create_concat_name (gnat_unit, body_p ? "elabb" : "elabs"), 0, void_ftype, NULL_TREE, 0, 1, 0, 0); begin_subprog_body (gnu_decl); set_lineno (gnat_unit, 1); pushlevel (0); expand_start_bindings (0); /* Emit the assignments for the elaborations we have to do. If there is no destination, this is just a call to execute some statement that was placed within the declarative region. */ for (; gnu_elab_list; gnu_elab_list = TREE_CHAIN (gnu_elab_list)) if (TREE_PURPOSE (gnu_elab_list) == NULL_TREE) expand_expr_stmt (TREE_VALUE (gnu_elab_list)); else expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, TREE_PURPOSE (gnu_elab_list), TREE_VALUE (gnu_elab_list))); /* Process initialization for any bodies we encountered among the definitions. */ for (elab = first_to_elab; elab; elab = elab->next) gnat_to_code (elab->block); /* Now generate code for any actual statements in the body. */ if (Present (gnat_statements)) gnat_to_code (gnat_statements); expand_end_bindings (getdecls (), 1, 0); poplevel (0, 0, 0); end_subprog_body (); } /* GNAT_UNIT is the Defining_Identifier for some subprogram. Make elaboration functions for the spec and body of it. Currently the function just returns -- eventually it may have some elaboration order checks in it. */ static void build_subprogram_elab (gnat_unit) gnat_tree gnat_unit; { tree gnu_decl; /* Set our file and line number to that of the object and set up the elaboration routine. */ gnu_decl = create_subprog_decl (create_concat_name (gnat_unit, "elabb"), 0, void_ftype, NULL_TREE, 0, 1, 0, 0); begin_subprog_body (gnu_decl); set_lineno (gnat_unit, 1); pushlevel (0); expand_start_bindings (0); expand_end_bindings (getdecls (), 1, 0); poplevel (0, 0, 0); end_subprog_body (); gnu_decl = create_subprog_decl (create_concat_name (gnat_unit, "elabs"), 0, void_ftype, NULL_TREE, 0, 1, 0, 0); begin_subprog_body (gnu_decl); set_lineno (gnat_unit, 1); pushlevel (0); expand_start_bindings (0); expand_end_bindings (getdecls (), 1, 0); poplevel (0, 0, 0); end_subprog_body (); } /* Determine the input_filename and the lineno from the source location (Sloc) of GNAT_NODE node. Set the global variable input_filename and lineno. If WRITE_NOTE_P is true, emit a line number note. */ void set_lineno (gnat_node, write_note_p) gnat_tree gnat_node; int write_note_p; { extern Int Number_Units; extern struct Needed_File_Info *File_Info_Ptr; extern int **Lines_Ptrs; int current_unit_number; int Last_Line; Source_Ptr source_location = Sloc (gnat_node); int Lo = 0; int Hi; int Mid; /* If node not from source code, ignore. */ if (source_location < 0) return; for (current_unit_number = 0; current_unit_number < Number_Units; current_unit_number++) { if (source_location >= File_Info_Ptr[current_unit_number].First_Sloc && source_location <= File_Info_Ptr[current_unit_number].Last_Sloc) break; } sloc_offset = source_location - File_Info_Ptr[current_unit_number].First_Sloc; if (current_unit_number == Number_Units) abort (); input_filename = Get_Name_String (File_Info_Ptr[current_unit_number].File_Name); Hi = File_Info_Ptr[current_unit_number].Last_Line - 1; for (;;) { Mid = (Lo + Hi) / 2; if (source_location < Lines_Ptrs[current_unit_number][Mid]) Hi = Mid - 1; else if (Mid == Hi || source_location < Lines_Ptrs[current_unit_number][Mid + 1]) { lineno = Mid + 1; break; } else Lo = Mid + 1; } if (write_note_p) emit_line_note (input_filename, lineno); } /* Post an error message. MSG is the error message, properly annotated. NODE is the node at which to post the error and the node to use for the "&" substitution. */ void post_error (msg, node) char *msg; gnat_tree node; { struct template {int first, last; } temp = {1, strlen (msg)}; struct fat_pointer { char *array; struct template *temp; } fp = {msg, &temp}; errout__error_msg_n (fp, node); } /* Initialize the table that maps GNAT codes to GCC codes for simple binary and unary operations. */ void init_code_table () { gnu_codes[N_Op_And] = TRUTH_AND_EXPR; gnu_codes[N_Op_And_Then] = TRUTH_ANDIF_EXPR; gnu_codes[N_Op_Or] = TRUTH_OR_EXPR; gnu_codes[N_Op_Or_Else] = TRUTH_ORIF_EXPR; gnu_codes[N_Op_Xor] = TRUTH_XOR_EXPR; gnu_codes[N_Op_Eq] = EQ_EXPR; gnu_codes[N_Op_Ne] = NE_EXPR; gnu_codes[N_Op_Lt] = LT_EXPR; gnu_codes[N_Op_Le] = LE_EXPR; gnu_codes[N_Op_Gt] = GT_EXPR; gnu_codes[N_Op_Ge] = GE_EXPR; gnu_codes[N_Op_Add] = PLUS_EXPR; gnu_codes[N_Op_Subtract] = MINUS_EXPR; gnu_codes[N_Op_Multiply] = MULT_EXPR; gnu_codes[N_Op_Mod] = FLOOR_MOD_EXPR; gnu_codes[N_Op_Rem] = TRUNC_MOD_EXPR; gnu_codes[N_Op_Expon] = EXPON_EXPR; gnu_codes[N_Op_Minus] = NEGATE_EXPR; gnu_codes[N_Op_Abs] = ABS_EXPR; gnu_codes[N_Op_Not] = TRUTH_NOT_EXPR; } aggregate). GNU_ARRAY_TYPE is the gnu type corresponding to the array aggregate. GNAT_COMPONENT_TYPE is the type of the array component. It is needed for range checking. */ static tree pos_to_constructor (gnat_expr, gnu_array_type, gnat_component_type) gnat_tree gnat_expr; tree gnu_array_type; gnat_tree gnat_componegnat-1.67-src/src/a-trans.h 444 10015 7640 5357 5506244466 10654 /****************************************************************************/ /* */ /* GNAT COMPILER COMPONENTS */ /* */ /* TREE TRANSFORMER */ /* */ /* Specification */ /* */ /* $Revision: 1.8 $ */ /* */ /* Copyright (c) 1992,1993, NYU, All Rights Reserved */ /* */ /* 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 */ /* Software Foundation; either version 2, or (at your option) any later */ /* version. GNAT is distributed in the hope that it will be useful, but */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- */ /* ABILITY 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 GNAT; see file COPYING. If not, write */ /* to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* */ /****************************************************************************/ /* Type used to identify entries in the gnat tree. A node of type `gnat_tree' is the root of a gnat tree or subtree. */ typedef Tree_Id gnat_tree; #define BAD_GNAT_TREE ((gnat_tree) -1) /* Offset from first sloc in file. Set in parallel with LINENO and CURRENT_FILE_NAME. */ extern int sloc_offset; /* For most front-ends, this is the parser for the language. For us, we process the GNAT tree. */ extern int yyparse PROTO((void)); /* This function is the driver of the GNAT to GCC tree transformation process. GNAT_NODE is the root of some gnat tree. It generates code for that part of the tree. */ extern void gnat_to_code PROTO((gnat_tree)); /* GNAT_NODE is the root of some GNAT tree. Return the root of the GCC tree corresponding to that GNAT tree. Normally, no code is generated; we just return an equivalent tree which is used elsewhere to generate code. */ extern tree gnat_to_gnu PROTO((gnat_tree)); /* Determine the input_filename and the lineno from the source location (Sloc) of GNAT_NODE node. Set the global variable input_filename and lineno. If WRITE_NOTE_P is true, emit a line number note. */ extern void set_lineno PROTO((gnat_tree, int)); /* Post an error message. MSG is the error message, properly annotated. NODE is the node at which to post the error and the node to use for the "&" substitution. */ extern void post_error PROTO((char *, gnat_tree)); /* Initialize the table that maps GNAT codes to GCC codes for simple binary and unary operations. */ extern void init_code_table PROTO((void)); E, exp); return exp; } /* Surround EXP with a SAVE_EXPR, but if it is an UNCONSTRAINED_ARRAY_REF, surround it's first operand instead. */ static tree make_save_expr (exp) tree exp; { if (TREE_CODE (exp) == UNCONSTRAINED_ARRAY_REF) return build1 (UNCONSTgnat-1.67-src/src/a-tree.def 444 10015 7640 5067 5506244466 10771 /****************************************************************************/ /* */ /* GNAT COMPILER COMPONENTS */ /* */ /* GNAT-SPECIFIC GCC TREE CODES */ /* */ /* Specification */ /* */ /* $Revision: 1.3 $ */ /* */ /* Copyright (c) 1993, NYU, All Rights Reserved */ /* */ /* 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 */ /* Software Foundation; either version 2, or (at your option) any later */ /* version. GNAT is distributed in the hope that it will be useful, but */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- */ /* ABILITY 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 GNAT; see file COPYING. If not, write */ /* to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* */ /****************************************************************************/ /* A GNAT tree node to transform to a GCC tree. This is only used when the node would generate code, rather then just a tree, and we are in the global context. The only field used if TREE_COMPLEXITY, which contains the GNAT node number. */ DEFTREECODE (TRANSFORM_EXPR, "transform_expr", "e", 0) /* Perform an unchecked conversion between the input and the output. */ DEFTREECODE (UNCHECKED_CONVERT_EXPR, "unchecked_convert_expr", "1", 1) /* A type that is an unconstrained array itself. This note is never passed to GCC and the only field is TREE_TYPE, which is the type of the fat pointer. */ DEFTREECODE (UNCONSTRAINED_ARRAY_TYPE, "unconstrained_array_type", "t", 0) /* A reference to an unconstrained array. This node only exists as an intermediate node during the translation of a GNAT tree to a GCC tree; it is never passed to GCC. The only field used is operand 0, which is the fat pointer object. */ DEFTREECODE (UNCONSTRAINED_ARRAY_REF, "unconstrained_array_ref", "r", 1) #if 0 ---------------------- -- REVISION HISTORY -- ---------------------- ** New changes after this line and before endif. ** UNCHECKED_CONVERT_EXPR has length 1 #endif **********************/ /* */ /* GNAT COMPILER COMPONENTS */ /* */ /* GNAT-SPECIFIC GCC TREE CODES */ /* */ /* Specification */ /* */ /* $Revision: 1.3 $ */ /gnat-1.67-src/src/a-atree.h 444 10015 7640 31752 5506244467 10644 /****************************************************************************/ /* */ /* GNAT COMPILER COMPONENTS */ /* */ /* T R E E */ /* */ /* S p e c */ /* (C Version) */ /* */ /* $Revision: 1.20 $ */ /* */ /* Copyright (c) 1992,1993, NYU, All Rights Reserved */ /* */ /* 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 */ /* Software Foundation; either version 2, or (at your option) any later */ /* version. GNAT is distributed in the hope that it will be useful, but */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- */ /* ABILITY 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 GNAT; see file COPYING. If not, write */ /* to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* */ /****************************************************************************/ /* This is the C header corresponding to the Ada package specification for Tree. It also contains the implementations of inlined functions from the package body for Tree. It was generated manually from TREE_.ADA and TREE.ADA and must be kept synchronized with changes in these packages. Note that only routines for reading the tree are included, since the tree transformer is not supposed to modify the tree in any way. */ /* Structures to define tree node. */ /* The Ada record for a Node is a variant record discriminated by Is_Extension. It contains a common area consisting of Nkind, Ekind, and a large number of flags. Note that the field names are all lower-case, while the access macros are mixed-case. The first structure below corresponds to the variant part with is_extension = False and the second with is_extension = True. */ struct Non_Extended { Source_Ptr sloc; Int link; Int field1; Int field2; Int field3; Int field4; Int field5; }; /* The Following structure corresponds to variant with is_extension = True. */ struct Extended { Int field6; Int field7; Int field8; Int field9; Int field10; Int field11; Int field12; }; struct Node { Boolean is_extension : 1; Boolean in_list : 1; Boolean rewrite_sub : 1; Boolean rewrite_ins : 1; Boolean flag1 : 1; Boolean flag2 : 1; Boolean flag3 : 1; Boolean flag4 : 1; Boolean flag5 : 1; Boolean flag6 : 1; Boolean flag7 : 1; Boolean flag8 : 1; Boolean flag9 : 1; Boolean flag10 : 1; Boolean flag11 : 1; Boolean flag12 : 1; Boolean flag13 : 1; Boolean flag14 : 1; Boolean flag15 : 1; Boolean flag16 : 1; Boolean flag17 : 1; Boolean flag18 : 1; Boolean flag19 : 1; Boolean flag20 : 1; unsigned char kind : 8; union variant { struct Non_Extended NX; struct Extended EX; } V; }; /* The actual tree is an array of nodes. The pointer to this array is passed as a parameter to the tree transformer procedure and stored in the global variable Nodes_Ptr after adjusting it by subtracting Node_First_Entry, so that Node_Id values can be used as subscripts. */ extern struct Node *Nodes_Ptr; /* Store the subscript of the last allocated Node_Id value. */ extern Node_Id Last_Node_Id; /* The following is the structure used for the lists table. Nodes in this table are used in three different ways: For node list headers: Lfield1 points to the first node in the list (Empty if none) Lfield2 points to the last node in the list (Empty if none) Lnode points to the parent (Empty if none) For element list headers: Lfield1 points to the first element in the list (No_Elmt if none) Lfield2 points to the last element in the list (No_Elmt if none) Lnode points to the parent (Empty if none) For elements in an element list: Lfield1 points to the previous element or to header at list start Lfield2 points to the next element or to header at list end Lnode contains pointer to referenced Val of element */ struct List_Header { Int Lfield1; Int Lfield2; Node_Id Lnode; }; /* The list headers are stored in an array. The pointer to this array is passed as a parameter to the tree transformer procedure and stored in the global variable List_Headers_Ptr after adjusting it by subtracting List_First_Entry, so that List_Id values can be used as subscripts. */ extern struct List_Header *List_Headers_Ptr; /* Store the subscript of the last allocated List_Id value. */ extern List_Id Last_List_Id; /* Node List Access Functions */ INLINE Node_Id First (List) List_Id List; { return List_Headers_Ptr [List].Lfield1; } INLINE Node_Id Last (List) List_Id List; { return List_Headers_Ptr [List].Lfield2; } INLINE Node_Id Next (Node) Node_Id Node; { Int Id = Nodes_Ptr [Node].V.NX.link; if (IN (Id, List_Range)) return Empty; else return Id; } #define Prev atree__prev extern Node_Id Prev PROTO((Node_Id)); #define Parent atree__parent extern Node_Id Parent PROTO((Node_Id)); INLINE Boolean Is_Empty_List (Id) List_Id Id; { return (First (Id) == Empty); } INLINE Boolean Is_Non_Empty_List (Id) List_Id Id; { return (First (Id) != Empty); } INLINE Boolean Is_List_Member (Node) Node_Id Node; { return Nodes_Ptr [Node].in_list; } #define List_Containing atree__list_containing extern List_Id List_Containing PROTO((Node_Id)); /* Element List Access Functions: */ INLINE Node_Id Id_Of (Elmt) Elmt_Id Elmt; { return List_Headers_Ptr [Elmt - Elmt_Bias].Lnode; } INLINE Elmt_Id First_Elmt (List) Elist_Id List; { return List_Headers_Ptr [List - Elist_Bias].Lfield1; } INLINE Elmt_Id Last_Elmt (List) Elist_Id List; { return List_Headers_Ptr [List - Elist_Bias].Lfield2; } INLINE Elmt_Id Next_Elmt (Node) Elmt_Id Node; { Int N = List_Headers_Ptr [Node - Elmt_Bias].Lfield2; if (IN (N, Elist_Range)) return No_Elmt; else return N; } INLINE Elmt_Id Prev_Elmt (Node) Elmt_Id Node; { Int N = List_Headers_Ptr [Node - Elmt_Bias].Lfield1; if (IN (N, Elist_Range)) return No_Elmt; else return N; } INLINE Boolean Is_Empty_Elmt_List (Id) Elist_Id Id; { return List_Headers_Ptr [Id - Elist_Bias].Lfield1 == No_Elmt; } INLINE Boolean Is_Non_Empty_Elmt_List (Id) Elist_Id Id; { return List_Headers_Ptr [Id - Elist_Bias].Lfield1 != No_Elmt; } /* Overloaded Functions: These functions are overloaded in the original Ada source, but there is only one corresponding C function, which works as described below. */ /* Type used for union of Node_Id, List_Id, Elist_Id. */ typedef Int Tree_Id; /* These two functions can only be used for Node_Id and List_Id values and they work in the C version because Empty = No_List = 0. */ INLINE Boolean No (N) Tree_Id N; { return N == Empty; } INLINE Boolean Present (N) Tree_Id N; { return N != Empty; } /* Test the range of N to distinguish between the cases of Node_Id, List_Id and Elist_Id arguments. */ extern Node_Id Parent PROTO((Tree_Id)); /* Node Access Functions: */ #define Nkind(N) ((Node_Kind)(Nodes_Ptr [N].kind)) #define Ekind(N) ((Entity_Kind)(Nodes_Ptr [N + 1].kind)) #define Sloc(N) (Nodes_Ptr [N].V.NX.sloc) #define Field1(N) (Nodes_Ptr [N].V.NX.field1) #define Field2(N) (Nodes_Ptr [N].V.NX.field2) #define Field3(N) (Nodes_Ptr [N].V.NX.field3) #define Field4(N) (Nodes_Ptr [N].V.NX.field4) #define Field5(N) (Nodes_Ptr [N].V.NX.Field5) #define Field6(N) (Nodes_Ptr [N+1].V.EX.field6) #define Field7(N) (Nodes_Ptr [N+1].V.EX.field7) #define Field8(N) (Nodes_Ptr [N+1].V.EX.field8) #define Field9(N) (Nodes_Ptr [N+1].V.EX.field9) #define Field10(N) (Nodes_Ptr [N+1].V.EX.field10) #define Field11(N) (Nodes_Ptr [N+1].V.EX.field11) #define Field12(N) (Nodes_Ptr [N+1].V.EX.field12) #define Node1(N) (Nodes_Ptr [N].V.NX.field1) #define Node2(N) (Nodes_Ptr [N].V.NX.field2) #define Node3(N) (Nodes_Ptr [N].V.NX.field3) #define Node4(N) (Nodes_Ptr [N].V.NX.field4) #define Node5(N) (Nodes_Ptr [N].V.NX.field5) #define Node6(N) (Nodes_Ptr [N+1].V.EX.field6) #define Node7(N) (Nodes_Ptr [N+1].V.EX.field7) #define Node8(N) (Nodes_Ptr [N+1].V.EX.field8) #define Node9(N) (Nodes_Ptr [N+1].V.EX.field9) #define Node10(N) (Nodes_Ptr [N+1].V.EX.field10) #define Node11(N) (Nodes_Ptr [N+1].V.EX.field11) #define Node12(N) (Nodes_Ptr [N+1].V.EX.field12) #define List1(N) (Nodes_Ptr [N].V.NX.field1) #define List2(N) (Nodes_Ptr [N].V.NX.field2) #define List3(N) (Nodes_Ptr [N].V.NX.field3) #define List4(N) (Nodes_Ptr [N].V.NX.field4) #define List5(N) (Nodes_Ptr [N].V.NX.field5) #define List6(N) (Nodes_Ptr [N+1].V.EX.field6) #define List7(N) (Nodes_Ptr [N+1].V.EX.field7) #define List8(N) (Nodes_Ptr [N+1].V.EX.field8) #define List9(N) (Nodes_Ptr [N+1].V.EX.field9) #define List10(N) (Nodes_Ptr [N+1].V.EX.field10) #define List11(N) (Nodes_Ptr [N+1].V.EX.field11) #define List12(N) (Nodes_Ptr [N+1].V.EX.field12) #define Elist1(N) (Nodes_Ptr [N].V.NX.field1) #define Elist2(N) (Nodes_Ptr [N].V.NX.field2) #define Elist3(N) (Nodes_Ptr [N].V.NX.field3) #define Elist4(N) (Nodes_Ptr [N].V.NX.field4) #define Elist5(N) (Nodes_Ptr [N].V.NX.field5) #define Elist6(N) (Nodes_Ptr [N+1].V.EX.field6) #define Elist7(N) (Nodes_Ptr [N+1].V.EX.field7) #define Elist8(N) (Nodes_Ptr [N+1].V.EX.field8) #define Elist9(N) (Nodes_Ptr [N+1].V.EX.field9) #define Elist10(N) (Nodes_Ptr [N+1].V.EX.field10) #define Elist11(N) (Nodes_Ptr [N+1].V.EX.field11) #define Elist12(N) (Nodes_Ptr [N+1].V.EX.field12) #define Name1(N) (Nodes_Ptr [N].V.NX.field1) #define Name2(N) (Nodes_Ptr [N].V.NX.field2) #define Name3(N) (Nodes_Ptr [N].V.NX.field3) #define Name4(N) (Nodes_Ptr [N].V.NX.field4) #define Name5(N) (Nodes_Ptr [N].V.NX.field5) #define Char_Code1(N) (Nodes_Ptr [N].V.NX.field1 - Char_Code_Bias) #define Char_Code2(N) (Nodes_Ptr [N].V.NX.field2 - Char_Code_Bias) #define Char_Code3(N) (Nodes_Ptr [N].V.NX.field3 - Char_Code_Bias) #define Char_Code4(N) (Nodes_Ptr [N].V.NX.field4 - Char_Code_Bias) #define Char_Code5(N) (Nodes_Ptr [N].V.NX.field5 - Char_Code_Bias) #define Str1(N) (Nodes_Ptr [N].V.NX.field1) #define Str2(N) (Nodes_Ptr [N].V.NX.field2) #define Str3(N) (Nodes_Ptr [N].V.NX.field3) #define Str4(N) (Nodes_Ptr [N].V.NX.field4) #define Str5(N) (Nodes_Ptr [N].V.NX.field5) #define Uint1(N) (Nodes_Ptr [N].V.NX.field1) #define Uint2(N) (Nodes_Ptr [N].V.NX.field2) #define Uint3(N) (Nodes_Ptr [N].V.NX.field3) #define Uint4(N) (Nodes_Ptr [N].V.NX.field4) #define Uint5(N) (Nodes_Ptr [N].V.NX.field5) #define Uint6(N) (Nodes_Ptr [N+1].V.EX.field6) #define Uint7(N) (Nodes_Ptr [N+1].V.EX.field7) #define Uint8(N) (Nodes_Ptr [N+1].V.EX.field8) #define Uint9(N) (Nodes_Ptr [N+1].V.EX.field9) #define Uint10(N) (Nodes_Ptr [N+1].V.EX.field10) #define Uint11(N) (Nodes_Ptr [N+1].V.EX.field11) #define Uint12(N) (Nodes_Ptr [N+1].V.EX.field12) #define Flag1(N) (Nodes_Ptr [N].flag1) #define Flag2(N) (Nodes_Ptr [N].flag2) #define Flag3(N) (Nodes_Ptr [N].flag3) #define Flag4(N) (Nodes_Ptr [N].flag4) #define Flag5(N) (Nodes_Ptr [N].flag5) #define Flag6(N) (Nodes_Ptr [N].flag6) #define Flag7(N) (Nodes_Ptr [N].flag7) #define Flag8(N) (Nodes_Ptr [N].flag8) #define Flag9(N) (Nodes_Ptr [N].flag9) #define Flag10(N) (Nodes_Ptr [N].flag10) #define Flag11(N) (Nodes_Ptr [N].flag11) #define Flag12(N) (Nodes_Ptr [N].flag12) #define Flag13(N) (Nodes_Ptr [N].flag13) #define Flag14(N) (Nodes_Ptr [N].flag14) #define Flag15(N) (Nodes_Ptr [N].flag15) #define Flag16(N) (Nodes_Ptr [N].flag16) #define Flag17(N) (Nodes_Ptr [N].flag17) #define Flag18(N) (Nodes_Ptr [N].flag18) #define Flag19(N) (Nodes_Ptr [N].flag19) #define Flag20(N) (Nodes_Ptr [N].flag20) #define Flag21(N) (Nodes_Ptr [N+1].in_list) #define Flag22(N) (Nodes_Ptr [N+1].rewrite_sub) #define Flag23(N) (Nodes_Ptr [N+1].rewrite_ins) #define Flag24(N) (Nodes_Ptr [N+1].flag1) #define Flag25(N) (Nodes_Ptr [N+1].flag2) #define Flag26(N) (Nodes_Ptr [N+1].flag3) #define Flag27(N) (Nodes_Ptr [N+1].flag4) #define Flag28(N) (Nodes_Ptr [N+1].flag5) #define Flag29(N) (Nodes_Ptr [N+1].flag6) #define Flag30(N) (Nodes_Ptr [N+1].flag7) #define Flag31(N) (Nodes_Ptr [N+1].flag8) #define Flag32(N) (Nodes_Ptr [N+1].flag9) #define Flag33(N) (Nodes_Ptr [N+1].flag10) #define Flag34(N) (Nodes_Ptr [N+1].flag11) #define Flag35(N) (Nodes_Ptr [N+1].flag12) #define Flag36(N) (Nodes_Ptr [N+1].flag13) #define Flag37(N) (Nodes_Ptr [N+1].flag14) #define Flag38(N) (Nodes_Ptr [N+1].flag15) #define Flag39(N) (Nodes_Ptr [N+1].flag16) #define Flag40(N) (Nodes_Ptr [N+1].flag17) #define Flag41(N) (Nodes_Ptr [N+1].flag18) #define Flag42(N) (Nodes_Ptr [N+1].flag19) #define Flag43(N) (Nodes_Ptr [N+1].flag20) /* End of a-atree.h (C version of Atree package specification) */ LINE Elmt_Id First_Elmgnat-1.67-src/src/a-types.h 444 10015 7640 21064 5506244470 10675 /****************************************************************************/ /* */ /* GNAT COMPILER COMPONENTS */ /* */ /* T Y P E S */ /* */ /* H e a d e r */ /* */ /* $Revision: 1.13 $ */ /* */ /* Copyright (c) 1992,1993, NYU, All Rights Reserved */ /* */ /* 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 */ /* Software Foundation; either version 2, or (at your option) any later */ /* version. GNAT is distributed in the hope that it will be useful, but */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- */ /* ABILITY 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 GNAT; see file COPYING. If not, write */ /* to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* */ /****************************************************************************/ /* This is the C file that corresponds to the Ada package spec Types. It was created manually from the file types-.ada. This package contains host independent type definitions which are used throughout the compiler modules. The comments in the C version are brief reminders of the purpose of each declaration. For complete documentation, see the Ada version of these definitions. */ /* Boolean Types: */ /* Boolean type (cannot use enum, because of bit field restriction on some compilers. */ typedef unsigned int Boolean; #define False 0 #define True 1 /* General Use Integer Types */ /* Signed 32/bit integer */ typedef int Int; /* Signed 16 bit integer */ typedef short Short; /* Non/negative Int values */ typedef Int Nat; /* Positive Int values */ typedef Int Pos; /* 8/bit unsigned integer */ typedef char Byte; /* 8/Bit Character and String Types: */ /* 8/bit character type */ typedef char Char; /* Graphic characters, as defined in ARM */ typedef Char Graphic_Character; /* Line terminator characters (LF, VT, FF, CR) */ typedef Char Line_Terminator; /* Characters with the upper bit set */ typedef Char Upper_Half_Character; /* String type built on Char (note that zero is an OK index) */ typedef Char *Str; /* Pointer to string of Chars */ typedef Char *Str_Ptr; /* Types for Node/Entity Kinds: */ /* The reason that these are defined here in the C version, rather than in the corresponding packages is that the requirement for putting bodies of inlined stuff IN the C header changes the dependencies. Both a-sinfo.h and a-einfo.h now reference routines defined in tree.h. Note: these types would more naturally be defined as unsigned char, but once again, the annoying restriction on bit fields for some compilers bites us! */ typedef unsigned int Node_Kind; typedef unsigned int Entity_Kind; /* Types used for Text Buffer Handling: */ /* Type used for subscripts in text buffer. */ typedef Int Text_Ptr; /* Text buffer used to hold source file or library information file. */ typedef Char *Text_Buffer; /* Pointer to text buffer. */ typedef Char *Text_Buffer_Ptr; /* Types used for Source Input Handling: */ /* Line number type, used for storing all line numbers. */ typedef Int Line_Number_Type; /* Column number type, used for storing all column numbers. */ typedef Int Column_Number_Type; /* Type used to store text of a source file. */ typedef Text_Buffer Source_Buffer; /* Pointer to source buffer. */ typedef Text_Buffer_Ptr Source_Buffer_Ptr; /* Type used for source location. */ typedef Text_Ptr Source_Ptr; /* Value used to indicate no source position set. */ #define No_Location -1 /* Used for Sloc in all nodes in the representation of package Standard. */ #define Standard_Location -2 /* Range definitions for Tree Data: */ #define List_Low_Bound -100000000 #define List_High_Bound 0 #define Node_Low_Bound 0 #define Node_High_Bound 99999999 #define Elist_Low_Bound 100000000 #define Elist_High_Bound 199999999 #define Elmt_Low_Bound 200000000 #define Elmt_High_Bound 299999999 #define Names_Low_Bound 300000000 #define Names_High_Bound 399999999 #define Strings_Low_Bound 400000000 #define Strings_High_Bound 499999999 #define Uint_Low_Bound 500000000 #define Uint_High_Bound 599999999 #define Char_Code_Bias 600000000 SUBTYPE (List_Range, Int, List_Low_Bound, List_High_Bound) SUBTYPE (Node_Range, Int, Node_Low_Bound, Node_High_Bound) SUBTYPE (Elist_Range, Int, Elist_Low_Bound, Elist_High_Bound) SUBTYPE (Elmt_Range, Int, Elmt_Low_Bound, Elmt_High_Bound) SUBTYPE (Names_Range, Int, Names_Low_Bound, Names_High_Bound) SUBTYPE (Strings_Range, Int, Strings_Low_Bound, Strings_High_Bound) SUBTYPE (Uint_Range, Int, Uint_Low_Bound, Uint_High_Bound) SUBTYPE (Char_Code_Range, Int, Char_Code_Bias, (Char_Code_Bias + 65535)) /* Types for Names_Table Package: */ typedef Int Name_Id; /* Name_Id value for no name present. */ #define No_Name Names_Low_Bound /* Name_Id value for bad name. */ #define Error_Name (Names_Low_Bound + 1) /* First subscript of names table. */ #define First_Name_Id (Names_Low_Bound + 2) /* Value of Chars of the parent field for record extension. */ #define Name_uParent First_Name_Id + 26 /* Types for Tree Package: */ /* Subscript of nodes table entry. */ typedef Int Node_Id; /* Used in semantics for Node_Id value referencing an entity. */ typedef Node_Id Entity_Id; /* Null node. */ #define Empty 0 /* Error node. */ #define Error 1 /* Subscript of first allocated node. */ #define First_Node_Id Empty /* Subscript of entry in lists table. */ typedef Int List_Id; /* Indicates absence of a list. */ #define No_List 0 /* Error list. */ #define Error_List List_Low_Bound /* Subscript of first allocated list header. */ #define First_List_Id Error_List /* Element list Id, biased subscript value of entry in lists table. */ typedef Int Elist_Id; /* Bias added to subscript in list table to get Elist_Id value. */ #define Elist_Bias (Elist_Low_Bound - List_Low_Bound) /* Used to indicate absence of an element list. */ #define No_Elist Elist_Low_Bound /* Element Id, biaseed subscript value of entry in lists table. */ typedef Int Elmt_Id; /* Bias added to subscript in list table to get Elmt_Id value. */ #define Elmt_Bias (Elmt_Low_Bound - List_Low_Bound) /* Used to indicate absence of an element list. */ #define No_Elmt Elmt_Low_Bound /* Types for String_Table Package: */ /* Subscript of strings table entry. */ typedef Int String_Id; /* Used to indicate missing string Id. */ #define No_String Strings_Low_Bound /* Subscript of first entry in strings table. */ #define First_String_Id (No_String + 1) /* Types for Uint_Support Package: */ /* Type used for representation of universal integers. */ typedef Int Uint; /* Used to indicate missing Uint value. */ #define No_Uint Uint_Low_Bound /* Base value used to represent Uint values. */ #define Base 32768 #define Uint_Direct_Bias (Uint_Low_Bound + Base) #define Uint_Direct_First (Uint_Direct_Bias - (Base - 1)) #define Uint_Direct_Last (Uint_Direct_Bias + (Base - 1)) /* Define range of direct biased values (in range -(Base-1)..+(Base-1)). */ SUBTYPE (Uint_Direct, Uint, Uint_Direct_First, Uint_Direct_Last) /* Subscript of first entry in Uint table. */ #define Uint_First_Entry (Uint_Direct_Last + 1) /* Constants in Uint format. */ #define Uint_0 (Uint_Direct_Bias + 0) #define Uint_1 (Uint_Direct_Bias + 1) #define Uint_2 (Uint_Direct_Bias + 2) #define Uint_10 (Uint_Direct_Bias + 10) #define Uint_16 (Uint_Direct_Bias + 16) /* Character Code Type: */ /* Character code value, intended to be 16 bits. */ typedef short Char_Code; /* Types Used for Library Management: */ /* Unit number. */ typedef Int Unit_Number_Type; /* Unit number value for main unit. */ #define Main_Unit 0 /* Type used for lines table. */ typedef Source_Ptr *Lines_Table_Type; /* Type used for pointer to lines table. */ typedef Source_Ptr *Lines_Table_Ptr; /* Length of time stamp va. lue #define Time_Stamp_Length 22 /* Type used to represent time stamp. */ typedef Char *Time_Stamp_Type; /* Name_Id synonym used for file names. */ typedef Name_Id File_Name_Type; /* Constant used to indicate no file found. */ #define No_File No_Name /* Name_Id synonym used for unit names. */ typedef Name_Id Unit_Name_Type; /* End of a-types.h (C version of Types package specification) */ Number_Units; current_unit_number++) { if (source_location >= File_Info_Ptr[current_unit_number].First_Sloc && source_location <= File_Info_Ptr[current_unit_number].Last_Sloc) break; } sloc_offset = source_location - File_Info_Ptr[current_unit_number].First_Sloc; if (current_unit_number == Number_Units) abort (); input_filename = Get_Name_String (File_Info_Ptr[current_unit_number].File_Name); Hi = File_Infognat-1.67-src/src/a-uint.c 444 10015 7640 7671 5506244470 10473 /****************************************************************************/ /* */ /* GNAT COMPILER COMPONENTS */ /* */ /* U I N T _ S U P P O R T */ /* */ /* Body */ /* (C Version) */ /* */ /* $Revision: 1.13 $ */ /* */ /* Copyright (c) 1992,1993, NYU, All Rights Reserved */ /* */ /* 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 */ /* Software Foundation; either version 2, or (at your option) any later */ /* version. GNAT is distributed in the hope that it will be useful, but */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- */ /* ABILITY 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 GNAT; see file COPYING. If not, write */ /* to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* */ /****************************************************************************/ /* This file corresponds to the Ada package body Uint_Support. It was created manually from the file uint.ada. */ #include "config.h" #include "tree.h" #include "a-ada.h" #include "a-types.h" #include "a-atree.h" #include "a-sinfo.h" #include "a-einfo.h" #include "a-namet.h" #include "a-string.h" #include "a-uint.h" /* Universal integers are represented by the Uint type which is an index into the Uints_Ptr table containing Uint_Entry values. A Uint_Entry contains an index and length for getting the "digits" of the universal integer from the Udigits_Ptr table. For efficiency, this method is used only for integer values larger than the constant Uint_Bias. If a Uint is less than this constant, then it contains the integer value itself. The origin of the Uints_Ptr table is adjusted so that a Uint value of Uint_Bias indexes the first element. */ /* Similarly to UI_To_Int, but return a GCC INTEGER_CST. Overflow is tested by the constant-folding used to build the node. TYPE is the GCC type of the resulting node. */ tree UI_To_gnu (Input, type) Uint Input; tree type; { tree gnu_ret; if (Input <= Uint_Direct_Last) gnu_ret = convert (type, build_int_2 (Input - Uint_Direct_Bias, 0)); else { Int Idx = Uints_Ptr[Input].Loc; Pos Length = Uints_Ptr[Input].Length; Int First = Udigits_Ptr[Idx]; tree gnu_base = convert (type, build_int_2 (Base, 0)); if (Length <= 0) abort (); gnu_ret = convert (type, build_int_2 (First, First < 0 ? -1 : 0)); if (First < 0) for (Idx++, Length--; Length; Idx++, Length--) gnu_ret = fold (build (MINUS_EXPR, type, fold (build (MULT_EXPR, type, gnu_ret, gnu_base)), convert (type, build_int_2 (Udigits_Ptr[Idx], 0)))); else for (Idx++, Length--; Length; Idx++, Length--) gnu_ret = fold (build (PLUS_EXPR, type, fold (build (MULT_EXPR, type, gnu_ret, gnu_base)), convert (type, build_int_2 (Udigits_Ptr[Idx], 0)))); } /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on GNU_RET. */ while ((TREE_CODE (gnu_ret) == NOP_EXPR || TREE_CODE (gnu_ret) == NON_LVALUE_EXPR) && TREE_TYPE (TREE_OPERAND (gnu_ret, 0)) == TREE_TYPE (gnu_ret)) gnu_ret = TREE_OPERAND (gnu_ret, 0); return gnu_ret; } kage: */ /* Subscript of nodes table entry. */ typedef Int Node_Id; gnat-1.67-src/src/a-uint.h 444 10015 7640 5151 5506244471 10470 /****************************************************************************/ /* */ /* GNAT COMPILER COMPONENTS */ /* */ /* U I N T _ S U P P O R T */ /* */ /* Specification */ /* (C Version) */ /* */ /* $Revision: 1.10 $ */ /* */ /* Copyright (c) 1992,1993, NYU, All Rights Reserved */ /* */ /* 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 */ /* Software Foundation; either version 2, or (at your option) any later */ /* version. GNAT is distributed in the hope that it will be useful, but */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- */ /* ABILITY 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 GNAT; see file COPYING. If not, write */ /* to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* */ /****************************************************************************/ /* This file corresponds to the Ada package specification Uint_Support. It was created manually from the files uint_.ada, uint.ada */ /* Support for universal integer arithmetic */ struct Uint_Entry { Pos Length; Int Loc; }; /* Obtain Int value from Uint input. For the moment, the result is assumed to fit in HOST_BITS_PER_INT bits, with no provision for out of range values. */ #define UI_To_Int uintp__ui_to_int extern Int UI_To_Int PROTO((Uint)); #ifdef TREE_CODE /* Don't lose if tree.h not included. */ /* Similarly, but return a GCC INTEGER_CST. Overflow is tested by the constant-folding used to build the node. TYPE is the GCC type of the resulting node. */ extern tree UI_To_gnu PROTO((Uint, tree)); #endif /* Universal integers are represented by the Uint type which is an index into the Uints_Ptr table containing Uint_Entry values. A Uint_Entry contains an index and length for getting the "digits" of the universal integer from the Udigits_Ptr table. For efficiency, this method is used only for integer values larger than the constant Uint_Bias. If a Uint is less than this constant, then it contains the integer value itself. The origin of the Uints_Ptr table is adjusted so that a Uint value of Uint_Bias indexes the first element. */ extern struct Uint_Entry *Uints_Ptr; extern Int *Udigits_Ptr; the constant-folding used to build the node. TYPE is the GCC type of the resulting node. */ tree UI_To_gnu (Input, type) Uint Input; tree type; { tree gnu_ret; if (Input <= Uint_Direct_Last) gnu_ret = convert (type, build_int_2 (Input - Uint_Direct_Bias, 0)); else { Int Idx = Uints_Ptr[Input].Loc; Pos Length = Uints_Ptr[Input].Length; Int First = Udigignat-1.67-src/src/xeinfo.spt 444 10015 7640 22512 5506244471 11162 *----------------------------------------------------------------------------- *- -- *- G N A T -- *- -- *- COMPILER UTILITIES -- *- -- *- X E I N F O -- *- -- *- $Revision: 1.17 $ -- *- -- *- Copyright (c) 1992,1993, NYU, All Rights Reserved -- *- -- *- 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 -- *- Software Foundation; either version 2, or (at your option) any later -- *- version. GNAT is distributed in the hope that it will be useful, but -- *- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- *- ABILITY 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 GNAT; see file COPYING. If not, write -- *- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- *- -- *----------------------------------------------------------------------------- * Program to construct C header file a-einfo.h (C version of einfo.ads spec, * for use by Gigi, contains all definitions and access functions, but does not * contain set procedures, since Gigi is not allowed to modify the GNAT tree) * * Input files: * * einfo.ads spec of Einfo package * einfo.adb body of Einfo package * * Output files: * * a-einfo.h Corresponding c header file * * Note: this program assumes that einfo.ads has been compiled without errors * * An optional argument allows the specification of an output file name to * override the default a-einfo.h file name for the generated output file. * * Most, but not all of the functions in Einfo can be inlined in the C header. * Those functions which cannot be inlined are identified in the header and * in terminal output when this utility program is run. "$Revision: 1.17 $" "$Rev" "ision: " break(' ') $ xeinforev arg = trim(host(1)) arg = ident(arg, "0") trim(host(0)) ofile = ident(arg) 'a-einfo.h' ofile = differ(arg) arg lineno = 0 &stlimit = -1 input(.in,1,'einfo.ads') input(.inb,5,'einfo.adb') output(.out,2,ofile) &anchor = 1 wsp = span(' ' char(9)) | '' * Get einfo revs and write header to output file slp1 line = inb ident(line) :s(err) line breakx('$') '$Rev' 'ision: ' break(' ') $ einfobrev . :f(slp1) slp line = in ident(line) :s(start) line breakx('$') '$Rev' 'ision: ' break(' ') $ einforev :s(vsn) line '-- S p e c ' = . '-- C Header File ' line '--' = '/*' line rtab(2) $ a '--' = a '*/' out = line :(slp) vsn out = '/* Generated by xeinfo revision ' xeinforev . ' using */' out = '/* einfo.ads revision ' einforev . ' */' out = '/* einfo.adb revision ' einfobrev . ' */' :(slp) start lc = 'abcdefghijklmnopqrstuvwxyz' uc = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' out = * status = 'D' for defined function, 'I' for inlined function status = table(200) * Get non-comment line (comment lines skipped) define('getlins()a,b') :(fd2) getlins getlins = trim(in) :f(freturn) lineno = lineno + 1 ident(getlins) :s(getlins) getlins wsp $ a '--' = :f(return)s(getlins) * Process function header into C form and output it fd2 define('sethead(line,term)a,args,formal,formaltype,filler,i') :(fd3) sethead line wsp $ a . 'procedure' :s(return) line wsp $ a . 'function' wsp break(' ') $ Name = :s(sh5)f(err) sh5 args = line wsp $ filler '(' = :f(sh8) args = filler '(' sh6 line break(' :') $ formal wsp ':' wsp . breakx(' );') $ formaltype = :f(err) args = args formaltype ' ' formal line wsp '; ' = :f(sh7) args = args ',' :(sh6) sh7 line wsp ')' = args = args ')' sh8 line wsp 'return' wsp breakx(' ;') $ rtn :s(sh10) * return statement may be on next line. line = trim(in) line wsp 'return' wsp breakx(' ;') $ rtn :f(err) sh10 i = i = ident(status,'I') "INLINE " out = a i rtn ' ' Name args term . :(return) fd3 * find pragma inlines i0 lineno = 0 i1 line = getlins() :f(n0) line wsp 'pragma Inline (' break(')') $ name :f(i1) status = 'I' :(i1) * process specification n0 input(.in,4,'einfo.ads') lineno = 0 n1 line = getlins() line wsp 'package ' :s(n2)f(n1) n2 V = 0 line = getlins() line wsp 'type Entity_Kind' :f(n2a) n3 line = getlins() line wsp break(',') $ N ',' :f(n4) out = ' #define ' rpad(N,32) ' ' V V = V + 1 :(n3) n4 line wsp rem $ N | break(')') $ N :f(err) out = ' #define ' rpad(N,32) ' ' V n5 line = getlins() :f(err) line wsp 'function' :s(n9) line wsp $ a 'subtype ' break(' ') $ N :f(n5) n8 getlins() wsp break(' ') $ N1 :f(err) n8a line = trim(in) :f(err) lineno = lineno + 1 line wsp '-- ' rem $ N2 :s(n8a) line wsp break(';') $ N3 :f(err) out = a 'SUBTYPE (' N ', Entity_Kind, ' out = a ' ' N1 ', ' N3 ')' :(n5) n9 line wsp $ aa 'function' wsp break(' (') $ FN status = ident(status) 'D' out = ident(status,'D') ' #define ' FN . ' einfo__' replace(FN,uc,lc) sethead(line,';') line = getlins() line wsp 'function First_Private' :f(n9) sethead(line,';') * Read body to find inlined functions out = out = ' /********************************/' out = ' /* Bodies for Inlined Functions */' out = ' /********************************/' input(.in,3,'einfo.adb') lineno = 1 n10 line = getlins() :f(n13) line wsp $ aa 'function' wsp break(' (') $ FN :f(n10) ident(status,'I') :s(n10a) terminal = ident(status,'D') . "Need body for " FN :(n10) n10a line breakx('r') 'return' :s(n10b) nline = getlins() nline wsp = line = line nline :(n10a) n10b fline = line n10c line = getlins() line wsp "begin" :f(n10c) line = getlins() line wsp "pragma " ("Assert (" | "Debug (") . :f(n10d) * pragma Assert found, get its continuation lines alpp line breakx(';') :s(alpt) line = getlins() :(alpp) alpt line = getlins() n10d line wsp "if Debug" :f(n11) line = getlins() n11 line breakx('-') $ a '--' = a line wsp 'return ' break(';') $ expr :f(n11a) line = getlins() line wsp 'end' breakx(';') ';' :f(err) expr breakx(' ') $ a " in " rem $ b = "IN (" a ', ' b ")" expr breakx(' ') $ a " = " rem $ b = a ' == ' b out = sethead(fline,'') * special kludge for Get_Name_Entity_Id case expr = ident(expr, 'Entity_Id (Get_Name_Table_Info (Id))') . '(Entity_Id) Get_Name_Table_Info (Id)' out = aa ' { return ' expr '; }' :(n10) * Multi-line function, assume no translation required n11a out = sethead(fline,' {') n11b pline = line line = getlins() :f(err) line wsp $ xx "end;" :s(n11c) line breakx('-') $ a '--' = a out = pline :(n11b) n11c out = pline out = xx ' }' :(n10) n13 out = out = . '/* End of einfo.h (C version of Einfo package specification)' . ' */' :(end) end 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 witgnat-1.67-src/src/ali.ads 444 10015 7640 24711 5506244472 10404 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- A L I -- -- -- -- S p e c -- -- -- -- $Revision: 1.4 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Table; with Types; use Types; package ALI is -- This package defines the internal data structures used for representation -- of Ada Library Information (ALI) acquired from the ALI files generated -- by the front end. -------------- -- Id Types -- -------------- -- The various entries are stored in tables with distinct subscript -- ranges. The following type definitions indicate the ranges used -- for the subscripts (Id values) for the various tables. type ALI_Id is range 0 .. 999_999; -- Id values used for ALIs table entries type Unit_Id is range 1_000_000 .. 1_999_999; -- Id values used for Unit table entries type With_Id is range 2_000_000 .. 2_999_999; -- Id values used for Withs table entries type Sdep_Id is range 3_000_000 .. 3_999_999; -- Id values used for Sdep table entries type Source_Id is range 4_000_000 .. 4_999_999; -- Id values used for Source table entries -------------------- -- ALI File Table -- -------------------- -- Each ALI file read generates an entry in the ALIs table No_ALI_Id : constant ALI_Id := ALI_Id'First; -- Special value indicating no ALI entry First_ALI_Entry : constant ALI_Id := No_ALI_Id + 1; -- Id of first actual entry in table type Main_Program_Type is (None, Proc, Func); -- Indicator of whether unit can be used as main program type ALIs_Record is record Afile : File_Name_Type; -- Name of ALI file Sfile : File_Name_Type; -- Name of source file that generates this ALI file (which is equal -- to the name of the source file in the first unit table entry for -- this ALI file, since the body if present is always first). Ver : Str (1 .. 16); -- Value of library version (V line in ALI file) Std : Str (1 .. 16); -- Value of standard version (S line in ALI file) First_Unit : Unit_Id; -- Id of first Unit table entry for this file Last_Unit : Unit_Id; -- Id of last Unit table entry for this file First_Sdep : Sdep_Id; -- Id of first Sdep table entry for this file Last_Sdep : Sdep_Id; -- Id of last Sdep table entry for this file Main_Program : Main_Program_Type; -- Indicator of whether first unit can be used as main program end record; package ALIs is new Table ( Component_Type => ALIs_Record, Index_Type => ALI_Id, Low_Bound => 1, Initial => 500, Increment => 200, Table_Name => "ALIs"); ---------------- -- Unit Table -- ---------------- -- Each unit within an ALI file generates an entry in the unit table No_Unit_Id : constant Unit_Id := Unit_Id'First; -- Special value indicating no unit table entry First_Unit_Entry : constant Unit_Id := No_Unit_Id + 1; -- Id of first actual entry in table type Unit_Type is (Is_Spec, Is_Body, Is_Spec_Only, Is_Body_Only); -- Indicates type of entry, if both body and spec appear in the ALI file, -- then the first unit is marked Is_Body, and the second is marked Is_Spec. -- If only a spec appears, then it is marked as Is_Spec_Only, and if only -- a body appears, then it is marked Is_Body_Only). type Unit_Record is record My_ALI : ALI_Id; -- Corresponding ALI entry Uname : Unit_Name_Type; -- Name of Unit Sfile : File_Name_Type; -- Name of source file Preelab : Boolean; -- Indicates presence of PRE parameter Elaborate_Body : Boolean; -- Indicates presence of EB parameter First_With : With_Id; -- Id of first with table entry for this file Last_With : With_Id; -- Id of last with table entry for this file Utype : Unit_Type; -- Type of entry end record; package Unit is new Table ( Component_Type => Unit_Record, Index_Type => Unit_Id, Low_Bound => First_Unit_Entry, Initial => 100, Increment => 200, Table_Name => "Unit"); ----------------- -- Withs Table -- ----------------- -- Each With line (W line) in an ALI file generates a Withs table entry No_With_Id : constant With_Id := With_Id'First; -- Special value indicating no unit table entry First_With_Entry : constant With_Id := No_With_Id + 1; -- Id of first actual entry in table type With_Record is record Uname : Unit_Name_Type; -- Name of Unit Sfile : File_Name_Type; -- Name of source file, set to No_File in generic case Afile : File_Name_Type; -- Name of ALI file, set to No_File in generic case Elaborate : Boolean; -- Indicates presence of E parameter Elaborate_All : Boolean; -- Indicates presence of EA parameter end record; package Withs is new Table ( Component_Type => With_Record, Index_Type => With_Id, Low_Bound => First_With_Entry, Initial => 5000, Increment => 200, Table_Name => "With"); ------------------------------------ -- Sdep (Source Dependency) Table -- ------------------------------------ -- Each source dependency (D line) in an ALI file generates an -- entry in the Sdep table. No_Sdep_Id : constant Sdep_Id := Sdep_Id'First; -- Special value indicating no Sdep table entry First_Sdep_Entry : constant Sdep_Id := No_Sdep_Id + 1; -- Id of first actual entry in table type Sdep_Record is record Sfile : File_Name_Type; -- Name of source file Stamp : Time_Stamp_Type; -- Time stamp value end record; package Sdep is new Table ( Component_Type => Sdep_Record, Index_Type => Sdep_Id, Low_Bound => First_Sdep_Entry, Initial => 5000, Increment => 200, Table_Name => "Sdep"); ----------------------------- -- Source File Table Table -- ----------------------------- -- A source file table entry is built for every source file that is -- in the source dependency table of any of the ALI files that make -- up the current program. No_Source_Id : constant Source_Id := Source_Id'First; -- Special value indicating no Source table entry First_Source_Entry : constant Source_Id := No_Source_Id + 1; -- Id of first actual entry in table type Source_Record is record Sfile : File_Name_Type; -- Name of source file Stamp : Time_Stamp_Type; -- Time stamp value. If Check_Source_Files is set and the source -- file is located, then Stamp is set from the source file. Otherwise -- Stamp is set from the latest stamp value found in any of the -- ALI files for the current program. Source_Found : Boolean; -- This flag is set to True if the corresponding source file was -- located and the Stamp value was set from the actual source file. -- It is always false if Check_Source_Files is not set. end record; package Source is new Table ( Component_Type => Source_Record, Index_Type => Source_Id, Low_Bound => First_Source_Entry, Initial => 1000, Increment => 200, Table_Name => "Source"); ---------------------------- -- Use of Name Table Info -- ---------------------------- -- All unit names and file names are entered into the Names table. The -- Info fields of these entries are used as follows: -- Unit name Info field has Unit_Id of unit table entry -- ALI file name Info field has ALI_Id of ALI table entry -- Source file name Info field has Source_Id of unit table entry -------------------------------------------------- -- Subprograms for Manipulating ALI Information -- -------------------------------------------------- procedure Initialize_ALI; -- Initialize the ALI tables for a new bind procedure Read_ALI (Afile, Sfile : File_Name_Type); -- Reads a specified ALI file and all subsidiary ALI files that it -- references. The recursion is terminated by avoiding reading an -- ALI file that has already been read. The second parameter is the -- name of the corresponding source file (used for error messages only) -- If Sfile is No_File (used for main file), then it is a fatal error -- for the file to be missing. function Scan_ALI (F : File_Name_Type; T : Text_Buffer_Ptr) return ALI_Id; -- Given the text of an ALI file, scan and store the information from -- the file, and return the Id of the resulting entry in the ALI table. -- If the file is found to be incorrectly formatted, an error message -- is generated, and the program is terminated. procedure Set_Source_Table; -- Build source table end ALI; it_Id := Unit_Id'First; -- Special value indicatinggnat-1.67-src/src/xsinfo.spt 444 10015 7640 11263 5506244472 11202 *----------------------------------------------------------------------------- *- -- *- G N A T -- *- -- *- COMPILER UTILITIES -- *- -- *- X S I N F O -- *- -- *- $Revision: 1.11 $ -- *- -- *- Copyright (c) 1992,1993, NYU, All Rights Reserved -- *- -- *- 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 -- *- Software Foundation; either version 2, or (at your option) any later -- *- version. GNAT is distributed in the hope that it will be useful, but -- *- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- *- ABILITY 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 GNAT; see file COPYING. If not, write -- *- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- *- -- *----------------------------------------------------------------------------- * Program to construct C header file a-sinfo.h (C version of sinfo.ads spec, * for use by Gigi, contains all definitions and access functions, but does not * contain set procedures, since Gigi is not allowed to modify the GNAT tree) * * Input files: * * sinfo.ads Spec of Sinfo package * * Output files: * * a-sinfo.h Corresponding c header file * * Note: this program assumes that sinfo.ads has passed the error checks which * are carried out by the csinfo utility, so it does not duplicate these checks * * An optional argument allows the specification of an output file name to * override the default a-sinfo.h file name for the generated output file. "$Revision: 1.11 $" "$Rev" "ision: " break(' ') $ xsinforev arg = trim(host(1)) arg = ident(arg, "0") trim(host(0)) ofile = ident(arg) 'a-sinfo.h' ofile = differ(arg) arg lineno = 0 &stlimit = -1 input(.in,1,'sinfo.ads') output(.out,2,ofile) &anchor = 1 wsp = span(' ' char(9)) | '' * Get sinfo rev and write header to output file slp line = in ident(line) :s(start) line breakx('$') '$Rev' 'ision: ' break(' ') $ sinforev :s(vsn) line '-- S p e c ' = . '-- C Header File ' line '--' = '/*' line rtab(2) $ a '--' = a '*/' out = line :(slp) vsn out = '/* Generated by xsinfo revision ' xsinforev . ' using */' out = '/* sinfo.ads revision ' sinforev . ' */' :(slp) start * Get non-comment non-blank line define('getline()a,b') :(n1) getline getline = trim(in) :f(err) ident(getline) :s(getline) lineno = lineno + 1 getline wsp $ a '--' = :f(return) getline span(' ') 'End functions (note' :s(freturn)f(getline) n1 line = getline() :f(err) line 'with Types;' :s(n2) out = line :(n1) n2 line = getline() :f(err) n3 line = getline() :f(err) line wsp $ a "type Node_Kind is" :s(n4) out = line :(n3) n4 out = NKV = 0 n5 line = getline() :f(err) line wsp $ a 'N_' break(',)') $ name . len(1) $ term :s(n6) out = line :(n5) n6 out = a '#define N_' name ' ' NKV NKV = NKV + 1 ident(term,',') :s(n5) out = out = a '#define Number_Node_Kinds ' NKV n7 line = getline() :f(err) line wsp $ a 'subtype ' break(' ') $ N :s(n8) line wsp $ a 'function' :s(n10) out = line :(n7) n8 out = a 'SUBTYPE (' N ', Node_Kind, ' line = getline() * normal case line wsp break(' ') $ N1 . ' .. ' break(';') $ N2 :f(n8a) out = a ' ' N1 ', ' N2 ')' :(n7) * continuation case n8a line wsp break(' ') $ N1 " .." rpos(0) :f(err) getline() span(' ') break(";") $ N2 :f(err) out = a ' ' N1 ',' out = a ' ' N2 ')' :(n7) n9 line = getline() :f(n13) n10 line wsp $ a 'function ' rem $ Name :s(n11) out = line :(n9) n11 line = getline() line . wsp '(N : ' . break(')') $ arg . ') return ' break(';') $ rtn . ';' wsp '--' wsp rem $ comment :f(err) out = a 'INLINE ' rpad(rtn,9) . ' ' rpad(Name,30) . ' (' arg ' N)' out = a ' ' . '{ return ' comment ' (N); }' :(n9) n13 out = end hecks * * An optional argument allows the specification of an output file name to * override the default a-sinfo.h file name for the generated output file. "$Revision: 1.11 $" "$Rev" "ision: " break(' ') $ xsinforev arg = trim(host(1)) arg = ident(arg, "0") trim(host(0)) ofile = ident(arg) 'a-sinfo.h' ofgnat-1.67-src/src/xtreeprs.spt 444 10015 7640 15320 5506244473 11547 *----------------------------------------------------------------------------- *- -- *- G N A T -- *- -- *- COMPILER UTILITIES -- *- -- *- X T R E E P R S -- *- -- *- $Revision: 1.16 $ -- *- -- *- Copyright (c) 1992,1993, NYU, All Rights Reserved -- *- -- *- 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 -- *- Software Foundation; either version 2, or (at your option) any later -- *- version. GNAT is distributed in the hope that it will be useful, but -- *- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- *- ABILITY 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 GNAT; see file COPYING. If not, write -- *- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- *- -- *----------------------------------------------------------------------------- * Program to construct the spec of the Treeprs package * * Input files: * * sinfo.ads Spec of Sinfo package * treeprs.adt Template for Treeprs package * * Output files: * * treeprs.ads Spec of Treeprs package * * Note: this program assumes that sinfo.ads has passed the error checks which * are carried out by the csinfo utility, so it does not duplicate these checks * * An optional argument allows the specification of an output file name to * override the default treeprs.ads file name for the generated output file. "$Revision: 1.16 $" "$Rev" "ision: " break(' ') $ treeprsrev lineno = 0 &stlimit = -1 input(.ins,1,'sinfo.ads') input(.int,2,'treeprs.adt') arg = trim(host(1)) arg = ident(arg, "0") trim(host(0)) (ident(arg) output(.outs,3,'treeprs.ads')) (differ(arg) output(.outs,3,arg)) &anchor = 1 names = array(300) positions = array(300) count = 0 curpos = 0 wsp = span(' ' char(9)) strings = table(300) * Special fields table. The following fields are not recorded or checked by * csinfo, since they are specially handled. This means that the both the * field definitions, and the corresponding subprograms are completely ignored. special = table(20) special<'Etype'> = 1 special<'Left_Opnd'> = 1 special<'Right_Opnd'> = 1 special<'Chars'> = 1 special<'Parens'> = 1 special<'No_Overflow_Expr'> = 1 special<'Must_Check_Expr'> = 1 special<'Has_No_Side_Effects'> = 1 special<'Is_Overloaded'> = 1 special<'Is_Static'> = 1 special<'Is_Evaluated'> = 1 special<'Analyzed'> = 1 special<'Error_Posted'> = 1 F_Field1 = '#' F_Field2 = '$' F_Field3 = '%' F_Field4 = '&' F_Field5 = "'" F_Field6 = "(" F_Field7 = ")" F_Flag1 = '*' F_Flag2 = '+' F_Flag3 = ',' F_Flag4 = '-' F_Flag5 = '.' F_Flag6 = '/' F_Flag7 = '0' F_Flag8 = '1' F_Flag9 = '2' F_Flag10 = '3' F_Flag11 = '4' F_Flag12 = '5' F_Flag13 = '6' F_Flag14 = '7' F_Flag15 = '8' F_Flag16 = '9' * Get sinfo rev slp line = ins line breakx('$') '$Rev' 'ision: ' break(' ') $ sinforev :f(slp) * Copy initial part of template to spec lp1 line = int :f(err) line breakx('$') '$Rev' 'ision: ' break(' ') $ temprev :f(lp1a) outs = . '-- Generated by xtreeprs revision ' . treeprsrev ' using' . ' --' outs = . '-- sinfo.ads revision ' sinforev . ' --' outs = . '-- treeprs.adt revision ' temprev . ' --' :(lp1) * Skip lines describing the template lp1a line '-- This file is a template' :f(lp1c) lp1b line = trim(int) :f(err) differ(line) :s(lp1b) lp1c line 'package' :s(p1) line breakx('T') $ a 'T e m p l a t e' = . a ' S p e c ' outs = line :(lp1) p1 outs = line * Copy rest of comments up to template insert point to spec lp2x line = int :f(err) line '!!TEMPLATE INSERTION POINT' :s(start) outs = line :(lp2x) * Here we are doing the actual insertions start outs = ' Pchars : constant Str :=' lp line = trim(ins) :f(err) lineno = lineno + 1 line wsp 'type Node_Kind' :s(outc) line wsp '-- N_' rem $ node :f(lp) node break(' ,.') :s(lp) outstring = node ' ' lp2 line = trim(ins) :f(err) ident(line) :s(stringout) line span(' ') '-- ' break(' ') $ synonym ' (' break(')') $ field . :f(lp2) synonym 'plus' :s(lp2) differ(special) :s(lp2) field break('-') $ field ffield = field field 'Flag' :s(nxta) field rtab(1) $ a = 'Field' nxta field = 'F_' field field = $field terminal = ident(field) "line " lineno " has unrecognized field name " . ffield nnn2 outstring = outstring field synonym :(lp2) stringout strings = outstring :(lp) outc line = trim(ins) :f(err) line wsp 'N_' break(',)') $ syn . len(1) $ term :f(outc) s = strings s break(' ') $ node ' ' = count = count + 1 names = syn positions = curpos curpos = curpos + size(s) outs = ' -- ' node ident(term,')') :s(outx) prefix = ' ' outcl sp = 79 - 4 - size(prefix) le(size(s),sp) :s(outcl2) s len(sp) $ s1 = outs = prefix '"' s1 '" &' prefix = ' ' :(outcl) outcl2 outs = prefix '"' s '" &' :(outc) outx sp = 79 - 4 - size(prefix) le(size(s),sp) :s(outx2) s len(sp) $ s1 = outs = prefix '"' s1 '" &' prefix = ' ' :(outx) outx2 outs = ' "' s '";' outs = outs = ' type Pchar_Pos_Array is array (Node_Kind) of Int;' outs = " Pchar_Pos : constant Pchar_Pos_Array := " . "Pchar_Pos_Array'(" m = 0 outxl eq(m = m + 1,count) :s(last) name = rpad('N_' names,40) outs = " " name ' => ' positions ',' :(outxl) last name = rpad('N_' names,40) outs = " " name ' => ' positions ');' vle outs = outs = "end Treeprs;" end ec of the Treeprs package * * Input files: * * sinfo.ads Spec of Sinfo package * treeprs.adt Template for Treeprs package * * Output files: * * treeprs.ads Spec of Treeprs package * * Note: this program assumes that sinfo.ads has passed the error checks which * are carried outgnat-1.67-src/src/xnmake.spt 444 10015 7640 21603 5506244473 11157 *----------------------------------------------------------------------------- *- -- *- G N A T -- *- -- *- COMPILER UTILITIES -- *- -- *- X N M A K E -- *- -- *- $Revision: 1.11 $ -- *- -- *- Copyright (c) 1992,1993, NYU, All Rights Reserved -- *- -- *- 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 -- *- Software Foundation; either version 2, or (at your option) any later -- *- version. GNAT is distributed in the hope that it will be useful, but -- *- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- *- ABILITY 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 GNAT; see file COPYING. If not, write -- *- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- *- -- *----------------------------------------------------------------------------- * Program to construct the spec and body of the Nmake package * * Input files: * * sinfo.ads Spec of Sinfo package * nmake.adt Template for Nmake package * * Output files: * * nmake.ads Spec of Nmake package * nmake.adb Body of Nmake package * * Note: this program assumes that sinfo.ads has passed the error checks which * are carried out by the csinfo utility, so it does not duplicate these checks * * In the absence of any switches, both the ads and adb files are constructed. * The switch -s or /s indicates that only the ads file is to be constructed. * The switch -b or /b indicates that only the adb file is to be constructed. * * If a file name argument is given, then the output is written to this file * rather than to nmake.ads or nmake.adb. A file name can only be given if * exactly one of the -s or -b options is present. "$Revision: 1.11 $" "$Rev" "ision: " break(' ') $ xnmakerev terminal = lineno = 0 &stlimit = -1 nwidth = 28 &anchor = 1 files = 'nmake.ads' fileb = 'nmake.adb' args = trim(host(1)) args = ident(args, "0") trim(host(0)) args breakx('-/') $ a len(1) any('bB') (span(' ') | '') = a :f(o1) files = o1 args breakx('-/') $ a len(1) any('sS') (span(' ') | '') = a :f(o2) fileb = o2 args span(' ') = args break(' ') $ a span(' ') rpos(0) = a args break(' ') :f(o3) bado terminal = "invalid arguments" :(end) o3 ident(args) :s(o4) ident(files) :s(o5) ident(fileb) :s(o6) terminal = "if file name given, must use -b or -s" :(end) o5 fileb = args :(o4) o6 files = args :(o4) o4 input(.ins,1,'sinfo.ads') input(.int,2,'nmake.adt') (differ(files) output(.outs,3,files)) (differ(fileb) output(.outb,4,fileb)) &anchor = 1 wsp = span(' ' char(9)) digits = '0123456789' digit = any(digits) * Get sinfo rev slp line = ins line breakx('$') '$Rev' 'ision: ' break(' ') $ sinforev :f(slp) * Copy initial part of template to spec and body lp1 line = int :f(err) line breakx('$') '$Rev' 'ision: ' break(' ') $ temprev :f(lp1a) outb = outs = . '-- Generated by xnmake revision ' . xnmakerev ' using' . ' --' outb = outs = . '-- sinfo.ads revision ' sinforev . ' --' outb = outs = . '-- nmake.adt revision ' temprev . ' --' :(lp1) * Skip lines describing the template lp1a line '-- This file is a template' :f(lp1c) lp1b line = trim(int) :f(err) differ(line) :s(lp1b) lp1c line 'package' :s(p1) line breakx('T') $ a 'T e m p l a t e' = . a ' S p e c ' outs = line line breakx('S') $ a 'S p e c' = a 'B o d y' outb = line :(lp1) p1 outs = 'package Nmake is' outb = 'package body Nmake is' outb = * Copy rest of comments up to template insert point to spec only lp2 line = int :f(err) line '!!TEMPLATE INSERTION POINT' :s(lp3) outs = line :(lp2) * Here we are doing the actual insertions lp3 line = trim(ins) :f(err) line wsp '-- N_' rem $ node :f(lp3) node breakx(' .,') :s(lp3) ident(node,'Unused') :s(lp3) ident(node,'Empty') :s(done) prevl = ' function Make_' node ' (Sloc : Source_Ptr' arg_list = lp4 line = trim(ins) :f(err) ident(line) :s(ef) line wsp '-- plus fields for binary operator' :s(cb) line wsp '-- plus fields for unary operator' :s(cu) line wsp '-- plus fields for expression' :s(ce) line wsp '-- ' break(' ') $ synonym ' (' break(')') $ field . rem $ comment :f(lp4) ident(synonym, "Prev_Ids") :s(lp4) ident(synonym, "More_Ids") :s(lp4) field breakx('-') '-Sem' :s(lp4) field breakx('-') '-Lib' :s(lp4) type = field breakx(digits) $ field field = ident(field, 'Str') 'String_Id' field = ident(field, 'Node') 'Node_Id' field = ident(field, 'Name') 'Name_Id' field = ident(field, 'List') 'List_Id' field = ident(field, 'Elist') 'Elist_Id' field = ident(field, 'Flag') 'Boolean' default = default = ident(field, 'Boolean') 'False' comment breakx('(') '(set to ' break(' ') $ default ' if' outb = outs = prevl ';' arg_list = arg_list synonym ',' synonym = rpad(synonym,nwidth) prevl = ident(default) " " synonym ' : ' field :s(lp4) prevl = " " synonym ' : ' field ' := ' default :(lp4) ce outb = outs = prevl ';' arg_list = arg_list 'Parens,' prevl = " " rpad('Parens',nwidth) . ' : Boolean := False' :(lp4) cu outb = outs = prevl ';' arg_list = arg_list 'Right_Opnd,' prevl = " " rpad('Right_Opnd',nwidth) ' : Node_Id' :(lp4) cb outb = outs = prevl ';' arg_list = arg_list 'Left_Opnd,Right_Opnd,' outb = outs = " " rpad('Left_Opnd',nwidth) ' : Node_Id;' prevl = " " rpad('Right_Opnd',nwidth) ' : Node_Id' :(lp4) ef outb = outs = prevl ')' outs = ' return Node_Id;' outs = ' pragma Inline (Make_' node ');' outb = ' return Node_Id' outb = ' is' outb = . ' N : constant Node_Id :=' node 'Defining' :s(extend) node 'Entry_Body' :s(extend) outb = . ' New_Node (N_' node ', Sloc);' :(merge) extend outb = . ' Extend_Node (New_Node (N_' node ', Sloc));' merge outb = ' begin' efl arg_list break(',') $ arg ',' = :f(efe) outb = lt(size(arg),28) ' Set_' arg ' (N, ' arg ');' :s(efl) outb = ' Set_' arg outb = ' (N, ' arg ');' :(efl) efe node 'Op_' rem $ Op_Name :f(efx) outb = ident(node,'Op_Plus') . ' Set_Chars (N, Name_Op_Add);' :s(efx) outb = ident(node,'Op_Minus') . ' Set_Chars (N, Name_Op_Subtract);' :s(efx) outb = ' Set_Chars (N, Name_' node ');' efx outb = ' return N;' outb = ' end Make_' node ';' outs = outb = :(lp3) done outs = outb = 'end Nmake;' end (host(1)) args = ident(args, "0") trim(host(0)) args breakx('-/') $ a len(1) any('bB') (span(' ') | '') = a gnat-1.67-src/src/mk-ttypes.c 444 10015 7640 11552 5506244474 11250 /****************************************************************************/ /* */ /* GNAT COMPILER COMPONENTS */ /* */ /* Make TTYPES.ADS */ /* */ /* Body */ /* */ /* $Revision: 1.3 $ */ /* */ /* Copyright (c) 1992,1993, NYU, All Rights Reserved */ /* */ /* 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 */ /* Software Foundation; either version 2, or (at your option) any later */ /* version. GNAT is distributed in the hope that it will be useful, but */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- */ /* ABILITY 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 GNAT; see file COPYING. If not, write */ /* to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* */ /****************************************************************************/ #include "hconfig.h" #include "machmode.h" #include /* Provide default values for all of the type widths (copied from c-decl.c). */ #ifndef CHAR_TYPE_SIZE #define CHAR_TYPE_SIZE BITS_PER_UNIT #endif #ifndef SHORT_TYPE_SIZE #define SHORT_TYPE_SIZE (BITS_PER_UNIT * MIN ((UNITS_PER_WORD + 1) / 2, 2)) #endif #ifndef INT_TYPE_SIZE #define INT_TYPE_SIZE BITS_PER_WORD #endif #ifndef LONG_TYPE_SIZE #define LONG_TYPE_SIZE BITS_PER_WORD #endif #ifndef LONG_LONG_TYPE_SIZE #define LONG_LONG_TYPE_SIZE (BITS_PER_WORD * 2) #endif #ifndef FLOAT_TYPE_SIZE #define FLOAT_TYPE_SIZE BITS_PER_WORD #endif #ifndef DOUBLE_TYPE_SIZE #define DOUBLE_TYPE_SIZE (BITS_PER_WORD * 2) #endif #ifndef LONG_DOUBLE_TYPE_SIZE #define LONG_DOUBLE_TYPE_SIZE (BITS_PER_WORD * 2) #endif /* Maps integer bit sizes to the value of the 'Width attribute for a type of that many bits. */ struct {int size; int width;} widths[] = {{8, 4}, {16, 6}, {32, 11}, {64, 21}}; #define NUM_WIDTHS sizeof widths / sizeof widths[0] /* Maps float bit sizes to the value of the 'Digits for a type of that many bits. */ struct {int size; int digits;} digits[] = {{32, 6}, {64, 15}, {96, 18}, {128, 18}}; #define NUM_DIGITS sizeof digits / sizeof digits[0] /* Map character in template into value. */ struct {char c; int bits; int suffix;} charmap[] = {{'c', CHAR_TYPE_SIZE, 1}, {'s', SHORT_TYPE_SIZE, 1}, {'i', INT_TYPE_SIZE, 1}, {'l', LONG_TYPE_SIZE, 1}, {'L', LONG_LONG_TYPE_SIZE, 1}, {'F', FLOAT_TYPE_SIZE, 1}, {'f', FLOAT_TYPE_SIZE, 1}, {'d', DOUBLE_TYPE_SIZE, 1}, {'D', LONG_DOUBLE_TYPE_SIZE, 1}, {'U', BITS_PER_UNIT, 0}, {'W', BITS_PER_WORD, 0}}; #define NUM_CHARS sizeof charmap / sizeof charmap[0] int main (argc, argv) int argc; char **argv; { FILE *infile; int c; infile = fopen (argv[1], "r"); if (infile == 0) { perror (argv[1]); exit (FATAL_EXIT_CODE); } /* Read the entire file doing something special when we hit a "%". */ while ((c = getc (infile)) != EOF) { if (c != '%') putchar (c); else { int bit_size = -1; int i; int value = -1; int suffix; c = getc (infile); /* Scan the character map to get the size for this object. */ for (i = 0; i < NUM_CHARS; i++) if (charmap[i].c == c) bit_size = charmap[i].bits, suffix = charmap[i].suffix; if (bit_size == -1) { fprintf (stderr, "Unknown map character `%c'\n", c); exit (FATAL_EXIT_CODE); } /* See if we have a suffix and handle it if so. */ if (suffix) { c = getc (infile); switch (c) { case 'S': value = bit_size; break; case 'W': for (i = 0; i < NUM_WIDTHS; i++) if (widths[i].size == bit_size) value = widths[i].width; break; case 'D': for (i = 0 ; i < NUM_DIGITS; i++) if (digits[i].size == bit_size) value = digits[i].digits; break; default: fprintf (stderr, "Unknown suffix character '%c'\n", c); exit (FATAL_EXIT_CODE); } } else value = bit_size; if (value == -1) { fprintf (stderr, "Cannot find needed value\n"); exit (FATAL_EXIT_CODE); } printf ("%d", value); } } fflush (stdout); exit (ferror (stdout) != 0 ? FATAL_EXIT_CODE : SUCCESS_EXIT_CODE); /* NOTREACHED */ return 0; } */ /* $Revision: 1.3 $ */ /* gnat-1.67-src/src/ali.adb 444 10015 7640 41533 5506244474 10366 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- A L I -- -- -- -- B o d y -- -- -- -- $Revision: 1.9 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Binderr; use Binderr; with Butil; use Butil; with Namet; use Namet; with Opt; use Opt; with Osint; use Osint; with Output; use Output; package body ALI is -------------------- -- Initialize_ALI -- -------------------- procedure Initialize_ALI is begin ALIs.Init; Unit.Init; Withs.Init; Sdep.Init; end Initialize_ALI; -------------- -- Read_ALI -- -------------- procedure Read_ALI (Afile, Sfile : File_Name_Type) is Id : ALI_Id; Text : Text_Buffer_Ptr; begin -- Immediate return if ALI file already read, as indicated by a non- -- zero information field in the names table entry for the file. We -- also test for No_File (happens in the generic case), and ignore -- the call if Afile is No_File. if Afile = No_File or else Get_Name_Table_Info (Afile) /= 0 then return; end if; Text := Read_Library_Info (Afile, Sfile = No_File); if Text = null then Error_Msg_Name_1 := Afile; Error_Msg_Name_2 := Sfile; Error_Msg ("% not found, % must be compiled"); Set_Name_Table_Info (Afile, Int (No_Unit_Id)); else Id := Scan_ALI (Afile, Text); for I in ALIs.Table (Id).First_Unit .. ALIs.Table (Id).Last_Unit loop for J in Unit.Table (I).First_With .. Unit.Table (I).Last_With loop Read_ALI (Withs.Table (J).Afile, Withs.Table (J).Sfile); end loop; end loop; end if; end Read_ALI; -------------- -- Scan_ALI -- -------------- function Scan_ALI (F : File_Name_Type; T : Text_Buffer_Ptr) return ALI_Id is P : Text_Ptr := T'First; Line : Line_Number_Type := 1; Id : ALI_Id; C : Char; -- Local subprograms function At_Eol return Boolean; -- Test if at end of line function At_End_Of_Field return Boolean; -- Test if at end of line, or if at blank or horizontal tab procedure Check_At_End_Of_Field; -- Check if we are at end of field, fatal error if not procedure Checkc (C : Char); -- Check next character is C. If so bump past it, if not fatal error procedure Fatal_Error; -- Generate fatal error message for badly formatted ALI file function Getc return Char; -- Get next character, bumping P past the character obtained function Get_Name return Name_Id; -- Skip blanks, then scan out a name function Get_Stamp return Time_Stamp_Type; -- Skip blanks, then scan out a time stamp procedure Skip_Eol; -- Skip past end of line (fatal error if not at end of line) procedure Skip_Space; -- Skip past white space (blanks or horizontal tab) ------------ -- At_Eol -- ------------ function At_Eol return Boolean is begin return T (P) = EOF or else T (P) = CR or else T (P) = LF; end At_Eol; --------------------- -- At_End_Of_Field -- --------------------- function At_End_Of_Field return Boolean is begin return T (P) <= ' '; end At_End_Of_Field; --------------------------- -- Check_At_End_Of_Field -- --------------------------- procedure Check_At_End_Of_Field is begin if not At_End_Of_Field then Fatal_Error; end if; end Check_At_End_Of_Field; ------------ -- Checkc -- ------------ procedure Checkc (C : Char) is begin if T (P) = C then P := P + 1; else Fatal_Error; end if; end Checkc; ----------------- -- Fatal_Error -- ----------------- procedure Fatal_Error is Ptr1 : Text_Ptr; Ptr2 : Text_Ptr; Col : Int; procedure Wchar (C : Char) is begin if C = HT then loop Wchar (' '); exit when Col mod 8 = 0; end loop; else Write_Char (C); Col := Col + 1; end if; end Wchar; begin Write_Str ("fatal error: file "); Write_Name (F); Write_Str (" is incorrectly formatted"); Write_Eol; -- Find start of line Ptr1 := P; while Ptr1 > T'First and then T (Ptr1 - 1) /= CR and then T (Ptr1 - 1) /= LF loop Ptr1 := Ptr1 - 1; end loop; Write_Int (Int (Line)); Write_Str (". "); if Line < 100 then Write_Char (' '); end if; if Line < 10 then Write_Char (' '); end if; Col := 0; Ptr2 := Ptr1; while Ptr2 < T'Last and then T (Ptr2) /= CR and then T (Ptr2) /= LF loop Wchar (T (Ptr2)); Ptr2 := Ptr2 + 1; end loop; Write_Eol; Write_Str (" "); Col := 0; while Ptr1 < P loop if T (Ptr1) = HT then Wchar (HT); else Wchar (' '); end if; Ptr1 := Ptr1 + 1; end loop; Wchar ('|'); Write_Eol; Exit_Program (E_Fatal); end Fatal_Error; ---------- -- Getc -- ---------- function Getc return Char is begin if P = T'Last then return EOF; else P := P + 1; return T (P - 1); end if; end Getc; -------------- -- Get_Name -- -------------- function Get_Name return Name_Id is begin Name_Len := 0; Skip_Space; if At_Eol then Fatal_Error; end if; loop Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := Getc; exit when At_End_Of_Field; end loop; return Name_Find; end Get_Name; --------------- -- Get_Stamp -- --------------- function Get_Stamp return Time_Stamp_Type is T : Time_Stamp_Type; begin Skip_Space; if At_Eol then Fatal_Error; end if; for I in T'range loop T (I) := Getc; end loop; return T; end Get_Stamp; -------------- -- Skip_Eol -- -------------- procedure Skip_Eol is begin Skip_Space; if not At_Eol then Fatal_Error; end if; -- Loop to skip past blank lines (first time through skips this EOL) while T (P) < ' ' and then T (P) /= EOF loop if T (P) = LF then Line := Line + 1; end if; P := P + 1; end loop; end Skip_Eol; ---------------- -- Skip_Space -- ---------------- procedure Skip_Space is begin while T (P) = ' ' or else T (P) = HT loop P := P + 1; end loop; end Skip_Space; -------------------------------------- -- Start of processing for Scan_ALI -- -------------------------------------- begin ALIs.Increment_Last; Id := ALIs.Last; Set_Name_Table_Info (F, Int (Id)); ALIs.Table (Id).Afile := F; ALIs.Table (Id).First_Unit := No_Unit_Id; -- Acquire library version Checkc ('V'); Checkc (' '); Checkc ('"'); for I in ALIs.Table (Id).Ver'range loop ALIs.Table (Id).Ver (I) := Getc; end loop; Checkc ('"'); Skip_Eol; -- Acquire standard version Checkc ('S'); Checkc (' '); Checkc ('"'); for I in ALIs.Table (Id).Std'range loop ALIs.Table (Id).Std (I) := Getc; end loop; Checkc ('"'); Skip_Eol; -- Acquire main program line if present C := Getc; if C = 'M' then Checkc (' '); C := Getc; if C = 'F' then ALIs.Table (Id).Main_Program := Func; elsif C = 'P' then ALIs.Table (Id).Main_Program := Proc; else P := P - 1; Fatal_Error; end if; Skip_Eol; C := Getc; else ALIs.Table (Id).Main_Program := None; end if; -- Loop to acquire unit entries Unit_Loop : while C = 'U' loop Checkc (' '); Unit.Increment_Last; if ALIs.Table (Id).First_Unit = No_Unit_Id then ALIs.Table (Id).First_Unit := Unit.Last; end if; Unit.Table (Unit.Last).Uname := Get_Name; Unit.Table (Unit.Last).My_ALI := Id; Unit.Table (Unit.Last).Sfile := Get_Name; Unit.Table (Unit.Last).Preelab := False; Unit.Table (Unit.Last).Elaborate_Body := False; Unit.Table (Unit.Last).First_With := Withs.Last + 1; Set_Name_Table_Info (Unit.Table (Unit.Last).Uname, Int (Unit.Last)); -- Scan out possible PRE and EB parameters while not At_Eol loop Skip_Space; if Getc = 'P' then Checkc ('R'); Checkc ('E'); Check_At_End_Of_Field; Unit.Table (Unit.Last).Preelab := True; elsif Getc = 'E' then Checkc ('B'); Check_At_End_Of_Field; Unit.Table (Unit.Last).Elaborate_Body := True; end if; end loop; Skip_Eol; C := Getc; -- Scan out With lines for this unit With_Loop : while C = 'W' loop Checkc (' '); Withs.Increment_Last; Withs.Table (Withs.Last).Uname := Get_Name; Withs.Table (Withs.Last).Elaborate := False; Withs.Table (Withs.Last).Elaborate_All := False; -- Generic case if At_Eol then Withs.Table (Withs.Last).Sfile := No_File; Withs.Table (Withs.Last).Afile := No_File; -- Normal case else Withs.Table (Withs.Last).Sfile := Get_Name; Withs.Table (Withs.Last).Afile := Get_Name; -- Scan out possible E and EA parameters while not At_Eol loop Skip_Space; if Getc = 'E' then if At_End_Of_Field then Withs.Table (Withs.Last).Elaborate := True; else Checkc ('A'); Check_At_End_Of_Field; Withs.Table (Withs.Last).Elaborate_All := True; end if; end if; end loop; end if; Skip_Eol; C := Getc; Unit.Table (Unit.Last).Last_With := Withs.Last; end loop With_Loop; end loop Unit_Loop; -- End loop through units for one ALI file ALIs.Table (Id).Last_Unit := Unit.Last; ALIs.Table (Id).Sfile := Unit.Table (ALIs.Table (Id).First_Unit).Sfile; -- Set types of the units (there can be at most 2 of them) if ALIs.Table (Id).First_Unit /= ALIs.Table (Id).Last_Unit then Unit.Table (ALIs.Table (Id).First_Unit).Utype := Is_Body; Unit.Table (ALIs.Table (Id).Last_Unit).Utype := Is_Spec; else Get_Name_String (Unit.Table (Unit.Last).Uname); if Name_Buffer (Name_Len) = 'b' then Unit.Table (Unit.Last).Utype := Is_Body_Only; else Unit.Table (Unit.Last).Utype := Is_Spec_Only; end if; end if; -- Scan out source dependency lines for this ALI file ALIs.Table (Id).First_Sdep := Sdep.Last + 1; while C = 'D' loop Checkc (' '); Sdep.Increment_Last; Sdep.Table (Sdep.Last).Sfile := Get_Name; Sdep.Table (Sdep.Last).Stamp := Get_Stamp; -- Skip comments after stamp while not At_Eol loop P := P + 1; end loop; Skip_Eol; C := Getc; end loop; ALIs.Table (Id).Last_Sdep := Sdep.Last; if C /= EOF then Fatal_Error; end if; return Id; end Scan_ALI; ---------------------- -- Set_Source_Table -- ---------------------- procedure Set_Source_Table is F : File_Name_Type; S : Source_Id; Stamp : Time_Stamp_Type; begin ALIs_Loop : for A in ALIs.First .. ALIs.Last loop Sdep_Loop : for D in ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep loop F := Sdep.Table (D).Sfile; -- If this is the first time we are seeing this source file, -- then make a new entry in the source table. if Get_Name_Table_Info (F) = 0 then Source.Increment_Last; S := Source.Last; Set_Name_Table_Info (F, Int (S)); Source.Table (S).Sfile := F; -- In check source files mode, try to get stamp from file if Check_Source_Files then Stamp := Source_File_Stamp (F); -- If we got the stamp, then set the stamp in the source -- table entry and mark it as set from the source so that -- it does not get subsequently changed. if Stamp (Stamp'First) /= ' ' then Source.Table (S).Stamp := Stamp; Source.Table (S).Source_Found := True; -- If we could not find the file, then the stamp is set -- from the dependency table entry (to be possibly reset -- if we find a later stamp in subsequent processing) else Source.Table (S).Stamp := Sdep.Table (D).Stamp; Source.Table (S).Source_Found := False; -- In All_Sources mode, flag error of file not found if All_Sources then Error_Msg_Name_1 := F; Error_Msg ("cannot locate %"); end if; end if; -- First time for this source file, but Check_Source_Files -- is off, so simply initialize the stamp from the Sdep entry else Source.Table (S).Source_Found := False; Source.Table (S).Stamp := Sdep.Table (D).Stamp; end if; -- Here if this is not the first time for this source file, -- so that the source table entry is already constructed. else S := Source_Id (Get_Name_Table_Info (F)); -- If stamp was set from source file don't touch it. Otherwise -- update the stamp if the current reference in the Sdep entry -- is later than the current entry in the source table. if not Source.Table (S).Source_Found and then Later (Sdep.Table (D).Stamp, Source.Table (S).Stamp) then Source.Table (S).Stamp := Sdep.Table (D).Stamp; end if; end if; end loop Sdep_Loop; end loop ALIs_Loop; end Set_Source_Table; end ALI; ---- begin ALIs.Increment_Last; Id := ALIs.Last; Set_Name_Table_Info (F, Int (Id)); ALIs.Table (Id).Afile := F; ALIs.Table (Id).Fignat-1.67-src/src/bcheck.ads 444 10015 7640 4621 5506244475 11037 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- B C H E C K -- -- -- -- S p e c -- -- -- -- $Revision: 1.3 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ package Bcheck is -- This package contains the routines to perform binder consistency checks procedure Check_Versions; -- Check correct library and standard versions used procedure Check_Consistency; -- This procedure performs checks that the ALI files are consistent -- with the corresponding source files and with one another. At the -- time this is called, the Source table has been completely built and -- contains either the time stamp from the actual source file if the -- Check_Source_Files mode is set, or the latest stamp found in any of -- the ALI files in the program. end Bcheck; loop ALIs.Table (Id).Std (I) := Getc; end loop; Checkc ('"'); Skip_Eol; -- gnat-1.67-src/src/bcheck.adb 444 10015 7640 11464 5506244475 11041 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- B C H E C K -- -- -- -- B o d y -- -- -- -- $Revision: 1.6 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with ALI; use ALI; with Binderr; use Binderr; with Gnatvsn; use Gnatvsn; with Libfmt; use Libfmt; with Namet; use Namet; with Opt; use Opt; package body Bcheck is -------------------- -- Check_Versions -- -------------------- procedure Check_Versions is begin for A in ALIs.First .. ALIs.Last loop if ALIs.Table (A).Ver /= Library_Version then Error_Msg_Name_1 := Unit.Table (ALIs.Table (A).First_Unit).Sfile; if Ignore_Time_Stamp_Errors then Error_Msg ("?% should be recompiled (compiled with old version)"); else Error_Msg ("% must be recompiled (compiled with old version)"); end if; end if; if ALIs.Table (A).Std /= Standard_Version then Error_Msg_Name_1 := Unit.Table (ALIs.Table (A).First_Unit).Sfile; if Ignore_Time_Stamp_Errors then Error_Msg ("?% should be recompiled (wrong version of Standard)"); else Error_Msg ("% must be recompiled (wrong version of Standard)"); end if; end if; end loop; end Check_Versions; ----------------------- -- Check_Consistency -- ----------------------- procedure Check_Consistency is Src : Source_Id; -- Source file Id for this Sdep entry begin -- Loop through ALI files ALIs_Loop : for A in ALIs.First .. ALIs.Last loop -- Loop through Sdep entries in one ALI file Sdep_Loop : for D in ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep loop Src := Source_Id (Get_Name_Table_Info (Sdep.Table (D).Sfile)); -- If stamp does not match, generate error message if Sdep.Table (D).Stamp /= Source.Table (Src).Stamp then Error_Msg_Name_1 := ALIs.Table (A).Sfile; Error_Msg_Name_2 := Sdep.Table (D).Sfile; -- Two styles of message, depending on whether or not -- the updated file is the one that must be recompiled if Error_Msg_Name_1 = Error_Msg_Name_2 then if Ignore_Time_Stamp_Errors then Error_Msg ("?% has been modified and should be recompiled"); else Error_Msg ("% has been modified and must be recompiled"); end if; else if Ignore_Time_Stamp_Errors then Error_Msg ("?% should be recompiled (% has been modified)"); else Error_Msg ("% must be recompiled (% has been modified)"); end if; end if; -- Exit from the loop through Sdep entries once we find one -- that does not match. exit Sdep_Loop; end if; end loop Sdep_Loop; end loop ALIs_Loop; end Check_Consistency; end Bcheck; ("?% should be recompiled (compiled with old version)"); else Error_Msg ("% must be recompiled (compiled with old version)"); end if; end gnat-1.67-src/src/binde.ads 444 10015 7640 4432 5506244476 10702 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- B I N D E -- -- -- -- S p e c -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This package contains the routines to determine elaboration order with ALI; use ALI; with Table; with Types; use Types; package Binde is -- The following table records the chosen elaboration order package Elab_Order is new Table ( Component_Type => Unit_Id, Index_Type => Nat, Low_Bound => 1, Initial => 500, Increment => 200, Table_Name => "Elab_Order"); procedure Find_Elab_Order; -- Determine elaboration order end Binde; Consistency; end Bcheck; ("?% should be recompiled (compiled with old version)"); else Error_Msg ("% must be recompiled (compiled with old version)"); end if; end gnat-1.67-src/src/binde.adb 444 10015 7640 57324 5506244476 10711 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- B I N D E -- -- -- -- B o d y -- -- -- -- $Revision: 1.8 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Binderr; use Binderr; with Butil; use Butil; with Debug; use Debug; with Namet; use Namet; with Opt; use Opt; with Output; use Output; package body Binde is -- The following data structures are used to represent the graph that is -- used to determine the elaboration order (using a topological sort). -- The following structures are used to record successors type Successor_Id is new Nat; -- Identification of single successor entry No_Succ : constant Successor_Id := 0; -- Used to indicate end of list of successors type Succ_Reason is (Withed, Elab, Elab_All, Spec_First); -- Reason for existence of successor link type Successor_Link is record Before : Unit_Id; -- Predecessor unit After : Unit_Id; -- Successor unit Next : Successor_Id; -- Next successor on this list Reason : Succ_Reason; -- Reason for this link end record; package Succ is new Table ( Component_Type => Successor_Link, Index_Type => Successor_Id, Low_Bound => 1, Initial => 500, Increment => 200, Table_Name => "Succ"); -- A Unit_Node record is built for each active unit type Unit_Node_Record is record Successors : Successor_Id; -- Pointer to list of links for successor nodes Num_Pred : Nat; -- Number of predecessors for this unit Nextnp : Unit_Id; -- Forward pointer for list of units with no predecessors Elab_Order : Nat; -- Position in elaboration order (zero = not placed yet) Visited : Boolean; -- Used in computing transitive closure for elaborate all and -- also in locating cycles in Diagnose_Circularity. Done : Boolean; -- Flag set when unit is chosen and placed in elaboration order end record; package UNR is new Table ( Component_Type => Unit_Node_Record, Index_Type => Unit_Id, Low_Bound => First_Unit_Entry, Initial => 500, Increment => 200, Table_Name => "UNR"); No_Pred : Unit_Id; -- Head of list of items with no predecessors Num_Left : Int; -- Number of entries not yet dealt with ----------------------- -- Local Subprograms -- ----------------------- function Better_Choice (U1, U2 : Unit_Id) return Boolean; -- U1 and U2 are both candidates for selection as the next unit to be -- elaborated. Both have number of predecessors set to zero, and neither -- is an instance of a spec with pragma Elaborate_Body set where the -- body cannot also be immediately placed. This function determines -- whether U1 is a better choice than U2 (i.e. should be elaborated -- first), and if so, returns True. procedure Build_Link (Before, After : Unit_Id; R : Succ_Reason); -- Establish a successor link, Before must be elaborated before After, -- and the reason for the link is R. procedure Choose (Chosen : Unit_Id); -- Chosen is the next entry chosen in the elaboration order. This -- procedure updates all data structures appropriately. function Corresponding_Body (U : Unit_Id) return Unit_Id; -- Given a unit which is a spec for which there is a separate body, -- return the unit id of the body. It is an error to call this routine -- with a unit that is not a spec, or which does not have a separate body. function Corresponding_Spec (U : Unit_Id) return Unit_Id; -- Given a unit which is a body for which there is a separate spec, -- return the unit id of the spec. It is an error to call this routine -- with a unit that is not a body, or which does not have a separate spec. procedure Diagnose_Circularity; -- Called when a circular elaboration order is found to print out -- appropriate diagnostic information giving details of the cycle procedure Elab_All_Links (Before, After : Unit_Id); -- Used to compute the transitive closure of elaboration links for an -- Elaborate_All pragma. Unit After has a pragma Elaborate_All, and -- unit Before must be previously elaborated. First a link is built -- making sure that unit Before is elaborated before After, then a -- recursive call ensures that we also build links for any units needed -- by Before (i.e. these units must also be elaborated before After). procedure Gather_Dependencies; -- Compute dependencies, building the Succ and UNR tables function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id; -- This function uses the Info field set in the names table to obtain -- the unit Id of a unit, given its name id value. procedure Write_Dependencies; -- Write out dependencies (called only if appropriate option is set) ------------------- -- Better_Choice -- ------------------- function Better_Choice (U1, U2 : Unit_Id) return Boolean is function Body_Unit (U : Unit_Id) return Boolean; -- Determines if given unit is a body function Waiting_Body (U : Unit_Id) return Boolean; -- Determines if U is a waiting body, defined as a body which has not -- been elaborated, but whose spec has been elaborated. function Body_Unit (U : Unit_Id) return Boolean is begin return Unit.Table (U).Utype = Is_Body or else Unit.Table (U).Utype = Is_Body_Only; end Body_Unit; function Waiting_Body (U : Unit_Id) return Boolean is begin return Unit.Table (U).Utype = Is_Body and then UNR.Table (Corresponding_Spec (U)).Done; end Waiting_Body; begin -- Anything is better than nothing if U2 = No_Unit_Id then return True; end if; -- Always prefer a waiting body to any other case if Waiting_Body (U1) and not Waiting_Body (U2) then return True; elsif Waiting_Body (U2) and not Waiting_Body (U1) then return False; end if; -- Always prefer a body to a spec if Body_Unit (U1) and not Body_Unit (U2) then return True; elsif Body_Unit (U2) and not Body_Unit (U1) then return False; end if; -- Otherwise decide on the basis of alphabetical order return Uname_Less (Unit.Table (U1).Uname, Unit.Table (U2).Uname); end Better_Choice; ---------------- -- Build_Link -- ---------------- procedure Build_Link (Before, After : Unit_Id; R : Succ_Reason) is begin Succ.Increment_Last; Succ.Table (Succ.Last).Before := Before; Succ.Table (Succ.Last).After := After; Succ.Table (Succ.Last).Next := UNR.Table (Before).Successors; UNR.Table (Before).Successors := Succ.Last; Succ.Table (Succ.Last).Reason := R; UNR.Table (After).Num_Pred := UNR.Table (After).Num_Pred + 1; end Build_Link; ------------ -- Choose -- ------------ procedure Choose (Chosen : Unit_Id) is S : Successor_Id; U : Unit_Id; begin if Debug_Flag_C then Write_Str ("Choosing Unit "); Write_Unit_Name (Unit.Table (Chosen).Uname); Write_Eol; end if; -- Add to elaboration order unless preelaborable if not Unit.Table (Chosen).Preelab then Elab_Order.Increment_Last; Elab_Order.Table (Elab_Order.Last) := Chosen; end if; -- Remove from No_Pred list. This is a little inefficient and may -- be we should doubly link the list, but it will do for now! if No_Pred = Chosen then No_Pred := UNR.Table (Chosen).Nextnp; else U := No_Pred; while U /= No_Unit_Id loop if UNR.Table (U).Nextnp = Chosen then UNR.Table (U).Nextnp := UNR.Table (Chosen).Nextnp; exit; end if; U := UNR.Table (U).Nextnp; end loop; end if; -- For all successors, decrement the number of predecessors, and -- if it becomes zero, then add to no predecessor list. S := UNR.Table (Chosen).Successors; while S /= No_Succ loop U := Succ.Table (S).After; UNR.Table (U).Num_Pred := UNR.Table (U).Num_Pred - 1; if Debug_Flag_N then Write_String (" decrementing Num_Pred for unit "); Write_Unit_Name (Unit.Table (U).Uname); Write_String (" new value = "); Write_Int (Int (UNR.Table (U).Num_Pred)); Write_Eol; end if; if UNR.Table (U).Num_Pred = 0 then UNR.Table (U).Nextnp := No_Pred; No_Pred := U; end if; S := Succ.Table (S).Next; end loop; -- All done, adjust number of units left count and set flag for done Num_Left := Num_Left - 1; UNR.Table (Chosen).Done := True; end Choose; ------------------------ -- Corresponding_Body -- ------------------------ -- Currently if the body and spec are separate, then they appear as -- two separate units in the same ALI file, with the body appearing -- first and the spec appearing second. function Corresponding_Body (U : Unit_Id) return Unit_Id is begin if Unit.Table (U).Utype /= Is_Spec then Binder_Abort; else return U - 1; end if; end Corresponding_Body; ------------------------ -- Corresponding_Spec -- ------------------------ -- Currently if the body and spec are separate, then they appear as -- two separate units in the same ALI file, with the body appearing -- first and the spec appearing second. function Corresponding_Spec (U : Unit_Id) return Unit_Id is begin if Unit.Table (U).Utype /= Is_Body then Binder_Abort; else return U + 1; end if; end Corresponding_Spec; -------------------------- -- Diagnose_Circularity -- -------------------------- procedure Diagnose_Circularity is Marked : Boolean; S : Successor_Id; Revisited_Node : Unit_Id; -- Node that marks the closure of the cycle Printing : Boolean; -- Used to control output during the recursive search. If set on the -- way up, it means that output describing the path taken is to be -- output. It is reset as soon as Revisited_Node is reached. -- The following is the recursive routine used to locate the cycle -- it is called once the only non-Done nodes in the list are known -- to be parts of cycles. procedure Visit_Node (U : Unit_Id) is S : Successor_Id; US : Unit_Id; begin if UNR.Table (U).Visited then Revisited_Node := U; Printing := True; return; end if; UNR.Table (U).Visited := True; -- Look for a successor that is also part of the cycle S := UNR.Table (U).Successors; loop US := Succ.Table (S).After; if not UNR.Table (US).Done then Visit_Node (US); if Printing then Error_Msg_Name_1 := Unit.Table (U).Uname; Error_Msg_Name_2 := Unit.Table (US).Uname; case Succ.Table (S).Reason is when Withed => Error_Msg ("& must be elaborated before & (with)"); when Elab => Error_Msg ("& must be elaborated before & (Elaborate)"); when Elab_All => Error_Msg ("& must be elaborated before & (Elaborate_All)"); when Spec_First => Error_Msg ("& must be elaborated before & (spec first)"); end case; if U = Revisited_Node then Printing := False; end if; return; end if; end if; S := Succ.Table (S).Next; end loop; end Visit_Node; -- Start of processing for Diagnose_Circularity begin Error_Msg ("Elaboration circularity detected"); -- The approach is to sweep through the unit list repeatedly, -- marking any nodes that have no successors that are not marked -- Done, as Done. When we have no more to mark, the remaining -- nodes must form the culprit cycle. loop Marked := False; for U in Unit.First .. Unit.Last loop if not UNR.Table (U).Done then S := UNR.Table (U).Successors; loop exit when S = No_Succ; exit when not UNR.Table (Succ.Table (S).After).Done; S := Succ.Table (S).Next; end loop; if S = No_Succ then UNR.Table (U).Done := True; Marked := True; end if; end if; end loop; exit when not Marked; end loop; -- OK, remaining units in the table (there must be at least one) -- form one or more cycles. We will just pick out one cycle to -- complain about (a situation with more than one cycle is rare). for U in Unit.First .. Unit.Last loop UNR.Table (U).Visited := False; end loop; for U in Unit.First .. Unit.Last loop if not UNR.Table (U).Done then Visit_Node (U); exit; end if; end loop; end Diagnose_Circularity; -------------------- -- Elab_All_Links -- -------------------- procedure Elab_All_Links (Before, After : Unit_Id) is begin if UNR.Table (Before).Visited then return; end if; -- Build the direct link for Before UNR.Table (Before).Visited := True; Build_Link (Before, After, Elab_All); -- Process all units With'ed by Before recursively for W in Unit.Table (Before).First_With .. Unit.Table (Before).Last_With loop -- Skip if no ALI file for this with, happens with generics now, -- will happen only with specialized generics like unchecked -- stuff when we finally fix generics??? if Withs.Table (W).Afile /= No_File then Elab_All_Links (Unit_Id_Of (Withs.Table (W).Uname), After); end if; end loop; -- Process corresponding body, if there is one if Unit.Table (Before).Utype = Is_Spec then Elab_All_Links (Corresponding_Body (Before), After); end if; end Elab_All_Links; --------------------- -- Find_Elab_Order -- --------------------- procedure Find_Elab_Order is U : Unit_Id; Best_So_Far : Unit_Id; begin Succ.Init; Num_Left := Int (Unit.Last - Unit.First + 1); -- Initialize unit table for elaboration control for U in Unit.First .. Unit.Last loop UNR.Increment_Last; UNR.Table (UNR.Last).Successors := No_Succ; UNR.Table (UNR.Last).Num_Pred := 0; UNR.Table (UNR.Last).Nextnp := No_Unit_Id; UNR.Table (UNR.Last).Elab_Order := 0; UNR.Table (UNR.Last).Done := False; end loop; -- Gather dependencies and outpu them if option set Gather_Dependencies; -- Output elaboration dependencies if option is set if Elab_Dependency_Output then Write_Dependencies; end if; -- Initialize the no predecessor list No_Pred := No_Unit_Id; for U in UNR.First .. UNR.Last loop if UNR.Table (U).Num_Pred = 0 then UNR.Table (U).Nextnp := No_Pred; No_Pred := U; end if; end loop; -- OK, now we determine the elaboration order proper. All we do is to -- select the best choice from the no predecessor list till the list -- is empty. Note that preelaborable units are not treated specially -- until the point at which they are chosen. At this point a test makes -- sure that they are not actually added to the preelaboration order. while No_Pred /= No_Unit_Id loop U := No_Pred; Best_So_Far := No_Unit_Id; -- Loop to choose best entry in No_Pred list loop -- We must ignore entries that have Pragma Elaborate_Body set -- unless both the spec and body have Num_Pred set to zero if not Unit.Table (U).Elaborate_Body or else UNR.Table (Corresponding_Body (U)).Num_Pred = 0 then -- This is a candididate to be considered for choice if Better_Choice (U, Best_So_Far) then Best_So_Far := U; end if; end if; U := UNR.Table (U).Nextnp; exit when U = No_Unit_Id; end loop; -- If no candididate chosen, it means that all the items with -- No_Pred set to zero are instances of specs with Elaborate_Body -- set where the bodies cannot be elaborated yet. This can only -- happen if there are other entries that cannot be elaborated -- because of a circular elaboration situation. exit when Best_So_Far = No_Unit_Id; Choose (Best_So_Far); -- If we just chose a spec with Elaborate_Body set, then we -- must immediately elaborate the spec, before any other units. if Unit.Table (Best_So_Far).Elaborate_Body then Choose (Corresponding_Body (Best_So_Far)); end if; end loop; -- If we haven't elaborated all the entries, then we have some kind -- of circular elaboration dependency (assuming everything is working!) if Num_Left /= 0 then Diagnose_Circularity; end if; end Find_Elab_Order; ------------------------- -- Gather_Dependencies -- ------------------------- procedure Gather_Dependencies is Withed_Unit : Unit_Id; begin -- Loop through all units for U in Unit.First .. Unit.Last loop -- If there is a body and a spec, then spec must be elaborated first -- Note that the corresponding spec immediately follows the body if Unit.Table (U).Utype = Is_Body then Build_Link (Corresponding_Spec (U), U, Spec_First); end if; -- Process WITH references for this unit ignoring generic units for W in Unit.Table (U).First_With .. Unit.Table (U).Last_With loop if Withs.Table (W).Sfile /= No_File then Withed_Unit := Unit_Id (Unit_Id_Of (Withs.Table (W).Uname)); -- Pragma Elaborate case. We must build a link for the withed -- unit itself, and also the corresponding body if there is one -- However, skip this processing if there is no ALI file for -- the WITH entry, because this means it is a generic (even -- when we fix the generics so that an ALI file is present, -- we probably still will have no ALI file for unchecked -- and other special cases). if Withs.Table (W).Elaborate and then Withs.Table (W).Afile /= No_File then Build_Link (Withed_Unit, U, Withed); if Unit.Table (Withed_Unit).Utype = Is_Spec then Build_Link (Corresponding_Body (Withed_Unit), U, Elab); end if; -- Pragma Elaborate_All case, for this we use the recursive -- Elab_All_Links procedure to establish the links. elsif Withs.Table (W).Elaborate_All then -- Reset flags used to stop multiple visits to a given node -- but set our flag to stop a self-recursive link. for Uref in UNR.First .. UNR.Last loop UNR.Table (Uref).Visited := False; end loop; UNR.Table (U).Visited := True; -- Now establish all the links we need Elab_All_Links (Withed_Unit, U); -- Case of normal WITH with no elaboration pragmas, just -- build the single link to the directly referenced unit else Build_Link (Withed_Unit, U, Withed); end if; end if; end loop; end loop; end Gather_Dependencies; ---------------- -- Unit_Id_Of -- ---------------- function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is Info : constant Int := Get_Name_Table_Info (Uname); begin if Info = 0 or else Unit_Id (Info) = No_Unit_Id then Binder_Abort; else return Unit_Id (Info); end if; end Unit_Id_Of; ------------------------ -- Write_Dependencies -- ------------------------ procedure Write_Dependencies is Col : Pos; begin Write_Eol; Write_String (" ELABORATION ORDER DEPENDENCIES"); Write_Eol; Write_Eol; Write_String ("Elaborate Before Because"); Write_Eol; Write_String ("--------- ------ -------"); Write_Eol; for S in Succ.First .. Succ.Last loop Write_Unit_Name (Unit.Table (Succ.Table (S).Before).Uname); Col := Name_Len + 1; if Col >= 29 then Write_Eol; Col := 1; end if; while Col < 29 loop Write_Char (' '); Col := Col + 1; end loop; Write_Unit_Name (Unit.Table (Succ.Table (S).After).Uname); Col := Col + Name_Len; if Col >= 57 then Write_Eol; Col := 1; end if; while Col < 57 loop Write_Char (' '); Col := Col + 1; end loop; case Succ.Table (S).Reason is when Withed => Write_String ("with"); when Elab => Write_String ("Elaborate"); when Elab_All => Write_String ("Elaborate_All"); when Spec_First => Write_String ("spec first"); end case; Write_Eol; end loop; Write_Eol; end Write_Dependencies; end Binde; ff when we finally fix generics??? if Withs.Table (W).Afile /= No_File then Elab_All_Links (Unit_Id_Of (Withs.Table (W).Uname), After); end if; end loop; -- Process corresponding body, if there is one if Unit.Table (Before).Utype = Is_Spec then gnat-1.67-src/src/binderr.ads 444 10015 7640 13155 5506244477 11271 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- B I N D E R R -- -- -- -- S p e c -- -- -- -- $Revision: 1.4 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Binderr is -- This package contains the routines to output error messages for the binder -- and also the routines for handling fatal error conditions in the binder. --------------------------------------------------------- -- Error Message Text and Message Insertion Characters -- --------------------------------------------------------- -- Error message text strings are composed of letters, digits and the -- special characters space, comma, period, colon and semicolon, -- apostrophe and parentheses. Special insertion characters can also -- appear which cause the error message circuit to modify the given -- string as follows: -- Insertion character % (Percent: insert file name from Names table) -- The character % is replaced by the text for the file name specified -- by the Name_Id value stored in Error_Msg_Name_1, as generated by -- the routine Get_Name_String stored in Error_Msg_Name_1. The name -- is always enclosed in quotes. A second % may appear in a single -- message in which case it is similarly replaced by the name which -- is specified by the Name_Id value stored in Error_Msg_Name_2. -- Insertion character & (Ampersand: insert unit name from Names table) -- The character & is replaced by the text for the unit name specified -- by the Name_Id value stored in Error_Msg_Name_1, as generated by -- the routine Get_Name_String stored in Error_Msg_Name_1. The name -- is always enclosed in quotes. A second & may appear in a single -- message in which case it is similarly replaced by the name which -- is specified by the Name_Id value stored in Error_Msg_Name_2. -- Insertion character ? (Question mark: warning message) -- The character ?, which must be the first character in the message -- string, signals a warning message instead of an error message. ----------------------------------------------------- -- Global Values Used for Error Message Insertions -- ----------------------------------------------------- -- The following global variables are essentially additional parameters -- passed to the error message routine for insertion sequences described -- above. The reason these are passed globally is that the insertion -- mechanism is essentially an untyped one in which the appropriate -- variables are set dependingon the specific insertion characters used. Error_Msg_Name_1 : Name_Id; Error_Msg_Name_2 : Name_Id; -- Name_Id values for % insertion characters in message ------------------------------------------- -- Subprograms for Handling Fatal Errors -- ------------------------------------------- procedure Binder_Abort; -- Signals a binder error unconditionally. Never returns control. Used -- in a case where the traceback alone is sufficient diagnostic information -- in the case where an error traceback is generated. procedure Binder_Error; -- Signals a binder error unconditionally. Returns control if a traceback -- is to be generated. Used in a case where the traceback is to be preceded -- by additional information. The protocol is to call Binder_Error, then -- generate the additional information required, then call Binder_Abort. -- The additional information will always go to Standard_Error. ------------------------------ -- Error Output Subprograms -- ------------------------------ procedure Error_Msg (Msg : Str); -- Output specified error message to standard error or standard output -- as governed by the brief and verbose switches, and update error -- counts appropriately procedure Finalize_Binderr; -- Finalize error output for one file procedure Initialize_Binderr; -- Initialize error output for one file end Binderr; en Binder_Abort; else return Unit_Id (Info); end if; end Unit_Id_Of; ------------------------ -- Write_Dependencies -- ------------------------ procedure Write_Dependencies is Col : Pos; begin Write_Eol; Write_String (" ELABORATION ORDER DEPENDENCIES"); Write_Eol; Write_Eol; Write_String gnat-1.67-src/src/binderr.adb 444 10015 7640 17373 5506244477 11256 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- B I N D E R R -- -- -- -- B o d y -- -- -- -- $Revision: 1.8 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Butil; use Butil; with Debug; use Debug; with Errcount; use Errcount; with Excep; use Excep; with Namet; use Namet; with Opt; use Opt; with Osint; use Osint; with Output; use Output; with System.Traceback; use System.Traceback; package body Binderr is ----------------------- -- Local Subprograms -- ----------------------- procedure Error_Msg_Output (Msg : Str); -- Output given message, with insertions, to current message output file ------------------ -- Binder_Abort -- ------------------ procedure Binder_Abort is begin -- Case of errors have been detected. In this case, we guess that the -- abort is caused by previous errors, and we don't make too much fuss -- about it, since we want to let the programmer fix the errors first. -- This treatment is disabled by debug flag -dk so that we can force -- a traceback when we are trying to get rid of cascaded bombs! if not Debug_Flag_K and then Errors_Detected /= 0 then raise Unrecoverable_Error; -- Otherwise we have a real abort. First generate software traceback -- if we are doing software tracebacks. Then do a system level abort. else if Tracebacks_Stored then Output_Traceback; -- We exit softly if we generated a software traceback, to be -- sure that buffers get flushed etc. The assumption is that -- we would not be doing a software traceback if the abort -- gave useful information! Exit_Program (E_Errors); else Exit_Program (E_Abort); end if; end if; end Binder_Abort; ------------------ -- Binder_Error -- ------------------ procedure Binder_Error is begin -- Case of errors have been detected. In this case, we guess that the -- abort is caused by previous errors, and we don't make too much fuss -- about it, since we want to let the programmer fix the errors first. -- This treatment is disabled by debug flag -dk so that we can force -- a traceback when we are trying to get rid of cascaded bombs! if not Debug_Flag_K and then Errors_Detected /= 0 then raise Unrecoverable_Error; -- Otherwise we have a real abort. In the case of Binder_Error, as -- opposed to Binder_Abort, we return to the caller to generate -- additional diagnostic information (which will go to standard error) else Set_Standard_Error; return; end if; end Binder_Error; --------------- -- Error_Msg -- --------------- procedure Error_Msg (Msg : Str) is begin if Msg (Msg'First) = '?' then if Warning_Mode = Suppress then return; end if; if Warning_Mode = Treat_As_Error then Errors_Detected := Errors_Detected + 1; else Warnings_Detected := Warnings_Detected + 1; end if; else Errors_Detected := Errors_Detected + 1; end if; if Brief_Output or else (not Verbose_Mode) then Set_Standard_Error; Error_Msg_Output (Msg); Set_Standard_Output; end if; if Verbose_Mode then if Errors_Detected + Warnings_Detected = 0 then Write_Eol; end if; Error_Msg_Output (Msg); end if; if Warnings_Detected + Errors_Detected > Maximum_Errors then raise Unrecoverable_Error; end if; end Error_Msg; ---------------------- -- Error_Msg_Output -- ---------------------- procedure Error_Msg_Output (Msg : Str) is Use_Second_Name : Boolean := False; begin if Warnings_Detected + Errors_Detected > Maximum_Errors then Write_String ("error: maximum errors exceeded"); Write_Eol; return; end if; if Msg (Msg'First) = '?' then if Warning_Mode = Suppress then return; else Write_String ("warning: "); end if; else Write_String ("error: "); end if; for I in Msg'range loop if Msg (I) = '%' then if Use_Second_Name then Get_Name_String (Error_Msg_Name_2); else Use_Second_Name := True; Get_Name_String (Error_Msg_Name_1); end if; Write_Char ('"'); Write_Str (Name_Buffer (1 .. Name_Len)); Write_Char ('"'); elsif Msg (I) = '&' then Write_Char ('"'); if Use_Second_Name then Write_Unit_Name (Error_Msg_Name_2); else Use_Second_Name := True; Write_Unit_Name (Error_Msg_Name_1); end if; Write_Char ('"'); elsif Msg (I) /= '?' then Write_Char (Msg (I)); end if; end loop; Write_Eol; end Error_Msg_Output; ---------------------- -- Finalize_Binderr -- ---------------------- procedure Finalize_Binderr is begin -- Message giving number of errors detected (verbose mode only) if Verbose_Mode then Write_Eol; if Errors_Detected = 0 then Write_String ("No errors"); elsif Errors_Detected = 1 then Write_String ("1 error"); else Write_Int (Errors_Detected); Write_String (" errors"); end if; if Warnings_Detected = 1 then Write_String (", 1 warning"); elsif Warnings_Detected > 1 then Write_String (", "); Write_Int (Warnings_Detected); Write_String (" warnings"); end if; Write_Eol; end if; end Finalize_Binderr; ------------------------ -- Initialize_Binderr -- ------------------------ procedure Initialize_Binderr is begin Errors_Detected := 0; Warnings_Detected := 0; end Initialize_Binderr; end Binderr; Write_Unit_Name (Unit.Table (Succ.Table (S).Before).Uname); Col := Name_Len + 1; if Col >= 29 then Write_Eol; Col := 1; end if; while Col < 29 loop Write_Char (' '); Cognat-1.67-src/src/bindgen.ads 444 10015 7640 4375 5506244500 11221 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- B I N D G E N -- -- -- -- S p e c -- -- -- -- $Revision: 1.3 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This package contains the routines to output the binder file. This is -- a C program which contains the following: -- initialization for main program case -- sequence of calls to elaboration routines in appropriate order -- call to main program for main program case -- See the body for exact details of the file that is generated package Bindgen is ------------------ -- Subprograms -- ------------------ procedure Gen_Output_File; end Bindgen; raise Unrecoverable_Error; end if; end Error_Msg; ---------------------- -- Error_Msg_Output -- ---------------------- procedure Error_Msg_Output (Msg : Str) is Use_Second_Name : Boolean := False; begin if Warngnat-1.67-src/src/bindgen.adb 444 10015 7640 30570 5506244500 11214 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- B I N D G E N -- -- -- -- B o d y -- -- -- -- $Revision: 1.15 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with ALI; use ALI; with Binde; use Binde; with Namet; use Namet; with Opt; use Opt; with Osint; use Osint; with Types; use Types; package body Bindgen is Statement_Buffer : Str (1 .. 1000); -- Buffer used for constructing output statements Withed_Text_IO : Boolean := False; -- Flag which indicates whether the program has a context clause for -- units Text_IO or Ada.Text_IO. ----------------------- -- Local Subprograms -- ----------------------- procedure Gen_Elab_Calls; -- Generate sequence of elaboration calls procedure Gen_Main_Program_File; -- Generate lines for output file in main program case procedure Gen_Non_Main_Program_File; -- Generate lines for output file in non-main program case --------------------- -- Gen_Output_File -- --------------------- procedure Gen_Output_File is begin Create_Binder_Output; if Bind_Main_Program then Gen_Main_Program_File; else Gen_Non_Main_Program_File; end if; Close_Binder_Output; end Gen_Output_File; -------------------- -- Gen_Elab_Calls -- -------------------- procedure Gen_Elab_Calls is L : Nat; Col : Nat; begin for E in Elab_Order.First .. Elab_Order.Last loop Get_Name_String (Unit.Table (Elab_Order.Table (E)).Uname); -- Temporary check to see if the unit Text_IO has been withed. If it -- has been we need to set the flag "Withed_Text_IO" so that there -- is a call to "ada__text_io__aux__textio_finalization" inserted -- immediately after the main program completes. When "finalization" -- is implemented this code will be removed and be replaced by the -- appropriate finalization action in Text_IO. if Name_Buffer (1 .. Name_Len) = "ada.text_io%s" then Withed_Text_IO := True; end if; Statement_Buffer (1 .. 3) := " "; -- Copy the unit name (and replace '.' into '__' for child unit) L := 4; for I in 1 .. Name_Len - 2 loop if Name_Buffer (I) /= '.' then Statement_Buffer (L) := Name_Buffer (I); L := L + 1; else Statement_Buffer (L .. L + 1) := "__"; L := L + 2; end if; end loop; Statement_Buffer (L .. L + 6) := "___elab"; Statement_Buffer (L + 7) := Name_Buffer (Name_Len); Statement_Buffer (L + 8 .. L + 11) := " ();"; L := L + 11; -- If not spec that has an associated body, then generate a -- comment giving the name of the corresponding ALI file if Unit.Table (Elab_Order.Table (E)).Utype /= Is_Spec then -- Tab to column 41 if not already past it Col := L; Statement_Buffer (L + 1) := HT; L := L + 1; Col := (Col + 7) / 8 * 8; while Col < 40 loop Statement_Buffer (L + 1) := HT; L := L + 1; Col := Col + 8; end loop; -- Now output the file name as a comment Get_Name_String (ALIs.Table (Unit.Table (Elab_Order.Table (E)).My_ALI).Afile); Statement_Buffer (L + 1 .. L + 5) := " /* "; Statement_Buffer (L + 6 .. L + Name_Len + 5) := Name_Buffer (1 .. Name_Len); L := L + Name_Len + 5; Statement_Buffer (L + 1 .. L + 3) := " */"; L := L + 3; end if; Write_Binder_Info (Statement_Buffer (1 .. L)); end loop; end Gen_Elab_Calls; --------------------------- -- Gen_Main_Program_File -- --------------------------- procedure Gen_Main_Program_File is begin Write_Binder_Info ("#include " ); Write_Binder_Info (" " ); Write_Binder_Info ("/* predefined exceptions */ " ); Write_Binder_Info ("char constraint_error; " ); Write_Binder_Info ("char numeric_error; " ); Write_Binder_Info ("char program_error; " ); Write_Binder_Info ("char storage_error; " ); Write_Binder_Info ("char tasking_error; " ); Write_Binder_Info (" " ); Write_Binder_Info ("static int static_argc; " ); Write_Binder_Info ("static char * *static_argv; " ); Write_Binder_Info (" " ); Write_Binder_Info ("int arg_count () { return static_argc; } " ); Write_Binder_Info (" " ); Write_Binder_Info ("int len_arg (arg_num) " ); Write_Binder_Info (" int arg_num; " ); Write_Binder_Info (" { return strlen(static_argv[arg_num]); } " ); Write_Binder_Info (" " ); Write_Binder_Info ("int fill_arg (a, i) " ); Write_Binder_Info (" char * a; " ); Write_Binder_Info (" int i; " ); Write_Binder_Info ("{ strncpy (a, static_argv[i], " ); Write_Binder_Info (" strlen(static_argv[i])); } " ); Write_Binder_Info (" " ); Write_Binder_Info ("void catch_except (ptr, i) " ); Write_Binder_Info (" void *ptr; " ); Write_Binder_Info (" int i; " ); Write_Binder_Info ("{ " ); Write_Binder_Info (" extern char *__gnat_exception; " ); Write_Binder_Info (" " ); Write_Binder_Info (" if (!ptr)" ); Write_Binder_Info (" {" ); Write_Binder_Info (" if (__gnat_exception == &constraint_error)" ); Write_Binder_Info (" puts (""\nraised Constraint_Error\n"");" ); Write_Binder_Info (" else if (__gnat_exception == &numeric_error)"); Write_Binder_Info (" puts (""\nraised Numeric_Error\n"");" ); Write_Binder_Info (" else if (__gnat_exception == &program_error)"); Write_Binder_Info (" puts (""\nraised Program_Error\n"");" ); Write_Binder_Info (" else if (__gnat_exception == &storage_error)"); Write_Binder_Info (" puts (""\nraised Storage_Error\n"");" ); Write_Binder_Info (" else" ); Write_Binder_Info (" puts (""\nraised unhandled exception\n"");"); Write_Binder_Info (" " ); Write_Binder_Info (" exit (1);" ); Write_Binder_Info (" }" ); Write_Binder_Info (" else" ); Write_Binder_Info (" longjmp (ptr, i);" ); Write_Binder_Info ("}" ); Write_Binder_Info (" " ); Write_Binder_Info ("void __gnat_raise_constraint ()" ); Write_Binder_Info ("{" ); Write_Binder_Info (" extern char *__gnat_exception; " ); Write_Binder_Info (" extern void *__gnat_jmpbuf; " ); Write_Binder_Info (" __gnat_exception = &constraint_error;" ); Write_Binder_Info ("" ); Write_Binder_Info (" catch_except (__gnat_jmpbuf, 1);" ); Write_Binder_Info ("}" ); Write_Binder_Info (" " ); if ALIs.Table (ALIs.First).Main_Program = Proc then Write_Binder_Info ("void main (argc, argv)" ); else Write_Binder_Info ("int main (argc, argv)" ); end if; Write_Binder_Info (" int argc;" ); Write_Binder_Info (" char * argv[];" ); Write_Binder_Info ("{ " ); Write_Binder_Info (" static_argc = argc;" ); Write_Binder_Info (" static_argv = argv;" ); Write_Binder_Info (" " ); Gen_Elab_Calls; Write_Binder_Info (" "); Get_Name_String (Unit.Table (Unit.First).Uname); -- Main program is procedure case if ALIs.Table (ALIs.First).Main_Program = Proc then Statement_Buffer (1 .. 8) := " _ada_"; Statement_Buffer (9 .. Name_Len + 6) := Name_Buffer (1 .. Name_Len - 2); Statement_Buffer (Name_Len + 7 .. Name_Len + 10) := " ();"; Write_Binder_Info (Statement_Buffer (1 .. Name_Len + 10)); -- Main program is function case else -- ALIs.Table (ALIs.First).Main_Program = Func Statement_Buffer (1 .. 16) := " return (_ada_"; Statement_Buffer (17 .. Name_Len + 14) := Name_Buffer (1 .. Name_Len - 2); Statement_Buffer (Name_Len + 15 .. Name_Len + 19) := " ());"; Write_Binder_Info (Statement_Buffer (1 .. Name_Len + 19)); end if; -- Generate a call to the text_io procedure which performs cleanup -- operations on temporary files. See comment above at the beginning -- of Gen_Elab_Calls. if Withed_Text_IO then Write_Binder_Info (" ada__text_io__aux__text_io_finalization ();"); end if; Write_Binder_Info (" exit (0);"); Write_Binder_Info ("}"); end Gen_Main_Program_File; ------------------------------- -- Gen_Non_Main_Program_File -- ------------------------------- procedure Gen_Non_Main_Program_File is begin Write_Binder_Info ("void ada__bind ()" ); Write_Binder_Info ("{ " ); Gen_Elab_Calls; Write_Binder_Info ("}" ); end Gen_Non_Main_Program_File; end Bindgen; nt Get_Name_String (ALIs.Table (Unit.Table (Elab_Order.Table (E)).My_ALI).Afile); Statement_Buffegnat-1.67-src/src/bindusg.ads 444 10015 7640 3575 5506244501 11250 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- B I N D U S G -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Procedure to generate screen of usage information if no file name present procedure Bindusg; nt ()" ); Write_Binder_Info ("{" ); Write_Binder_Infognat-1.67-src/src/bindusg.adb 444 10015 7640 11522 5506244501 11236 ------------------------------------------------------------------------------ -- -- -- GBIND BINDER COMPONENTS -- -- -- -- B I N D U S G -- -- -- -- B o d y -- -- -- -- $Revision: 1.8 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Osint; use Osint; with Output; use Output; with Sysid; use Sysid; with Types; use Types; procedure Bindusg is procedure Write_Switch_Character is begin if MS_DOS then Write_Char ('/'); else Write_Char ('-'); end if; end Write_Switch_Character; begin -- Usage line Write_String ("Usage: "); Write_Program_Name; Write_Char (' '); Write_String ("switches lfile"); Write_Eol; Write_Eol; -- Line for -a switch Write_String (" "); Write_Switch_Character; Write_String ("a Require all source files to be"); Write_String (" present"); Write_Eol; -- Line for -b switch Write_String (" "); Write_Switch_Character; Write_String ("b Generate brief messages to std"); Write_String ("err even if verbose mode set"); Write_Eol; -- Line for -c switch Write_String (" "); Write_Switch_Character; Write_String ("c Check only, no generation of b"); Write_String ("inder output file"); Write_Eol; -- Line for -e switch Write_String (" "); Write_Switch_Character; Write_String ("e Output complete list of elabor"); Write_String ("ation order dependencies"); Write_Eol; -- Line for -i switch Write_String (" "); Write_Switch_Character; Write_String ("ix Identifier char set (x=1/2/3/4/p"); Write_String ("/f/n) default = "); if MS_DOS then Write_String ("p (IBM/PC)"); else Write_String ("1 (Latin-1)"); end if; Write_Eol; -- Line for -l switch Write_String (" "); Write_Switch_Character; Write_String ("l Output chosen elaboration order"); Write_Eol; -- Line for -m switch Write_String (" "); Write_Switch_Character; Write_String ("mnnn Limit number of detected error"); Write_String ("s to nnn (1-999)"); Write_Eol; -- Line for -n switch Write_String (" "); Write_Switch_Character; Write_String ("n No main program"); Write_Eol; -- Line for -o switch Write_String (" "); Write_Switch_Character; Write_String ("o file give the Output name (default is bind_xxx.c) "); Write_Eol; -- Line for -s switch Write_String (" "); Write_Switch_Character; Write_String ("s Check consistency of any source "); Write_String ("files that can be located"); Write_Eol; -- Line for -t switch Write_String (" "); Write_Switch_Character; Write_String ("t Ignore time stamp errors"); Write_Eol; -- Line for -v switch Write_String (" "); Write_Switch_Character; Write_String ("v Verbose mode. Error messages,"); Write_String ("header, summary output to stdout"); Write_Eol; -- Lines for -w switch Write_String (" "); Write_Switch_Character; Write_String ("wx Warning mode. (x=s/e for supp"); Write_String ("ress/treat as error)"); Write_Eol; -- Line for sfile Write_String (" lfile Library file names"); if MS_DOS then Write_String (" (wild cards allowed for multiple files)"); end if; Write_Eol; end Bindusg; n_Non_Main_Program_File; end Bindgen; nt Get_Name_String (ALIs.Table (Unit.Table (Elab_Order.Table (E)).My_ALI).Afile); Statement_Buffegnat-1.67-src/src/butil.ads 444 10015 7640 4511 5506244501 10723 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- B U T I L -- -- -- -- S p e c -- -- -- -- $Revision: 1.3 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Butil is -- This package contains utility routines for the binder function Later (T1, T2 : Time_Stamp_Type) return Boolean; -- Return True if T1 represents a later time than T2 function Uname_Less (U1, U2 : Unit_Name_Type) return Boolean; -- Determines if the unit name U1 is alphabetically before U2 procedure Write_Unit_Name (U : Unit_Name_Type); -- Output unit name with (body) or (spec) after as required. On return -- Name_Len is set to the number of characters which were output. end Butil; a Require all source files to be"); Write_String (" present"); Write_Eol; -- Line for -b switch Write_String (" "); Write_Switch_Character; Write_String ("bgnat-1.67-src/src/butil.adb 444 10015 7640 6554 5506244502 10714 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- B U T I L -- -- -- -- B o d y -- -- -- -- $Revision: 1.5 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Namet; use Namet; with Output; use Output; package body Butil is ----------- -- Later -- ----------- function Later (T1, T2 : Time_Stamp_Type) return Boolean is begin for I in T1'range loop if T1 (I) > T2 (I) then return True; elsif T1 (I) < T2 (I) then return False; end if; end loop; return False; end Later; ---------------- -- Uname_Less -- ---------------- function Uname_Less (U1, U2 : Unit_Name_Type) return Boolean is begin Get_Name_String (U1); declare U1_Name : constant Str (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); Min_Length : Nat; begin Get_Name_String (U2); if Name_Len < U1_Name'Last then Min_Length := Name_Len; else Min_Length := U1_Name'Last; end if; for I in 1 .. Min_Length loop if U1_Name (I) > Name_Buffer (I) then return False; elsif U1_Name (I) < Name_Buffer (I) then return True; end if; end loop; return U1_Name'Last < Name_Len; end; end Uname_Less; --------------------- -- Write_Unit_Name -- --------------------- procedure Write_Unit_Name (U : Unit_Name_Type) is begin Get_Name_String (U); Write_Str (Name_Buffer (1 .. Name_Len - 2)); if Name_Buffer (Name_Len) = 's' then Write_Str (" (spec)"); else Write_Str (" (body)"); end if; Name_Len := Name_Len + 5; end Write_Unit_Name; end Butil; Write_String ("l Output chosen elaboration order"); Write_Eol; -- Line for -m switch Write_String (" "); Write_Switch_Charactegnat-1.67-src/src/gnatbind.adb 444 10015 7640 13137 5506244502 11376 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- G N A T B I N D -- -- -- -- B o d y -- -- -- -- $Revision: 1.8 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with ALI; use ALI; with Bcheck; use Bcheck; with Binde; use Binde; with Binderr; use Binderr; with Bindgen; use Bindgen; with Bindusg; with Butil; use Butil; with Errcount; use Errcount; with Excep; use Excep; with Gnatvsn; use Gnatvsn; with Libfmt; use Libfmt; with Namet; use Namet; with Opt; use Opt; with Osint; use Osint; with Output; use Output; with Types; use Types; procedure Gnatbind is Total_Errors : Nat := 0; -- Counts total errors in all files Total_Warnings : Nat := 0; -- Total warnings in all files Main_Lib_File : File_Name_Type; -- Current main library file begin Initialize_OS_Interface (Binder); if Verbose_Mode then Write_Eol; Write_String ("NYU GNAT Binder Version "); Write_String (Gnatbind_Version_String); Write_String (" (C) NYU, 1992-1993, All Rights Reserved"); Write_Eol; end if; -- Output usage information if no files if not More_Lib_Files then Bindusg; Exit_Program (E_Fatal); end if; -- The block here is to catch the Unrecoverable_Error exception in the -- case where we exceed the maximum number of permissible errors or some -- other unrecoverable error occurs. begin -- Carry out package initializations. These are initializations which -- might logically be performed at elaboration time, but Namet at -- least can't be done that way (because it is used in the Compiler), -- and we decide to be consistent. Like elaboration, the order in -- which these calls are made is in some cases important. Initialize_Namet; Initialize_Binderr; Initialize_ALI; if Verbose_Mode then Write_Eol; end if; -- Input ALI files while More_Lib_Files loop Main_Lib_File := Next_Main_Lib_File; if Verbose_Mode then if Check_Only then Write_String ("Checking: "); else Write_String ("Binding: "); end if; Write_Name (Main_Lib_File); Write_Eol; end if; Read_ALI (Main_Lib_File, No_File); end loop; -- Build source file from the ALI files we have read in Set_Source_Table; -- Check that main library file is a suitable main program if Bind_Main_Program and then ALIs.Table (ALIs.First).Main_Program = None then Error_Msg_Name_1 := Main_Lib_File; Error_Msg ("% does not contain a unit that can be a main program"); end if; -- Perform consistency checks Check_Versions; Check_Consistency; -- Complete bind if no errors if Errors_Detected = 0 then Find_Elab_Order; if Errors_Detected = 0 then if Elab_Order_Output then Write_Eol; Write_String ("ELABORATION ORDER"); Write_Eol; for I in Elab_Order.First .. Elab_Order.Last loop Write_String (" "); Write_Unit_Name (Unit.Table (Elab_Order.Table (I)).Uname); Write_Eol; end loop; Write_Eol; end if; if not Check_Only then Gen_Output_File; end if; end if; end if; Total_Errors := Total_Errors + Errors_Detected; Total_Warnings := Total_Warnings + Warnings_Detected; exception when Unrecoverable_Error => Total_Errors := Total_Errors + Errors_Detected; Total_Warnings := Total_Warnings + Warnings_Detected; end; -- All done. Set proper exit status. Finalize_Binderr; Finalize_Namet; if Total_Errors > 0 then Exit_Program (E_Errors); elsif Total_Warnings > 0 then Exit_Program (E_Warnings); else Exit_Program (E_Success); end if; end Gnatbind; se Opt; with Osint; use Osint; with Output; use Output; with Types; use Types; procedure Gnatbind is Total_Errors : Nat := 0; -- Counts total errors in all files Total_Warnings : Nat := 0; -- Total warnings in all files Main_Lib_File : File_Name_Type; -- Current main library file begin Initialize_OS_Interface (Binder); if Verbose_Mode then Write_Eol; Write_Stringnat-1.67-src/src/frontdrv.ads 444 10015 7640 4204 5506244503 11451 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- F R O N T D R V -- -- -- -- S p e c -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Main program for the stand-alone Gnat front-end. -- This front-end can compile more than one file at a time and the Xref tool -- can be enabled by appropriate switches. -- -- Basic cycle : -- -- file.ad[sb] ---> front-end ---> xref ---> file.ref -- ^ | -- | | -- +---------------+ procedure Frontdrv; h Output; use Output; with Types; use Types; procedure Gnatbind is Total_Errors : Nat := 0; -- Counts total errors in all files Total_Warnings : Nat := 0; -- Total warnings in all files Main_Lib_File : File_Name_Type; -- Current main library file begin Initialize_OS_Interface (Binder); if Verbose_Mode then Write_Eol; Write_Stringnat-1.67-src/src/frontdrv.adb 444 10015 7640 10666 5506244503 11461 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- F R O N T D R V -- -- -- -- B o d y -- -- -- -- $Revision: 1.5 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Csets; use Csets; with Comperr; use Comperr; with Errcount; use Errcount; with Errout; use Errout; with Xref_Tab; use Xref_Tab; with Excep; use Excep; with Frontend; with Gnatvsn; use Gnatvsn; with Xref; use Xref; with Lib; use Lib; with Namet; use Namet; with Opt; use Opt; with Osint; use Osint; with Output; use Output; with Par; with System.Assertions; with Types; use Types; with Usage; procedure Frontdrv is Total_Warnings : Nat := 0; -- Counts total warnings in all files Total_Errors : Nat := 0; -- Counts total errors in all files begin Initialize_OS_Interface (Compiler); Initialize_Xref; Initialize_Char_Tables; if Verbose_Mode or Full_List then Write_Eol; Write_Eol; Write_String ("GNAT Front End and Cross Reference Tool Version "); Write_String (Gnat_Version_String); Write_Eol; end if; -- Output usage information if no files if not More_Source_Files then Usage; Exit_Program (E_Fatal); end if; -- Loop through files while More_Source_Files loop begin Frontend; -- Update total error counts Total_Warnings := Total_Warnings + Warnings_Detected; Total_Errors := Total_Errors + Errors_Detected; Finalize_Error_Output; -- Let the Xref gather what it needs if Total_Errors = 0 and then (With_Warnings or Spec_REQs_Flag or Body_REQs_Flag) then Gather_Info (File.Table (Main_Unit).Cunit); end if; exception when Unrecoverable_Error => Total_Warnings := Total_Warnings + Warnings_Detected; Total_Errors := Total_Errors + Errors_Detected; Finalize_Error_Output; Set_Standard_Error; Write_String ("compilation of "); Write_Name (File.Table (Main_Unit).File_Name); Write_String (" abandoned"); Write_Eol; Set_Standard_Output; -- If we get an Assert failure, then we don't want to raise an -- unhandled exception, but rather to use the normal compilation -- abort mechanism when System.Assertions.Assert_Failure => Compiler_Error; Write_String ("internal error: assert failure"); Compiler_Abort; end; Finalize_Lib; Finalize_Namet; end loop; if Total_Errors = 0 and With_Warnings then Write_Xref; end if; -- All done. Set proper exit status if Total_Errors > 0 then Exit_Program (E_Errors); else Exit_Program (E_Success); end if; end Frontdrv; face (Binder); if Verbose_Mode then Write_Eol; Write_Stringnat-1.67-src/src/xref.ads 444 10015 7640 5214 5506244503 10553 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- X R E F -- -- -- -- S p e c -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- The Xref package contains the routines for gathering all definition/use -- information (entities and references to these entities). It creats a cross- -- reference list as well as the REQs (required interfaces) for the withed -- specs. with Types; use Types; package Xref is procedure Initialize_Xref; -- Sets the output flags in Etable to give the correct output. procedure Gather_Info (Top : Node_Id); -- Main procedure to build the entity tables and the REQs. -- Looks for new entities and new references, and - if found - adds -- them to the fitting entity table. procedure Write_Xref; -- Creates a cross reference list, containing all the entities and their -- corresponding references, which are found in the loaded files. -- The references are printed by file name and line numbers of their -- source location. end Xref; ); Write_Eol; end if; -- Output usage information if no files if not More_Lib_Files then Bindusg; Exit_Program (E_Fatal); end if; -- The block here is to catch the Unrecoverable_Error exception in the -- case where we exceed the maximum number of permissible errors or some -- other unrecoverable error occurs. begin gnat-1.67-src/src/xref.adb 444 10015 7640 137124 5506244505 10602 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- X R E F -- -- -- -- B o d y -- -- -- -- $Revision: 1.9 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Comperr; use Comperr; with Debug; use Debug; with Einfo; use Einfo; with Xref_Tab; use Xref_Tab; with Lib; use Lib; with Namet; use Namet; with Osint; use Osint; with Output; use Output; with Sinfo; use Sinfo; with Sprint; use Sprint; with Stand; use Stand; with Unchecked_Deallocation; package body Xref is use Unchecked_Access; -- File suffixes -- --------------------- Spec_REQ_Suffix : constant Str (1 .. 2) := ".r"; Body_REQ_Suffix : constant Str (1 .. 3) := ".br"; Org_Spec_Suffix : constant Str (1 .. 4) := ".org"; -- Other data -- ------------------ type Phase_Type is (Add_Entities_And_Refs, Unmark_Refs); Phase : Phase_Type; -- Used to signal the Traverse_Node procedure what we're doing. -- Add_Entities_And_REfs : normal mode to build the Entity_Tables. -- Unmark_Refs : special mode for multipass removal of unused -- nodes within the program tree. type Node_Numbers_Type is array (Node_Id range <>) of Boolean; type Access_Node_Numbers_Type is access Node_Numbers_Type; Node_Numbers : Access_Node_Numbers_Type; -- Array of flags used within Traverse_Node. Set to True if the node -- has been visited. type List_Numbers_Type is array (List_Id range <>) of Boolean; type Access_List_Numbers_Type is access List_Numbers_Type; List_Numbers : Access_List_Numbers_Type; -- Array of flags used within Traverse_Node. Set to True if the list -- has been visited. type Entity_Association_Type is array (Node_Id range <>) of Entity_Acc; type Access_Entity_Association_Type is access Entity_Association_Type; Entity_Association : Access_Entity_Association_Type; -- Array to associate the entities in the program tree with their -- Corresponding data structures. type File_Record is record Create_REQ : Boolean := False; Etbl : Entity_Table_Acc; end record; type File_Array_Type is array (Unit_Number_Type range <>) of File_Record; type File_Array_Acc is access File_Array_Type; Loaded_Files : File_Array_Acc; -- Array that associates the loaded files with the Entity_Tables. -- Create_REQ is used in Write_Spec_REQs to build the REQ for a withed -- spec. type Ref_Array_Type is array (Int range <>) of Node_Id; type Ref_Array_Acc is access Ref_Array_Type; Ref_Buffer : Ref_Array_Acc; Ref_Length : Int; -- Array to buffer the found references until all entities are added -- to our entity lists. -- Local subprograms -- ------------------------- procedure Allocate_Memory; -- Allocates the memory on the heap which is needed for the dynamic -- arrays. procedure Collect_Withs (Unum : Unit_Number_Type); -- Collect with clauses in the context clause of the given compilation -- unit. procedure Deallocate_Memory; -- Frees the memory on the heap which is needed for the dynamic arrays. procedure Init_Numbers; -- Clear Node_Numbers and List_Numbers to False (= unmarked). -- Use Init_Numbers before each call of Traverse_Node_Hierarchic. procedure Link_Subunits (The_Unit : Unit_Number_Type); -- Links the main Entity_Table with its loaded subunits. procedure Remove_Entities (The_Etbl : in Entity_Table_Acc; Found : in out Boolean); -- Looks for entities with no references and removes both the fitting node -- and all its parents which also get redundant. This is done by a loop -- to provide succesive dead code removal. procedure Set_Spec_REQ_Flags (The_Etbl : Entity_Table_Acc); -- Sets the Create_REQ fields to create a required interface for all -- withed specs as well as to select the transitive specs. procedure Traverse_Node_Hierarchic (N : Node_Id); -- Recursive procedure traversing the program tree. -- Can be used to add information to the Entity_Tables as well as -- to remove references of a dead program part (for dead code elimination). -- Before each call of Traverse_Node_Hierarchic the procedure -- Init_Numbers must be called to initialize the node and list flags. -- -- If an entity declaration is found, then the corresponding entity -- information gets immediately added to the fitting Entity_Table. -- Every reference which is found is buffered in Ref_Buffer to avoid -- the case of adding a reference pointing to an entity that doesn't yet -- appear in the fitting Entity_Table. procedure Traverse_Node_Linear; -- Linear procedure traversing the program tree. -- Can only be used to add information to the Entity_Tables. -- Is much faster than Traverse_Node_Hierarchic. -- -- If an entity declaration is found, then the corresponding entity -- information gets immediately added to the fitting Entity_Table. -- Every reference which is found is buffered in Ref_Buffer to avoid -- the case of adding a reference pointing to an entity that doesn't yet -- appear in the fitting Entity_Table. procedure Write_Org (The_Etbl : Entity_Table_Acc); -- Writes the original source of the given Entity_Table (GNAT -dw conform). -- Used to compare the required interfaces with it and then to create the -- correct provided interface. File suffix changes to Org_Spec_Suffix. procedure Write_Body_REQs; -- Writes the REQs for the body and its subunits the disk. -- The file name of a Body_REQ is the file name of the compilation unit, -- the suffix '.adb' replaced by Body_REQ_Suffix. procedure Write_Spec_REQs; -- Writes the REQs (one for each withed spec) to the disk. -- The file name of a Spec_REQ is the file name of the withed -- compilation unit, the suffix '.ads' replaced by -- '.' & the name of the withing unit & Body_REQ_Suffix. -- e.g. with Pack1; -- procedure Main is ... -- then we have the source file name main.adb and would get pack1.main.r -- with the Spec_REQ for Pack1 inside. --------------------- -- Allocate_Memory -- --------------------- procedure Allocate_Memory is begin -- Flags for Traverse_Node_Hierarchic. Node_Numbers := new Node_Numbers_Type (First_Node_Id .. Last_Node_Id); List_Numbers := new List_Numbers_Type (First_List_Id .. Last_List_Id); -- Pointers for direct entity access. Entity_Association := new Entity_Association_Type (Last_Standard_Node_Id + 1 .. Last_Node_Id); -- Array to associate the loaded files with their corresponding -- Entity_Table. Loaded_Files := new File_Array_Type (File.First .. File.Last); -- Buffer for found references. Ref_Buffer := new Ref_Array_Type (1 .. Int (Last_Node_Id - Last_Standard_Node_Id)); Ref_Length := 0; end Allocate_Memory; ------------------- -- Collect_Withs -- ------------------- procedure Collect_Withs (Unum : Unit_Number_Type) is Item : Node_Id; Withed_Unit : Unit_Number_Type; begin Item := First (Context_Items (File.Table (Unum).Cunit)); while Present (Item) loop if Nkind (Item) = N_With_Clause then Withed_Unit := Get_Cunit_Unit_Number (Library_Unit (Item)); Add_With (Loaded_Files (Unum).Etbl, Loaded_Files (Withed_Unit).Etbl); end if; Item := Next (Item); end loop; end Collect_Withs; ----------------------- -- Deallocate_Memory -- ----------------------- procedure Deallocate_Memory is procedure Free is new Unchecked_Deallocation (Node_Numbers_Type, Access_Node_Numbers_Type); procedure Free is new Unchecked_Deallocation (List_Numbers_Type, Access_List_Numbers_Type); procedure Free is new Unchecked_Deallocation (Entity_Association_Type, Access_Entity_Association_Type); procedure Free is new Unchecked_Deallocation (File_Array_Type, File_Array_Acc); procedure Free is new Unchecked_Deallocation (Ref_Array_Type, Ref_Array_Acc); begin Free (Node_Numbers); Free (List_Numbers); Free (Entity_Association); Free (Loaded_Files); Free (Ref_Buffer); end Deallocate_Memory; ----------------- -- Gather_Info -- ----------------- procedure Gather_Info (Top : Node_Id) is Spec : Unit_Number_Type; Unum : Unit_Number_Type; To_Unum : Unit_Number_Type; To_Entity : Entity_Id; Ref_Node : Node_Id; Main_Etbl : Entity_Table_Acc; begin Allocate_Memory; -- Allocation for the dynamic arrays. -- Associate the loaded files with the Entity_Tables. -- Ignore Zombies (e.g. the spec for a body acting as spec)! for I in Loaded_Files'range loop if File.Table (I).Source /= null then Add_Etbl (First_Etbl, Last_Etbl, I, Loaded_Files (I).Etbl); end if; end loop; Main_Etbl := Loaded_Files (Main_Unit).Etbl; Main_Etbl.RU := True; -- We mark the main Entity_Table as a 'required unit', that is -- we create a fully detailed Xref for it. -- Look for with clauses within the loaded files. -- Ignore Zombies (e.g. the spec for a body acting as spec) and -- do this only once ('Examined' signals a previous examination)! for I in Loaded_Files'range loop if File.Table (I).Source /= null and then not Loaded_Files (I).Etbl.Examined then Collect_Withs (I); end if; end loop; -- Here we link the multiple parts of an object -- (i.e. Spec/Body/Subunits) to give correct With_Warnings. case Main_Etbl.Status is when A_Body => Spec := Get_Cunit_Unit_Number (Library_Unit (Top)); if Spec_REQs_Flag then Write_Org (Loaded_Files (Spec).Etbl); end if; Loaded_Files (Spec).Create_REQ := True; -- In multifile mode we create full output for this spec. -- Otherwise we print only what is used. if Number_Of_Files > 1 then Loaded_Files (Spec).Etbl.RU := True; else Loaded_Files (Spec).Etbl.Status := Withed_Spec; end if; Loaded_Files (Spec).Etbl.Successor := Main_Etbl; Main_Etbl.Predecessor := Loaded_Files (Spec).Etbl; Link_Subunits (Main_Unit); when Sub_Body => Unum := Get_Cunit_Unit_Number (Library_Unit (Top)); Loaded_Files (Unum).Etbl.RU := True; if Loaded_Files (Unum).Etbl.Status = A_Body then Spec := Get_Cunit_Unit_Number (Library_Unit (File.Table (Unum).Cunit)); if Spec_REQs_Flag then Write_Org (Loaded_Files (Spec).Etbl); end if; -- In multifile mode we create full output for this spec. -- Otherwise we print only what is used. if Number_Of_Files > 1 then Loaded_Files (Spec).Etbl.RU := True; else Loaded_Files (Spec).Etbl.Status := Withed_Spec; end if; Loaded_Files (Spec).Etbl.Successor := Loaded_Files (Unum).Etbl; Loaded_Files (Unum).Etbl.Predecessor := Loaded_Files (Spec).Etbl; end if; Link_Subunits (Unum); when Body_As_Spec => Link_Subunits (Main_Unit); when A_Spec | Withed_Spec => if Spec_REQs_Flag then Write_Org (Main_Etbl); end if; end case; Set_Spec_REQ_Flags (Main_Etbl); -- Search and add the entities to the entity tables. Phase := Add_Entities_And_Refs; Traverse_Node_Linear; -- Take the references from the buffer and add them to the -- fitting entities. for I in 1 .. Ref_Length loop Ref_Node := Ref_Buffer (I); Unum := Get_Sloc_Unit_Number (Sloc (Ref_Node)); To_Unum := Get_Sloc_Unit_Number (Sloc (Entity (Ref_Node))); if not Loaded_Files (Unum).Etbl.Examined then To_Entity := Entity (Ref_Node); Add_Reference (Entity_Association (To_Entity), Loaded_Files (Unum).Etbl, Ref_Node); elsif Spec_REQs_Flag and then Loaded_Files (Unum).Create_REQ and then Unum = To_Unum then To_Entity := Entity (Ref_Node); Update_Reference (Entity_Association (To_Entity), Loaded_Files (Unum).Etbl, Ref_Node); end if; end loop; -- Write the Spec_REQs. if Spec_REQs_Flag then Write_Spec_REQs; end if; -- Write the Body_REQs. if Body_REQs_Flag and then Loaded_Files (Main_Unit).Etbl.Status in Body_As_Spec .. Sub_Body then Write_Body_REQs; end if; -- Mark the units to be Examined. for I in Loaded_Files'range loop if Loaded_Files (I).Etbl /= null then Loaded_Files (I).Etbl.Examined := True; end if; end loop; Deallocate_Memory; -- Deallocation for the dynamic arrays. end Gather_Info; ------------------ -- Init_Numbers -- ------------------ procedure Init_Numbers is begin -- Set node flags to unvisited (except those of Standard). for I in Node_Numbers'First .. Last_Standard_Node_Id loop Node_Numbers (I) := True; end loop; for I in Last_Standard_Node_Id + 1 .. Node_Numbers'Last loop Node_Numbers (I) := False; end loop; -- Set list flags to unvisited (except those of Standard). for I in List_Numbers'First .. Last_Standard_List_Id loop List_Numbers (I) := True; end loop; for I in Last_Standard_List_Id + 1 .. List_Numbers'Last loop List_Numbers (I) := False; end loop; end Init_Numbers; --------------------- -- Initialize_Info -- --------------------- procedure Initialize_Xref is begin With_Warnings := Debug_Flag_1 or Debug_Flag_2 or Debug_Flag_3 or Debug_Flag_4; Entity_Warnings := Debug_Flag_2 or Debug_Flag_3 or Debug_Flag_4; Xref_Flag := Debug_Flag_3 or Debug_Flag_4; Entity_Info_In_Xref := Debug_Flag_4; Spec_REQs_Flag := Debug_Flag_Q; Body_REQs_Flag := Debug_Flag_B; end Initialize_Xref; ------------------- -- Link_Subunits -- ------------------- procedure Link_Subunits (The_Unit : Unit_Number_Type) is Etbl_Tmp : Entity_Table_Acc := Loaded_Files (The_Unit).Etbl; Top_Node : constant Node_Id := File.Table (The_Unit).Cunit; begin for I in Loaded_Files'range loop if Loaded_Files (I).Etbl /= null and then Loaded_Files (I).Etbl.Kind = Sub and then I /= The_Unit and then Library_Unit (File.Table (I).Cunit) = Top_Node and then Loaded_Files (I).Etbl.Predecessor = null then while Etbl_Tmp.Successor /= null loop Etbl_Tmp := Etbl_Tmp.Successor; end loop; Etbl_Tmp.Successor := Loaded_Files (I).Etbl; Loaded_Files (I).Etbl.Predecessor := Etbl_Tmp; end if; end loop; end Link_Subunits; --------------------- -- Remove_Entities -- --------------------- procedure Remove_Entities (The_Etbl : in Entity_Table_Acc; Found : in out Boolean) is E_Tmp : Entity_Acc; -- To store the current entity within the loop. -------------------- -- Remove_Element -- -------------------- procedure Remove_Element (The_Node : Node_Id) is -- Removes the given node and also the surrounding Ada construct. L_Tmp : List_Id; P_Tmp : Node_Id; begin if Nkind (The_Node) in N_Entity then -- If we get a N_Defining_Identifier, N_Defining_Character_Literal or -- N_Defining_Operator_Symbol, then we have to distinguish between the -- various kinds of entities. case Ekind (The_Node) is -- We don't remove void entities since they are used internally when E_Void => null; -- Processing for variable (this is slightly different from the -- processing for constant, is that really correct ???) when E_Variable => P_Tmp := Parent (The_Node); if Is_List_Member (The_Node) then L_Tmp := List_Containing (The_Node); Traverse_Node_Hierarchic (The_Node); -- To cancel the references in the subtree of The_Node. Remove (The_Node); if Is_Empty_List (L_Tmp) then Remove_Element (P_Tmp); end if; else Traverse_Node_Hierarchic (The_Node); -- To cancel the references in the subtree of The_Node. Remove_Element (P_Tmp); end if; -- Don't do anything with components, since it is very tricky -- to find a hidden reference for a record component (e.g. in -- an aggregate, all components are implicitly referenced). when E_Component => null; -- Main processing for most cases when E_Constant | E_Named_Integer | E_Named_Real | E_Enumeration_Type | E_Enumeration_Subtype | E_Character_Type | E_Boolean_Type | E_Integer_Type | E_Integer_Subtype | E_Modular_Type | E_Modular_Subtype | E_Float_Type | E_Float_Subtype | E_Fixed_Type | E_Fixed_Subtype | E_Decimal_Type | E_Decimal_Subtype | E_Array_Type | E_Array_Subtype | E_String_Type | E_String_Subtype | E_String_Literal_Subtype | E_Enum_Table_Type | E_Slice_Subtype | E_Record_Type | E_Class_Subtype | E_Class_Type | E_Record_Subtype | E_Access_Type | E_Access_Subtype | E_General_Access_Type | E_Subprogram_Type | E_Incomplete_Type | E_Limited_Type | E_Task_Type | E_Task_Subtype | E_Protected_Type | E_Protected_Subtype | E_Exception_Type | E_Discriminant | E_Loop | E_Loop_Parameter | E_Block | E_Label | E_Entry | E_Protected_Object | E_Entry_Family | E_Exception => if Is_List_Member (The_Node) then L_Tmp := List_Containing (The_Node); P_Tmp := Parent (The_Node); Traverse_Node_Hierarchic (The_Node); -- To cancel the references in the subtree of The_Node. Remove (The_Node); if Is_Empty_List (L_Tmp) then Remove_Element (P_Tmp); end if; else Traverse_Node_Hierarchic (The_Node); -- To cancel the references in the subtree of The_Node. P_Tmp := Parent (The_Node); Remove_Element (P_Tmp); end if; -- Private type processing when E_Private_Type | E_Limited_Private_Type => Remove_Element (Full_Declaration (The_Node)); if Is_List_Member (The_Node) then L_Tmp := List_Containing (The_Node); P_Tmp := Parent (The_Node); Traverse_Node_Hierarchic (The_Node); -- To cancel the references in the subtree of The_Node. Remove (The_Node); if Is_Empty_List (L_Tmp) then Remove_Element (P_Tmp); end if; else Traverse_Node_Hierarchic (The_Node); -- To cancel the references in the subtree of The_Node. P_Tmp := Parent (The_Node); Remove_Element (P_Tmp); end if; when E_Enumeration_Literal => null; -- Since it's very tricky to find a hidden reference -- for an enumeration literal we do nothing -- (e.g. in a loop from type'first to type'last all literals -- are automatically referenced). when E_Function | E_Operator | E_Procedure | E_Package => if Scope (The_Node) > Last_Standard_Node_Id then -- Compilation unit nodes are not removed since -- this causes a lot of trouble. Traverse_Node_Hierarchic (The_Node); -- To cancel the references in the subtree of The_Node. P_Tmp := Parent (The_Node); Remove_Element (P_Tmp); -- There are only two possibilities in this case: -- Either the parent is a N_Function_Specification or -- a N_Procedure_Specification. end if; -- Cannot delete a parameter of a subprogram (or at least not -- easily because it would have all sorts of consequences) when E_In_Parameter | E_Out_Parameter | E_In_Out_Parameter => null; -- For the moment, forget the case of generics and their formal -- parameters. Might try to do something later here ??? when E_Generic_Package | E_Generic_Function | E_Generic_Procedure | E_Generic_In_Parameter | E_Generic_In_Out_Parameter | E_Formal_Derived_Type | E_Formal_Generic_Package => null; -- Body entities have no significance semantically, so ignore them when E_Task_Body | E_Subprogram_Body | E_Package_Body | E_Protected_Body => null; -- Internal allocator and access types should never appear -- at the stage a cross-reference is being computed when E_Allocator_Type | E_Access_Subprogram_Type | E_Anonymous_Access_Type => Compiler_Abort; end case; else case Nkind (The_Node) is when N_Empty => null; when N_Function_Specification .. N_Procedure_Specification => P_Tmp := Parent (The_Node); Remove_Element (P_Tmp); -- There are only two possibilities in this case: -- Either the parent is a N_Subprogram_Declaration or -- a N_Subprogram_Body. when N_Component_List | N_Record_Definition => null; -- These are intermediaire nodes. -- In this cases we don't remove the parent -- (e.g. N_Record_Definition for a N_Component_List) -- since the Record identifier is treated separately. when N_Object_Declaration => if Is_List_Member (The_Node) then L_Tmp := List_Containing (The_Node); P_Tmp := Parent (The_Node); Traverse_Node_Hierarchic (The_Node); -- To cancel the references in the subtree of The_Node. Remove (The_Node); -- Here we do *not* remove the parent since then we -- would delete the whole subprogram. end if; when others => if Is_List_Member (The_Node) then L_Tmp := List_Containing (The_Node); P_Tmp := Parent (The_Node); Traverse_Node_Hierarchic (The_Node); -- To cancel the references in the subtree of The_Node. Remove (The_Node); if Is_Empty_List (L_Tmp) then Remove_Element (P_Tmp); end if; else Traverse_Node_Hierarchic (The_Node); -- To cancel the references in the subtree of The_Node. P_Tmp := Parent (The_Node); Remove_Element (P_Tmp); end if; end case; end if; end Remove_Element; -------------------- -- Remove_Pragmas -- -------------------- procedure Remove_Pragmas (The_Entity : Entity_Acc) is -- Removes all the pragma nodes within the program tree which -- apply on the given entity. R_Tmp : Ref_Acc := First (The_Entity); begin while not Is_Null (R_Tmp) loop if Is_Pragma (R_Tmp) then Remove_Element (Parent (Parent (The_Node (R_Tmp)))); end if; R_Tmp := Next (R_Tmp); end loop; end Remove_Pragmas; -- begin of Remove_Entities -- begin E_Tmp := The_Etbl.First_Entity; Found := False; Phase := Unmark_Refs; Init_Numbers; while not Is_Null (E_Tmp) loop if Number_Of_Marks (E_Tmp) = 0 and then Give_Warning (E_Tmp) then -- Update the Entity_Table: Found := True; Mark_Entity (E_Tmp); -- We mark the entity in our entity table for the next pass -- to say: Don't remove this entity twice! -- Update the program tree: -- -- Since we need E_Tmp to find the pragmas, we have to -- remove the pragmas here rather than in Remove_Element if Entity_Type (E_Tmp) in E_Function .. E_Procedure then Remove_Pragmas (E_Tmp); end if; Remove_Element (Entity_Node (E_Tmp)); -- Here we remove the entities with no references. end if; E_Tmp := Next (E_Tmp); end loop; end Remove_Entities; ------------------------- -- Set_Spec_REQ_Flags -- ------------------------- procedure Set_Spec_REQ_Flags (The_Etbl : Entity_Table_Acc) is Etbl_Tmp : Entity_Table_Acc; With_Clause : With_Acc; begin -- Mark a spec withed by The_Etbl or a predecessor. Etbl_Tmp := The_Etbl; while Etbl_Tmp /= null loop With_Clause := Etbl_Tmp.First_With; while With_Clause /= null loop if With_Clause.Withed_Etbl.Kind /= Genr then Loaded_Files (Get_Cunit_Unit_Number (With_Clause.Withed_Etbl.Top_Node)).Create_REQ := True; end if; -- We don't create a REQ for a generic. With_Clause.Withed_Etbl.Status := Withed_Spec; With_Clause := With_Clause.Next_With; end loop; Etbl_Tmp := Etbl_Tmp.Predecessor; end loop; -- Mark a spec withed by a successor. Etbl_Tmp := The_Etbl.Successor; while Etbl_Tmp /= null loop With_Clause := Etbl_Tmp.First_With; while With_Clause /= null loop if With_Clause.Withed_Etbl.Kind /= Genr then Loaded_Files (Get_Cunit_Unit_Number (With_Clause.Withed_Etbl.Top_Node)).Create_REQ := True; end if; -- We don't create a REQ for a generic. With_Clause.Withed_Etbl.Status := Withed_Spec; With_Clause := With_Clause.Next_With; end loop; Etbl_Tmp := Etbl_Tmp.Successor; end loop; end Set_Spec_REQ_Flags; ------------------------------ -- Traverse_Node_Hierarchic -- ------------------------------ procedure Traverse_Node_Hierarchic (N : Node_Id) is Kind : Node_Kind; Unum : Unit_Number_Type; To_Unum : Unit_Number_Type; To_Entity : Entity_Id; -- Only to reduce the length of some function calls. procedure Visit_List (L : List_Id); procedure Visit_Descendent (D : Int); pragma Inline (Visit_Descendent); ---------------- -- Visit_List -- ---------------- procedure Visit_List (L : List_Id) is -- Visits the nodes of a list in the program tree N : Node_Id; begin if List_Numbers (L) = True then return; -- List is already visited else List_Numbers (L) := True; end if; N := First (L); if N /= Empty then while Next (N) /= Empty loop Traverse_Node_Hierarchic (N); N := Next (N); end loop; end if; Traverse_Node_Hierarchic (N); end Visit_List; ---------------------- -- visit_Descendent -- ---------------------- procedure Visit_Descendent (D : Int) is begin if D in Node_Range then if D = Int (Empty) or else D = Int (Error) or else (Parent (Node_Id (D)) /= Empty and then Parent (Node_Id (D)) /= N) then return; else Traverse_Node_Hierarchic (Node_Id (D)); end if; elsif D in List_Range then if D = Int (No_List) or else Is_Empty_List (List_Id (D)) or else (List_Parent (List_Id (D)) /= Empty and then List_Parent (List_Id (D)) /= N) then return; else Visit_List (List_Id (D)); end if; end if; end Visit_Descendent; -- Start of Traverse_Node_Hierarchic begin if N = Empty then return; end if; if Node_Numbers (N) = True then return; -- already visited else Node_Numbers (N) := True; end if; Kind := Nkind (N); case Phase is when Add_Entities_And_Refs => -- Look for named numbers or other constructs which get -- transformed into the corresponding litterals during -- semantics. if Is_Rewrite_Substitution (N) then Traverse_Node_Hierarchic (Original_Node (N)); end if; if Kind in N_Entity and then Ekind (N) /= E_Void and then not Is_Internal (N) and then Parent (N) /= Empty then Unum := Get_Sloc_Unit_Number (Sloc (N)); if Loaded_Files (Unum).Etbl.Examined then Update_Entity (Loaded_Files (Unum).Etbl, N, Entity_Association (N)); else Add_Entity (Loaded_Files (Unum).Etbl, N, Entity_Association (N)); end if; elsif Kind = N_Identifier then if Nkind (Parent (N)) = N_Range and then Parent (Parent (N)) = Empty then -- We don't accept things like an internal range -- declaration. null; elsif Entity (N) > Last_Standard_Node_Id then -- We suppress references to standard entities (e.g. integer) Ref_Length := Ref_Length + 1; Ref_Buffer (Ref_Length) := N; end if; elsif (Kind in N_Op or else Kind = N_Attribute_Reference or else Kind = N_Character_Literal or else Kind = N_Expanded_Name or else Kind = N_Operator_Symbol) and then Entity (N) > Last_Standard_Node_Id then Ref_Length := Ref_Length + 1; Ref_Buffer (Ref_Length) := N; end if; when Unmark_Refs => -- Look for named numbers or other constructs which get -- transformed into the corresponding litterals during -- semantics. if Is_Rewrite_Substitution (N) then Traverse_Node_Hierarchic (Original_Node (N)); end if; if Kind in N_Entity and then Ekind (N) /= E_Void and then not Is_Internal (N) and then Parent (N) /= Empty then -- We mark the entity and all its descendents in our entity -- table for the next pass to say: -- Don't remove this entity twice! It's already removed. Unum := Get_Sloc_Unit_Number (Sloc (N)); Mark_Entity (In_E_List (Loaded_Files (Unum).Etbl, N)); elsif Kind = N_Identifier then if Nkind (Parent (N)) = N_Range and then Parent (Parent (N)) = Empty then -- We don't accept things like an internal range -- declaration. null; elsif Entity (N) > Last_Standard_Node_Id then -- We suppress references to standard entities (e.g. integer) To_Unum := Get_Sloc_Unit_Number (Sloc (Entity (N))); To_Entity := Entity (N); Unmark_Reference (Entity_Association (To_Entity), N); end if; elsif (Kind in N_Op or else Kind = N_Attribute_Reference or else Kind = N_Character_Literal or else Kind = N_Expanded_Name or else Kind = N_Operator_Symbol) and then Entity (N) > Last_Standard_Node_Id then To_Unum := Get_Sloc_Unit_Number (Sloc (Entity (N))); To_Entity := Entity (N); Unmark_Reference (Entity_Association (To_Entity), N); end if; end case; Visit_Descendent (Field1 (N)); Visit_Descendent (Field2 (N)); Visit_Descendent (Field3 (N)); Visit_Descendent (Field4 (N)); Visit_Descendent (Field5 (N)); if Has_Extension (N) then Visit_Descendent (Field6 (N)); Visit_Descendent (Field7 (N)); Visit_Descendent (Field8 (N)); Visit_Descendent (Field9 (N)); Visit_Descendent (Field10 (N)); Visit_Descendent (Field11 (N)); Visit_Descendent (Field12 (N)); end if; end Traverse_Node_Hierarchic; -------------------------- -- Traverse_Node_Linear -- -------------------------- procedure Traverse_Node_Linear is Kind : Node_Kind; E_Kind : Entity_Kind; Unum : Unit_Number_Type; -- Only to reduce the length of some function calls. Skip_Next : Boolean := False; begin for N in Last_Standard_Node_Id + 1 .. Last_Node_Id loop if N = Empty then null; elsif Skip_Next then Skip_Next := False; else Kind := Nkind (N); -- Look for named numbers or other constructs which get -- transformed into the corresponding litterals during -- semantics. if Kind in N_Entity then if not Has_Extension (N) then null; -- Zombie node (unreachable from the top node). else Skip_Next := True; -- Skip the extended fields node which follows -- immediately. E_Kind := Ekind (N); -- Special treatment for some ticklish cases: -- -- To avoid double entities within the cross -- references we have to skip some nodes. -- The completions for private types can be marked as -- internal since we have a pointer to them. -- The completions for deferred constants don't have a -- pointer to their completion but they have an empty -- scope node since they don't pass semantics. if E_Kind = E_Private_Type then Set_Is_Internal (Full_Declaration (N)); end if; if (E_Kind = E_Constant and then Scope (N) = Empty) or else E_Kind = E_Void or else Is_Internal (N) or else Parent (N) = Empty then null; else Unum := Get_Sloc_Unit_Number (Sloc (N)); if Loaded_Files (Unum).Etbl.Examined then -- Update the entity if its already in the -- Entity_Table but with a wrong Node_Id. Update_Entity (Loaded_Files (Unum).Etbl, N, Entity_Association (N)); else -- Add the entity to the end of the Entity_Table. Add_Entity (Loaded_Files (Unum).Etbl, N, Entity_Association (N)); end if; end if; end if; elsif Kind = N_Identifier then if Nkind (Parent (N)) = N_Range and then Parent (Parent (N)) = Empty then -- We don't accept things like an internal range -- declaration. null; elsif Entity (N) > Last_Standard_Node_Id then -- We suppress references to standard entities (e.g. integer) Ref_Length := Ref_Length + 1; Ref_Buffer (Ref_Length) := N; end if; elsif (Kind in N_Op or else Kind = N_Attribute_Reference or else Kind = N_Character_Literal or else Kind = N_Expanded_Name or else Kind = N_Operator_Symbol) and then Entity (N) > Last_Standard_Node_Id then Ref_Length := Ref_Length + 1; Ref_Buffer (Ref_Length) := N; end if; end if; end loop; end Traverse_Node_Linear; --------------- -- Write_Org -- --------------- procedure Write_Org (The_Etbl : Entity_Table_Acc) is begin Name_Len := The_Etbl.File_Name'Length; Name_Buffer (1 .. Name_Len) := The_Etbl.File_Name.all; Name_Buffer (Name_Len - 3 .. Name_Len - 4 + Org_Spec_Suffix'Length) := Org_Spec_Suffix; Name_Buffer (Name_Len - 3 + Org_Spec_Suffix'Length) := NUL; -- In an earlier version of Gnat this was done automatically Create_Req_Output; Sprint_Node (The_Etbl.Top_Node); Write_Eol; Set_Standard_Output; Close_Xref_Output; end Write_Org; --------------------- -- Write_Body_REQs -- --------------------- procedure Write_Body_REQs is Main_Etbl : Entity_Table_Acc := Loaded_Files (Main_Unit).Etbl; Etbl_Tmp_1 : Entity_Table_Acc; Etbl_Tmp_2 : Entity_Table_Acc; First : Boolean; Found : Boolean; --------------- -- Open_File -- --------------- procedure Open_File (The_Etbl : Entity_Table_Acc) is begin -- Here we build the file name of the Body_REQ. -- The file name is the file name of the body, -- the suffix '.adb' changed into Body_REQ_Suffix ! Name_Len := The_Etbl.File_Name.all'Length; Name_Buffer (1 .. Name_Len) := The_Etbl.File_Name.all; Name_Buffer (Name_Len - 3 .. Name_Len - 4 + Body_REQ_Suffix'Length) := Body_REQ_Suffix; Name_Buffer (Name_Len - 3 + Body_REQ_Suffix'Length) := NUL; Create_Req_Output; end Open_File; ---------------- -- Close_File -- ---------------- procedure Close_File is begin Write_Eol; Set_Standard_Output; Close_Xref_Output; end Close_File; begin Etbl_Tmp_1 := Main_Etbl; Etbl_Tmp_2 := Main_Etbl; First := True; while Etbl_Tmp_1 /= null loop -- First we have to mark the body and its subunits across each -- others. while Etbl_Tmp_2 /= null loop if First then Clear_And_Mark_Xrefs (Etbl_Tmp_1, Etbl_Tmp_2); First := False; else Mark_Xrefs (Etbl_Tmp_1, Etbl_Tmp_2); end if; Etbl_Tmp_2 := Etbl_Tmp_2.Successor; end loop; -- Then remove the entities with no references step by step -- until all the remaining entities have one or more -- references. -- This must be done within a loop because after having -- removed some entities an earlier defined entity may become -- removable. -- Write_Org (Etbl_Tmp_1); can be inserted to measure dead code! Found := True; while Found loop Remove_Entities (Etbl_Tmp_1, Found); end loop; Open_File (Etbl_Tmp_1); -- CC -- don't touch the indentation now. -- has to be fixed later -- -- Xsprint.Indent := 0; Sprint_Node (Etbl_Tmp_1.Top_Node); Close_File; Etbl_Tmp_1 := Etbl_Tmp_1.Successor; Etbl_Tmp_2 := Main_Etbl; First := True; end loop; end Write_Body_REQs; --------------------- -- Write_Spec_REQs -- --------------------- procedure Write_Spec_REQs is Buffer : Str (1 .. 100); Length : Int; Found : Boolean; Etbl_Tmp : Entity_Table_Acc; --------------- -- Open_File -- --------------- procedure Open_File (I : Unit_Number_Type) is begin -- Here we build the file name of the Spec_REQ. -- The file name is the file name of the withed unit, -- the suffix changed from '.ads' into -- '.' & withing_unit_name & Spec_REQ_Suffix ! Get_Name_String (File.Table (Main_Unit).File_Name); Buffer (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); Length := Name_Len - 3; Get_Name_String (File.Table (I).File_Name); Name_Buffer (Name_Len + 1 .. Length + Name_Len) := Buffer (1 .. Length); Length := Length + Name_Len - 4; Name_Buffer (Length + 1 .. Length + Spec_REQ_Suffix'Length) := Spec_REQ_Suffix; Name_Buffer (Length + Spec_REQ_Suffix'Length + 1) := NUL; Create_Req_Output; end Open_File; ---------------- -- Close_File -- ---------------- procedure Close_File is begin Write_Eol; Set_Standard_Output; Close_Xref_Output; end Close_File; begin for I in Loaded_Files'range loop if Loaded_Files (I).Create_REQ then -- First we mark all the entities which are used by the withed -- spec itself. Clear_And_Mark_Xrefs (Loaded_Files (I).Etbl, Loaded_Files (I).Etbl); -- Then we mark all the entities which are used by the main object -- (Main_Unit, all predecessors and all successors). Etbl_Tmp := Loaded_Files (Main_Unit).Etbl; while Etbl_Tmp /= null loop Mark_Xrefs (Loaded_Files (I).Etbl, Etbl_Tmp); Etbl_Tmp := Etbl_Tmp.Predecessor; end loop; Etbl_Tmp := Loaded_Files (Main_Unit).Etbl.Successor; while Etbl_Tmp /= null loop Mark_Xrefs (Loaded_Files (I).Etbl, Etbl_Tmp); Etbl_Tmp := Etbl_Tmp.Successor; end loop; -- Then remove the entities with no references step by step -- until all the remaining entities have one or more -- references. -- This must be done within a loop because after having -- removed some entities an earlier defined entity may become -- removable. Found := True; while Found loop Remove_Entities (Loaded_Files (I).Etbl, Found); end loop; Open_File (I); -- CC -- don't touch the indentation now. -- has to be fixed later -- -- Xsprint.Indent := 0; Sprint_Node (File. Table (I).Cunit); Close_File; end if; end loop; end Write_Spec_REQs; ---------------- -- Write_Xref -- ---------------- procedure Write_Xref is Etbl_Tmp : Entity_Table_Acc; begin if Xref_Flag then -- File and screen output Create_Xref_Output; Etbl_Tmp := First_Etbl; while Etbl_Tmp /= null loop if Etbl_Tmp.RU then Writ (Etbl_Tmp, Full_Xref); elsif Etbl_Tmp.Status = Withed_Spec then Writ (Etbl_Tmp, Smart_Xref); end if; Etbl_Tmp := Etbl_Tmp.Next_Etbl; end loop; Close_Xref_Output; elsif With_Warnings then -- Only screen output Etbl_Tmp := First_Etbl; while Etbl_Tmp /= null loop if Etbl_Tmp.RU then Writ (Etbl_Tmp, Full_Only_Screen); elsif Etbl_Tmp.Status = Withed_Spec then Writ (Etbl_Tmp, Smart_Only_Screen); end if; Etbl_Tmp := Etbl_Tmp.Next_Etbl; end loop; end if; end Write_Xref; end Xref; l range -- declaration. null; elsif Entity (N) > Last_Standard_Node_Id then -- We suppress references to standard entities (e.g. integer) Ref_Length := Ref_Length + 1; Ref_Buffer (Ref_Length) := N; end if; elsif (Kind in N_Op or else Kind = N_Attribute_Reference or gnat-1.67-src/src/xref_tab.ads 444 10015 7640 47203 5506244505 11427 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- X R E F _ T A B -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- This package offers the data type Entity_Table and its methods. -- Etable is used to store all the definition/use information we need -- to build a cross reference file or required interfaces. -- Note that we store here both the Node_Id and the corresponding entitiy -- information like 'Chars', 'Sloc' or 'Line_Number'. -- We do this since program trees get lost whenever we start to -- compile a new unit. Node_Id is only a pointer into program trees. with Einfo; use Einfo; with Types; use Types; package Xref_Tab is -- Entity tables ----------------- -- An Entity_Table is used to store the information about entities -- and their references. We divide the huge amount of information into -- several parts: One Entity_Table for each compilation unit. -- An Entity_Table is defined as a twodimensional data list. -- The entities and their references appear in the same order as in the -- program tree (lower Node_Ids first). -- This represents also the order within the Ada programs and is important -- if we wanna print the Xref or look for possible overloading effects. -- xxxxxxxxxxxxxxxx -- x Entity_Table x -- xxxxxxxxxxxxxxxx -- I -- I -- V -- xxxxxxxxxxxxxxxx xxxxxxxxx xxxxxxxxx -- x Entity x-----> x Ref x-----> x Ref x-----> null; -- xxxxxxxxxxxxxxxx xxxxxxxxx xxxxxxxxx -- I -- I -- V -- xxxxxxxxxxxxxxxx xxxxxxxxx -- x Entity x-----> x Ref x-----> null; -- xxxxxxxxxxxxxxxx xxxxxxxxx -- I -- I -- V -- null; -- The record behind an Entity_Table is accessible for all clients -- -- 1) since there is no danger to do so. -- 2) since it would be very awkward to write all the appropriate read -- and write functions. -- -- Of course, the data structures of entities and references -- are full encapsulated - a client can access them only by subprogram -- calls. -- An Entity_Table has the following attributs: -- -- Marked: Flag showing the result of a call of Mark_Xref. -- Set if cross references are found. -- -- RU: Required Unit flag. -- Set if full Xref output is required. -- -- Examined: Flag, set if all entities are installed. -- -- File_Name: Pointer to the fitting file name. -- -- Unit_Name: Pointer to the fitting unit name. -- -- Status: Shows if the compilation unit is a simple spec, -- withed spec, a body which acts as its spec, a simple -- body or a subunit. -- -- Kind: Shows if the compilation unit is a procedure, -- function, generic, package, task, subunit or somethin -- else. -- -- Top_Node: Set to the Node_Id of the compilation unit node. -- -- First_With: Points to the first with-structure. First_With can -- be used to start hangling through all with-clauses. -- -- Predecessor: Points to the immediate predecessor (SU -> B -> S). -- -- Successor: Points to the immediate successor (S -> B -> SU). -- -- Length: Contains the number of installed entities. -- -- First_Entity: Points to the first entity-structure. First_Entity -- can be used to start hangling through all entities. -- -- Last_Entity: Points to the last entity-structure (internal use). -- -- Next_Etbl: Points to the immediate following Entity_Table. type Status_Type is (A_Spec, Withed_Spec, Body_As_Spec, A_Body, Sub_Body); type Kind_Type is (Proc, Func, Genr, Pack, Tsk, Sub, Unknown); type Entity_Table; type Entity_Table_Acc is access Entity_Table; type With_Clause; type With_Acc is access With_Clause; type With_Clause is record Withed_Etbl : Entity_Table_Acc; Next_With : With_Acc; end record; -- type Entity_Acc is private; -- type Ref_Acc is private; -- was in the private part ----------------------------- -- References: -- ----------- -- -- Marked: Flag showing the result of a call of Mark_Xref. -- Set if the reference fits into the search pattern. -- -- Is_Pragma: Flag, set if the reference is a pragma that doesn't -- use the entity but has to be removed if we declare the -- entity as dead code. -- -- Ref_Node: The Node_Id of the reference. -- -- Sloc: Points to the source allocation where the reference -- was found. -- -- Line_Number: The line number in which the reference was found. -- -- Etbl: Points to the Entity_Table of the compilation unit -- in which the reference was found. -- -- Next_Ref: Points to the immediate following reference structure. type Ref; type Ref_Acc is access Ref; type Ref is record Marked : Boolean := False; Is_Pragma : Boolean := False; Ref_Node : Node_Id; Sloc : Int; Line_Number : Int; Etbl : Entity_Table_Acc; Next_Ref : Ref_Acc; end record; -- Entities: -- --------- -- -- Marks: Contains the number of found references (after a call -- of Mark_Xrefs. -- -- Entity_Node: The Entity_Id of the entity. -- -- Entity_Type: The Entity_Kind of the entity. -- -- Chars: Pointer to the identifier string of the entity. -- -- Line_Number: The line number in which the entity was found. -- -- Scope_Path: Pointer to the whole scope path of the entity. -- -- Is_Internal: Flag, set if information output of the entity should -- be suppressed. -- -- Give_Warning: Flag, set if a warning message should be given in the -- case that we find no reference to this entity. -- -- Length: Contains the number of references to this entity. -- -- First_Ref: Points to the first reference to the entity. -- -- Last_Ref: Points to the last reference to the entity -- (internal use). -- -- Next_Entity: Points to the immediate following entity structure. type An_Entity; type Entity_Acc is access An_Entity; type An_Entity is record Marks : Natural := 0; Entity_Node : Entity_Id; Entity_Type : Entity_Kind; Chars : Str_Ptr; Line_Number : Int; Scope_Path : Str_Ptr; Is_Internal : Boolean; Give_Warning : Boolean := True; Length : Natural := 0; First_Ref : Ref_Acc; Last_Ref : Ref_Acc; Next_Entity : Entity_Acc; end record; -- -- end of old private part -- type Entity_Table is record Marked : Boolean := False; RU : Boolean := False; Examined : Boolean := False; File_Name : Str_Ptr; Unit_Name : Str_Ptr; Status : Status_Type; Kind : Kind_Type; Top_Node : Node_Id; First_With : With_Acc; Predecessor : Entity_Table_Acc; Successor : Entity_Table_Acc; Length : Natural := 0; First_Entity : Entity_Acc; Last_Entity : Entity_Acc; Next_Etbl : Entity_Table_Acc; end record; First_Etbl : Entity_Table_Acc; Last_Etbl : Entity_Table_Acc; -- Some Flags to control the output ------------------------------------ With_Warnings : Boolean; -- If set then warning messages for wrong with clauses appear on the -- screen. Entity_Warnings : Boolean; -- If set then warning messages for unused entities appear on the -- screen. Xref_Flag : Boolean; -- If set then a cross reference list gets written into a file. Entity_Info_In_Xref : Boolean; -- If set then entities appear with its Entity_Kind information in X.ref. Spec_REQs_Flag : Boolean; -- If set then the REQs for all withed specs get written into files. Body_REQs_Flag : Boolean; -- If set then the REQs for the body and its subunits get written into -- files. -- Subprograms --------------- procedure Add_Entity (To_Etbl : in Entity_Table_Acc; Entity_Node : in Entity_Id; New_Entity : in out Entity_Acc); -- Adds an entity to the end of the entity list of To_Etbl. -- Finally New_Entity points to the new Entity structure. procedure Add_Etbl (First_Etbl : in out Entity_Table_Acc; Last_Etbl : in out Entity_Table_Acc; Unit_Number : in Unit_Number_Type; New_Etbl : in out Entity_Table_Acc); -- Maintains the coherence of loaded files and the E_Tables! -- If Unit_Number is already in the list only some data gets updated. -- Otherwise a new entity table gets added to the end of the entity -- table list. -- Finally, in every case New_Etbl points to the Entity_Table -- which corresponds to Unit_Number. procedure Add_Reference (To_Entity : Entity_Acc; New_Etbl : Entity_Table_Acc; New_Ref : Node_Id); -- Adds a reference to the end of the reference list of the given entity. -- New_Etbl has to point to the entity table in which New_Ref appears. procedure Add_With (To_Etbl : Entity_Table_Acc; New_Etbl : Entity_Table_Acc); -- If Withed_Etbl is not already in the list, then a new With_Clause gets -- added to the end of the with list of To_Etbl procedure Clear_And_Mark_Xrefs (Home_Etbl : Entity_Table_Acc; Target_Etbl : Entity_Table_Acc); -- Looks in Home_Etbl for references with a source location in Target_Etbl. -- If one or more such references are found then the fitting references -- and the fitting entity in Home_Etbl as well as Target_Etbl get marked. -- All other nodes of Home_Etbl get unmarked. procedure Delete_Table (Old_Etbl : Entity_Table_Acc); -- Not implemented yet. -- Originally to deallocate the space of an Entity_Table object. function Double_Line_Entity return Boolean; -- Checks if the Name_Buffer contains two underlines. function Entity_Node (The_Entity : Entity_Acc) return Entity_Id; -- Returns the Entity_Id of the entity object to which The_Entity points. -- If The_Entity points to 'null' then Empty is returned. function Entity_Type (The_Entity : Entity_Acc) return Entity_Kind; -- Returns the Entity_Kind of the entity object to which The_Entity -- points. If The_Entity points to 'null' then E_Void is returned. function First (The_Etbl : Entity_Table_Acc) return Entity_Id; -- Returns the first entity of the given Entity_Table. function First (The_Entity : Entity_Acc) return Ref_Acc; -- Returns the first reference of the given entity. function Give_Warning (The_Entity : Entity_Acc) return Boolean; -- Tests if a warning message should appear if the given -- entity is unused. function In_E_List (The_Etbl : Entity_Table_Acc; The_Entity : Entity_Id) return Entity_Acc; -- Checks if the given entity is already in the entity list. -- If the entity is found the pointer to it is returned. -- If the entity is not in the list 'null' is returned. function In_Ref_List (The_Entity : Entity_Acc; The_Ref : Node_Id) return Boolean; -- Checks if the given reference is already in the reference list -- corresponding to the given entity. -- 'True' is returned if the entity is found. -- 'False' is returned if The_Entity points to 'null' or The_Entity -- is not in the list . function In_With_List (Home_Etbl : Entity_Table_Acc; Target_Etbl : Entity_Table_Acc) return Boolean; -- Checks if Home_Etbl is withed by Target_Etbl. -- If Target_Etbl is not in the list then 'False' is returned. function Is_Null (The_Entity : Entity_Acc) return Boolean; -- Tests if the given Entity_Acc points to 'null'. function Is_Null (The_Ref : Ref_Acc) return Boolean; -- Tests if the given Ref_Acc points to 'null'. function Is_Pragma (The_Ref : Ref_Acc) return Boolean; -- Tests if the given Ref_Acc is a pragma reference. procedure Mark_Entity (Old_Entity : Entity_Acc); -- Marks an entity of the entity list as used. -- This procedure is sometimes called to prevent the multi pass removal -- process from removing an unused entity twice. function Number_Of_Marks (The_Entity : Entity_Acc) return Natural; -- Returns the number of the marked references in the given entity. -- If The_Entity points to 'null' then 0 is returned. function Number_Of_Refs (The_Entity : Entity_Acc) return Natural; -- Returns the length of the reference list of the given entity. -- If The_Entity points to 'null' then 0 is returned. procedure Mark_Withed_Entities (The_Etbl : Entity_Table_Acc); -- Used for a withed spec to mark the entities which are used -- by its clients. -- If the client uses at least one entity then the client entity table -- gets also marked to signal a 'dead with clause'. procedure Mark_Xrefs (Home_Etbl : Entity_Table_Acc; Target_Etbl : Entity_Table_Acc); -- Looks in Home_Etbl for references with a source location in Target_Etbl. -- If one or more such references are found then the fitting references -- and the fitting entity in Home_Etbl as well as Target_Etbl get marked. function Next (The_Entity : Entity_Acc) return Entity_Acc; -- Returns the entity which follows the given entity in Entity_Table. -- 'null' is returned if the given entity is the last entity in the -- Entity_Table. function Next (The_Ref : Ref_Acc) return Ref_Acc; -- Returns the reference which follows the given reference in the list. -- 'null' is returned if the given reference is the last entity in the -- list. function The_Node (The_Ref : Ref_Acc) return Node_Id; -- Returns the Node_Id of the given reference. procedure Unmark_Entity (The_Table : Entity_Table_Acc; Old_Entity : Entity_Acc); -- Unmarks Old_Entity of the entity list. -- Nothing is done if Old_Entity or The_Table point to 'null'. procedure Unmark_Reference (The_Entity : Entity_Acc; Old_Ref : Node_Id); -- Unmarks a reference node of the reference list of The_Entity. -- Nothing is done if The_Entity points to 'null' or Old_Ref is -- not found in the list. procedure Update_Entity (To_Etbl : in Entity_Table_Acc; Entity_Node : in Entity_Id; New_Entity : in out Entity_Acc); -- If the entity is already in the list only the Entity_Id is updated. -- Otherwise Add_Entity is called. -- Used to sychnonize old Entity_Ids with new Unique_Names. -- Finally, in every case New_Entity points to the Entity structure -- which corresponds to Entity_Node. procedure Update_Reference (To_Entity : Entity_Acc; New_Etbl : Entity_Table_Acc; New_Ref : Node_Id); -- If the reference is already in the list only the Node_Id is updated. -- Otherwise Add_Reference is called.. -- Used to sychnonize old Node_Ids with the new Ids - only for creating -- the Spec_REQs. type Output_Level is (Full_Xref, Smart_Xref, Full_Only_Screen, Smart_Only_Screen); -- Used only for Writ! -- -- Full: Empty reference lists cause WARNING messages. -- Smart: The output of empty reference lists is supressed. -- -- Xref: Both screen and file output. -- Only_Screen: Only screen output. procedure Writ (The_Etbl : Entity_Table_Acc; Level : Output_Level); -- Writes the information stored in the Entity_Table to the Xref Output -- file. -- Note: The output of anonymous entities is always supressed. pragma Inline (Add_Entity); pragma Inline (Add_Etbl); pragma Inline (Add_Reference); pragma Inline (Add_With); pragma Inline (Clear_And_Mark_Xrefs); pragma Inline (Delete_Table); pragma Inline (Double_Line_Entity); pragma Inline (Entity_Node); pragma Inline (Entity_Type); pragma Inline (First); pragma Inline (Give_Warning); pragma Inline (In_E_List); pragma Inline (In_Ref_List); pragma Inline (In_With_List); pragma Inline (Is_Null); pragma Inline (Is_Pragma); pragma Inline (Mark_Entity); pragma Inline (Number_Of_Marks); pragma Inline (Mark_Xrefs); pragma Inline (Next); pragma Inline (The_Node); pragma Inline (Unmark_Entity); pragma Inline (Unmark_Reference); pragma Inline (Update_Entity); pragma Inline (Update_Reference); end Xref_Tab; is not already in the list, then a new With_Clause gets -- added to the end of the with list of To_Etbl procedure Clear_And_Mark_Xrefs (Home_Etbl : Entity_Table_Acc; Target_Etbl : Entity_Table_Acc); -- Looks in Home_Etbl for references with a source location in Targgnat-1.67-src/src/xref_tab.adb 444 10015 7640 167113 5506244507 11433 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- X R E F _ T A B -- -- -- -- B o d y -- -- -- -- $Revision: 1.3 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Output; use Output; with Atree; use Atree; with Lib; use Lib; with Namet; use Namet; with Osint; use Osint; with Sinfo; use Sinfo; with Sinput; use Sinput; with Stand; use Stand; package body Xref_Tab is ----------------------- -- Local subprograms -- ----------------------- function Scope_Path (The_Entity : Entity_Id) return Str; -- Returns the path string of the given entity. -- A path string consists of the name of the entity followed -- by the hierarchical scopes. -- The scope entities are separated by a point. However the first -- separator changes to a '#' if the entity is not accessible from -- outside the unit. ---------------- -- Add_Entity -- ---------------- procedure Add_Entity (To_Etbl : in Entity_Table_Acc; Entity_Node : in Entity_Id; New_Entity : in out Entity_Acc) is The_Kind : Entity_Kind := Ekind (Entity_Node); Parent_Node : Node_Id := Parent (Entity_Node); Grand_Parent : Node_Id; begin Get_Name_String (Chars (Entity_Node)); -- Check if it's an internal entity with two underlines in its -- name (e.g. loop__418) if not Double_Line_Entity then New_Entity := new An_Entity; New_Entity.Chars := new Str'(Name_Buffer (1 .. Name_Len)); New_Entity.Entity_Node := Entity_Node; New_Entity.Entity_Type := The_Kind; New_Entity.Line_Number := Int (Get_Line_Number (Sloc (Entity_Node))); New_Entity.Is_Internal := Is_Internal (Entity_Node); New_Entity.Scope_Path := new Str'(Scope_Path (Entity_Node)); if (To_Etbl.Length = 0) then To_Etbl.First_Entity := New_Entity; To_Etbl.Last_Entity := New_Entity; else To_Etbl.Last_Entity.Next_Entity := New_Entity; To_Etbl.Last_Entity := New_Entity; end if; To_Etbl.Length := To_Etbl.Length + 1; -- We give no warnings if certain nodes have no references: -- -- 1. an enumeration literal -- 2. a record component -- 3. a package name in a package body or body stub -- 4. a subprogram name or its parameters in a subprogram body -- or body stub which does not act as a spec. -- -- We do this because certain hidden references -- (e.g. within a range construct or an aggregate) -- don't appear in our reference list or because -- an identifier always points to the subprogram name -- in the spec. if The_Kind = E_Void or else The_Kind = E_Enumeration_Literal or else Nkind (Parent_Node) = N_Component_Declaration or else Nkind (Parent_Node) = N_Loop_Parameter_Specification or else Nkind (Parent_Node) in N_Package_Body .. N_Task_Body or else Nkind (Parent_Node) in N_Body_Stub or else (The_Kind in Subprogram_Kind and then Nkind (Parent (Parent_Node)) = N_Subprogram_Body and then Corresponding_Spec (Parent (Parent_Node)) /= Empty) then New_Entity.Give_Warning := False; end if; if The_Kind in Formal_Kind then Grand_Parent := Parent (Parent_Node); if ((Nkind (Parent (Grand_Parent)) = N_Subprogram_Body or else Nkind (Parent (Grand_Parent)) = N_Subprogram_Body_Stub) and then Corresponding_Spec (Parent (Grand_Parent)) /= Empty) or else (Is_Overloadable (Defining_Unit_Name (Grand_Parent)) and then Is_Imported (Defining_Unit_Name (Grand_Parent))) then New_Entity.Give_Warning := False; end if; if Is_Internal (Defining_Unit_Name (Grand_Parent)) then New_Entity.Is_Internal := True; end if; end if; end if; end Add_Entity; -------------- -- Add_Etbl -- -------------- procedure Add_Etbl (First_Etbl : in out Entity_Table_Acc; Last_Etbl : in out Entity_Table_Acc; Unit_Number : in Unit_Number_Type; New_Etbl : in out Entity_Table_Acc) is Unit_Node : Node_Id := Unit (File.Table (Unit_Number).Cunit); Etbl_Tmp : Entity_Table_Acc := First_Etbl; -- To store the current entity table within the search loop. Found : Boolean := False; begin -- We look if the entity table is already in the list. Get_Name_String (File.Table (Unit_Number).File_Name); while not Found loop if (Etbl_Tmp = null) then -- In this case we add the entity table to our list. New_Etbl := new Entity_Table; New_Etbl.Next_Etbl := null; New_Etbl.File_Name := new Str'(Name_Buffer (1 .. Name_Len)); Get_Name_String (File.Table (Unit_Number).Unit_Name); New_Etbl.Unit_Name := new Str'(Name_Buffer (1 .. Name_Len - 2)); if Name_Buffer (Name_Len) = 's' then New_Etbl.Status := A_Spec; elsif Acts_As_Spec (File.Table (Unit_Number).Cunit) then New_Etbl.Status := Body_As_Spec; else New_Etbl.Status := A_Body; end if; case Nkind (Unit_Node) is when N_Subprogram_Declaration | N_Subprogram_Body | N_Subprogram_Body_Stub => Unit_Node := Specification (Unit_Node); case Nkind (Unit_Node) is when N_Procedure_Specification => New_Etbl.Kind := Proc; when N_Function_Specification => New_Etbl.Kind := Func; when others => New_Etbl.Kind := Unknown; end case; when N_Package_Declaration | N_Package_Instantiation | N_Package_Body | N_Package_Body_Stub => New_Etbl.Kind := Pack; when N_Generic_Declaration | N_Function_Instantiation | N_Procedure_Instantiation => New_Etbl.Kind := Genr; when N_Task_Body_Stub => New_Etbl.Kind := Tsk; when N_Subunit => New_Etbl.Kind := Sub; New_Etbl.Status := Sub_Body; New_Etbl.RU := True; when others => New_Etbl.Kind := Unknown; end case; New_Etbl.Top_Node := File.Table (Unit_Number).Cunit; if (First_Etbl = null) then First_Etbl := New_Etbl; Last_Etbl := New_Etbl; else Last_Etbl.Next_Etbl := New_Etbl; Last_Etbl := New_Etbl; end if; Found := True; elsif (Etbl_Tmp.File_Name.all = Name_Buffer (1 .. Name_Len)) then -- In this case we update only the top Node_Id. Etbl_Tmp.Top_Node := File.Table (Unit_Number).Cunit; New_Etbl := Etbl_Tmp; Found := True; else Etbl_Tmp := Etbl_Tmp.Next_Etbl; end if; end loop; end Add_Etbl; ------------------- -- Add_Reference -- ------------------- procedure Add_Reference (To_Entity : Entity_Acc; New_Etbl : Entity_Table_Acc; New_Ref : Node_Id) is R_Tmp : Ref_Acc; New_Unit : Unit_Number_Type := Get_Sloc_Unit_Number (Sloc (New_Ref)); New_Sloc : Int := Int (Sloc (New_Ref)) - Int (File.Table (New_Unit).Source'First); begin if To_Entity /= null and then (To_Entity.Last_Ref = null or else To_Entity.Last_Ref.Etbl /= New_Etbl or else To_Entity.Last_Ref.Sloc < New_Sloc) then R_Tmp := new Ref; R_Tmp.Ref_Node := New_Ref; R_Tmp.Sloc := New_Sloc; R_Tmp.Line_Number := Int (Get_Line_Number (Sloc (New_Ref))); R_Tmp.Etbl := New_Etbl; if To_Entity.First_Ref = null then To_Entity.First_Ref := R_Tmp; To_Entity.Last_Ref := R_Tmp; else To_Entity.Last_Ref.Next_Ref := R_Tmp; To_Entity.Last_Ref := R_Tmp; end if; if Nkind (Parent (New_Ref)) = N_Pragma_Argument_Association then R_Tmp.Is_Pragma := True; else To_Entity.Length := To_Entity.Length + 1; end if; end if; end Add_Reference; -------------- -- Add_With -- -------------- procedure Add_With (To_Etbl : Entity_Table_Acc; New_Etbl : Entity_Table_Acc) is W_Tmp : With_Acc := To_Etbl.First_With; -- To store the current values within the search loop. Found : Boolean := False; begin if W_Tmp = null then -- No With_Clause yet ! To_Etbl.First_With := new With_Clause; To_Etbl.First_With.Withed_Etbl := New_Etbl; else -- Look for New_Etbl, if not in the list creat a new With_Clause! if W_Tmp.Withed_Etbl = New_Etbl then Found := True; end if; while W_Tmp.Next_With /= null and then not Found loop W_Tmp := W_Tmp.Next_With; if W_Tmp.Withed_Etbl = New_Etbl then Found := True; end if; end loop; if not Found then W_Tmp.Next_With := new With_Clause; W_Tmp.Next_With.Withed_Etbl := New_Etbl; end if; end if; end Add_With; -------------------------- -- Clear_And_Mark_Xrefs -- -------------------------- procedure Clear_And_Mark_Xrefs (Home_Etbl : Entity_Table_Acc; Target_Etbl : Entity_Table_Acc) is E_Tmp : Entity_Acc := Home_Etbl.First_Entity; R_Tmp : Ref_Acc; -- Patrick Parent_Node_Of_Ref : Node_Id; Is_Used_In_Elaborate : Boolean := False; -- End begin Target_Etbl.Marked := False; while (E_Tmp /= null) loop E_Tmp.Marks := 0; R_Tmp := E_Tmp.First_Ref; -- Patrick Is_Used_In_Elaborate := False; -- while (R_Tmp /= null) loop if R_Tmp.Etbl = Target_Etbl then -- Patrick -- If the reference is a with clause and the flag elaborate -- present is set then mark the entity Parent_Node_Of_Ref := Parent (R_Tmp.Ref_Node); if Nkind (Parent_Node_Of_Ref) = N_With_Clause then if Elaborate_Present (Parent_Node_Of_Ref) then Is_Used_In_Elaborate := True; end if; end if; -- End E_Tmp.Marks := E_Tmp.Marks + 1; R_Tmp.Marked := True; else R_Tmp.Marked := False; end if; R_Tmp := R_Tmp.Next_Ref; end loop; -- We mark the target entity table to signal that there are -- some cross references found. -- We don't consider the first entity (always referenced in the -- with clause) except if the target entity table is a subprogram, -- (in this case we're only able to reference the first entity). if E_Tmp.Marks /= 0 and then not Target_Etbl.Marked then if E_Tmp /= Home_Etbl.First_Entity or else Home_Etbl.Kind in Proc .. Genr or else Is_Used_In_Elaborate then Target_Etbl.Marked := True; end if; end if; E_Tmp := E_Tmp.Next_Entity; end loop; end Clear_And_Mark_Xrefs; ------------------ -- Delete_Table -- ------------------ procedure Delete_Table (Old_Etbl : Entity_Table_Acc) is begin null; end Delete_Table; ------------------------ -- Double_Line_Entity -- ------------------------ function Double_Line_Entity return Boolean is begin for I in 1 .. Name_Len loop if Name_Buffer (I) = '_' and then Name_Buffer (I + 1) = '_' then return True; end if; end loop; return False; end Double_Line_Entity; ----------------- -- Entity_Node -- ----------------- function Entity_Node (The_Entity : Entity_Acc) return Entity_Id is begin if (The_Entity = null) then return Empty; else return The_Entity.Entity_Node; end if; end Entity_Node; ----------------- -- Entity_Type -- ----------------- function Entity_Type (The_Entity : Entity_Acc) return Entity_Kind is begin if (The_Entity = null) then return E_Void; else return The_Entity.Entity_Type; end if; end Entity_Type; ----------- -- First -- ----------- function First (The_Etbl : Entity_Table_Acc) return Entity_Id is begin return The_Etbl.First_Entity.Entity_Node; end First; ----------- -- First -- ----------- function First (The_Entity : Entity_Acc) return Ref_Acc is begin return The_Entity.First_Ref; end First; ------------------ -- Give_Warning -- ------------------ function Give_Warning (The_Entity : Entity_Acc) return Boolean is begin return The_Entity.Give_Warning; end Give_Warning; --------------- -- In_E_List -- --------------- function In_E_List (The_Etbl : Entity_Table_Acc; The_Entity : Entity_Id) return Entity_Acc is E_Tmp : Entity_Acc; -- To store the current entity within the search loop. begin E_Tmp := The_Etbl.First_Entity; while E_Tmp /= null and then E_Tmp.Entity_Node /= The_Entity loop E_Tmp := E_Tmp.Next_Entity; end loop; return E_Tmp; end In_E_List; ----------------- -- In_Ref_List -- ----------------- function In_Ref_List (The_Entity : Entity_Acc; The_Ref : Node_Id) return Boolean is R_Tmp : Ref_Acc; -- To store the current reference within the search loop. begin if The_Entity = null then return False; else R_Tmp := The_Entity.First_Ref; while R_Tmp /= null and then R_Tmp.Ref_Node /= The_Ref loop R_Tmp := R_Tmp.Next_Ref; end loop; if (R_Tmp = null) then return False; else return True; end if; end if; end In_Ref_List; ------------------ -- In_With_List -- ------------------ function In_With_List (Home_Etbl : Entity_Table_Acc; Target_Etbl : Entity_Table_Acc) return Boolean is W_Tmp : With_Acc; -- To store the current entity within the search loop. begin W_Tmp := Target_Etbl.First_With; while W_Tmp /= null and then W_Tmp.Withed_Etbl /= Home_Etbl loop W_Tmp := W_Tmp.Next_With; end loop; if W_Tmp = null then return False; else return True; end if; end In_With_List; ------------- -- Is_Null -- ------------- function Is_Null (The_Entity : Entity_Acc) return Boolean is begin if (The_Entity = null) then return True; else return False; end if; end Is_Null; ------------- -- Is_Null -- ------------- function Is_Null (The_Ref : Ref_Acc) return Boolean is begin if The_Ref = null then return True; else return False; end if; end Is_Null; --------------- -- Is_Pragma -- --------------- function Is_Pragma (The_Ref : Ref_Acc) return Boolean is begin return The_Ref.Is_Pragma; end Is_Pragma; ----------------- -- Mark_Entity -- ----------------- procedure Mark_Entity (Old_Entity : Entity_Acc) is begin if Old_Entity /= null then Old_Entity.Marks := Old_Entity.Marks + 1; end if; end Mark_Entity; -------------------------- -- Mark_Withed_Entities -- -------------------------- procedure Mark_Withed_Entities (The_Etbl : Entity_Table_Acc) is R : Ref_Acc := The_Etbl.First_Entity.First_Ref; Current_Etbl : Entity_Table_Acc; Previous_Etbl : Entity_Table_Acc; -- To supress multiple calls of Mark_Xrefs for the same client. First : Boolean := True; begin -- We loop through all the references of the unit name entity. -- Each client must have at least one such reference in -- this list (the one of the with clause). while (R /= null) loop Current_Etbl := R.Etbl; if Current_Etbl /= Previous_Etbl and then Current_Etbl /= The_Etbl and then Current_Etbl.RU then -- If we find a cross reference of a new entity table then -- we mark the referenced entities. if First then Clear_And_Mark_Xrefs (The_Etbl, Current_Etbl); First := False; else Mark_Xrefs (The_Etbl, Current_Etbl); end if; Previous_Etbl := Current_Etbl; end if; R := R.Next_Ref; end loop; end Mark_Withed_Entities; ---------------- -- Mark_Xrefs -- ---------------- procedure Mark_Xrefs (Home_Etbl : Entity_Table_Acc; Target_Etbl : Entity_Table_Acc) is E_Tmp : Entity_Acc := Home_Etbl.First_Entity; Old_Marks : Natural; R_Tmp : Ref_Acc; -- Patrick Parent_Node_Of_Ref : Node_Id; Is_Used_In_Elaborate : Boolean := False; -- End begin Target_Etbl.Marked := False; while (E_Tmp /= null) loop Old_Marks := E_Tmp.Marks; R_Tmp := E_Tmp.First_Ref; -- Patrick Is_Used_In_Elaborate := False; -- while R_Tmp /= null loop if R_Tmp.Etbl = Target_Etbl and then not R_Tmp.Marked then -- Patrick -- If the reference is a with clause and the flag elaborate -- present is set then mark the entity Parent_Node_Of_Ref := Parent (R_Tmp.Ref_Node); if Nkind (Parent_Node_Of_Ref) = N_With_Clause then if Elaborate_Present (Parent_Node_Of_Ref) then Is_Used_In_Elaborate := True; end if; end if; -- End E_Tmp.Marks := E_Tmp.Marks + 1; R_Tmp.Marked := True; end if; R_Tmp := R_Tmp.Next_Ref; end loop; if E_Tmp.Marks /= Old_Marks and then not Target_Etbl.Marked then if E_Tmp /= Home_Etbl.First_Entity or else Home_Etbl.Kind in Proc .. Genr or else Is_Used_In_Elaborate then Target_Etbl.Marked := True; end if; end if; E_Tmp := E_Tmp.Next_Entity; end loop; end Mark_Xrefs; ---------- -- Next -- ---------- function Next (The_Entity : Entity_Acc) return Entity_Acc is begin if The_Entity = null then return null; else return The_Entity.Next_Entity; end if; end Next; ---------- -- Next -- ---------- function Next (The_Ref : Ref_Acc) return Ref_Acc is begin if The_Ref = null then return null; else return The_Ref.Next_Ref; end if; end Next; --------------------- -- Number_Of_Marks -- --------------------- function Number_Of_Marks (The_Entity : Entity_Acc) return Natural is begin if (The_Entity = null) then return 0; else return The_Entity.Marks; end if; end Number_Of_Marks; -------------------- -- Number_Of_Refs -- -------------------- function Number_Of_Refs (The_Entity : Entity_Acc) return Natural is begin if (The_Entity = null) then return 0; else return The_Entity.Length; end if; end Number_Of_Refs; ---------------- -- Scope_Path -- ---------------- function Scope_Path (The_Entity : Entity_Id) return Str is Scope_Node : Node_Id; Max_Buffer_Length : constant Nat := 100; -- The length of Buffer is limited to 100 characters. Buffer : Str (1 .. Max_Buffer_Length); -- The buffer variable to enable formatted output. -- The string in Buffer is *not* NUL terminated! -- -- Note: We fill the Buffer from the right to the left. -- So we can do with iteration instead of recursion. Buffer_Entry : Pos := Max_Buffer_Length; -- The current entry into Buffer (points to the last empty field). Loop_String : constant Str (1 .. 4) := "loop"; Block_String : constant Str (1 .. 5) := "block"; procedure Insert_Char_In_Buffer (The_Char : Char) is begin if Buffer_Entry = 0 then null; else Buffer (Buffer_Entry) := The_Char; Buffer_Entry := Buffer_Entry - 1; end if; end Insert_Char_In_Buffer; procedure Insert_Str_In_Buffer (Insert : Str) is begin if Insert'Length > Buffer_Entry then null; else Buffer (Buffer_Entry - Insert'Length + 1 .. Buffer_Entry) := Insert (1 .. Insert'Length); Buffer_Entry := Buffer_Entry - Insert'Length; end if; end Insert_Str_In_Buffer; begin Insert_Char_In_Buffer ('/'); -- If the entity is visible from outside we add a # to its scope. -- Thus we can easily distinguish between entities declared within -- the body and those declared within the spec. Scope_Node := The_Entity; Get_Name_String (Chars (Scope_Node)); Insert_Str_In_Buffer (Name_Buffer (1 .. Name_Len)); Scope_Node := Scope (Scope_Node); while Scope_Node > Last_Standard_Node_Id loop -- We stop adding scopes if we find a scope which is declared within -- the Standard package. if Scope (Scope_Node) < Last_Standard_Node_Id then -- Do this for the last scope part to mark the entity as -- visible or not. if Is_Public (The_Entity) then Insert_Char_In_Buffer ('.'); -- If the entity is public add a # after its scope. else Insert_Char_In_Buffer ('#'); -- If the entity is not public add a # after its scope. end if; else Insert_Char_In_Buffer ('.'); end if; Get_Name_String (Chars (Scope_Node)); if Ekind (Scope_Node) = E_Loop and then Double_Line_Entity then Insert_Str_In_Buffer (Loop_String); -- Given 'loop__456' we supress the '__456'. elsif Ekind (Scope_Node) = E_Block and then Double_Line_Entity then Insert_Str_In_Buffer (Block_String); -- Given 'block__1002' we supress the '__1002'. else Insert_Str_In_Buffer (Name_Buffer (1 .. Name_Len)); end if; Scope_Node := Scope (Scope_Node); end loop; Insert_Char_In_Buffer ('/'); return Buffer (Buffer_Entry + 1 .. Max_Buffer_Length); end Scope_Path; -------------- -- The_Node -- -------------- function The_Node (The_Ref : Ref_Acc) return Node_Id is begin return The_Ref.Ref_Node; end The_Node; -------------------- -- Unmark_Entity -- -------------------- procedure Unmark_Entity (The_Table : Entity_Table_Acc; Old_Entity : Entity_Acc) is begin if The_Table /= null and then Old_Entity /= null then Old_Entity.Marks := 0; end if; end Unmark_Entity; ---------------------- -- Unmark_Reference -- ---------------------- procedure Unmark_Reference (The_Entity : Entity_Acc; Old_Ref : Node_Id) is R_Tmp : Ref_Acc; -- To store the current references within the search loop. begin if The_Entity /= null then -- First we search the fitting reference, R_Tmp := The_Entity.First_Ref; while R_Tmp /= null and then R_Tmp.Ref_Node /= Old_Ref loop R_Tmp := R_Tmp.Next_Ref; end loop; -- then we unmark it. if R_Tmp /= null and then R_Tmp.Marked = True then R_Tmp.Marked := False; The_Entity.Marks := The_Entity.Marks - 1; end if; end if; end Unmark_Reference; ------------------- -- Update_Entity -- ------------------- procedure Update_Entity (To_Etbl : in Entity_Table_Acc; Entity_Node : in Entity_Id; New_Entity : in out Entity_Acc) is New_Line : Int; Found : Boolean := False; Path_Ptr : Str_Ptr; begin New_Entity := To_Etbl.First_Entity; New_Line := Int (Get_Line_Number (Sloc (Entity_Node))); if To_Etbl.Kind = Genr then Path_Ptr := new Str'(Scope_Path (Entity_Node)); -- In the case of generics we have to compare the whole -- path string since we have lots of entities with same -- line numbers and chars. else Get_Name_String (Chars (Entity_Node)); -- Otherwise it's enough to compare the line numbers and chars. end if; -- First we look if the entity is already in the list. while not Found loop if New_Entity = null then Add_Entity (To_Etbl, Entity_Node, New_Entity); Found := True; elsif New_Entity.Line_Number = New_Line then if To_Etbl.Kind = Genr then if New_Entity.Scope_Path.all = Path_Ptr.all then New_Entity.Entity_Node := Entity_Node; Found := True; else New_Entity := New_Entity.Next_Entity; end if; else if New_Entity.Chars.all = Name_Buffer (1 .. Name_Len) then New_Entity.Entity_Node := Entity_Node; Found := True; else New_Entity := New_Entity.Next_Entity; end if; end if; else New_Entity := New_Entity.Next_Entity; end if; end loop; end Update_Entity; ---------------------- -- Update_Reference -- ---------------------- procedure Update_Reference (To_Entity : Entity_Acc; New_Etbl : Entity_Table_Acc; New_Ref : Node_Id) is R_Tmp : Ref_Acc; -- To store the current values within the search loop. New_Unit : Unit_Number_Type := Get_Sloc_Unit_Number (Sloc (New_Ref)); New_Sloc : Int := Int (Sloc (New_Ref)) - Int (File.Table (New_Unit).Source'First); Found : Boolean := False; begin if To_Entity /= null then -- We look if the reference is already in the list. R_Tmp := To_Entity.First_Ref; while not Found loop if R_Tmp = null then Add_Reference (To_Entity, New_Etbl, New_Ref); Found := True; elsif R_Tmp.Etbl = New_Etbl and then R_Tmp.Sloc = New_Sloc then -- In this case we update only the Node_Id. R_Tmp.Ref_Node := New_Ref; Found := True; else R_Tmp := R_Tmp.Next_Ref; end if; end loop; end if; end Update_Reference; ---------- -- Writ -- ---------- procedure Writ (The_Etbl : Entity_Table_Acc; Level : Output_Level) is Header_Full : constant Str (1 .. 4) := "%%%%"; Header_Stub : constant Str (1 .. 4) := "----"; Header_Proc : constant Str (1 .. 12) := " procedure /"; Header_Func : constant Str (1 .. 11) := " function /"; Header_Genr : constant Str (1 .. 10) := " generic /"; Header_Pack : constant Str (1 .. 10) := " package /"; Header_Task : constant Str (1 .. 7) := " task /"; Header_Sub : constant Str (1 .. 10) := " subunit /"; Header_Unkn : constant Str (1 .. 10) := " unknown /"; Header_Spec : constant Str (1 .. 8) := "/ SPEC: "; Header_Body : constant Str (1 .. 8) := "/ BODY: "; Header_BoSp : constant Str (1 .. 15) := "/ SPEC & BODY: "; Warning_String_1 : constant Str (1 .. 4) := ">>> "; Warning_String_2 : constant Str (1 .. 6) := "unused"; Warning_String_3 : constant Str (1 .. 17) := "withed but unused"; Warning_String_4 : constant Str (1 .. 4) := " <<<"; Warning_String_5 : constant Str (1 .. 4) := " in "; Warning_String_6 : constant Str (1 .. 9) := "Warning: "; Warning_String_7 : constant Str (1 .. 38) := " +-> with clause should be in "; Warning_String_8 : constant Str (1 .. 36) := " --> with clause already in "; Warning_String_9 : constant Str (1 .. 20) := "withed unnecessarily"; Line_Length : constant Nat := 73; Entity_Indent : constant Int := 0; Reference_Indent : constant Int := 5; Too_Long_Indent : constant Int := 1; -- These four constants should be transferred into types.ads !! -- Used for the formatted output of Write_Buffer. Line_Too_Long : Boolean := False; -- To signal a previous truncated line. -- The indent then changes to be Too_Long_Indent spaces larger. E_Tmp : Entity_Acc; -- To store the current entity within the search loop. Buffer : Str (1 .. Line_Length + 1); -- The buffer variable to enable formatted output. -- The string in Buffer is *not* NUL terminated! Buffer_Length : Nat := 0; -- The current length of Buffer. -- Points to the last element in Buffer. Indent : Int; -- Current indention. procedure Add_Char_To_Buffer (The_Char : Char); -- Appends the given Char to the end of Buffer. -- Used for calling Unix_Write which accepts text only in form -- of a Str. procedure Add_Int_To_Buffer (Number : Int); -- Recursive procedure for writing integers. procedure Add_Str_To_Buffer (Append : Str); -- Appends the given string to the end of Buffer. procedure Check_Withing_Units; -- Looks for unnecessary with clauses in the clients of the Withed_Spec. -- Gives warnings both on the screen and in the Xref file if such -- an unnecessary with clause is found. procedure Write_Marked_References (First : Ref_Acc); -- Same as Write_References with the difference that here only -- references with the field Marked = True are considered. procedure Write_Path (The_Entity : Entity_Acc); -- Places the path string of the given entity in Buffer. -- A path string consists of the name of the entity followed -- by the hierarchical scopes. procedure Write_Place_Of_Declaration (The_Entity : Entity_Acc); -- Places the declaration string of the given entity in Buffer. -- A declaration string consists of the file name in -- which the entity is declared followed by the line number. procedure Write_References (First : Ref_Acc); -- Places the reference string of a given entity in Buffer. -- The reference string consists of source name files followed by the -- line numbers of the references within these files. procedure Write_Type (Text : String); -- Places the Entity_Kind string of a given Entity_Kind'Image in Buffer. -- The first two characters get cut ("E_"); procedure Write_Warning (The_Entity : Entity_Acc); -- Places a warning message in Buffer and writes a warning message on -- the screen if an entity is not used within its program unit. type Withed_Warning_Type is (Norm, Should, Already); procedure Write_Withed_Warning (Withing_Etbl : Entity_Table_Acc; Warning_Kind : Withed_Warning_Type; Extra_Etbl : Entity_Table_Acc); -- Places a warning message in Buffer and writes a warning message on -- the screen if -- -- 1.) a withed unit is not used (Norm). -- Here the field Extra_Etbl is redundant. -- 2.) the same with clause appears within a predecessor (Already). -- ' -> already in Extra_Etbl' -- 3.) a with clause should be moved into a successor (Should). -- ' -> should be in Extra_Etbl'. ------------------------ -- Add_Char_To_Buffer -- ------------------------ procedure Add_Char_To_Buffer (The_Char : Char) is begin if Buffer_Length = 0 then -- Do the correct indention. for I in 1 .. Indent loop Buffer (I) := ' '; end loop; Buffer_Length := Indent; -- Ignore a leading space. if The_Char /= ' ' then Buffer (Buffer_Length + 1) := The_Char; Buffer_Length := Buffer_Length + 1; end if; elsif Buffer_Length + 1 > Line_Length then if not Line_Too_Long then Line_Too_Long := True; Indent := Indent + Too_Long_Indent; end if; Write_Xref_Info (Buffer, Eol => False); Add_Char_To_Buffer (The_Char); else Buffer (Buffer_Length + 1) := The_Char; Buffer_Length := Buffer_Length + 1; end if; end Add_Char_To_Buffer; ----------------------- -- Add_Int_To_Buffer -- ----------------------- procedure Add_Int_To_Buffer (Number : Int) is Minibuffer : Str (1 .. 11); Free_Space : Int := 10; N : Int := Number; begin while N > 0 loop Minibuffer (Free_Space) := Char'VAL ((N mod 10) + 48); Free_Space := Free_Space - 1; N := N / 10; end loop; Add_Str_To_Buffer (Minibuffer (Free_Space + 1 .. 10)); end Add_Int_To_Buffer; ----------------------- -- Add_Str_To_Buffer -- ----------------------- procedure Add_Str_To_Buffer (Append : Str) is begin if Buffer_Length = 0 then -- Do the correct indention. for I in 1 .. Indent loop Buffer (I) := ' '; end loop; Buffer_Length := Indent; end if; if Buffer_Length + Append'Length <= Line_Length then -- All OK: no new line! Buffer (Buffer_Length + 1 .. Buffer_Length + Append'Length) := Append (Append'First .. Append'Last); Buffer_Length := Buffer_Length + Append'Length; elsif Append'Length > Line_Length - Indent - Too_Long_Indent then -- New line and truncation of the string. if Buffer_Length > Indent then Write_Xref_Info (Buffer, Eol => False); end if; Add_Str_To_Buffer (Append (Append'First .. Append'First + Line_Length - Indent - 1)); Write_Xref_Info (Buffer, Eol => False); if not Line_Too_Long then Line_Too_Long := True; Indent := Indent + Too_Long_Indent; Add_Str_To_Buffer (Append (Append'First + Line_Length - Indent + 1 .. Append'Last)); else Add_Str_To_Buffer (Append (Append'First + Line_Length - Indent .. Append'Last)); end if; else -- Only new line! if not Line_Too_Long then Line_Too_Long := True; Indent := Indent + Too_Long_Indent; end if; Write_Xref_Info (Buffer, Eol => False); Add_Str_To_Buffer (Append); end if; end Add_Str_To_Buffer; ------------------------- -- Check_Withing_Units -- ------------------------- procedure Check_Withing_Units is To_Clear : Boolean; -- To distinguish between Clear_And_Mark_Xrefs and Mark_Xrefs. Etbl_Tmp : Entity_Table_Acc; Withing_Etbl : Entity_Table_Acc; Etbl_Succ : Entity_Table_Acc; Succ_Used : Boolean; begin To_Clear := True; Etbl_Tmp := First_Etbl; while Etbl_Tmp /= null loop if Etbl_Tmp.Predecessor = null then -- We start at a spec of an Ada object. -- Find the with clause with the highest priority. -- -- A special case appears in one file mode where we mark the -- used entities of the spec but don't give any warnings. if Etbl_Tmp = The_Etbl then Withing_Etbl := Etbl_Tmp.Successor; else Withing_Etbl := Etbl_Tmp; while Withing_Etbl /= null and then not In_With_List (The_Etbl, Withing_Etbl) loop Withing_Etbl := Withing_Etbl.Successor; end loop; end if; -- Mark the used entities: -- 1. To check if there are unnecessary with clauses. -- 2. To write only the referenced entities of a non RU. -- -- Examine the withing compilation unit and all its successors -- which get the visibility automatically. Etbl_Succ := Withing_Etbl; while Etbl_Succ /= null loop if Etbl_Succ.RU then if To_Clear then Clear_And_Mark_Xrefs (The_Etbl, Etbl_Succ); To_Clear := False; else Mark_Xrefs (The_Etbl, Etbl_Succ); end if; else Etbl_Succ.Marked := False; end if; Etbl_Succ := Etbl_Succ.Successor; end loop; -- Give the correct warnings. if Withing_Etbl /= null and then Etbl_Tmp /= The_Etbl then if not Withing_Etbl.Marked and then Withing_Etbl.RU then Succ_Used := False; case Withing_Etbl.Status is when A_Spec | Withed_Spec => -- If the withed unit is not used by the spec but -- is used by a successor then give a hint to move the -- with clause into the body. Etbl_Succ := Withing_Etbl.Successor; while Etbl_Succ /= null loop if Etbl_Succ.Marked then Succ_Used := True; end if; Etbl_Succ := Etbl_Succ.Successor; end loop; if Succ_Used and then not In_With_List (The_Etbl, Withing_Etbl.Successor) then Write_Withed_Warning (Withing_Etbl, Should, Withing_Etbl.Successor); else Write_Withed_Warning (Withing_Etbl, Norm, null); end if; -- Warnings for subunits. if Withing_Etbl.Successor /= null then Etbl_Succ := Withing_Etbl.Successor.Successor; while Etbl_Succ /= null loop if In_With_List (The_Etbl, Etbl_Succ) then if Succ_Used then Write_Withed_Warning (Etbl_Succ, Already, Withing_Etbl); else Write_Withed_Warning (Etbl_Succ, Norm, null); end if; end if; Etbl_Succ := Etbl_Succ.Successor; end loop; end if; when A_Body | Body_As_Spec => -- If the withed unit is not used by the body but -- is used by a subunit then give no warning. Etbl_Succ := Withing_Etbl.Successor; while Etbl_Succ /= null loop if Etbl_Succ.Marked then Succ_Used := True; end if; Etbl_Succ := Etbl_Succ.Successor; end loop; if not Succ_Used then Write_Withed_Warning (Withing_Etbl, Norm, null); end if; -- Warnings for subunits. Etbl_Succ := Withing_Etbl.Successor; while Etbl_Succ /= null loop if In_With_List (The_Etbl, Etbl_Succ) then if Succ_Used then Write_Withed_Warning (Etbl_Succ, Already, Withing_Etbl); else Write_Withed_Warning (Etbl_Succ, Norm, null); end if; end if; Etbl_Succ := Etbl_Succ.Successor; end loop; when Sub_Body => Write_Withed_Warning (Withing_Etbl, Norm, null); -- Warnings for further subunits. Etbl_Succ := Withing_Etbl.Successor; while Etbl_Succ /= null loop if In_With_List (The_Etbl, Etbl_Succ) and then not Etbl_Succ.Marked then Write_Withed_Warning (Etbl_Succ, Norm, null); end if; Etbl_Succ := Etbl_Succ.Successor; end loop; end case; elsif Withing_Etbl.Status /= Sub_Body then -- If the with clause is USED then all the further with -- clauses in any successor are redundant. Etbl_Succ := Withing_Etbl.Successor; while Etbl_Succ /= null loop if In_With_List (The_Etbl, Etbl_Succ) then Write_Withed_Warning (Etbl_Succ, Already, Withing_Etbl); end if; Etbl_Succ := Etbl_Succ.Successor; end loop; end if; end if; end if; Etbl_Tmp := Etbl_Tmp.Next_Etbl; end loop; end Check_Withing_Units; ----------------------------- -- Write_Marked_References -- ----------------------------- procedure Write_Marked_References (First : Ref_Acc) is -- These Previous_xxx variables are used to supress the repetition -- of same units and same line numbers. Current_Ref : Ref_Acc := First; Current_Etbl : Entity_Table_Acc; Previous_Etbl : Entity_Table_Acc; Current_Line : Int; Previous_Line : Int; begin while Current_Ref /= null loop -- Loop through all the references of the list. if Current_Ref.Marked then Current_Etbl := Current_Ref.Etbl; if Current_Etbl /= Previous_Etbl then -- If we find a reference in a new file we add the new -- file name and the line number. if (Previous_Etbl /= null) then Add_Char_To_Buffer ('}'); Write_Xref_Info (Buffer); end if; -- Supress the } for the first file. Previous_Etbl := Current_Etbl; Previous_Line := -1; Add_Str_To_Buffer (Current_Etbl.File_Name.all); Add_Char_To_Buffer (' '); Add_Char_To_Buffer ('{'); end if; -- Normally we only add the line number. Current_Line := Current_Ref.Line_Number; if Current_Line /= Previous_Line then if (Previous_Line /= -1) then Add_Char_To_Buffer (' '); end if; -- Supress the space for the first reference. Previous_Line := Current_Line; Add_Int_To_Buffer (Current_Line); end if; end if; Current_Ref := Current_Ref.Next_Ref; end loop; if Previous_Etbl /= null then Add_Char_To_Buffer ('}'); Write_Xref_Info (Buffer); end if; end Write_Marked_References; ---------------- -- Write_Path -- ---------------- procedure Write_Path (The_Entity : Entity_Acc) is begin Add_Str_To_Buffer (The_Entity.Scope_Path.all); end Write_Path; -------------------------------- -- Write_Place_Of_Declaration -- -------------------------------- procedure Write_Place_Of_Declaration (The_Entity : Entity_Acc) is begin Add_Char_To_Buffer (' '); Add_Int_To_Buffer (The_Entity.Line_Number); Add_Char_To_Buffer (' '); end Write_Place_Of_Declaration; ---------------------- -- Write_References -- ---------------------- procedure Write_References (First : Ref_Acc) is -- These Previous_xxx variables are used to supress the repetition -- of same units and same line numbers. Current_Ref : Ref_Acc := First; Current_Etbl : Entity_Table_Acc; Previous_Etbl : Entity_Table_Acc; Current_Line : Int; Previous_Line : Int; begin while Current_Ref /= null loop -- Loop through all the references of the list. Current_Etbl := Current_Ref.Etbl; if Current_Etbl /= Previous_Etbl then -- If we find a reference in a new file we add the new -- file name and the line number. if Previous_Etbl /= null then Add_Char_To_Buffer ('}'); Write_Xref_Info (Buffer); end if; -- Supress the } for the first file. Previous_Etbl := Current_Etbl; Previous_Line := -1; Add_Str_To_Buffer (Current_Etbl.File_Name.all); Add_Char_To_Buffer (' '); Add_Char_To_Buffer ('{'); end if; -- Normally we only add the line number. Current_Line := Current_Ref.Line_Number; if Current_Line /= Previous_Line then if Previous_Line /= -1 then Add_Char_To_Buffer (' '); end if; -- Supress the space for the first reference. Previous_Line := Current_Line; Add_Int_To_Buffer (Current_Line); end if; Current_Ref := Current_Ref.Next_Ref; end loop; if Previous_Etbl /= null then Add_Char_To_Buffer ('}'); Write_Xref_Info (Buffer); end if; end Write_References; ---------------- -- Write_Type -- ---------------- procedure Write_Type (Text : String) is begin Add_Char_To_Buffer (' '); for I in Text'First + 2 .. Text'Last loop if Text (I) in 'A' .. 'Z' then Add_Char_To_Buffer (Char'Val (Character'Pos (Text (I)) + 32)); else Add_Char_To_Buffer (Char'Val (Character'Pos (Text (I)))); end if; end loop; end Write_Type; ------------------- -- Write_Warning -- ------------------- procedure Write_Warning (The_Entity : Entity_Acc) is begin -- File if Xref_Flag then Add_Str_To_Buffer (Warning_String_1); Add_Str_To_Buffer (Warning_String_6); Add_Str_To_Buffer (Warning_String_2); Add_Str_To_Buffer (Warning_String_4); end if; -- Screen Write_Char ('"'); Write_Str (The_Etbl.File_Name.all); Write_String (""", line "); Write_Int (The_Entity.Line_Number); Write_Char (':'); Write_Char (' '); Write_Str (Warning_String_6); Write_Str (The_Entity.Scope_Path.all); Write_Char (' '); Write_Str (Warning_String_2); Write_Eol; end Write_Warning; -------------------------- -- Write_Withed_Warning -- -------------------------- procedure Write_Withed_Warning (Withing_Etbl : Entity_Table_Acc; Warning_Kind : Withed_Warning_Type; Extra_Etbl : Entity_Table_Acc) is begin if With_Warnings then case Warning_Kind is when Norm => if Xref_Flag then Add_Str_To_Buffer (Warning_String_1); Add_Str_To_Buffer (Warning_String_6); Add_Str_To_Buffer (Warning_String_3); Add_Str_To_Buffer (Warning_String_5); Add_Str_To_Buffer (Withing_Etbl.File_Name.all); Add_Str_To_Buffer (Warning_String_4); Write_Xref_Info (Buffer); end if; Write_Str (Warning_String_6); Write_Str (The_Etbl.First_Entity.Scope_Path.all); Write_Char (' '); Write_Str (Warning_String_3); Write_Str (Warning_String_5); Write_Str (Withing_Etbl.File_Name.all); Write_Eol; when Should => if Xref_Flag then Add_Str_To_Buffer (Warning_String_1); Add_Str_To_Buffer (Warning_String_6); Add_Str_To_Buffer (Warning_String_3); Add_Str_To_Buffer (Warning_String_5); Add_Str_To_Buffer (Withing_Etbl.File_Name.all); Add_Str_To_Buffer (Warning_String_4); Write_Xref_Info (Buffer); Add_Str_To_Buffer (Warning_String_7); Add_Str_To_Buffer (Extra_Etbl.File_Name.all); Write_Xref_Info (Buffer); end if; Write_Str (Warning_String_6); Write_Str (The_Etbl.First_Entity.Scope_Path.all); Write_Char (' '); Write_Str (Warning_String_3); Write_Str (Warning_String_5); Write_Str (Withing_Etbl.File_Name.all); Write_Eol; Write_Str (Warning_String_7); Write_Str (Extra_Etbl.File_Name.all); Write_Eol; when Already => if Xref_Flag then Add_Str_To_Buffer (Warning_String_1); Add_Str_To_Buffer (Warning_String_6); Add_Str_To_Buffer (Warning_String_9); Add_Str_To_Buffer (Warning_String_5); Add_Str_To_Buffer (Withing_Etbl.File_Name.all); Add_Str_To_Buffer (Warning_String_4); Write_Xref_Info (Buffer); Add_Str_To_Buffer (Warning_String_8); Add_Str_To_Buffer (Extra_Etbl.File_Name.all); Write_Xref_Info (Buffer); end if; Write_Str (Warning_String_6); Write_Str (The_Etbl.First_Entity.Scope_Path.all); Write_Char (' '); Write_Str (Warning_String_9); Write_Str (Warning_String_5); Write_Str (Withing_Etbl.File_Name.all); Write_Eol; Write_Str (Warning_String_8); Write_Str (Extra_Etbl.File_Name.all); Write_Eol; end case; end if; end Write_Withed_Warning; -------------------------- -- begin of Write_Table -- -------------------------- begin case Level is when Full_Xref => -- Write a pretty headline. Indent := Entity_Indent; Write_Xref_Info (Buffer); Add_Str_To_Buffer (Header_Full); case The_Etbl.Kind is when Proc => Add_Str_To_Buffer (Header_Proc); when Func => Add_Str_To_Buffer (Header_Func); when Genr => Add_Str_To_Buffer (Header_Genr); when Pack => Add_Str_To_Buffer (Header_Pack); when Tsk => Add_Str_To_Buffer (Header_Task); when Sub => Add_Str_To_Buffer (Header_Sub); when Unknown => Add_Str_To_Buffer (Header_Unkn); end case; Add_Str_To_Buffer (The_Etbl.Unit_Name.all); case The_Etbl.Status is when A_Body | Sub_Body => Add_Str_To_Buffer (Header_Body); when Body_As_Spec => Add_Str_To_Buffer (Header_BoSp); when A_Spec | Withed_Spec => Add_Str_To_Buffer (Header_Spec); end case; Add_Str_To_Buffer (The_Etbl.File_Name.all); Add_Char_To_Buffer (' '); Add_Str_To_Buffer (Header_Full); Write_Xref_Info (Buffer); if The_Etbl.Status = Withed_Spec then Check_Withing_Units; end if; -- Loop through all the entities in Entity_Table. E_Tmp := The_Etbl.First_Entity; while E_Tmp /= null loop if not E_Tmp.Is_Internal then -- Don't write anonymous entities. -- First we write the entity, Indent := Entity_Indent; Write_Path (E_Tmp); -- then its type. if Entity_Info_In_Xref then Write_Type (Entity_Kind'Image (E_Tmp.Entity_Type)); end if; -- then its place of declaration. Write_Place_Of_Declaration (E_Tmp); -- Give warnings if the entity is not used. if Entity_Warnings and then E_Tmp.Length = 0 and then E_Tmp.Give_Warning then Write_Warning (E_Tmp); end if; if E_Tmp.First_Ref /= null then -- If some references exist, then write them. Write_Xref_Info (Buffer); Indent := Reference_Indent; Write_References (E_Tmp.First_Ref); else Write_Xref_Info (Buffer); end if; end if; E_Tmp := E_Tmp.Next_Entity; end loop; when Smart_Xref => -- Write a pretty headline. Indent := Entity_Indent; Write_Xref_Info (Buffer); Add_Str_To_Buffer (Header_Stub); case The_Etbl.Kind is when Proc => Add_Str_To_Buffer (Header_Proc); when Func => Add_Str_To_Buffer (Header_Func); when Genr => Add_Str_To_Buffer (Header_Genr); when Pack => Add_Str_To_Buffer (Header_Pack); when Tsk => Add_Str_To_Buffer (Header_Task); when Sub => Add_Str_To_Buffer (Header_Sub); when Unknown => Add_Str_To_Buffer (Header_Unkn); end case; Add_Str_To_Buffer (The_Etbl.Unit_Name.all); Add_Str_To_Buffer (Header_Spec); Add_Str_To_Buffer (The_Etbl.File_Name.all); Add_Char_To_Buffer (' '); Add_Str_To_Buffer (Header_Stub); Write_Xref_Info (Buffer); -- Loop through all the entities in Entity_Table. -- In this case we write something only if the entity is used within -- the target compilation unit. Check_Withing_Units; E_Tmp := The_Etbl.First_Entity; while E_Tmp /= null loop if E_Tmp.Marks > 0 then -- Don't write unmarked entities. -- First we write the entity, Indent := Entity_Indent; Write_Path (E_Tmp); -- then its type. if Entity_Info_In_Xref then Write_Type (Entity_Kind'Image (E_Tmp.Entity_Type)); end if; -- then its place of declaration, Write_Place_Of_Declaration (E_Tmp); -- and finally its references. Write_Xref_Info (Buffer); Indent := Reference_Indent; Write_Marked_References (E_Tmp.First_Ref); end if; E_Tmp := E_Tmp.Next_Entity; end loop; when Full_Only_Screen => if The_Etbl.Status = Withed_Spec then Check_Withing_Units; end if; -- Loop through all the entities in Entity_Table. E_Tmp := The_Etbl.First_Entity; while E_Tmp /= null loop -- Give warnings if the entity is not used. if Entity_Warnings and then E_Tmp.Length = 0 and then not E_Tmp.Is_Internal and then E_Tmp.Give_Warning then Write_Warning (E_Tmp); end if; E_Tmp := E_Tmp.Next_Entity; end loop; when Smart_Only_Screen => Check_Withing_Units; end case; end Writ; end Xref_Tab; y.Scope_Path.all); Write_Char (' '); Write_Str (Warning_String_3); Write_Str (Warning_String_5); Write_Str (Withing_Etbl.File_Name.all); Write_Eol; when Should => if Xref_Flag then Add_Str_To_Buffer (Warning_String_1); Add_Str_To_Buffer (Warning_String_6); gnat-1.67-src/src/xrefprov.adb 444 10015 7640 15005 5506244507 11464 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- X R E F P R O V -- -- -- -- B o d y -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Namet; use Namet; with Osint; use Osint; with Types; use Types; with Unixlib; use Unixlib; with Output; use Output; procedure Xrefprov is -- This procedure calculates provided interfaces from required -- interfaces given on the command line. -- The syntax is the following: -- -- provcalc unit.org unit.client1.r unit.client2.r ... -- -- unit.org is the recreated source of the original spec (it -- is used to find the correct order of declarations). -- unit.clientx.r are required interfaces of the clients for unit. -- Note: "unit", "client1", "client2" ... are placeholder for individual -- names. -- The outfile is named unit.p. --------------- -- Calculate -- --------------- procedure Calculate is -- Variables to handle the input sources: -- CC subtype Ind is Int range 1 .. Number_Of_Files; Un : constant Ind := 1; File_Buffer : array (Ind) of Source_Buffer_Ptr; Line_Start : array (1 .. Number_Of_Files) of Source_Ptr; Line_End : array (1 .. Number_Of_Files) of Source_Ptr; -- Entries into source files without leading spaces (indent -- is not constant!!). Line_End normally points to LF. Ref_Line_Start : Source_Ptr; -- Points to the beginning of the current reference line *with* -- leading spaces. The_File : File_Name_Type; Index : Nat; Found : Boolean; -- Variable to handle the ouput file: File_Handler : Unix_FD; --------------------- -- Fetch_New_Line -- --------------------- procedure Fetch_New_Line (J : Int) is -- "Reads" a new line and updates the corresponding -- Line_Start and Line_End values. S_Tmp : Source_Ptr; begin S_Tmp := Line_End (J) + 1; while File_Buffer (J).all (S_Tmp) = ' ' loop S_Tmp := S_Tmp + 1; end loop; Line_Start (J) := S_Tmp; while File_Buffer (J).all (S_Tmp) /= LF and then File_Buffer (J).all (S_Tmp) /= EOF loop S_Tmp := S_Tmp + 1; end loop; Line_End (J) := S_Tmp; end Fetch_New_Line; ------------------------ -- Begin of Calculate -- ------------------------ begin -- Read the recreated spec into memory. The_File := Next_Main_Source; File_Buffer (1) := Read_Source_File (The_File, True); Line_End (1) := File_Buffer (1)'First - 1; Fetch_New_Line (1); Ref_Line_Start := File_Buffer (1)'First; -- Open the provided interface file (suffix .p instead .org) Get_Name_String (The_File); Index := 1; while Name_Buffer (Index) /= '.' loop Index := Index + 1; end loop; Name_Buffer (Index + 1) := 'p'; Name_Buffer (Index + 2) := NUL; File_Handler := Unix_Create_File (Name_Buffer'Address); if File_Handler < 0 then Write_String ("Cannot create provided interface file!"); Write_Eol; Exit_Program (E_Fatal); end if; -- Read the required interfaces into memory. for I in 2 .. Number_Of_Files loop The_File := Next_Main_Source; File_Buffer (I) := Read_Source_File (The_File, True); Line_End (I) := File_Buffer (I)'First - 1; Fetch_New_Line (I); end loop; -- Start calculating. -- CC replaced 1 by Un to avoid a GNAT BUG while File_Buffer (Un).all (Line_End (1)) /= EOF loop Found := False; for I in 2 .. Number_Of_Files loop if File_Buffer (I).all (Line_Start (I) .. Line_End (I)) = File_Buffer (Un).all (Line_Start (1) .. Line_End (1)) then Found := True; Fetch_New_Line (I); end if; end loop; if Found = True then Unix_Write (File_Handler, File_Buffer (Un).all (Ref_Line_Start)'Address, Int (Line_End (1) - Ref_Line_Start) + 1); end if; Ref_Line_Start := Line_End (1) + 1; Fetch_New_Line (1); end loop; -- Close the provided interface file. Unix_Close (File_Handler); -- Look for incompatibilities. for I in 2 .. Number_Of_Files loop if File_Buffer (I).all (Line_End (I)) /= EOF then Write_Str ("Error comparing files!"); Write_Eol; Exit_Program (E_Fatal); end if; end loop; end Calculate; ----------------------- -- begin of Provcalc -- ----------------------- begin Initialize_OS_Interface (Compiler); Initialize_Namet; if Number_Of_Files < 2 then Write_Str ("Too less arguments!"); Write_Eol; Exit_Program (E_Fatal); else Calculate; end if; end Xrefprov; -- Loop through all the entities in Entity_Table. E_Tmp := The_Etbl.First_Entity; while E_Tmp /= null loop -- Give warnings if the entity is not used. if Entity_Warnings and then E_Tmp.Length = 0 and then not E_Tmp.Is_Internal and then E_Tmp.Give_Warning then Write_Warning (E_Tmp); end if; E_Tmp := E_Tmp.Next_Entity; end loop; when Smart_Only_Screen => gnat-1.67-src/src/sysid~d.ads 444 10015 7640 5402 5506244511 11302 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S Y S I D -- -- -- -- S p e c -- -- (DOS Version) -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Types; use Types; package Sysid is -- This package contains the flag that shows what operating system is used MS_DOS : constant Boolean := True; -- This flag is True if operating under MS/DOS or an operating system that -- shares its conventions (such as OS/2). It affects the output format of -- library information files (CR/LF at end of lines, and EOF at end of -- file), the default character set (PC), and the output of the usage -- information (switch character displayed as slash instead of minus). -- Note that the handling of input files is not dependent on the setting -- of this flag. For input source and library information files, the line -- terminator may be either CR/LF or LF alone, and the EOF character is -- optional, but will be recognized as signalling the end of file (and -- no further information will be read) if it is encountered. end Sysid; of declarations). -- unit.clientx.r are required interfaces of the clients for unit. -- Note: "unit", "client1", "client2" ... are placeholder for individual -- names. -- The outfile is named unit.p. --------------- -- Calcgnat-1.67-src/src/Makefile.os2 440 10015 7640 376360 5506244514 11333 # Makefile for GNU C compiler version 2.5.7 for OS/2 2.x. # Copyright (C) 1987, 1988, 1990-1993 Free Software Foundation, Inc. # Contributed by Samuel Figueroa (figueroa@cs.nyu.edu) #This file is part of GNU CC. #GNU CC 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. #GNU CC 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 GNU CC; see the file COPYING. If not, write to #the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. # This syntax in this makefile is compatible with that required by the NMAKE # utility, which is part of IBM's Developer's Toolkit for OS/2. # Not all targets work; specifically, targets having to do with installation # and those containing shell scripts do not work. Otherwise, this makefile # is similar in functionality to Makefile.in, which is included with gcc. # The targets for external use include: # all, doc, proto, install, install-cross, install-cross-rest, # uninstall, TAGS, mostlyclean, clean, distclean, realclean, # stage1, stage2, stage3, stage4. # Suppress smart makes who think they know how to automake Yacc files .y.c: # Variables that exist for you to override. # See below for how to change them for certain systems. # Selection of languages to be made. LANGUAGES = c c++ objective-c ada proto ALLOCA = ALLOCA_FLAGS = ALLOCA_FINISH = true # Various ways of specifying flags for compilations: # CFLAGS is for the user to override to, e.g., do a bootstrap with -O2. # BOOT_CFLAGS is the value of CFLAGS to pass # to the stage2 and stage3 compilations # XCFLAGS is used for most compilations but not when using the GCC just built. XCFLAGS = -O CFLAGS = BOOT_CFLAGS = -O2 $(CFLAGS) # These exists to be overridden by the x-* and t-* files, respectively. X_CFLAGS = T_CFLAGS = X_CPPFLAGS = T_CPPFLAGS = CC = gcc BISON = bison BISONFLAGS = AR = lib OLDAR_FLAGS = #qc AR_FLAGS = #rc SHELL = /bin/sh # on sysV, define this as cp. INSTALL = install -c # These permit overriding just for certain files. INSTALL_PROGRAM = $(INSTALL) INSTALL_DATA = $(INSTALL) SYMLINK = copy # Define this as & to perform parallel make on a Sequent. # Note that this has some bugs, and it seems currently necessary # to compile all the gen* files first by hand to avoid erroneous results. P = # How to invoke ranlib. # RANLIB = ranlib # Test to use to see whether ranlib exists on the system. # RANLIB_TEST = [ -f /usr/bin/ranlib -o -f /bin/ranlib ] # How to invoke patch. PATCH = gnupatch # Compiler to use for compiling gcc1.lib. # OLDCC should not be the GNU C compiler, # since that would compile typical gcc1.lib functions such as mulsi3 # into infinite recursions. OLDCC = icc # CFLAGS for use with OLDCC, for compiling gcc1.lib. # NOTE: -O does not work on some Unix systems! CCLIBFLAGS = -O -Ms $(INCLUDES) # Version of ar to use when compiling gcc1.lib. OLDAR = lib # The GCC to use for compiling gcc2.lib, enquire, and cross-test. # Usually the one we just built. # Don't use this as a dependency--use $(GCC_PASSES) or $(GCC_PARTS). GCC_FOR_TARGET = .\xgcc # This is used instead of ALL_CFLAGS when compiling with GCC_FOR_TARGET. # It omits XCFLAGS, and specifies -B.\. # It also specifies -B$(tooldir)/ to find as and ld for a cross compiler. GCC_CFLAGS=-B.\ -g $(INTERNAL_CFLAGS) $(X_CFLAGS) $(T_CFLAGS) $(CFLAGS) $(CROSS_GCC_CFLAGS) #-I\GCC\INCLUDE # Special flags for compiling enquire. # We disable optimization to make floating point more reliable. ENQUIRE_CFLAGS = -DNO_MEM -DNO_STDDEF -DNO_LONG_DOUBLE_IO -O0 ENQUIRE_LDFLAGS = $(LDFLAGS) # Tools to use when building a cross-compiler. # These are used because `configure' appends `cross-make' # to the makefile when making a cross-compiler. TARGET_TOOLPREFIX = $(tooldir)/bin/ AR_FOR_TARGET = $(TARGET_TOOLPREFIX)ar AR_FOR_TARGET_FLAGS = rc RANLIB_FOR_TARGET = $(TARGET_TOOLPREFIX)ranlib RANLIB_TEST_FOR_TARGET = [ -f $(TARGET_TOOLPREFIX)ranlib ] # Dir to search for system headers. Overridden by cross-make. SYSTEM_HEADER_DIR = D:\IBM.C\include # Control whether to run fixproto. STMP_FIXPROTO = #stmp-fixproto # There may be a premade insn-attrtab.c for this machine. # (You could rebuild it with genattrtab as usual, but it takes a long time.) # PREMADE_ATTRTAB is the file name of the file to use. # PREMADE_ATTRTAB_MD is the md file it corresponds to. PREMADE_ATTRTAB_MD = Makefile # Guaranteed not to cmp equal to md. PREMADE_ATTRTAB = target=i386-os2 xmake_file=..\Makefile.in tmake_file=..\Makefile.in version=2.5.7 mainversion=2.5 # Directory where sources are, from where we are. srcdir = . # Common prefix for installation directories. # NOTE: This directory must exist when you start installation. # The \\ may mess up the installation routines and making a cross-compiler. prefix = \\gcc # Directory in which to put localized header files. On the systems with # gcc as the native cc, `local_prefix' may not be `prefix' which is # `/usr'. local_prefix = $(prefix) # Directory in which to put host dependent programs and libraries exec_prefix = $(prefix) # Directory in which to put the executable for the command `gcc' bindir = $(exec_prefix)\\bin # Directory in which to put the directories used by the compiler. libdir = $(exec_prefix)\\lib # Directory in which the compiler finds executables, libraries, etc. libsubdir = $(libdir)\\gcc-lib\\$(target)\\$(version) # Directory for header file assert.h. includedir = $(prefix)\include # assertdir is overridden in cross-make. assertdir = $(includedir) # Extension (if any) to put in installed man-page filename. manext = .1 # Directory in which to put man pages. mandir = $(prefix)\man\man1 # Directory in which to find other cross-compilation tools and headers. # Used in install-cross. tooldir = $(prefix)\\$(target) # Dir for temp files. tmpdir = \tmp # Additional system libraries to link with. CLIB= # Change this to a null string if obstacks are installed in the # system library. OBSTACK=obstack.obj # Specify the rule for actually making libgcc.a, LIBGCC = gcc.lib # and the rule for installing it. INSTALL_LIBGCC = install-libgcc # Specify the rule for actually making gcc1.lib. # The value may be empty; that means to do absolutely nothing # with or for gcc1.lib. LIBGCC1 = #gcc1.lib # Specify the rule for making libgcc1.a for a cross-compiler. # The default rule assumes that libgcc1.a is supplied by the user. CROSS_LIBGCC1 = libgcc1.cross # Specify the rule for actually making gcc2.lib. LIBGCC2 = gcc2.lib # Options to use when compiling gcc2.lib. # -g1 causes output of debug info only for file-scope entities. # we use this here because that should be enough, and also # so that -g1 will be tested. # $(LIBGCC2_INCLUDES) is at the end rather than before $(GCC_CFLAGS) because # most likely there will be too many parameters for the ADDTOLIB2 batch file. # Therefore, this batch file lists at least some of the include paths, which # most likely makes the include paths in $(LIBGCC2_INCLUDES) redundant. LIBGCC2_CFLAGS = -O2 $(GCC_CFLAGS) -g1 $(LIBGCC2_INCLUDES) # Additional options to use when compiling gcc2.lib. # Some targets override this to -Iinclude LIBGCC2_INCLUDES = $(INCLUDES) # Things which must be built before building gcc2.lib. # Some targets override this to stmp-int-hdrs LIBGCC2_DEPS = # Enquire target (This is a variable so that a target can choose not to # build it.) ENQUIRE = enquire # Cross-test target (must also be overridable for a target) CROSS_TEST = cross-test # List of extra executables that should be compiled for this target machine # that are used for compiling from source code to object code. # The rules for compiling them should be in the t-* file for the machine. EXTRA_PASSES = # Like EXTRA_PASSES, but these are used when linking. EXTRA_PROGRAMS = # List of extra object files that should be compiled for this target machine. # The rules for compiling them should be in the t-* file for the machine. EXTRA_PARTS = # List of extra object files that should be compiled and linked with # compiler proper (cc1, cc1obj, cc1plus). EXTRA_OBJS = # List of additional header files to install. # Often this is edited directly by `configure'. EXTRA_HEADERS = # Set this to `ld' to enable use of collect2. # USE_COLLECT2 = # It is convenient for configure to add the assignment at the beginning, # so don't override it here. # List of extra C and assembler files to add to gcc1.lib. # Assembler files should have names ending in `.asm'. LIB1FUNCS_EXTRA = # List of extra C and assembler files to add to gcc2.lib. # Assembler files should have names ending in `.asm'. LIB2FUNCS_EXTRA = # Program to convert libraries. LIBCONVERT = # Control whether header files are installed. # We will change this to install-fixincludes eventually. # It would be useful for people to try this now. INSTALL_HEADERS=install-headers # Select which version of fixincludes to use (I.E. regular versus SVR4) FIXINCLUDES=fixincludes # Additional directories of header files to run fixincludes on. # On most systems, this is empty. OTHER_FIXINCLUDES_DIRS= # List of things which should already be built whenever we try to use xgcc # to compile anything (without linking). GCC_PASSES=xgcc.exe cc1.exe cpp.exe $(EXTRA_PASSES) # List of things which should already be built whenever we try to use xgcc # to link anything. GCC_PARTS=$(GCC_PASSES) $(LIBGCC) $(EXTRA_PROGRAMS) $(USE_COLLECT2) $(EXTRA_PARTS) # Directory to link to, when using the target `maketest'. DIR = ..\gcc # Guaranteed to not exist when not passing md through cpp. MD_FILE = md-cpp-not-used # Flags to use when cross-building GCC. # Prefix to apply to names of object files when using them # to run on the machine we are compiling on. HOST_PREFIX= # Prefix to apply to names of object files when compiling them # to run on the machine we are compiling on. # The default for this variable is chosen to keep these rules # out of the way of the other rules for compiling the same source files. HOST_PREFIX_1=loser- HOST_CC=$(CC) HOST_CFLAGS=$(ALL_CFLAGS) HOST_CLIB=$(CLIB) HOST_LDFLAGS=$(LDFLAGS) HOST_CPPFLAGS=$(ALL_CPPFLAGS) HOST_ALLOCA=$(ALLOCA) HOST_MALLOC=$(MALLOC) HOST_OBSTACK=$(OBSTACK) # Choose the real default target. ALL=all.internal # Choose the real install target. INSTALL_TARGET=install-native # Source for float.h. Overridden by cross-make. FLOAT_H=float.h-nat # End of variables for you to override. # Definition of `all' is here so that new rules inserted by sed # do not specify the default target. # The real definition is under `all.internal' (for native compilers) # or `all.cross' (for cross compilers). all: all.indirect # This tells GNU Make version 3 not to put all variables in the environment. .NOEXPORT: # sed inserts variable overrides after the following line. ####target overrides ####host overrides ####cross overrides ####build overrides # Now figure out from those variables how to compile and link. all.indirect: $(ALL) # IN_GCC tells obstack.h to use gstddef.h. INTERNAL_CFLAGS = $(CROSS) -DIN_GCC # This is the variable actually used when we compile. ALL_CFLAGS = $(INTERNAL_CFLAGS) $(X_CFLAGS) $(T_CFLAGS) $(CFLAGS) $(XCFLAGS) # Likewise. ALL_CPPFLAGS = $(CPPFLAGS) $(X_CPPFLAGS) $(T_CPPFLAGS) # Even if ALLOCA is set, don't use it if compiling with GCC. # USE_ALLOCA= ` case "$(CC)" in "$(OLDCC)") echo $(ALLOCA) ;; esac ` !IF "$(CC)" == "$(OLDCC)" USE_ALLOCA= $(ALLOCA) !ELSE USE_ALLOCA= !ENDIF # USE_HOST_ALLOCA= ` case "$(HOST_CC)"@"$(HOST_ALLOCA)" in "$(OLDCC)"@?*) echo $(HOST_PREFIX)$(HOST_ALLOCA) ;; esac ` !IF "$(HOST_CC)" == "$(OLDCC)" && "$(HOST_ALLOCA)" != "" USE_HOST_ALLOCA= $(HOST_PREFIX)$(HOST_ALLOCA) !ELSE USE_HOST_ALLOCA= !ENDIF # USE_HOST_MALLOC= ` case "$(HOST_MALLOC)" in ?*) echo $(HOST_PREFIX)$(HOST_MALLOC) ;; esac ` !IF "$(HOST_MALLOC)" == "" USE_HOST_MALLOC= !ELSE USE_HOST_MALLOC= $(HOST_PREFIX)$(HOST_MALLOC) !ENDIF # USE_HOST_OBSTACK= ` case "$(HOST_OBSTACK)" in ?*) echo $(HOST_PREFIX)$(HOST_OBSTACK) ;; esac ` !IF "$(HOST_OBSTACK)" == "" USE_HOST_OBSTACK= !ELSE USE_HOST_OBSTACK= $(HOST_PREFIX)$(HOST_OBSTACK) !ENDIF # Dependency on obstack, alloca, malloc or whatever library facilities # are not installed in the system libraries. # We don't use USE_ALLOCA because backquote expansion doesn't work in deps. LIBDEPS= $(OBSTACK) $(ALLOCA) $(MALLOC) # Likewise, for use in the tools that must run on this machine # even if we are cross-building GCC. # We don't use USE_ALLOCA because backquote expansion doesn't work in deps. HOST_LIBDEPS= $(HOST_PREFIX)$(HOST_OBSTACK) $(HOST_PREFIX)$(HOST_ALLOCA) $(HOST_PREFIX)$(HOST_MALLOC) # How to link with both our special library facilities # and the system's installed libraries. LIBS = $(OBSTACK) $(USE_ALLOCA) $(MALLOC) $(CLIB) # Likewise, for use in the tools that must run on this machine # even if we are cross-building GCC. HOST_LIBS = $(USE_HOST_OBSTACK) $(USE_HOST_ALLOCA) $(USE_HOST_MALLOC) \ $(HOST_CLIB) HOST_RTL = $(HOST_PREFIX)rtl.obj HOST_RTLANAL = $(HOST_PREFIX)rtlanal.obj HOST_PRINT = $(HOST_PREFIX)print-rtl.obj # Specify the directories to be searched for header files. # Both . and srcdir are used, in that order, # so that tm.h and config.h will be found in the compilation # subdirectory rather than in the source directory. INCLUDES = -I. -I$(srcdir) -I$(srcdir)\config #-I\GCC\INCLUDE SUBDIR_INCLUDES = -I.. -I..\$(srcdir) -I..\$(srcdir)\config # Always use -I$(srcdir)\config when compiling. .c.obj: $(CC) -c $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) $< # This tells GNU make version 3 not to export all the variables # defined in this file into the environment. .NOEXPORT: # Lists of files for various purposes. # A list of all the language-specific executables. COMPILERS = cc1.exe cc1plus.exe cc1obj.exe gnat1.exe # Language-specific object files for C. C_OBJS = c-parse.obj c-lang.obj c-lex.obj c-pragma.obj \ c-decl.obj c-typeck.obj c-convert.obj c-aux-info.obj c-common.obj c-iterate.obj # Language-specific object files for Objectionable C. OBJC_OBJS = objc-parse.obj objc-actions.obj \ c-lex.obj c-decl.obj c-typeck.obj c-convert.obj c-aux-info.obj c-common.obj c-pragma.obj # Language-specific object files for C++. CPLUS_OBJS1 = cp-parse.obj cp-decl.obj cp-decl2.obj \ cp-typeck.obj cp-type2.obj cp-tree.obj cp-ptree.obj CPLUS_OBJS2 = cp-cvt.obj cp-search.obj cp-lex.obj cp-gc.obj cp-call.obj \ cp-class.obj cp-init.obj cp-method.obj cp-except.obj CPLUS_OBJS3 = cp-expr.obj cp-pt.obj cp-edsel.obj cp-xref.obj \ $(CPLUS_INPUT) cp-spew.obj c-common.obj cp-error.obj cp-errfn.obj CPLUS_OBJS = $(CPLUS_OBJS1) $(CPLUS_OBJS2) $(CPLUS_OBJS3) # Languages-specific object files for Ada. GNAT1_C_OBJS = bind_gnat1drv.obj a-adaint.obj a-gtran3.obj a-misc.obj a-trans3.obj \ a-trans4.obj a-trans.obj a-uint.obj GNAT_ADA_OBJS1 = alloc.obj atree.obj casing.obj comperr.obj csets.obj debug.obj debug_sem.obj \ einfo.obj errcount.obj errout.obj excep.obj expand.obj exp_attr.obj exp_ch2.obj exp_ch3.obj GNAT_ADA_OBJS2 = exp_ch4.obj exp_ch5.obj exp_ch6.obj exp_ch7.obj exp_ch8.obj exp_ch9.obj exp_ch10.obj \ exp_ch11.obj exp_ch12.obj exp_ch13.obj exp_prag.obj exp_util.obj fname.obj frontend.obj GNAT_ADA_OBJS3 = gnatvsn.obj lib.obj libfmt.obj limits.obj namet.obj nmake.obj opt.obj osint.obj output.obj \ par.obj rtsfind.obj scans.obj scn.obj sem.obj sem_attr.obj sem_ch3.obj sem_ch4.obj GNAT_ADA_OBJS4 = sem_ch5.obj sem_ch6.obj sem_ch7.obj sem_ch8.obj sem_ch9.obj sem_ch10.obj sem_ch11.obj \ sem_ch12.obj sem_ch13.obj sem_disp.obj sem_eval.obj sem_prag.obj sem_res.obj sem_type.obj GNAT_ADA_OBJS5 = sem_util.obj sinfo.obj sinfo-change.obj sinput.obj snames.obj sprint.obj stand.obj \ stringt.obj switch.obj sysid.obj system.obj system-assertions.obj system-traceback.obj GNAT_ADA_OBJS6 = system_environment.obj tbuild.obj treepr.obj \ treeprs.obj ttypes.obj types.obj uintp.obj uname.obj unixlib.obj usage.obj GNAT_ADA_OBJS = $(GNAT_ADA_OBJS1) $(GNAT_ADA_OBJS2) $(GNAT_ADA_OBJS3) \ $(GNAT_ADA_OBJS4) $(GNAT_ADA_OBJS5) $(GNAT_ADA_OBJS6) GNATF_OBJS1 = frontdrv.obj xref.obj xref_tab.obj a-adaint.obj GNATF_OBJS = $(GNAT_ADA_OBJS) $(GNATF_OBJS1) GNAT1_ADA_OBJS1 = back_end.obj gnat1drv.obj GNAT1_ADA_OBJS = $(GNAT_ADA_OBJS) $(GNAT1_ADA_OBJS1) GNAT1_OBJS = $(GNAT1_C_OBJS) $(GNAT1_ADA_OBJS) GNATBIND_OBJS1 = gnatbind.obj ali.obj alloc.obj bcheck.obj binde.obj binderr.obj bindgen.obj \ bindusg.obj butil.obj debug.obj errcount.obj excep.obj gnatvsn.obj libfmt.obj GNATBIND_OBJS2 = limits.obj namet.obj opt.obj osint.obj output.obj switch.obj sysid.obj system.obj \ system-assertions.obj system-traceback.obj system_environment.obj \ types.obj unixlib.obj a-adaint.obj GNATBIND_OBJS = $(GNATBIND_OBJS1) $(GNATBIND_OBJS2) # Files specific to the C interpreter bytecode compiler(s). BC_OBJS = bc-emit.obj bc-optab.obj # Language-independent object files. OBJS1 = toplev.obj version.obj tree.obj print-tree.obj stor-layout.obj fold-const.obj \ function.obj stmt.obj expr.obj calls.obj expmed.obj explow.obj optabs.obj varasm.obj OBJS2 = rtl.obj print-rtl.obj rtlanal.obj emit-rtl.obj real.obj \ dbxout.obj sdbout.obj dwarfout.obj xcoffout.obj OBJS3 = integrate.obj jump.obj cse.obj loop.obj unroll.obj flow.obj stupid.obj combine.obj \ regclass.obj local-alloc.obj global.obj reload.obj reload1.obj caller-save.obj OBJS4 = insn-peep.obj reorg.obj sched.obj final.obj recog.obj reg-stack.obj \ insn-opinit.obj insn-recog.obj insn-extract.obj insn-output.obj insn-emit.obj \ insn-attrtab.obj aux-output.obj getpwd.obj convert.obj $(EXTRA_OBJS) OBJS = $(OBJS1) $(OBJS2) $(OBJS3) $(OBJS4) # GEN files are listed separately, so they can be built before doing parallel # makes for cc1 or cc1plus. Otherwise sequent parallel make attempts to load # them before rtl.obj is compiled. GEN= genemit.exe genoutput.exe genrecog.exe genextract.exe genflags.exe gencodes.exe genconfig.exe genpeep.exe # Files to be copied away after each stage in building. STAGESTUFF = *.obj insn-flags.h insn-config.h insn-codes.h \ insn-output.c insn-recog.c insn-emit.c insn-extract.c insn-peep.c \ insn-attr.h insn-attrtab.c insn-opinit.c \ stamp-flags stamp-config stamp-codes \ stamp-output stamp-recog stamp-emit stamp-extract stamp-peep \ stamp-attr stamp-attrtab stamp-opinit stamp-proto \ genemit.exe genoutput.exe genrecog.exe genextract.exe genflags.exe gencodes.exe genconfig.exe genpeep.exe \ genattrtab.exe genattr.exe genopinit.exe \ bc-arity.h bc-opcode.h bc-opname.h \ stamp-bcarity stamp-bcopcode stamp-bcopname \ bi-arity bi-opcode bi-opname \ $(GCC_PASSES) $(EXTRA_PARTS) $(EXTRA_PROGRAMS) gcc-cross cccp.exe g++.exe g++-cross \ cc1plus.exe cc1obj.exe enquire.exe protoize.exe unprotoize.exe specs collect2.exe $(USE_COLLECT2) # Members of gcc1.lib. LIB1FUNCS1 = _mulsi3 _udivsi3 _divsi3 _umodsi3 _modsi3 \ _lshrsi3 _lshlsi3 _ashrsi3 _ashlsi3 \ _divdf3 _muldf3 _negdf2 _adddf3 _subdf3 LIB1FUNCS2 = _fixdfsi _fixsfsi _floatsidf _floatsisf _truncdfsf2 _extendsfdf2 \ _addsf3 _negsf2 _subsf3 _mulsf3 _divsf3 LIB1FUNCS3 = _eqdf2 _nedf2 _gtdf2 _gedf2 _ltdf2 _ledf2 \ _eqsf2 _nesf2 _gtsf2 _gesf2 _ltsf2 _lesf2 LIB1FUNCS = $(LIB1FUNCS1) $(LIB1FUNCS2) $(LIB1FUNCS3) # Library members defined in libgcc2.c. LIB2FUNCS1 = _muldi3 _divdi3 _moddi3 _udivdi3 _umoddi3 _negdi2 \ _lshrdi3 _lshldi3 _ashldi3 _ashrdi3 _ffsdi2 LIB2FUNCS2 = _udiv_w_sdiv _udivmoddi4 _cmpdi2 _ucmpdi2 _floatdidf _floatdisf \ _fixunsdfsi _fixunssfsi _fixunsdfdi _fixdfdi _fixunssfdi _fixsfdi \ _fixxfdi _fixunsxfdi _floatdixf _fixunsxfsi LIB2FUNCS3 = _fixtfdi _fixunstfdi _floatditf \ __gcc_bcmp _varargs _eprintf _op_new _new_handler _op_delete \ _bb _shtab _clear_cache _trampoline __main _exit _ctors LIB2FUNCS = $(LIB2FUNCS1) $(LIB2FUNCS2) $(LIB2FUNCS3) # Header files that are made available under the same name # to programs compiled with GCC. USER_H = va-alpha.h va-h8300.h va-i860.h va-i960.h va-mips.h va-m88k.h \ va-pa.h va-pyr.h va-sparc.h va-clipper.h va-spur.h proto.h $(EXTRA_HEADERS) # The files that "belong" in CONFIG_H are deliberately omitted # because having them there would not be useful in actual practice. # All they would do is cause complete recompilation every time # one of the machine description files is edited. # That may or may not be what one wants to do. # If it is, rm *.obj is an easy way to do it. # CONFIG_H = config.h tm.h CONFIG_H = RTL_H = rtl.h rtl.def machmode.h machmode.def TREE_H = tree.h real.h tree.def machmode.h machmode.def CPLUS_TREE_H = $(TREE_H) cp-tree.h cp-tree.def BYTECODE_H = bytecode.h bc-emit.h bc-optab.h # Avoid a lot of time thinking about remaking Makefile.in and *.def. .SUFFIXES: .in .def # Say how to compile Ada programs. .SUFFIXES: .ada .adb .ads ADA_FLAGS = $(ALL_CFLAGS) -gnatg -gnata GNATBIND = gnatbind .ada.obj: $(CC) -c $(ADA_FLAGS) $< .adb.obj: $(CC) -c $(ADA_FLAGS) $< .ads.obj: $(CC) -c $(ADA_FLAGS) $< Makefile: $(srcdir)\Makefile.in $(srcdir)\configure $(srcdir)\version.c \ $(srcdir)\config\$(xmake_file) $(srcdir)\config\$(tmake_file) sh config.status all.internal: start.encap rest.encap # This is what to compile if making a cross-compiler. all.cross: native gcc-cross g++-cross specs $(LIBGCC) stmp-headers $(STMP_FIXPROTO) $(CROSS_TEST) $(ENQUIRE) $(EXTRA_PARTS) # This is what to compile if making gcc with a cross-compiler. all.build: native xgcc g++.exe $(EXTRA_PARTS) # This is what must be made before installing GCC and converting libraries. start.encap: native xgcc.exe specs $(LIBGCC1) xlimits.h # Use this to make a GCC that will be used only to recompile GCC. for-bootstrap: start.encap $(LIBGCC) # These can't be made, with COFF encapsulation, until after GCC can run. rest.encap: $(LIBGCC) gfloat.h $(STMP_FIXPROTO) $(EXTRA_PARTS) # This is what is made with the host's compiler # whether making a cross compiler or not. native: config.status cpp.exe $(LANGUAGES) $(EXTRA_PASSES) $(EXTRA_PROGRAMS) $(USE_COLLECT2) # Define the names for selecting languages in LANGUAGES. # Note that it would be nice to move the dependency on g++ # into the C++ rule, but that needs a little bit of work # to do the right thing within all.cross. C c : cc1.exe C++ c++: cc1plus.exe OBJC objc: cc1obj.exe objc-runtime OBJECTIVE-C objective-c: cc1obj.exe objc-runtime ADA Ada ada: gnat1.exe gnatbind.exe PROTO: proto.exe # Really, really stupid make features, such as SUN's KEEP_STATE, may force # a target to build even if it is up-to-date. So we must verify that # config.status does not exist before failing. config.status: config.h hconfig.h tconfig.h tm.h aux-output.c md CreateMiscFiles.cmd CreateMiscFiles # @if [ ! -f config.status ] ; then \ #! error You must configure gcc. Look at the INSTALL file for details. # false; \ # else \ # true; \ # fi config.h hconfig.h tconfig.h: $(srcdir)\config\i386\xm-os2.h -rm -f $@ copy $(srcdir)\config\i386\xm-os2.h $@ touch $@ tm.h: $(srcdir)\config\i386\os2.h -rm -f $@ copy $(srcdir)\config\i386\os2.h $@ touch $@ aux-output.c: $(srcdir)\config\i386\i386.c -rm -f $@ copy $(srcdir)\config\i386\i386.c $@ touch $@ md: $(srcdir)\config\i386\i386.md -rm -f $@ copy $(srcdir)\config\i386\i386.md $@ touch $@ # On the target machine, finish building a cross compiler. # This does the things that can't be done on the host machine. rest.cross: $(LIBGCC) gfloat.h specs # Verify that it works to compile and link cross-test. # If it does, then there are sufficient replacements for libgcc1.a. cross-test: cross-test.o native gcc-cross $(LIBGCC) $(GCC_PARTS) $(GCC_FOR_TARGET) $(GCC_CFLAGS) cross-test.o -o $@ cross-test.o: cross-test.c native gcc-cross $(GCC_FOR_TARGET) $(GCC_CFLAGS) $(ALL_CPPFLAGS) -c $(srcdir)/cross-test.c # Recompile all the language-independent object files. # This is used only if the user explicitly asks for it. compilations: $(OBJS) # We call this executable `xgcc' rather than `gcc' # to avoid confusion if the current directory is in the path # and CC is `gcc'. It is renamed to `gcc' when it is installed. xgcc.exe: config.status gcc.obj version.obj $(LIBDEPS) $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o xgcc.exe gcc.obj version.obj $(LIBS) # Dump a specs file to make -B.\ read these specs over installed ones. specs: xgcc.exe $(GCC_FOR_TARGET) -dumpspecs > specs # Create the compiler driver for g++. g++.exe: config.status g++.obj $(LIBDEPS) $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o g++.exe g++.obj $(LIBS) # We do want to create an executable named `xgcc', so we can use it to # compile libgcc2.a. # Also create gcc-cross, so that install-common will install properly. gcc-cross: xgcc copy xgcc gcc-cross # Create a version of the g++ driver which calls the cross-compiler. g++-cross: $(srcdir)/g++.c $(CC) $(ALL_CFLAGS) $(INCLUDES) $(LDFLAGS) -o g++-cross \ -DGCC_NAME=\"$(target)-gcc\" $(srcdir)/g++.c version.o $(LIBS) cc1.exe: config.status $(P) $(C_OBJS) $(OBJS) $(BC_OBJS) $(LIBDEPS) # $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o cc1.exe $(C_OBJS) $(OBJS) $(BC_OBJS) $(LIBS) rm -f cc1.lnk echo $(C_OBJS) + >cc1.lnk echo $(OBJS1) + >>cc1.lnk echo $(OBJS2) + >>cc1.lnk echo $(OBJS3) + >>cc1.lnk echo $(OBJS4) + >>cc1.lnk echo $(BC_OBJS) $(LIBS) >>cc1.lnk echo cc1 /NOI /DE /PM:VIO /align:16 /exepack /base:65536 /stack:4194304, NUL, libc os2; >>cc1.lnk link386 @cc1.lnk cc1plus.exe: config.status $(P) $(CPLUS_OBJS) $(OBJS) $(BC_OBJS) $(LIBDEPS) # $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o cc1plus.exe $(CPLUS_OBJS) $(BC_OBJS) $(OBJS) $(LIBS) rm -f cc1plus.lnk echo $(CPLUS_OBJS1) + >cc1plus.lnk echo $(CPLUS_OBJS2) + >>cc1plus.lnk echo $(CPLUS_OBJS3) + >>cc1plus.lnk echo $(OBJS1) + >>cc1plus.lnk echo $(OBJS2) + >>cc1plus.lnk echo $(OBJS3) + >>cc1plus.lnk echo $(OBJS4) + >>cc1plus.lnk echo $(BC_OBJS) $(LIBS) >>cc1plus.lnk echo cc1plus $(LDFLAGS) /NOI /DE /PM:VIO /align:16 /exepack /base:65536 /stack:4194304; >>cc1plus.lnk link386 @cc1plus.lnk cc1obj.exe: config.status $(P) $(OBJC_OBJS) $(OBJS) $(BC_OBJS) $(LIBDEPS) # $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o cc1obj.exe $(OBJC_OBJS) $(OBJS) $(BC_OBJS) $(LIBS) rm -f cc1obj.lnk echo $(OBJC_OBJS) + >cc1obj.lnk echo $(OBJS1) + >>cc1obj.lnk echo $(OBJS2) + >>cc1obj.lnk echo $(OBJS3) + >>cc1obj.lnk echo $(OBJS4) + >>cc1obj.lnk echo $(BC_OBJS) $(LIBS) >>cc1obj.lnk echo cc1obj $(LDFLAGS) /NOI /DE /PM:VIO /align:16 /exepack /base:65536 /stack:4194304; >>cc1obj.lnk link386 @cc1obj.lnk gnat1.exe: config.status $(P) $(GNAT1_OBJS) $(OBJS) $(BC_OBJS) $(LIBDEPS) # $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o gnat1.exe $(GNAT1_OBJS) $(OBJS) $(BC_OBJS) $(LIBS) rm -f gnat1.lnk echo $(GNAT1_C_OBJS) + >gnat1.lnk echo $(GNAT_ADA_OBJS1) + >>gnat1.lnk echo $(GNAT_ADA_OBJS2) + >>gnat1.lnk echo $(GNAT_ADA_OBJS3) + >>gnat1.lnk echo $(GNAT_ADA_OBJS4) + >>gnat1.lnk echo $(GNAT_ADA_OBJS5) + >>gnat1.lnk echo $(GNAT_ADA_OBJS6) + >>gnat1.lnk echo $(GNAT1_ADA_OBJS1) + >>gnat1.lnk echo $(OBJS1) + >>gnat1.lnk echo $(OBJS2) + >>gnat1.lnk echo $(OBJS3) + >>gnat1.lnk echo $(OBJS4) + >>gnat1.lnk echo $(BC_OBJS) $(LIBS) >>gnat1.lnk echo gnat1 /NOI /DE /PM:VIO /align:16 /exepack /base:65536 /stack:4194304, NUL, libc os2; >>gnat1.lnk link386 @gnat1.lnk gnatf.exe: $(P) $(GNATF_OBJS) bind_frontdrv.obj # $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o gnatf.exe $(GNATF_OBJS) bind_frontdrv.obj rm -f gnatf.lnk echo $(GNAT_ADA_OBJS1) + >gnatf.lnk echo $(GNAT_ADA_OBJS2) + >>gnatf.lnk echo $(GNAT_ADA_OBJS3) + >>gnatf.lnk echo $(GNAT_ADA_OBJS4) + >>gnatf.lnk echo $(GNAT_ADA_OBJS5) + >>gnatf.lnk echo $(GNAT_ADA_OBJS6) + >>gnatf.lnk echo $(GNATF_OBJS1) + >>gnatf.lnk echo bind_frontdrv.obj >>gnatf.lnk echo gnatf /NOI /DE /PM:VIO /align:16 /exepack /base:65536 /stack:4194304, NUL, libc os2; >>gnatf.lnk link386 @gnatf.lnk gnatbind.exe: $(P) $(GNATBIND_OBJS) bind_gnatbind.obj # $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o gnatbind.exe $(GNATBIND_OBJS) bind_gnatbind.obj rm -f gnatbind.lnk echo $(GNATBIND_OBJS1) + >gnatbind.lnk echo $(GNATBIND_OBJS2) bind_gnatbind.obj >>gnatbind.lnk echo gnatbind /NOI /DE /PM:VIO /align:16 /exepack /base:65536 /stack:4194304, NUL, libc os2; >>gnatbind.lnk link386 @gnatbind.lnk # .s files for cross-building gnat-cross: force $(MAKE) $(GNAT1_ADA_OBJS) CC="gcc -Bstage1/" CFLAGS="-S -gnatp" # Copy float.h from its source. gfloat.h: $(FLOAT_H) rm -f gfloat.h copy $(FLOAT_H) gfloat.h touch gfloat.h # Create float.h source for the native machine. float.h-nat: enquire.exe -.\enquire -f > tmp-float.h mv tmp-float.h float.h-nat # Create a dummy float.h source for a cross-compiler. float.h-cross: echo "#error float.h values not known for cross-compiler" > float.h-cross # Used to compile enquire with standard cc, but have forgotten why. # Let's try with GCC. enquire.exe: enquire.obj $(GCC_PARTS) $(GCC_FOR_TARGET) $(GCC_CFLAGS) $(ENQUIRE_LDFLAGS) enquire.obj -o $@ enquire.obj: $(srcdir)\enquire.c $(GCC_PASSES) # -if [ "$(srcdir)" != "." ]; then rm -f .\enquire.c; else true; fi # -cp $(srcdir)\enquire.c . > \dev\null 2>&1 # Breaking this line caused a problem with one version of GNU make. $(GCC_FOR_TARGET) $(GCC_CFLAGS) $(ALL_CPPFLAGS) $(ENQUIRE_CFLAGS) -I. -c $(srcdir)\enquire.c # Build the version of limits.h that we will install. xlimits.h: glimits.h limitx.h limity.h if exist $(SYSTEM_HEADER_DIR)\limits.h \ copy /a $(srcdir)\limitx.h+$(srcdir)\glimits.h+$(srcdir)\limity.h xlimits.h if not exist $(SYSTEM_HEADER_DIR)\limits.h \ copy $(srcdir)\glimits.h xlimits.h # Build gcc.lib. # This is done in two parts because some functions, in libgcc1.c, # must be compiled with something other than GCC, # while the rest, in libgcc2.c, must be compiled with xgcc. # That means we can't do libgcc2.c until after xgcc, cc1, etc. # Use this as value of LIBGCC1 to cause conversion to GNU library format. # LIBCONVERT should put its output in libgcc1.conv. libgcc1.conv: gcc1.lib $(LIBCONVERT) gcc1.lib libgcc1.conv # Use this as value of LIBGCC1 to inhibit use of libgcc1.c entirely. # Make an empty file instead. libgcc1.null: $(GCC_PASSES) echo "__foo () {}" > dummy.c $(GCC_FOR_TARGET) $(GCC_CFLAGS) -c dummy.c $(OLDAR) $(OLDAR_FLAGS) libgcc1.null dummy.obj; rm -f dummy.obj rm -f dummy.c # This is $(LIBGCC1) for a cross-compiler. # We have no automatic way of building libgcc1.a, # so it's up to the installer to find a way to do that. # This rule deliberately does not depend on libgcc1.a # so that it will fail if the installer hasn't provided it. libgcc1.cross: mv libgcc1.a libgcc1.cross || (echo You must find a way to make libgcc1.a; false) # Compile the library of arithmetic subroutines with the native compiler. # Don't compile it with GCC! # (That would cause most arithmetic functions to call themselves.) gcc1.lib: libgcc1.c $(CONFIG_H) $(LIB1FUNCS_EXTRA) config.status -rm -f tmpgcc1.lib # Actually build it in tmpgcc1.lib, then rename at end, # so that gcc1.lib itself remains nonexistent if compilation is aborted. # -e causes any failing command to make this rule fail. # -e doesn't work in certain shells, so we test $$? as well. # lynx has a broken ar, it always complains when the initial library is # empty, thus this command works only if we don't do -e # There is a trailing backslash (\) deleted from the following line. # set -e; for %%n in ($(LIB1FUNCS1)) do \ addtolib1 %%n $(srcdir)\libgcc1.c $(OLDCC) $(CCLIBFLAGS) for %%n in ($(LIB1FUNCS2)) do \ addtolib1 %%n $(srcdir)\libgcc1.c $(OLDCC) $(CCLIBFLAGS) for %%n in ($(LIB1FUNCS3)) do \ addtolib1 %%n $(srcdir)\libgcc1.c $(OLDCC) $(CCLIBFLAGS) # Some shells crash when a loop has no items. # So make sure there is always at least one--`..'. # Then ignore it. # We don't use -e here because there are if statements # that should not make the command give up when the if condition is false. # Instead, we test for failure after each command where it matters. ! if "$(LIB1FUNCS_EXTRA)" != "" -for file in .. $(LIB1FUNCS_EXTRA); \ do \ if [ x$${file} != x.. ]; then \ name=`echo $${file} | sed -e 's/[.]c$$//' -e 's/[.]asm$$//'`; \ echo $${name}; \ if [ $${name}.asm = $${file} ]; then \ cp $${file} $${name}.s || exit 1; file=$${name}.s; \ else true; fi; \ $(OLDCC) $(CCLIBFLAGS) $(INCLUDES) -c $${file}; \ if [ $$? -eq 0 ] ; then true; else exit 1; fi; \ $(OLDAR) $(OLDAR_FLAGS) tmpgcc1.lib $${name}.obj; \ if [ $$? -eq 0 ] ; then true; else exit 1; fi; \ rm -f $${name}.[so]; \ else true; \ fi; \ done ! endif rm -f gcc1.lib mv tmpgcc1.lib gcc1.lib # Compiling gcc2.lib requires making sure that cc1, etc. have been compiled. # But recompiling cc1 should not force recompilation of gcc2.lib. # If you want to force recompilation, delete gcc2.lib. # Depend on install-cross-tools to make sure we set up properly # to run the assembler before we try compiling anything. # install-cross-tools does nothing if not cross compiling. libgcc2.ready: $(GCC_PASSES) $(LIBGCC2_DEPS) -if not exist libgcc2.ready \ touch libgcc2.ready gcc2.lib: libgcc2.c libgcc2.ready $(CONFIG_H) $(LIB2FUNCS_EXTRA) \ machmode.h longlong.h gbl-ctors.h config.status # Actually build it in tmpgcc2.lib, then rename at end, # so that gcc2.lib itself remains nonexistent if compilation is aborted. -rm -f tmpgcc2.lib ! if "$(LIBGCC1)" != "" copy $(LIBGCC1) tmpgcc2.lib ! endif # -e causes any failing command to make this rule fail. # -e doesn't work in certain shells, so we test $$? as well. # lynx has a broken ar, it always complains when the initial library is # empty, thus this command works only if we don't do -e # There is a trailing backslash (\) deleted from the following line. # set -e; for %%n in ($(LIB2FUNCS1)) do \ addtolib2 %%n $(srcdir)\libgcc2.c $(GCC_FOR_TARGET) $(LIBGCC2_CFLAGS) for %%n in ($(LIB2FUNCS2)) do \ addtolib2 %%n $(srcdir)\libgcc2.c $(GCC_FOR_TARGET) $(LIBGCC2_CFLAGS) for %%n in ($(LIB2FUNCS3)) do \ addtolib2 %%n $(srcdir)\libgcc2.c $(GCC_FOR_TARGET) $(LIBGCC2_CFLAGS) # Some shells crash when a loop has no items. # So make sure there is always at least one--`..'. # Then ignore it. # We don't use -e here because there are if statements # that should not make the command give up when the if condition is false. # Instead, we test for failure after each command where it matters. ! if "$(LIB2FUNCS_EXTRA)" != "" -for file in .. $(LIB2FUNCS_EXTRA); \ do \ if [ x$${file} != x.. ]; then \ name=`echo $${file} | sed -e 's/[.]c$$//' -e 's/[.]asm$$//'`; \ echo $${name}; \ if [ $${name}.asm = $${file} ]; then \ cp $${file} $${name}.s || exit 1; file=$${name}.s; \ else true; fi; \ $(GCC_FOR_TARGET) $(LIBGCC2_CFLAGS) $(INCLUDES) -c $${file}; \ if [ $$? -eq 0 ] ; then true; else exit 1; fi; \ $(AR) $(AR_FLAGS) tmpgcc2.lib $${name}.obj; \ rm -f $${name}.[so]; \ else true; \ fi; \ done ! endif rm -f gcc2.lib mv tmpgcc2.lib gcc2.lib # These lines were deleted from above the mv command # because ranlibing libgcc.a itself should suffice. # -if [ x${HPUX_GAS} = x ] ; then \ # if $(RANLIB_TEST) ; then $(RANLIB) tmplibgcc2.a; else true; fi \ # else true; fi # Combine the various libraries into a single library, gcc.lib. gcc.lib: $(LIBGCC1) $(LIBGCC2) rm -f gcc.lib copy $(LIBGCC2) gcc.lib # -if $(RANLIB_TEST) ; then $(RANLIB) tmpgcc.lib; else true; fi # Actually build it in tmpgcc.lib, then rename at end, # so that gcc.lib itself remains nonexistent if compilation is aborted. # mv tmpgcc.lib gcc.lib objc-runtime: objc.lib # Build the Objective C runtime library. objc.lib: cc1obj libgcc2.ready if [ -d objc ]; then true; else mkdir objc; fi thisdir1=`pwd`; \ srcdir1=`cd $(srcdir); pwd`; \ cd objc; \ $(MAKE) -f $${srcdir1}\objc\Makefile objc.lib \ srcdir=$${srcdir1} tooldir=$(tooldir) AR="$(AR)" AR_FLAGS="$(AR_FLAGS)" \ GCC_FOR_TARGET="$${thisdir1}\xgcc" \ GCC_CFLAGS="-B$${thisdir1}\ $(GCC_CFLAGS)" -rm -f objc.lib ln objc\objc.lib . >\dev\null 2>&1 || cp objc\objc.lib . # -if $(RANLIB_TEST) ; then $(RANLIB) objc.lib; else true; fi # This is used by objc\Makefile if the user runs that directly. subobjc.lib: cc1obj libgcc2.ready thisdir1=`pwd`; \ srcdir1=`cd $(srcdir); pwd`; \ cd objc; \ $(MAKE) -f $$srcdir1\objc\Makefile objc.lib \ srcdir=$$srcdir1 tooldir=$(tooldir) AR="$(AR)" AR_FLAGS="$(AR_FLAGS)" \ GCC_FOR_TARGET="$$thisdir1\xgcc" \ GCC_CFLAGS="-B$$thisdir1\ $(GCC_CFLAGS)" # Compile two additional files that are linked with every program # linked using GCC on system V, for the sake of C++ constructors. crtbegin.obj: crtstuff.c $(GCC_PASSES) $(CONFIG_H) gbl-ctors.h $(GCC_FOR_TARGET) $(GCC_CFLAGS) $(INCLUDES) -DCRT_BEGIN \ -finhibit-size-directive -fno-inline-functions \ -g0 -c $(srcdir)\crtstuff.c -o crtbegin.obj crtend.obj: crtstuff.c $(GCC_PASSES) $(CONFIG_H) gbl-ctors.h $(GCC_FOR_TARGET) $(GCC_CFLAGS) $(INCLUDES) -DCRT_END \ -finhibit-size-directive -fno-inline-functions \ -g0 -c $(srcdir)\crtstuff.c -o crtend.obj # Compiling object files from source files. # Note that dependencies on obstack.h are not written # because that file is not part of GCC. # Dependencies on gvarargs.h are not written # because all that file does, when not compiling with GCC, # is include the system varargs.h. # C language specific files. c-parse.obj : $(srcdir)\c-parse.c $(CONFIG_H) $(TREE_H) c-lex.h c-parse.h \ c-tree.h input.h flags.h $(CC) $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) -c $(srcdir)\c-parse.c $(srcdir)\c-parse.c $(srcdir)\c-parse.h: $(srcdir)\c-parse.y #! IF "$(srcdir)" != "." # cd $(srcdir) #! ENDIF # $(BISON) $(BISONFLAGS) -d c-parse.y -o c-parse.c touch $(srcdir)\c-parse.c touch $(srcdir)\c-parse.h $(srcdir)\c-parse.y: $(srcdir)\c-parse.in # sed -e "/^ifobjc$$/,/^end ifobjc$$/d" \ # -e "/^ifc$$/d" -e "/^end ifc$$/d" \ # $(srcdir)/c-parse.in > $(srcdir)/c-parse.y touch $(srcdir)\c-parse.y c-decl.obj : c-decl.c $(CONFIG_H) $(TREE_H) c-tree.h c-lex.h flags.h c-typeck.obj : c-typeck.c $(CONFIG_H) $(TREE_H) c-tree.h flags.h c-lang.obj : c-lang.c $(CONFIG_H) $(TREE_H) c-lex.obj : c-lex.c $(CONFIG_H) $(TREE_H) c-lex.h c-tree.h c-parse.h \ input.h flags.h c-aux-info.obj : c-aux-info.c $(CONFIG_H) $(TREE_H) c-tree.h flags.h c-convert.obj : c-convert.c $(CONFIG_H) $(TREE_H) flags.h c-pragma.obj: c-pragma.c $(CONFIG_H) $(TREE_H) c-iterate.obj: c-iterate.c $(CONFIG_H) $(TREE_H) $(RTL_H) c-tree.h flags.h # C++ language specific files. cp-parse.obj : $(srcdir)\cp-parse.c $(CONFIG_H) $(CPLUS_TREE_H) flags.h cp-lex.h ! IF "$(srcdir)" == "." $(CC) -c $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) cp-parse.c ! ELSE $(CC) -c $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) $(srcdir)\cp-parse.c ! ENDIF $(srcdir)\cp-parse.c $(srcdir)\cp-parse.h : $(srcdir)\cp-parse.y @echo expect 27 shift/reduce conflicts and 14 reduce/reduce conflicts ! IF "$(srcdir)" != "." cd $(srcdir) ! ENDIF $(BISON) $(BISONFLAGS) -d -o cp-parse.c cp-parse.y ! IF "$(srcdir)" != "." cd $(srcdir) ! ENDIF grep '^#define[ ]*YYEMPTY' cp-parse.c >>cp-parse.h cp-spew.obj : cp-spew.c $(CONFIG_H) $(CPLUS_TREE_H) \ $(srcdir)\cp-parse.h flags.h cp-lex.h cp-lex.obj : cp-lex.c $(CONFIG_H) $(CPLUS_TREE_H) \ $(srcdir)\cp-parse.h $(srcdir)\cp-input.c flags.h cp-hash.h cp-lex.h cp-decl.obj : cp-decl.c $(CONFIG_H) $(CPLUS_TREE_H) flags.h \ cp-lex.h cp-decl.h stack.h cp-decl2.obj : cp-decl2.c $(CONFIG_H) $(CPLUS_TREE_H) flags.h \ cp-lex.h cp-decl.h cp-type2.obj : cp-type2.c $(CONFIG_H) $(CPLUS_TREE_H) flags.h cp-typeck.obj : cp-typeck.c $(CONFIG_H) $(CPLUS_TREE_H) flags.h $(RTL_H) cp-class.obj : cp-class.c $(CONFIG_H) $(CPLUS_TREE_H) flags.h cp-call.obj : cp-call.c $(CONFIG_H) $(CPLUS_TREE_H) flags.h cp-init.obj : cp-init.c $(CONFIG_H) $(CPLUS_TREE_H) flags.h $(RTL_H) cp-method.obj : cp-method.c $(CONFIG_H) $(CPLUS_TREE_H) cp-cvt.obj : cp-cvt.c $(CONFIG_H) $(CPLUS_TREE_H) cp-search.obj : cp-search.c $(CONFIG_H) $(CPLUS_TREE_H) stack.h flags.h cp-tree.obj : cp-tree.c $(CONFIG_H) $(CPLUS_TREE_H) flags.h cp-ptree.obj : cp-ptree.c $(CONFIG_H) $(CPLUS_TREE_H) cp-gc.obj : cp-gc.c $(CONFIG_H) $(CPLUS_TREE_H) flags.h cp-except.obj : cp-except.c $(CONFIG_H) $(CPLUS_TREE_H) flags.h $(RTL_H) cp-expr.obj : cp-expr.c $(CONFIG_H) $(CPLUS_TREE_H) $(RTL_H) flags.h \ expr.h insn-codes.h cp-edsel.obj : cp-edsel.c $(CONFIG_H) $(CPLUS_TREE_H) stack.h flags.h cp-xref.obj : cp-xref.c $(CONFIG_H) $(CPLUS_TREE_H) input.h cp-pt.obj : cp-pt.c $(CONFIG_H) $(CPLUS_TREE_H) cp-decl.h cp-parse.h cp-error.obj : cp-error.c $(CONFIG_H) $(CPLUS_TREE_H) cp-errfn.obj : cp-errfn.c $(CONFIG_H) $(CPLUS_TREE_H) g++.obj : g++.c $(CONFIG_H) gvarargs.h # Ada language specific files. ada_extra_files : treeprs.ads sysid.ads a-einfo.h a-sinfo.h nmake.adb \ nmake.ads bind_gnat1drv.c : $(GNAT1_ADA_OBJS) $(GNATBIND) -n gnat1drv.ali bind_gnat1drv.obj : bind_gnat1drv.c bind_frontdrv.c : $(GNATF_OBJS) $(GNATBIND) frontdrv.ali bind_frontdrv.obj : bind_frontdrv.c bind_gnatbind.c : $(GNATBIND_OBJS) $(GNATBIND) gnatbind.ali bind_gnatbind.obj : bind_gnatbind.c treeprs.ads : treeprs.adt sinfo.ads xtreeprs.spt gtreeprs sysid.ads : sysid~d.ads rm -f sysid.ads copy sysid~d.ads sysid.ads touch sysid.ads a-einfo.h : einfo.ads einfo.adb xeinfo.spt xeinfo a-sinfo.h : sinfo.ads xsinfo.spt xsinfo nmake.adb : nmake.adt sinfo.ads xnmake.spt gnmake -b nmake.ads : nmake.adt sinfo.ads xnmake.spt gnmake -s mk-ttypes.obj : mk-ttypes.c hconfig.h machmode.h $(HOST_CC) -c $(HOST_CFLAGS) $(HOST_CPPFLAGS) $(INCLUDES) $(srcdir)\mk-ttypes.c mk-ttypes.exe : mk-ttypes.obj $(HOST_LIBDEPS) $(HOST_CC) $(HOST_CFLAGS) $(HOST_LDFLAGS) -o mk-ttypes.exe \ mk-ttypes.obj $(HOST_LIBS) ttypes.ads: stamp-ttypes stamp-ttypes : ttypes.adt mk-ttypes.exe $(srcdir)\move-if-change.cmd .\mk-ttypes ttypes.adt > tmp-ttypes.ads $(srcdir)\move-if-change tmp-ttypes.ads ttypes.ads touch stamp-ttypes mk-ttypes-fpt.obj : mk-ttypes-fpt.c hconfig.h $(HOST_CC) -c $(HOST_CFLAGS) $(HOST_CPPFLAGS) $(INCLUDES) $(srcdir)\mk-ttypes-fpt.c mk-ttypes-fpt.exe : mk-ttypes-fpt.obj $(HOST_LIBDEPS) $(HOST_CC) $(HOST_CFLAGS) $(HOST_LDFLAGS) -o mk-ttypes-fpt.exe \ mk-ttypes-fpt.obj $(HOST_LIBS) ttypes-fpt.ads: stamp-ttypes-fpt stamp-ttypes-fpt : ttypes-fpt.adt mk-ttypes-fpt.exe $(srcdir)\move-if-change.cmd .\mk-ttypes-fpt ttypes-fpt.adt > tmp-ttypes-fpt.ads $(srcdir)\move-if-change tmp-ttypes-fpt.ads ttypes-fpt.ads touch stamp-ttypes-fpt A_MISC_H = a-misc.h a-tree.def a-adaint.obj : $(CONFIG_H) a-gtran3.obj : $(CONFIG_H) $(TREE_H) obstack.h flags.h convert.h a-ada.h \ a-types.h a-atree.h a-sinfo.h a-einfo.h a-namet.h a-string.h a-uint.h \ a-trans.h a-trans3.h a-trans4.h a-gtran3.h $(A_MISC_H) a-rtree.h a-ptypes.obj : $(CONFIG_H) a-misc.obj : $(CONFIG_H) $(TREE_H) a-ada.h a-types.h a-atree.h a-sinfo.h \ a-einfo.h a-namet.h a-string.h a-uint.h a-trans.h a-trans3.h $(A_MISC_H) \ a-rtree.h flags.h $(RTL_H) expr.h insn-codes.h a-trans3.obj : $(CONFIG_H) $(TREE_H) flags.h a-ada.h a-types.h a-atree.h \ a-sinfo.h a-einfo.h a-namet.h a-string.h a-uint.h a-trans.h a-gtran3.h \ a-trans3.h a-trans4.h $(A_MISC_H) a-rtree.h convert.h a-trans4.obj : $(CONFIG_H) $(TREE_H) flags.h a-ada.h a-types.h a-atree.h \ a-sinfo.h a-einfo.h a-namet.h a-string.h a-uint.h a-trans.h a-trans3.h \ a-trans4.h $(A_MISC_H) a-trans.obj : $(CONFIG_H) $(TREE_H) flags.h a-ada.h a-types.h a-atree.h \ a-sinfo.h a-einfo.h a-namet.h a-string.h a-uint.h a-trans.h a-trans3.h \ a-gtran3.h a-trans4.h $(A_MISC_H) a-rtree.h a-uint.obj : $(CONFIG_H) $(TREE_H) a-ada.h a-types.h a-atree.h a-sinfo.h \ a-einfo.h a-namet.h a-string.h a-uint.h ali.obj : ali.ads ali.adb alloc.ads binderr.ads butil.ads debug.ads \ limits.ads namet.ads opt.ads osint.ads output.ads system.ads table.ads \ table.adb types.ads unchecked_deallocation.ads \ unchecked_deallocation.adb alloc.obj : alloc.ads atree.obj : alloc.ads atree.ads atree.adb atree-ts.adb comperr.ads debug.ads \ einfo.ads output.ads sinfo.ads system.ads system-assertions.ads \ table.ads table.adb types.ads unchecked_conversion.ads \ unchecked_conversion.adb unchecked_deallocation.ads \ unchecked_deallocation.adb back_end.obj : alloc.ads atree.ads back_end.ads back_end.adb casing.ads \ debug.ads einfo.ads lib.ads limits.ads namet.ads output.ads sinfo.ads \ stringt.ads system.ads table.ads table.adb types.ads uintp.ads \ unchecked_deallocation.ads unchecked_deallocation.adb bcheck.obj : ali.ads alloc.ads bcheck.ads bcheck.adb binderr.ads debug.ads \ gnatvsn.ads libfmt.ads limits.ads namet.ads opt.ads output.ads \ system.ads table.ads table.adb types.ads unchecked_deallocation.ads \ unchecked_deallocation.adb binde.obj : ali.ads alloc.ads binde.ads binde.adb binderr.ads butil.ads \ debug.ads limits.ads namet.ads opt.ads output.ads system.ads table.ads \ table.adb types.ads unchecked_deallocation.ads \ unchecked_deallocation.adb binderr.obj : alloc.ads binderr.ads binderr.adb butil.ads debug.ads \ errcount.ads excep.ads limits.ads namet.ads opt.ads osint.ads \ output.ads system.ads system-traceback.ads table.ads table.adb \ types.ads unchecked_deallocation.ads unchecked_deallocation.adb bindgen.obj : ali.ads alloc.ads binde.ads bindgen.ads bindgen.adb debug.ads \ limits.ads namet.ads opt.ads osint.ads output.ads system.ads table.ads \ table.adb types.ads unchecked_deallocation.ads \ unchecked_deallocation.adb bindusg.obj : bindusg.ads bindusg.adb osint.ads output.ads sysid.ads \ system.ads types.ads unchecked_deallocation.ads \ unchecked_deallocation.adb butil.obj : alloc.ads butil.ads butil.adb debug.ads limits.ads namet.ads \ output.ads system.ads table.ads table.adb types.ads \ unchecked_deallocation.ads unchecked_deallocation.adb casing.obj : alloc.ads casing.ads casing.adb csets.ads debug.ads limits.ads \ namet.ads output.ads scans.ads system.ads table.ads table.adb types.ads \ unchecked_deallocation.ads unchecked_deallocation.adb comperr.obj : comperr.ads comperr.adb debug.ads errcount.ads excep.ads \ osint.ads output.ads system.ads system-traceback.ads treepr.ads \ types.ads unchecked_deallocation.ads unchecked_deallocation.adb csets.obj : csets.ads csets.adb opt.ads system.ads types.ads \ unchecked_deallocation.ads unchecked_deallocation.adb debug.obj : debug.ads debug.adb output.ads system.ads types.ads \ unchecked_deallocation.ads unchecked_deallocation.adb debug_sem.obj : alloc.ads atree.ads debug.ads debug_sem.ads debug_sem.adb \ einfo.ads output.ads sinfo.ads sinput.ads system.ads table.ads \ table.adb types.ads unchecked_deallocation.ads \ unchecked_deallocation.adb einfo.obj : alloc.ads atree.ads comperr.ads debug.ads einfo.ads einfo.adb \ limits.ads namet.ads output.ads sinfo.ads snames.ads system.ads \ system-assertions.ads table.ads table.adb types.ads \ unchecked_deallocation.ads unchecked_deallocation.adb errcount.obj : errcount.ads system.ads types.ads unchecked_deallocation.ads \ unchecked_deallocation.adb errout.obj : alloc.ads atree.ads casing.ads csets.ads debug.ads einfo.ads \ errcount.ads errout.ads errout.adb excep.ads exp_util.ads lib.ads \ limits.ads namet.ads opt.ads output.ads scans.ads sinfo.ads sinput.ads \ stand.ads system.ads table.ads table.adb types.ads uintp.ads uname.ads \ unchecked_deallocation.ads unchecked_deallocation.adb excep.obj : excep.ads exp_attr.obj : alloc.ads atree.ads debug.ads einfo.ads exp_attr.ads \ exp_attr.adb exp_ch9.ads limits.ads namet.ads nmake.ads opt.ads \ output.ads rtsfind.ads sem.ads sem_res.ads sinfo.ads snames.ads \ stand.ads system.ads table.ads table.adb tbuild.ads ttypes.ads \ types.ads uintp.ads unchecked_deallocation.ads \ unchecked_deallocation.adb exp_ch10.obj : exp_ch10.ads exp_ch11.obj : exp_ch11.ads exp_ch12.obj : exp_ch12.ads exp_ch13.obj : alloc.ads atree.ads debug.ads einfo.ads exp_ch13.ads \ exp_ch13.adb exp_ch3.ads nmake.ads output.ads rtsfind.ads sinfo.ads \ snames.ads system.ads table.ads table.adb tbuild.ads types.ads \ unchecked_deallocation.ads unchecked_deallocation.adb exp_ch2.obj : alloc.ads atree.ads debug.ads einfo.ads exp_ch2.ads \ exp_ch2.adb output.ads sinfo.ads system.ads table.ads table.adb \ types.ads unchecked_deallocation.ads unchecked_deallocation.adb exp_ch3.obj : alloc.ads atree.ads comperr.ads debug.ads einfo.ads \ exp_ch3.ads exp_ch3.adb exp_ch9.ads exp_util.ads limits.ads namet.ads \ nmake.ads opt.ads output.ads rtsfind.ads sem.ads sem_ch3.ads \ sem_res.ads sem_util.ads sinfo.ads snames.ads stand.ads system.ads \ system-assertions.ads table.ads table.adb tbuild.ads types.ads \ uintp.ads unchecked_deallocation.ads unchecked_deallocation.adb exp_ch4.obj : alloc.ads atree.ads comperr.ads debug.ads einfo.ads \ exp_ch4.ads exp_ch4.adb exp_ch9.ads exp_util.ads limits.ads namet.ads \ nmake.ads opt.ads output.ads rtsfind.ads sem.ads sem_eval.ads \ sem_res.ads sem_util.ads sinfo.ads snames.ads stand.ads system.ads \ table.ads table.adb tbuild.ads types.ads uintp.ads \ unchecked_deallocation.ads unchecked_deallocation.adb exp_ch5.obj : alloc.ads atree.ads debug.ads einfo.ads exp_ch5.ads \ exp_ch5.adb exp_ch9.ads exp_util.ads nmake.ads opt.ads output.ads \ rtsfind.ads sem.ads sem_util.ads sinfo.ads snames.ads system.ads \ table.ads table.adb tbuild.ads types.ads unchecked_deallocation.ads \ unchecked_deallocation.adb exp_ch6.obj : alloc.ads atree.ads comperr.ads debug.ads einfo.ads errout.ads \ exp_ch6.ads exp_ch6.adb exp_ch9.ads exp_util.ads limits.ads namet.ads \ nmake.ads opt.ads output.ads rtsfind.ads sem.ads sem_ch3.ads \ sem_disp.ads sem_util.ads sinfo.ads snames.ads stand.ads system.ads \ system-assertions.ads table.ads table.adb tbuild.ads types.ads \ uintp.ads unchecked_deallocation.ads unchecked_deallocation.adb exp_ch7.obj : exp_ch7.ads exp_ch7.adb exp_ch9.ads system.ads types.ads \ unchecked_deallocation.adb exp_ch8.obj : exp_ch8.ads exp_ch9.obj : alloc.ads atree.ads comperr.ads debug.ads einfo.ads \ exp_ch3.ads exp_ch9.ads exp_ch9.adb exp_util.ads limits.ads namet.ads \ nmake.ads opt.ads output.ads rtsfind.ads sem.ads sem_res.ads sinfo.ads \ snames.ads stand.ads system.ads system-assertions.ads table.ads \ table.adb tbuild.ads types.ads uintp.ads unchecked_deallocation.ads \ unchecked_deallocation.adb exp_prag.obj : alloc.ads atree.ads comperr.ads debug.ads einfo.ads \ exp_prag.ads exp_prag.adb exp_util.ads nmake.ads opt.ads output.ads \ rtsfind.ads sem.ads sinfo.ads snames.ads system.ads \ system-assertions.ads table.ads table.adb tbuild.ads types.ads \ unchecked_deallocation.ads unchecked_deallocation.adb exp_util.obj : alloc.ads atree.ads casing.ads debug.ads einfo.ads \ errcount.ads exp_util.ads exp_util.adb lib.ads limits.ads namet.ads \ nmake.ads opt.ads output.ads rtsfind.ads sem.ads sem_ch13.ads \ sem_res.ads sem_util.ads sinfo.ads sinput.ads snames.ads stand.ads \ system.ads system-assertions.ads table.ads table.adb tbuild.ads \ ttypes.ads types.ads uintp.ads unchecked_deallocation.ads \ unchecked_deallocation.adb expand.obj : alloc.ads atree.ads debug.ads debug_sem.ads einfo.ads \ exp_attr.ads exp_ch10.ads exp_ch11.ads exp_ch12.ads exp_ch13.ads \ exp_ch2.ads exp_ch3.ads exp_ch4.ads exp_ch5.ads exp_ch6.ads exp_ch7.ads \ exp_ch8.ads exp_ch9.ads exp_prag.ads exp_util.ads expand.ads expand.adb \ opt.ads output.ads sinfo.ads sinput.ads system.ads table.ads table.adb \ types.ads unchecked_deallocation.ads unchecked_deallocation.adb fname.obj : alloc.ads comperr.ads csets.ads debug.ads fname.ads fname.adb \ limits.ads namet.ads opt.ads osint.ads output.ads system.ads \ system-assertions.ads table.ads table.adb types.ads \ unchecked_deallocation.ads unchecked_deallocation.adb frontend.obj : alloc.ads atree.ads casing.ads debug.ads einfo.ads errout.ads \ frontend.ads frontend.adb lib.ads limits.ads namet.ads opt.ads \ output.ads par.ads rtsfind.ads scn.ads sem.ads sinfo.ads snames.ads \ sprint.ads stand.ads stringt.ads system.ads table.ads table.adb \ treepr.ads types.ads uintp.ads unchecked_deallocation.ads \ unchecked_deallocation.adb usage.ads gnat1drv.obj : alloc.ads atree.ads back_end.ads casing.ads comperr.ads \ csets.ads debug.ads einfo.ads errcount.ads errout.ads excep.ads \ frontend.ads gnat1drv.ads gnat1drv.adb gnatvsn.ads lib.ads limits.ads \ namet.ads opt.ads osint.ads output.ads par.ads sinfo.ads system.ads \ system-assertions.ads table.ads table.adb types.ads \ unchecked_deallocation.ads unchecked_deallocation.adb usage.ads gnatbind.obj : ali.ads alloc.ads bcheck.ads binde.ads binderr.ads \ bindgen.ads bindusg.ads butil.ads debug.ads errcount.ads excep.ads \ gnatbind.adb gnatvsn.ads libfmt.ads limits.ads namet.ads opt.ads \ osint.ads output.ads system.ads table.ads table.adb types.ads \ unchecked_deallocation.ads unchecked_deallocation.adb gnatvsn.obj : gnatvsn.ads system.ads types.ads unchecked_deallocation.ads \ unchecked_deallocation.adb lib.obj : alloc.ads atree.ads casing.ads debug.ads einfo.ads errout.ads \ fname.ads gnatvsn.ads lib.ads lib.adb lib-list.adb lib-load.adb \ lib-sort.adb lib-writ.adb libfmt.ads limits.ads namet.ads osint.ads \ output.ads par.ads scn.ads sinfo.ads system.ads table.ads table.adb \ types.ads uname.ads unchecked_deallocation.ads \ unchecked_deallocation.adb libfmt.obj : libfmt.ads system.ads types.ads unchecked_deallocation.ads \ unchecked_deallocation.adb limits.obj : limits.ads namet.obj : alloc.ads debug.ads limits.ads namet.ads namet.adb namet-ch.adb \ output.ads system.ads system-assertions.ads table.ads table.adb \ types.ads unchecked_deallocation.ads unchecked_deallocation.adb nmake.obj : alloc.ads atree.ads debug.ads einfo.ads nmake.ads nmake.adb \ output.ads sinfo.ads snames.ads system.ads table.ads table.adb \ types.ads unchecked_deallocation.ads unchecked_deallocation.adb opt.obj : opt.ads system.ads types.ads unchecked_deallocation.ads \ unchecked_deallocation.adb osint.obj : alloc.ads debug.ads limits.ads namet.ads opt.ads osint.ads \ osint.adb output.ads switch.ads sysid.ads system.ads \ system-assertions.ads system_environment.ads table.ads table.adb \ types.ads unchecked_deallocation.ads unchecked_deallocation.adb \ unixlib.ads output.obj : output.ads output.adb system.ads types.ads \ unchecked_deallocation.ads unchecked_deallocation.adb unixlib.ads par.obj : alloc.ads atree.ads casing.ads comperr.ads csets.ads debug.ads \ einfo.ads errout.ads excep.ads fname.ads lib.ads limits.ads namet.ads \ nmake.ads opt.ads output.ads par.ads par.adb par-ch10.adb par-ch11.adb \ par-ch12.adb par-ch13.adb par-ch2.adb par-ch3.adb par-ch4.adb \ par-ch5.adb par-ch6.adb par-ch7.adb par-ch8.adb par-ch9.adb \ par-endh.adb par-labl.adb par-load.adb par-prag.adb par-sync.adb \ par-tchk.adb par-util.adb scans.ads scn.ads sinfo.ads sinfo-change.ads \ sinput.ads snames.ads system.ads table.ads table.adb tbuild.ads \ types.ads uintp.ads uname.ads unchecked_deallocation.ads \ unchecked_deallocation.adb rtsfind.obj : alloc.ads atree.ads casing.ads comperr.ads csets.ads debug.ads \ einfo.ads excep.ads fname.ads lib.ads limits.ads namet.ads nmake.ads \ opt.ads output.ads rtsfind.ads rtsfind.adb sem.ads sem_util.ads \ sinfo.ads snames.ads system.ads table.ads table.adb tbuild.ads \ types.ads unchecked_deallocation.ads unchecked_deallocation.adb scans.obj : scans.ads scans.adb system.ads types.ads \ unchecked_deallocation.ads unchecked_deallocation.adb scn.obj : alloc.ads atree.ads casing.ads csets.ads debug.ads einfo.ads \ errout.ads lib.ads limits.ads namet.ads opt.ads output.ads scans.ads \ scn.ads scn.adb scn-nlit.adb scn-slit.adb sinfo.ads sinput.ads \ snames.ads stringt.ads system.ads table.ads table.adb types.ads \ uintp.ads unchecked_deallocation.ads unchecked_deallocation.adb sem.obj : alloc.ads atree.ads casing.ads comperr.ads debug.ads debug_sem.ads \ einfo.ads errout.ads exp_util.ads expand.ads lib.ads limits.ads \ namet.ads opt.ads output.ads sem.ads sem.adb sem_attr.ads sem_ch10.ads \ sem_ch11.ads sem_ch12.ads sem_ch13.ads sem_ch3.ads sem_ch4.ads \ sem_ch5.ads sem_ch6.ads sem_ch7.ads sem_ch8.ads sem_ch9.ads \ sem_prag.ads sem_util.ads sinfo.ads sinput.ads snames.ads stand.ads \ system.ads table.ads table.adb types.ads unchecked_deallocation.ads \ unchecked_deallocation.adb sem_attr.obj : alloc.ads atree.ads debug.ads einfo.ads errout.ads limits.ads \ namet.ads nmake.ads opt.ads output.ads rtsfind.ads sem.ads sem_attr.ads \ sem_attr.adb sem_ch6.ads sem_ch8.ads sem_eval.ads sem_res.ads \ sem_type.ads sem_util.ads sinfo.ads snames.ads stand.ads system.ads \ table.ads table.adb tbuild.ads types.ads uintp.ads \ unchecked_deallocation.ads unchecked_deallocation.adb sem_ch10.obj : alloc.ads atree.ads casing.ads debug.ads einfo.ads \ errcount.ads errout.ads lib.ads limits.ads namet.ads nmake.ads opt.ads \ output.ads sem.ads sem_ch10.ads sem_ch10.adb sem_ch6.ads sem_ch7.ads \ sem_ch8.ads sem_util.ads sinfo.ads sinfo-change.ads snames.ads \ stand.ads stringt.ads system.ads table.ads table.adb tbuild.ads \ types.ads uname.ads unchecked_deallocation.ads \ unchecked_deallocation.adb sem_ch11.obj : alloc.ads atree.ads debug.ads einfo.ads errout.ads limits.ads \ namet.ads opt.ads output.ads sem_ch11.ads sem_ch11.adb sem_ch5.ads \ sem_ch8.ads sem_util.ads sinfo.ads stand.ads system.ads table.ads \ table.adb types.ads unchecked_deallocation.ads \ unchecked_deallocation.adb sem_ch12.obj : alloc.ads atree.ads casing.ads comperr.ads debug.ads \ einfo.ads errout.ads exp_util.ads lib.ads limits.ads namet.ads opt.ads \ output.ads sem.ads sem_ch10.ads sem_ch12.ads sem_ch12.adb sem_ch13.ads \ sem_ch3.ads sem_ch6.ads sem_ch7.ads sem_ch8.ads sem_res.ads \ sem_util.ads sinfo.ads snames.ads stand.ads system.ads table.ads \ table.adb tbuild.ads types.ads unchecked_deallocation.ads \ unchecked_deallocation.adb sem_ch13.obj : alloc.ads atree.ads debug.ads einfo.ads errout.ads excep.ads \ limits.ads namet.ads nmake.ads opt.ads output.ads rtsfind.ads sem.ads \ sem_ch13.ads sem_ch13.adb sem_ch3.ads sem_ch8.ads sem_eval.ads \ sem_res.ads sem_util.ads sinfo.ads snames.ads stand.ads system.ads \ table.ads table.adb ttypes.ads types.ads uintp.ads \ unchecked_deallocation.ads unchecked_deallocation.adb sem_ch3.obj : alloc.ads atree.ads comperr.ads debug.ads einfo.ads errout.ads \ exp_util.ads limits.ads namet.ads nmake.ads opt.ads output.ads \ rtsfind.ads sem.ads sem_ch12.ads sem_ch13.ads sem_ch3.ads sem_ch3.adb \ sem_ch5.ads sem_ch6.ads sem_ch7.ads sem_ch8.ads sem_ch9.ads \ sem_eval.ads sem_res.ads sem_type.ads sem_util.ads sinfo.ads snames.ads \ stand.ads system.ads system-assertions.ads table.ads table.adb \ tbuild.ads ttypes.ads types.ads uintp.ads unchecked_deallocation.ads \ unchecked_deallocation.adb sem_ch4.obj : alloc.ads atree.ads debug.ads einfo.ads errout.ads \ exp_util.ads limits.ads namet.ads nmake.ads opt.ads output.ads sem.ads \ sem_ch3.ads sem_ch4.ads sem_ch4.adb sem_ch8.ads sem_type.ads \ sem_util.ads sinfo.ads snames.ads stand.ads system.ads table.ads \ table.adb tbuild.ads types.ads unchecked_deallocation.ads \ unchecked_deallocation.adb sem_ch5.obj : alloc.ads atree.ads comperr.ads debug.ads einfo.ads errout.ads \ limits.ads namet.ads opt.ads output.ads sem.ads sem_ch3.ads sem_ch5.ads \ sem_ch5.adb sem_ch8.ads sem_disp.ads sem_eval.ads sem_res.ads \ sem_type.ads sem_util.ads sinfo.ads snames.ads stand.ads system.ads \ table.ads table.adb types.ads uintp.ads unchecked_deallocation.ads \ unchecked_deallocation.adb sem_ch6.obj : alloc.ads atree.ads casing.ads debug.ads einfo.ads errout.ads \ exp_util.ads lib.ads limits.ads namet.ads nmake.ads opt.ads output.ads \ rtsfind.ads sem.ads sem_ch3.ads sem_ch4.ads sem_ch6.ads sem_ch6.adb \ sem_ch8.ads sem_ch9.ads sem_disp.ads sem_res.ads sem_util.ads sinfo.ads \ sinfo-change.ads snames.ads stand.ads stringt.ads system.ads table.ads \ table.adb tbuild.ads types.ads unchecked_deallocation.ads \ unchecked_deallocation.adb sem_ch7.obj : alloc.ads atree.ads casing.ads debug.ads einfo.ads errout.ads \ lib.ads limits.ads namet.ads opt.ads output.ads sem.ads sem_ch13.ads \ sem_ch3.ads sem_ch7.ads sem_ch7.adb sem_ch8.ads sem_util.ads sinfo.ads \ snames.ads stand.ads system.ads table.ads table.adb types.ads \ unchecked_deallocation.ads unchecked_deallocation.adb sem_ch8.obj : alloc.ads atree.ads comperr.ads debug.ads einfo.ads errout.ads \ limits.ads namet.ads nmake.ads opt.ads output.ads sem.ads sem_attr.ads \ sem_ch3.ads sem_ch4.ads sem_ch5.ads sem_ch6.ads sem_ch8.ads sem_ch8.adb \ sem_res.ads sem_type.ads sem_util.ads sinfo.ads sinfo-change.ads \ snames.ads stand.ads system.ads table.ads table.adb tbuild.ads \ types.ads unchecked_deallocation.ads unchecked_deallocation.adb sem_ch9.obj : alloc.ads atree.ads debug.ads einfo.ads errout.ads limits.ads \ namet.ads opt.ads output.ads sem.ads sem_ch3.ads sem_ch4.ads \ sem_ch5.ads sem_ch6.ads sem_ch8.ads sem_ch9.ads sem_ch9.adb sem_res.ads \ sem_util.ads sinfo.ads snames.ads stand.ads system.ads table.ads \ table.adb tbuild.ads ttypes.ads types.ads uintp.ads \ unchecked_deallocation.ads unchecked_deallocation.adb sem_disp.obj : alloc.ads atree.ads debug.ads einfo.ads errout.ads \ exp_ch6.ads output.ads sem_disp.ads sem_disp.adb sem_util.ads sinfo.ads \ system.ads table.ads table.adb types.ads unchecked_deallocation.ads \ unchecked_deallocation.adb sem_eval.obj : alloc.ads atree.ads comperr.ads debug.ads debug_sem.ads \ einfo.ads errout.ads excep.ads limits.ads namet.ads output.ads \ sem_eval.ads sem_eval.adb sem_util.ads sinfo.ads sinput.ads snames.ads \ stand.ads stringt.ads system.ads system-assertions.ads table.ads \ table.adb tbuild.ads types.ads uintp.ads unchecked_deallocation.ads \ unchecked_deallocation.adb sem_prag.obj : alloc.ads atree.ads debug.ads einfo.ads errout.ads limits.ads \ namet.ads nmake.ads opt.ads output.ads rtsfind.ads sem.ads sem_ch8.ads \ sem_eval.ads sem_prag.ads sem_prag.adb sem_res.ads sem_util.ads \ sinfo.ads snames.ads stand.ads system.ads table.ads table.adb \ tbuild.ads types.ads unchecked_deallocation.ads \ unchecked_deallocation.adb sem_res.obj : alloc.ads atree.ads comperr.ads debug.ads debug_sem.ads \ einfo.ads errout.ads expand.ads limits.ads namet.ads nmake.ads opt.ads \ output.ads rtsfind.ads sem.ads sem_attr.ads sem_ch3.ads sem_ch4.ads \ sem_ch5.ads sem_disp.ads sem_eval.ads sem_res.ads sem_res.adb \ sem_type.ads sem_util.ads sinfo.ads sinput.ads snames.ads stand.ads \ stringt.ads system.ads table.ads table.adb tbuild.ads types.ads \ uintp.ads unchecked_deallocation.ads unchecked_deallocation.adb sem_type.obj : alloc.ads atree.ads comperr.ads debug.ads einfo.ads \ errout.ads limits.ads namet.ads output.ads sem_ch6.ads sem_ch8.ads \ sem_type.ads sem_type.adb sem_util.ads sinfo.ads snames.ads stand.ads \ system.ads system-assertions.ads table.ads table.adb types.ads \ unchecked_deallocation.ads unchecked_deallocation.adb sem_util.obj : alloc.ads atree.ads casing.ads comperr.ads csets.ads \ debug.ads einfo.ads errout.ads lib.ads limits.ads namet.ads nmake.ads \ opt.ads output.ads sem.ads sem_eval.ads sem_res.ads sem_type.ads \ sem_util.ads sem_util.adb sinfo.ads sinput.ads snames.ads stand.ads \ system.ads table.ads table.adb tbuild.ads types.ads uintp.ads \ unchecked_deallocation.ads unchecked_deallocation.adb sinfo-change.obj : alloc.ads atree.ads debug.ads einfo.ads output.ads \ sinfo.ads sinfo-change.ads sinfo-change.adb system.ads table.ads \ table.adb types.ads unchecked_deallocation.ads \ unchecked_deallocation.adb sinfo.obj : alloc.ads atree.ads comperr.ads debug.ads einfo.ads output.ads \ sinfo.ads sinfo.adb system.ads system-assertions.ads table.ads \ table.adb types.ads unchecked_deallocation.ads \ unchecked_deallocation.adb sinput.obj : alloc.ads casing.ads debug.ads lib.ads limits.ads namet.ads \ output.ads scans.ads sinput.ads sinput.adb system.ads table.ads \ table.adb types.ads unchecked_deallocation.ads \ unchecked_deallocation.adb snames.obj : alloc.ads comperr.ads debug.ads limits.ads namet.ads output.ads \ snames.ads snames.adb system.ads table.ads table.adb types.ads \ unchecked_deallocation.ads unchecked_deallocation.adb sprint.obj : alloc.ads atree.ads casing.ads csets.ads debug.ads einfo.ads \ lib.ads limits.ads namet.ads opt.ads output.ads sinfo.ads sprint.ads \ sprint.adb stand.ads stringt.ads system.ads table.ads table.adb \ types.ads uintp.ads uname.ads unchecked_deallocation.ads \ unchecked_deallocation.adb stand.obj : alloc.ads atree.ads csets.ads debug.ads einfo.ads limits.ads \ namet.ads nmake.ads opt.ads output.ads sinfo.ads snames.ads stand.ads \ stand.adb stringt.ads system.ads table.ads table.adb ttypes.ads \ types.ads uintp.ads unchecked_deallocation.ads \ unchecked_deallocation.adb stringt.obj : alloc.ads debug.ads output.ads stringt.ads stringt.adb \ system.ads system-assertions.ads table.ads table.adb types.ads \ unchecked_deallocation.ads unchecked_deallocation.adb switch.obj : debug.ads opt.ads osint.ads output.ads switch.ads switch.adb \ sysid.ads system.ads types.ads unchecked_deallocation.ads \ unchecked_deallocation.adb sysid.obj : sysid.ads system-assertions.obj : system.ads system-assertions.ads system-traceback.obj : debug.ads system.ads system-traceback.ads \ system-traceback.adb types.ads unchecked_deallocation.ads \ unchecked_deallocation.adb system.obj : system.ads system_environment.obj : system.ads system_environment.ads \ system_environment.adb tbuild.obj : alloc.ads atree.ads debug.ads einfo.ads errout.ads limits.ads \ namet.ads nmake.ads output.ads sinfo.ads snames.ads stand.ads \ system.ads table.ads table.adb tbuild.ads tbuild.adb types.ads \ unchecked_deallocation.ads unchecked_deallocation.adb treepr.obj : alloc.ads atree.ads casing.ads csets.ads debug.ads einfo.ads \ lib.ads limits.ads namet.ads opt.ads output.ads sinfo.ads sinput.ads \ stand.ads stringt.ads system.ads table.ads table.adb treepr.ads \ treepr.adb treeprs.ads types.ads uintp.ads uname.ads \ unchecked_deallocation.ads unchecked_deallocation.adb treeprs.obj : sinfo.ads system.ads treeprs.ads types.ads \ unchecked_deallocation.ads unchecked_deallocation.adb ttypes.obj : ttypes.ads types.obj : system.ads types.ads types.adb unchecked_deallocation.ads \ unchecked_deallocation.adb uintp.obj : alloc.ads comperr.ads debug.ads limits.ads namet.ads output.ads \ system.ads system-assertions.ads table.ads table.adb types.ads \ uintp.ads uintp.adb unchecked_deallocation.ads \ unchecked_deallocation.adb uname.obj : alloc.ads atree.ads casing.ads comperr.ads debug.ads einfo.ads \ lib.ads limits.ads namet.ads output.ads sinfo.ads system.ads \ system-assertions.ads table.ads table.adb types.ads uname.ads uname.adb \ unchecked_deallocation.ads unchecked_deallocation.adb unixlib.obj : system.ads types.ads unchecked_deallocation.ads \ unchecked_deallocation.adb unixlib.ads unixlib.adb usage.obj : opt.ads osint.ads output.ads sysid.ads system.ads types.ads \ unchecked_deallocation.ads unchecked_deallocation.adb usage.ads \ usage.adb xref.obj : alloc.ads atree.ads casing.ads debug.ads einfo.ads lib.ads \ limits.ads namet.ads osint.ads output.ads sinfo.ads sprint.ads \ stand.ads system.ads table.ads table.adb types.ads \ unchecked_deallocation.ads unchecked_deallocation.adb xref.ads xref.adb \ xref_tab.ads xref_tab.obj : alloc.ads atree.ads casing.ads debug.ads einfo.ads lib.ads \ limits.ads namet.ads osint.ads output.ads sinfo.ads sinput.ads \ stand.ads system.ads table.ads table.adb types.ads \ unchecked_deallocation.ads unchecked_deallocation.adb xref_tab.ads \ xref_tab.adb # To make a configuration always use collect2, set USE_COLLECT2 to ld. ld: collect2 rm -f ld ln collect2 ld collect2.exe : collect2.obj version.obj $(LIBDEPS) # Don't try modifying collect2 (aka ld) in place--it might be linking this. -rm -f collect2 $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o collect2.exe collect2.obj version.obj $(LIBS) collect2.obj : collect2.c $(CONFIG_H) gstab.h ! IF "$(srcdir)" == "." $(CC) $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \ -DTARGET_MACHINE="$(target)" \ -c collect2.c ! ELSE $(CC) $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \ -DTARGET_MACHINE="$(target)" \ -c $(srcdir)\collect2.c ! ENDIF # Objectionable C language specific files. objc-parse.obj : $(srcdir)\objc-parse.c $(CONFIG_H) $(TREE_H) c-lex.h \ c-tree.h input.h flags.h objc-actions.h $(CC) $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) -c $(srcdir)\objc-parse.c $(srcdir)\objc-parse.c : $(srcdir)\objc-parse.y ! IF "$(srcdir)" != "." cd $(srcdir) ! ENDIF $(BISON) $(BISONFLAGS) objc-parse.y -o objc-parse.c $(srcdir)\objc-parse.y: $(srcdir)\c-parse.in $(srcdir)\cond.awk ! IF "$(srcdir)" != "." cd $(srcdir) ! ENDIF awk -f cond.awk objc=1 c-parse.in > objc-parse.y objc-actions.obj : objc-actions.c $(CONFIG_H) $(TREE_H) c-tree.h c-lex.h \ flags.h objc-actions.h # A file used by all variants of C. c-common.obj : c-common.c $(CONFIG_H) $(TREE_H) c-tree.h c-lex.h flags.h # Language-independent files. gcc.obj: gcc.c $(CONFIG_H) gvarargs.h config.status ! IF "$(srcdir)" == "." $(CC) $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \ -DSTANDARD_STARTFILE_PREFIX="$(libdir)\\" \ -DSTANDARD_EXEC_PREFIX="$(libdir)\\gcc-lib\\" \ -DDEFAULT_TARGET_MACHINE="$(target)" \ -DTOOLDIR_BASE_PREFIX="$(prefix)\\" \ -DTOOLDIR="$(tooldir)\\" \ $(MAYBE_TARGET_DEFAULT) \ -c gcc.c ! ELSE $(CC) $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \ -DSTANDARD_STARTFILE_PREFIX="$(libdir)\\" \ -DSTANDARD_EXEC_PREFIX="$(libdir)\\gcc-lib\\" \ -DDEFAULT_TARGET_MACHINE="$(target)" \ -DTOOLDIR_BASE_PREFIX="$(prefix)\\" \ -DTOOLDIR="$(tooldir)\\" \ $(MAYBE_TARGET_DEFAULT) \ -c $(srcdir)\gcc.c ! ENDIF gcc.c: patches-gcc257.os2 $(PATCH) < %s dumpvers.exe: dumpvers.c version.obj: version.c obstack.obj: obstack.c $(CC) -c -D____386BSD____ $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) obstack.c convert.obj: convert.c $(CONFIG_H) $(TREE_H) flags.h convert.h tree.obj : tree.c $(CONFIG_H) $(TREE_H) gvarargs.h flags.h function.h print-tree.obj : print-tree.c $(CONFIG_H) $(TREE_H) stor-layout.obj : stor-layout.c $(CONFIG_H) $(TREE_H) function.h fold-const.obj : fold-const.c $(CONFIG_H) $(TREE_H) flags.h toplev.obj : toplev.c $(CONFIG_H) $(TREE_H) $(RTL_H) flags.h input.h \ insn-attr.h xcoffout.h defaults.h ! IF "$(srcdir)" == "." $(CC) $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \ $(MAYBE_TARGET_DEFAULT) $(MAYBE_USE_COLLECT2) \ -c toplev.c ! ELSE $(CC) $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \ $(MAYBE_TARGET_DEFAULT) $(MAYBE_USE_COLLECT2) \ -c $(srcdir)\toplev.c ! ENDIF toplev.c : patches-gcc257.os2 $(PATCH) < %s rtl.obj : rtl.c $(CONFIG_H) $(RTL_H) print-rtl.obj : print-rtl.c $(CONFIG_H) $(RTL_H) rtlanal.obj : rtlanal.c $(CONFIG_H) $(RTL_H) toplev.obj: bytecode.h bc-emit.h varasm.obj : varasm.c $(CONFIG_H) $(TREE_H) $(RTL_H) flags.h function.h \ defaults.h insn-codes.h expr.h hard-reg-set.h regs.h xcoffout.h bytecode.h function.obj : function.c $(CONFIG_H) $(RTL_H) $(TREE_H) flags.h function.h \ insn-flags.h insn-codes.h expr.h regs.h hard-reg-set.h insn-config.h \ recog.h output.h bytecode.h stmt.obj : stmt.c $(CONFIG_H) $(RTL_H) $(TREE_H) flags.h function.h \ insn-flags.h insn-config.h insn-codes.h hard-reg-set.h expr.h loop.h \ recog.h bytecode.h bc-typecd.h bc-typecd.def bc-opcode.h bc-optab.h \ bc-emit.h expr.obj : expr.c $(CONFIG_H) $(RTL_H) $(TREE_H) flags.h function.h \ insn-flags.h insn-codes.h expr.h insn-config.h recog.h output.h \ typeclass.h bytecode.h bc-opcode.h bc-typecd.h bc-typecd.def bc-optab.h \ bc-emit.h modemap.def calls.obj : calls.c $(CONFIG_H) $(RTL_H) $(TREE_H) flags.h expr.h insn-codes.h \ insn-flags.h gvarargs.h expmed.obj : expmed.c $(CONFIG_H) $(RTL_H) $(TREE_H) flags.h \ insn-flags.h insn-config.h insn-codes.h expr.h recog.h real.h explow.obj : explow.c $(CONFIG_H) $(RTL_H) $(TREE_H) flags.h hard-reg-set.h \ insn-config.h expr.h recog.h insn-flags.h insn-codes.h optabs.obj : optabs.c $(CONFIG_H) $(RTL_H) $(TREE_H) flags.h \ insn-flags.h insn-config.h insn-codes.h expr.h recog.h reload.h dbxout.obj : dbxout.c $(CONFIG_H) $(TREE_H) $(RTL_H) flags.h regs.h \ insn-config.h reload.h gstab.h xcoffout.h defaults.h output.h sdbout.obj : sdbout.c $(CONFIG_H) $(TREE_H) $(RTL_H) gsyms.h flags.h \ insn-config.h reload.h dwarfout.obj : dwarfout.c $(CONFIG_H) $(TREE_H) $(RTL_H) dwarf.h flags.h \ insn-config.h reload.h output.h defaults.h xcoffout.obj : xcoffout.c $(CONFIG_H) $(TREE_H) $(RTL_H) xcoffout.h flags.h emit-rtl.obj : emit-rtl.c $(CONFIG_H) $(RTL_H) $(TREE_H) flags.h gvarargs.h \ function.h regs.h insn-config.h insn-codes.h real.h expr.h bytecode.h \ bc-opcode.h bc-typecd.h bc-typecd.def bc-optab.h bc-emit.h bc-opname.h real.obj : real.c $(CONFIG_H) $(TREE_H) getpwd.obj : getpwd.c $(CONFIG_H) integrate.obj : integrate.c $(CONFIG_H) $(RTL_H) $(TREE_H) flags.h integrate.h \ insn-flags.h insn-config.h insn-codes.h expr.h real.h function.h \ bytecode.h jump.obj : jump.c $(CONFIG_H) $(RTL_H) flags.h hard-reg-set.h regs.h \ insn-config.h insn-flags.h insn-codes.h expr.h real.h stupid.obj : stupid.c $(CONFIG_H) $(RTL_H) regs.h hard-reg-set.h flags.h cse.obj : cse.c $(CONFIG_H) $(RTL_H) regs.h hard-reg-set.h flags.h real.h \ insn-config.h recog.h loop.obj : loop.c $(CONFIG_H) $(RTL_H) flags.h loop.h insn-config.h \ insn-flags.h insn-codes.h regs.h hard-reg-set.h recog.h expr.h real.h unroll.obj : unroll.c $(CONFIG_H) $(RTL_H) insn-config.h insn-codes.h \ integrate.h regs.h flags.h expr.h loop.h flow.obj : flow.c $(CONFIG_H) $(RTL_H) flags.h insn-config.h \ basic-block.h regs.h hard-reg-set.h output.h combine.obj : combine.c $(CONFIG_H) $(RTL_H) gvarargs.h flags.h \ insn-config.h insn-flags.h insn-codes.h insn-attr.h regs.h expr.h \ basic-block.h recog.h real.h hard-reg-set.h regclass.obj : regclass.c $(CONFIG_H) $(RTL_H) hard-reg-set.h flags.h \ basic-block.h regs.h insn-config.h recog.h reload.h real.h bytecode.h local-alloc.obj : local-alloc.c $(CONFIG_H) $(RTL_H) flags.h basic-block.h \ regs.h hard-reg-set.h insn-config.h recog.h output.h global.obj : global.c $(CONFIG_H) $(RTL_H) flags.h \ basic-block.h regs.h hard-reg-set.h insn-config.h output.h reload.obj : reload.c $(CONFIG_H) $(RTL_H) flags.h \ reload.h recog.h hard-reg-set.h insn-config.h insn-codes.h regs.h real.h reload1.obj : reload1.c $(CONFIG_H) $(RTL_H) flags.h expr.h \ reload.h regs.h hard-reg-set.h insn-config.h insn-flags.h insn-codes.h \ basic-block.h recog.h output.h caller-save.obj : caller-save.c $(CONFIG_H) $(RTL_H) flags.h \ regs.h hard-reg-set.h insn-config.h basic-block.h recog.h reload.h expr.h reorg.obj : reorg.c $(CONFIG_H) $(RTL_H) conditions.h hard-reg-set.h \ basic-block.h regs.h insn-config.h insn-attr.h insn-flags.h recog.h \ flags.h output.h sched.obj : sched.c $(CONFIG_H) $(RTL_H) basic-block.h regs.h hard-reg-set.h \ flags.h insn-config.h insn-attr.h final.obj : final.c $(CONFIG_H) $(RTL_H) $(TREE_H) gvarargs.h flags.h regs.h \ recog.h conditions.h insn-config.h insn-attr.h real.h output.h \ hard-reg-set.h insn-flags.h insn-codes.h gstab.h xcoffout.h defaults.h recog.obj : recog.c $(CONFIG_H) $(RTL_H) \ regs.h recog.h hard-reg-set.h flags.h insn-config.h insn-attr.h \ insn-flags.h insn-codes.h real.h reg-stack.obj : reg-stack.c $(CONFIG_H) $(RTL_H) $(TREE_H) \ regs.h hard-reg-set.h flags.h insn-config.h aux-output.obj : aux-output.c $(CONFIG_H) \ $(RTL_H) regs.h hard-reg-set.h real.h insn-config.h conditions.h \ insn-flags.h output.h insn-attr.h insn-codes.h # Build auxiliary files that support ecoff format. mips-tfile: mips-tfile.o version.o $(LIBDEPS) $(CC) $(CFLAGS) $(LDFLAGS) -o mips-tfile mips-tfile.obj version.obj $(LIBS) mips-tfile.obj : mips-tfile.c $(CONFIG_H) $(RTL_H) mips-tdump: mips-tdump.obj version.obj $(LIBDEPS) $(CC) $(CFLAGS) $(LDFLAGS) -o mips-tdump mips-tdump.obj version.obj $(LIBS) mips-tdump.obj : mips-tdump.c $(CONFIG_H) $(RTL_H) # Normally this target is not used; but it is used if you # define ALLOCA=alloca.obj. In that case, you must get a suitable alloca.c # from the GNU Emacs distribution. alloca.obj: alloca.c ! IF "$(srcdir)" == "." $(CC) $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) $(ALLOCA_FLAGS) \ -c alloca.c ! ELSE $(CC) $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) $(ALLOCA_FLAGS) \ -c $(srcdir)\alloca.c ! ENDIF $(ALLOCA_FINISH) # Generate header and source files from the machine description, # and compile them. .PRECIOUS: insn-config.h insn-flags.h insn-codes.h \ insn-emit.c insn-recog.c insn-extract.c insn-output.c insn-peep.c \ insn-attr.h insn-attrtab.c # The following pair of rules has this effect: # genconfig is run only if the md has changed since genconfig was last run; # but the file insn-config.h is touched only when its contents actually change. # Each of the other insn-* files is handled by a similar pair of rules. # This causes an anomaly in the results of make -n # because insn-* is older than stamp-* # and thus make -n thinks that insn-* will be updated # and force recompilation of things that depend on it. # We use move-if-changed precisely to avoid such recompilation. # But there is no way to teach make -n that it will be avoided. # Each of the insn-*.[ch] rules used to have a semicolon at the end, # for otherwise the system Make on SunOS 4.1 never tries # to recompile insn-*.o. However, this causes the OS/2 NMAKE utility # to think that insn-*.[ch] is being updated. insn-config.h: stamp-config stamp-config : md genconfig.exe $(srcdir)\move-if-change.cmd .\genconfig md > tmp-config.h $(srcdir)\move-if-change tmp-config.h insn-config.h touch stamp-config insn-flags.h: stamp-flags stamp-flags : md genflags.exe $(srcdir)\move-if-change.cmd .\genflags md > tmp-flags.h $(srcdir)\move-if-change tmp-flags.h insn-flags.h touch stamp-flags insn-codes.h: stamp-codes stamp-codes : md gencodes.exe $(srcdir)\move-if-change.cmd .\gencodes md > tmp-codes.h $(srcdir)\move-if-change tmp-codes.h insn-codes.h touch stamp-codes insn-emit.obj : insn-emit.c $(CONFIG_H) $(RTL_H) expr.h real.h output.h \ insn-config.h insn-flags.h insn-codes.h $(CC) $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) -c insn-emit.c insn-emit.c: stamp-emit stamp-emit : md genemit.exe $(srcdir)\move-if-change.cmd .\genemit md > tmp-emit.c $(srcdir)\move-if-change tmp-emit.c insn-emit.c touch stamp-emit insn-recog.obj : insn-recog.c $(CONFIG_H) $(RTL_H) insn-config.h recog.h \ real.h output.h flags.h $(CC) $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) -c insn-recog.c insn-recog.c: stamp-recog stamp-recog : md genrecog.exe $(srcdir)\move-if-change.cmd .\genrecog md > tmp-recog.c $(srcdir)\move-if-change tmp-recog.c insn-recog.c touch stamp-recog insn-opinit.obj : insn-opinit.c $(CONFIG_H) $(RTL_H) insn-codes.h insn-flags.h \ insn-config.h flags.h rtl.h recog.h expr.h reload.h $(CC) $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) -c insn-opinit.c insn-opinit.c: stamp-opinit stamp-opinit : md genopinit.exe $(srcdir)\move-if-change.cmd .\genopinit md > tmp-opinit.c $(srcdir)\move-if-change tmp-opinit.c insn-opinit.c touch stamp-opinit insn-extract.obj : insn-extract.c $(CONFIG_H) $(RTL_H) $(CC) $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) -c insn-extract.c insn-extract.c: stamp-extract stamp-extract : md genextract.exe $(srcdir)\move-if-change.cmd .\genextract md > tmp-extract.c $(srcdir)\move-if-change tmp-extract.c insn-extract.c touch stamp-extract insn-peep.obj : insn-peep.c $(CONFIG_H) $(RTL_H) regs.h output.h real.h $(CC) $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) -c insn-peep.c insn-peep.c: stamp-peep stamp-peep : md genpeep.exe $(srcdir)\move-if-change.cmd .\genpeep md > tmp-peep.c $(srcdir)\move-if-change tmp-peep.c insn-peep.c touch stamp-peep insn-attrtab.obj : insn-attrtab.c $(CONFIG_H) $(RTL_H) regs.h real.h output.h \ insn-attr.h insn-config.h $(CC) $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) -c insn-attrtab.c insn-attr.h: stamp-attr stamp-attr : md genattr.exe $(srcdir)\move-if-change.cmd .\genattr md > tmp-attr.h $(srcdir)\move-if-change tmp-attr.h insn-attr.h touch stamp-attr insn-attrtab.c: stamp-attrtab stamp-attrtab : md genattrtab.exe $(srcdir)\move-if-change.cmd #! if ! [comp $(PREMADE_ATTRTAB_MD) md tmp-attrtab.c #! endif $(srcdir)\move-if-change tmp-attrtab.c insn-attrtab.c touch stamp-attrtab insn-output.obj : insn-output.c $(CONFIG_H) $(RTL_H) regs.h real.h conditions.h \ hard-reg-set.h insn-config.h insn-flags.h insn-attr.h output.h recog.h \ insn-codes.h $(CC) $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) -c insn-output.c insn-output.c: stamp-output stamp-output : md genoutput.exe $(srcdir)\move-if-change.cmd .\genoutput md > tmp-output.c $(srcdir)\move-if-change tmp-output.c insn-output.c touch stamp-output # Compile the programs that generate insn-* from the machine description. # They are compiled with $(HOST_CC), and associated libraries, # since they need to run on this machine # even if GCC is being compiled to run on some other machine. # $(CONFIG_H) is omitted from the deps of the gen*.obj # because these programs don't really depend on anything # about the target machine. They do depend on config.h itself, # since that describes the host machine. # Pass the md file through cpp if the target requests it. $(MD_FILE): $(CPP_MD) -if [ -f md.pre-cpp ]; then \ rm -f md ; ./cpp $(CPP_MD_FLAGS) md.pre-cpp | sed 's/^# /; /g' > md ; \ else true ; \ fi genconfig.exe : genconfig.obj $(HOST_RTL) $(HOST_LIBDEPS) $(HOST_CC) $(HOST_CFLAGS) $(HOST_LDFLAGS) -o genconfig.exe \ genconfig.obj $(HOST_RTL) $(HOST_LIBS) genconfig.obj : genconfig.c $(RTL_H) hconfig.h $(HOST_CC) -c $(HOST_CFLAGS) $(HOST_CPPFLAGS) $(INCLUDES) $(srcdir)\genconfig.c genflags.exe : genflags.obj $(HOST_RTL) $(HOST_LIBDEPS) $(HOST_CC) $(HOST_CFLAGS) $(HOST_LDFLAGS) -o genflags.exe \ genflags.obj $(HOST_RTL) $(HOST_LIBS) genflags.obj : genflags.c $(RTL_H) hconfig.h $(HOST_CC) -c $(HOST_CFLAGS) $(HOST_CPPFLAGS) $(INCLUDES) $(srcdir)\genflags.c gencodes.exe : gencodes.obj $(HOST_RTL) $(HOST_LIBDEPS) $(HOST_CC) $(HOST_CFLAGS) $(HOST_LDFLAGS) -o gencodes.exe \ gencodes.obj $(HOST_RTL) $(HOST_LIBS) gencodes.obj : gencodes.c $(RTL_H) hconfig.h $(HOST_CC) -c $(HOST_CFLAGS) $(HOST_CPPFLAGS) $(INCLUDES) $(srcdir)\gencodes.c genemit.exe : genemit.obj $(HOST_RTL) $(HOST_LIBDEPS) $(HOST_CC) $(HOST_CFLAGS) $(HOST_LDFLAGS) -o genemit.exe \ genemit.obj $(HOST_RTL) $(HOST_LIBS) genemit.obj : genemit.c $(RTL_H) hconfig.h $(HOST_CC) -c $(HOST_CFLAGS) $(HOST_CPPFLAGS) $(INCLUDES) $(srcdir)\genemit.c genopinit.exe : genopinit.obj $(HOST_RTL) $(HOST_LIBDEPS) $(HOST_CC) $(HOST_CFLAGS) $(HOST_LDFLAGS) -o genopinit.exe \ genopinit.obj $(HOST_RTL) $(HOST_LIBS) genopinit.obj : genopinit.c $(RTL_H) hconfig.h $(HOST_CC) -c $(HOST_CFLAGS) $(HOST_CPPFLAGS) $(INCLUDES) $(srcdir)/genopinit.c genrecog.exe : genrecog.obj $(HOST_RTL) $(HOST_LIBDEPS) $(HOST_CC) $(HOST_CFLAGS) $(HOST_LDFLAGS) -o genrecog.exe \ genrecog.obj $(HOST_RTL) $(HOST_LIBS) genrecog.obj : genrecog.c $(RTL_H) hconfig.h $(HOST_CC) -c $(HOST_CFLAGS) $(HOST_CPPFLAGS) $(INCLUDES) $(srcdir)\genrecog.c genextract.exe : genextract.obj $(HOST_RTL) $(HOST_LIBDEPS) $(HOST_CC) $(HOST_CFLAGS) $(HOST_LDFLAGS) -o genextract.exe \ genextract.obj $(HOST_RTL) $(HOST_LIBS) genextract.obj : genextract.c $(RTL_H) hconfig.h insn-config.h $(HOST_CC) -c $(HOST_CFLAGS) $(HOST_CPPFLAGS) $(INCLUDES) $(srcdir)\genextract.c genpeep.exe : genpeep.obj $(HOST_RTL) $(HOST_LIBDEPS) $(HOST_CC) $(HOST_CFLAGS) $(HOST_LDFLAGS) -o genpeep.exe \ genpeep.obj $(HOST_RTL) $(HOST_LIBS) genpeep.obj : genpeep.c $(RTL_H) hconfig.h $(HOST_CC) -c $(HOST_CFLAGS) $(HOST_CPPFLAGS) $(INCLUDES) $(srcdir)\genpeep.c genattr.exe : genattr.obj $(HOST_RTL) $(HOST_LIBDEPS) $(HOST_CC) $(HOST_CFLAGS) $(HOST_LDFLAGS) -o genattr.exe \ genattr.obj $(HOST_RTL) $(HOST_LIBS) genattr.obj : genattr.c $(RTL_H) hconfig.h $(HOST_CC) -c $(HOST_CFLAGS) $(HOST_CPPFLAGS) $(INCLUDES) $(srcdir)\genattr.c genattrtab.exe : genattrtab.obj $(HOST_RTL) $(HOST_PRINT) $(HOST_RTLANAL) $(HOST_LIBDEPS) $(HOST_CC) $(HOST_CFLAGS) $(HOST_LDFLAGS) -o genattrtab.exe \ genattrtab.obj $(HOST_RTL) $(HOST_PRINT) $(HOST_RTLANAL) $(HOST_LIBS) genattrtab.obj : genattrtab.c $(RTL_H) hconfig.h insn-config.h $(HOST_CC) -c $(HOST_CFLAGS) $(HOST_CPPFLAGS) $(INCLUDES) $(srcdir)\genattrtab.c genoutput.exe : genoutput.obj $(HOST_RTL) $(HOST_LIBDEPS) $(HOST_CC) $(HOST_CFLAGS) $(HOST_LDFLAGS) -o genoutput.exe \ genoutput.obj $(HOST_RTL) $(HOST_LIBS) genoutput.obj : genoutput.c $(RTL_H) hconfig.h $(HOST_CC) -c $(HOST_CFLAGS) $(HOST_CPPFLAGS) $(INCLUDES) $(srcdir)\genoutput.c # Compile the libraries to be used by gen*. # If we are not cross-building, gen* use the same .obj's that cc1 will use, # and HOST_PREFIX_1 is `foobar', just to ensure these rules don't conflict # with the rules for rtl.obj, alloca.obj, etc. $(HOST_PREFIX_1)rtl.obj: $(srcdir)\rtl.c $(CONFIG_H) $(RTL_H) rm -f $(HOST_PREFIX)rtl.c sed -e 's/config[.]h/hconfig.h/' $(srcdir)\rtl.c > $(HOST_PREFIX)rtl.c $(HOST_CC) -c $(HOST_CFLAGS) $(HOST_CPPFLAGS) $(INCLUDES) $(HOST_PREFIX)rtl.c $(HOST_PREFIX_1)print-rtl.obj: $(srcdir)\print-rtl.c $(CONFIG_H) $(RTL_H) rm -f $(HOST_PREFIX)print-rtl.c sed -e 's/config[.]h/hconfig.h/' $(srcdir)\print-rtl.c > $(HOST_PREFIX)print-rtl.c $(HOST_CC) -c $(HOST_CFLAGS) $(HOST_CPPFLAGS) $(INCLUDES) $(HOST_PREFIX)print-rtl.c $(HOST_PREFIX_1)rtlanal.obj: $(srcdir)\rtlanal.c $(CONFIG_H) $(RTL_H) rm -f $(HOST_PREFIX)rtlanal.c sed -e 's/config[.]h/hconfig.h/' $(srcdir)\rtlanal.c > $(HOST_PREFIX)rtlanal.c $(HOST_CC) -c $(HOST_CFLAGS) $(HOST_CPPFLAGS) $(INCLUDES) $(HOST_PREFIX)rtlanal.c $(HOST_PREFIX_1)alloca.obj: alloca.c rm -f $(HOST_PREFIX)alloca.c copy $(srcdir)\alloca.c $(HOST_PREFIX)alloca.c $(HOST_CC) -c $(HOST_CFLAGS) $(HOST_CPPFLAGS) $(INCLUDES) $(HOST_PREFIX)alloca.c $(HOST_PREFIX_1)obstack.obj: obstack.c rm -f $(HOST_PREFIX)obstack.c sed -e 's/config[.]h/hconfig.h/' $(srcdir)\obstack.c > $(HOST_PREFIX)obstack.c $(HOST_CC) -c $(HOST_CFLAGS) $(HOST_CPPFLAGS) $(INCLUDES) $(HOST_PREFIX)obstack.c $(HOST_PREFIX_1)malloc.obj: malloc.c rm -f $(HOST_PREFIX)malloc.c sed -e 's/config[.]h/hconfig.h/' $(srcdir)\malloc.c > $(HOST_PREFIX)malloc.c $(HOST_CC) -c $(HOST_CFLAGS) $(HOST_CPPFLAGS) $(INCLUDES) $(HOST_PREFIX)malloc.c # This satisfies the dependency that we get if you cross-compile a compiler # that does not need to compile alloca, malloc or whatever. $(HOST_PREFIX_1): touch $(HOST_PREFIX_1) # Remake bytecode files. # BI_ALL=bi-run.obj BI_ALL= BC_ALL=bc-opname.h bc-opcode.h bc-arity.h BI_OBJ=bi-parser.obj bi-lexer.obj bi-reverse.obj bc-emit.obj : bc-emit.c $(CONFIG_H) $(RTL_H) real.h $(BYTECODE_H) \ bc-arity.h bc-opcode.h bc-typecd.h bc-typecd.def bi-run.h bytetypes.h bc-optab.obj : bc-optab.c $(CONFIG_H) $(REAL_H) $(BYTECODE_H) \ bc-opcode.h bc-typecd.h bc-typecd.def bytecode: $(BI_ALL) $(BC_ALL) bi-arity.exe: bi-arity.obj $(BI_OBJ) $(HOST_LIBDEPS) $(HOST_CC) $(HOST_CFLAGS) $(HOST_LDFLAGS) -o bi-arity.exe \ bi-arity.obj $(BI_OBJ) $(HOST_LIBS) bi-opcode.exe: bi-opcode.obj $(BI_OBJ) $(HOST_LIBDEPS) $(HOST_CC) $(HOST_CFLAGS) $(HOST_LDFLAGS) -o bi-opcode.exe \ bi-opcode.obj $(BI_OBJ) $(HOST_LIBS) bi-opname.exe: bi-opname.obj $(BI_OBJ) $(HOST_LIBDEPS) $(HOST_CC) $(HOST_CFLAGS) $(HOST_LDFLAGS) -o bi-opname.exe \ bi-opname.obj $(BI_OBJ) $(HOST_LIBS) bi-run.obj: $(srcdir)\bi-run.c $(srcdir)\bi-run.h $(srcdir)\bc-typecd.h \ bc-opname.h bc-arity.h bc-opcode.h $(CC) $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) -c $(srcdir)\bi-run.c $(srcdir)\bi-parser.c $(srcdir)\bi-parser.h: $(srcdir)\bi-parser.y # cd $(srcdir); $(BISON) $(BISONFLAGS) -d bi-parser.y -o bi-parser.c touch $(srcdir)\bi-parser.c touch $(srcdir)\bi-parser.h bi-parser.obj: $(srcdir)\bi-parser.c $(srcdir)\bi-defs.h hconfig.h $(HOST_CC) -c $(HOST_CFLAGS) $(HOST_CPPFLAGS) $(INCLUDES) \ $(srcdir)\bi-parser.c bi-lexer.obj: $(srcdir)\bi-lexer.c $(srcdir)\bi-parser.h hconfig.h $(HOST_CC) -c $(HOST_CFLAGS) $(HOST_CPPFLAGS) $(INCLUDES) \ $(srcdir)\bi-lexer.c bi-arity.obj: bi-arity.c $(srcdir)\bi-defs.h hconfig.h $(HOST_CC) -c $(HOST_CFLAGS) $(HOST_CPPFLAGS) $(INCLUDES) \ $(srcdir)\bi-arity.c bi-opcode.obj: bi-opcode.c $(srcdir)\bi-defs.h hconfig.h $(HOST_CC) -c $(HOST_CFLAGS) $(HOST_CPPFLAGS) $(INCLUDES) \ $(srcdir)\bi-opcode.c bi-opname.obj: bi-opname.c $(srcdir)\bi-defs.h hconfig.h $(HOST_CC) -c $(HOST_CFLAGS) $(HOST_CPPFLAGS) $(INCLUDES) \ $(srcdir)\bi-opname.c bi-reverse.obj: bi-reverse.c $(srcdir)\bi-defs.h $(HOST_CC) -c $(HOST_CFLAGS) $(HOST_CPPFLAGS) $(INCLUDES) \ $(srcdir)\bi-reverse.c bc-arity.h: stamp-bcarity stamp-bcarity : $(srcdir)\bytecode.def bi-arity.exe $(srcdir)\move-if-change.cmd .\bi-arity < $(srcdir)\bytecode.def >tmp-bc-arity.h $(srcdir)\move-if-change tmp-bc-arity.h bc-arity.h touch stamp-bcarity bc-opcode.h: stamp-bcopcode stamp-bcopcode : $(srcdir)\bytecode.def bi-opcode.exe $(srcdir)\move-if-change.cmd .\bi-opcode < $(srcdir)\bytecode.def >tmp-bcopcd.h $(srcdir)\move-if-change tmp-bcopcd.h bc-opcode.h touch stamp-bcopcode bc-opname.h: stamp-bcopname stamp-bcopname : $(srcdir)\bytecode.def bi-opname.exe $(srcdir)\move-if-change.cmd .\bi-opname < $(srcdir)\bytecode.def >tmp-bcopnm.h $(srcdir)\move-if-change tmp-bcopnm.h bc-opname.h touch stamp-bcopname bytecode.mostlyclean: -rm -f bc-arity.h bc-opcode.h bc-opname.h bytecode.distclean bytecode.clean: bytecode.mostlyclean -rm -f bi-arity.exe bi-opcode.exe bi-opname.exe bi-lexer.exe bytecode.realclean: bytecode.clean -rm -f bi-parser.c bi-parser.h # Remake cpp and protoize. # Making the preprocessor cpp.exe: cccp.exe -rm -f cpp.exe copy cccp.exe cpp.exe touch cpp.exe cccp.exe: cccp.obj cexp.obj version.obj $(LIBDEPS) $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o cccp.exe cccp.obj cexp.obj version.obj $(LIBS) cexp.obj: $(srcdir)\cexp.c $(CONFIG_H) $(CC) $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) -c $(srcdir)\cexp.c $(srcdir)\cexp.c: $(srcdir)\cexp.y #! IF "$(srcdir)" != "." # cd $(srcdir) #! ENDIF # $(BISON) -o cexp.c cexp.y touch $(srcdir)\cexp.c cccp.obj: cccp.c $(CONFIG_H) pcp.h version.c config.status # The reason we use $(libdir)\g++-include rather than using libsubdir # is for compatibility with the current version of libg++. ! IF "$(srcdir)" == "." $(CC) $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \ -DGCC_INCLUDE_DIR="$(libsubdir)\\include" \ -DGPLUSPLUS_INCLUDE_DIR="$(libdir)\\g++-include" \ -DLOCAL_INCLUDE_DIR="$(local_prefix)\\include" \ -DCROSS_INCLUDE_DIR="$(libsubdir)\\sys-include" \ -DTOOL_INCLUDE_DIR="$(tooldir)\\include" \ -DTOOLDIR="$(tooldir)\\" \ -c cccp.c ! ELSE $(CC) $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \ -DGCC_INCLUDE_DIR="$(libsubdir)\\include" \ -DGPLUSPLUS_INCLUDE_DIR="$(libdir)\\g++-include" \ -DLOCAL_INCLUDE_DIR="$(local_prefix)\\include" \ -DCROSS_INCLUDE_DIR="$(libsubdir)\\sys-include" \ -DTOOL_INCLUDE_DIR="$(tooldir)\\include" \ -DTOOLDIR="$(tooldir)\\" \ -c $(srcdir)\cccp.c ! ENDIF cccp.c: patches-gcc257.os2 $(PATCH) < %s proto: config.status protoize unprotoize SYSCALLS.c.X protoize.exe: protoize.obj getopt.obj getopt1.obj getpwd.obj version.obj $(LIBDEPS) $(CC) $(ALL_CFLAGS) $(LDFLAGS) \ protoize.obj getopt.obj getopt1.obj getpwd.obj version.obj $(LIBS) -o $@ protoize.obj: stamp-proto ; unprotoize.exe: unprotoize.obj getopt.obj getopt1.obj getpwd.obj version.obj $(LIBDEPS) $(CC) $(ALL_CFLAGS) $(LDFLAGS) \ unprotoize.obj getopt.obj getopt1.obj getpwd.obj version.obj $(LIBS) -o $@ unprotoize.obj: stamp-proto ; stamp-proto: $(srcdir)\protoize.c getopt.h $(CONFIG_H) $(CC) -c $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \ -DGCC_INCLUDE_DIR="$(libsubdir)\\include" \ -DGPLUSPLUS_INCLUDE_DIR="$(libdir)\\g++-include" \ -DCROSS_INCLUDE_DIR="$(libsubdir)\\sys-include" \ -DTOOL_INCLUDE_DIR="$(tooldir)\\include" \ -DLOCAL_INCLUDE_DIR="$(prefix)\\include" \ -DSTD_PROTO_DIR="$(libsubdir)" \ -DUNPROTOIZE $(srcdir)\protoize.c mv protoize.obj unprotoize.obj $(CC) -c $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \ -DGCC_INCLUDE_DIR="$(libsubdir)\\include" \ -DGPLUSPLUS_INCLUDE_DIR="$(libdir)\\g++-include" \ -DCROSS_INCLUDE_DIR="$(libsubdir)\\sys-include" \ -DTOOL_INCLUDE_DIR="$(tooldir)\\include" \ -DLOCAL_INCLUDE_DIR="$(prefix)\\include" \ -DSTD_PROTO_DIR="$(libsubdir)" \ $(srcdir)\protoize.c touch stamp-proto getopt.obj: $(srcdir)\getopt.c getopt.h $(CC) -c $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) $(srcdir)\getopt.c getopt1.obj: $(srcdir)\getopt1.c getopt.h $(CC) -c $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) $(srcdir)\getopt1.c # This info describes the target machine, so compile with GCC just built. SYSCALLS.c.X: $(srcdir)\sys-types.h $(srcdir)\sys-protos.h $(GCC_PASSES) -rm -f SYSCALLS.c tmp-SYSCALLS.s cat $(srcdir)\sys-types.h $(srcdir)\sys-protos.h > SYSCALLS.c $(GCC_FOR_TARGET) $(GCC_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \ -aux-info $@ -S -o tmp-SYSCALLS.s SYSCALLS.c -rm -f SYSCALLS.c tmp-SYSCALLS.s test-protoize-simple: .\protoize.exe .\unprotoize.exe $(GCC_PASSES) -rm -f tmp-proto.[cso] copy $(srcdir)\protoize.c tmp-proto.c chmod u+w tmp-proto.c .\protoize -N -B .\ -x getopt.h -c "-B.\ -Wall -Wwrite-strings \ -g $(CFLAGS) $(INCLUDES) \ -DGCC_INCLUDE_DIR=0 \ -DGPLUSPLUS_INCLUDE_DIR=0 \ -DCROSS_INCLUDE_DIR=0 \ -DTOOL_INCLUDE_DIR=0 \ -DSTD_PROTO_DIR=0" tmp-proto.c @echo '**********' Expect 400 lines of differences. -diff $(srcdir)\protoize.c tmp-proto.c > tmp-proto.diff -wc -l tmp-proto.diff .\unprotoize -N -x getopt.h -c "-B.\ -Wall -Wwrite-strings \ -g $(CFLAGS) $(INCLUDES) \ -DGCC_INCLUDE_DIR=0 \ -DGPLUSPLUS_INCLUDE_DIR=0 \ -DCROSS_INCLUDE_DIR=0 \ -DTOOL_INCLUDE_DIR=0 \ -DSTD_PROTO_DIR=0" tmp-proto.c @echo Expect zero differences. diff $(srcdir)\protoize.c tmp-proto.c | cat -rm -f tmp-proto.[cso] # Build the include directory. The stamp files are stmp-* rather than # stamp-* so that mostlyclean does not force the include directory to # be rebuilt. # Build the include directory except for float.h (which depends upon # enquire). stmp-int-hdrs: stmp-fixinc $(USER_H) gvarargs.h gstdarg.h gstddef.h \ xlimits.h objc-headers # Copy in the headers provided with gcc. # The sed command gets just the last file name component; # this is necessary because VPATH could add a dirname. # Using basename would be simpler, but some systems don't have it. objdir=`pwd`; \ cd $(srcdir); \ for file in $(USER_H); do \ realfile=`echo $$file | sed -e 's|.*/\([^/]*\)$$|\1|'`; \ rm -f $$objdir/include/$$realfile; \ cp $$realfile $$objdir/include; \ chmod a+r $$objdir/include/$$realfile; \ done rm -f include/varargs.h cp $(srcdir)/gvarargs.h include/varargs.h chmod a+r include/varargs.h rm -f include/stdarg.h cp $(srcdir)/gstdarg.h include/stdarg.h chmod a+r include/stdarg.h rm -f include/stddef.h cp $(srcdir)/gstddef.h include/stddef.h chmod a+r include/stddef.h rm -f include/limits.h cp xlimits.h include/limits.h chmod a+r include/limits.h # Install the README rm -f include/README cp $(srcdir)/README-fixinc include/README chmod a+r include/README touch stmp-int-hdrs # Build the complete include directory. stmp-headers: stmp-int-hdrs gfloat.h rm -f include/float.h cp gfloat.h include/float.h chmod a+r include/float.h touch stmp-headers # Running fixincludes requires making sure that xgcc and cpp have been # compiled (they are used to get the value of __SIZE_TYPE__). # But recompiling xgcc should not force the the header files to be # fixed again. If you want to do that, delete stmp-fixinc. fixinc.ready: xgcc cpp -if [ -f fixinc.ready ] ; then \ true; \ else \ touch fixinc.ready; \ fi # Build fixed copies of system files. stmp-fixinc: $(srcdir)/$(FIXINCLUDES) gsyslimits.h fixinc.ready rm -rf include mkdir include if [ x$(FIXINCLUDES) != xMakefile.in ]; \ then \ for dir in $(SYSTEM_HEADER_DIR) $(OTHER_FIXINCLUDES_DIRS); do \ if [ -d $$dir ]; \ then \ $(srcdir)/$(FIXINCLUDES) include $$dir $(srcdir) "`pwd`/xgcc -B`pwd`/"; \ else true; fi; \ done; \ else true; \ fi rm -f include/syslimits.h if [ -f include/limits.h ]; then \ mv include/limits.h include/syslimits.h; \ else \ cp $(srcdir)/gsyslimits.h include/syslimits.h; \ fi chmod a+r include/syslimits.h touch stmp-fixinc # copy objc header files into build directory objc-headers: stmp-fixinc if [ -d objc ]; then true; else mkdir objc; fi thisdir1=`pwd`; \ srcdir1=`cd $(srcdir); pwd`; \ cd objc; \ $(MAKE) -f $${srcdir1}/objc/Makefile copy-headers \ srcdir=$${srcdir1} tooldir=$(tooldir) AR="$(AR)" AR_FLAGS="$(AR_FLAGS)" \ GCC_FOR_TARGET="$${thisdir1}/xgcc -B$${thisdir1}/" \ GCC_CFLAGS="$(GCC_CFLAGS)" incinstalldir=$${thisdir1}/include touch objc-headers # Files related to the fixproto script. deduced.h: $(GCC_PASSES) $(srcdir)\scan-types.sh stmp-int-hdrs CC="$(GCC_FOR_TARGET) $(GCC_CFLAGS) $(ALL_CPPFLAGS) -I. -I$(srcdir) -Iinclude -I$(SYSTEM_HEADER_DIR)"; \ export CC; \ $(srcdir)\scan-types.sh "$(srcdir)" >tmp-deduced.h mv tmp-deduced.h deduced.h gen-protos.exe: gen-protos.obj scan.obj $(HOST_LIBDEPS) $(HOST_CC) $(HOST_CFLAGS) $(HOST_LDFLAGS) -o gen-protos.exe \ gen-protos.obj scan.obj $(HOST_LIBS) gen-protos.obj: gen-protos.c scan.h hconfig.h $(HOST_CC) -c $(HOST_CFLAGS) $(HOST_CPPFLAGS) $(INCLUDES) $(srcdir)\gen-protos.c scan.obj: scan.c scan.h hconfig.h $(HOST_CC) -c $(HOST_CFLAGS) $(HOST_CPPFLAGS) $(INCLUDES) $(srcdir)\scan.c xsys-protos.h: $(GCC_PASSES) $(srcdir)\sys-protos.h deduced.h gen-protos Makefile cat deduced.h $(srcdir)/sys-protos.h > fixtmp.c $(GCC_FOR_TARGET) fixtmp.c -E \ | sed -e 's/ / /g' -e 's/ *(/ (/g' -e 's/ [ ]*/ /g' -e 's/( )/()/' \ | .\gen-protos >xsys-protos.h rm -rf fixtmp.c fix-header.exe: fix-header.obj scan-decls.obj scan.obj xsys-protos.h $(HOST_LIBDEPS) $(HOST_CC) $(HOST_CFLAGS) $(HOST_LDFLAGS) -o fix-header.exe \ fix-header.obj scan-decls.obj scan.obj $(HOST_LIBS) fix-header.obj: fix-header.c obstack.h scan.h xsys-protos.h hconfig.h $(HOST_CC) -c $(HOST_CFLAGS) $(HOST_CPPFLAGS) $(INCLUDES) $(srcdir)\fix-header.c scan-decls.obj: scan-decls.c scan.h hconfig.h $(HOST_CC) -c $(HOST_CFLAGS) $(HOST_CPPFLAGS) $(INCLUDES) $(srcdir)\scan-decls.c # stmp-fixproto depends on this, not on fix-header directly. # The idea is to make sure fix-header gets built, # but not rerun fixproto after each stage # just because fix-header's mtime has changed. fixhdr.ready: fix-header -if [ -f fixhdr.ready ] ; then \ true; \ else \ touch fixhdr.ready; \ fi # stmp-headers is to make sure fixincludes has already finished. # The if statement is so that we don't run fixproto a second time # if it has already been run on the files in `include'. stmp-fixproto: fixhdr.ready fixproto stmp-headers @echo "Various warnings and error messages from fixproto are normal" -if [ -d include ] ; then true; else mkdir include; fi if [ -f include/fixed ] ; then true; \ else \ CPP="$(GCC_FOR_TARGET) -E"; export CPP; \ $(srcdir)\fixproto include include $(SYSTEM_HEADER_DIR); \ touch include\fixed; \ fi touch stmp-fixproto # Remake the info files. doc: info info: $(srcdir)\cpp.info $(srcdir)\gcc.info $(srcdir)\cpp.info: cpp.texi cd $(srcdir); $(MAKEINFO) cpp.texi #$(srcdir)\gplus.info: gplus.texi # $(MAKEINFO) `echo $(srcdir)\gplus.texi | sed 's,^\.\\,,'` $(srcdir)\gcc.info: gcc.texi extend.texi install.texi invoke.texi \ md.texi rtl.texi tm.texi cd $(srcdir); $(MAKEINFO) gcc.texi dvi: $(srcdir)\gcc.dvi $(srcdir)\cpp.dvi # This works with GNU Make's default rule. $(srcdir)\gcc.dvi: gcc.texi extend.texi install.texi invoke.texi \ md.texi rtl.texi tm.texi $(TEXI2DVI) $< # This works with GNU Make's default rule. $(srcdir)\cpp.dvi: cpp.texi $(TEXI2DVI) $< $(srcdir)\INSTALL: install1.texi install.texi ! IF "$(srcdir)" == "." $(MAKEINFO) -D INSTALLONLY --no-header --no-split install1.texi ! ELSE $(MAKEINFO) -D INSTALLONLY --no-header --no-split $(srcdir)\install1.texi ! ENDIF # Deletion of files made during compilation. # There are four levels of this: # `mostlyclean', `clean', `distclean' and `realclean'. # `mostlyclean' is useful while working on a particular type of machine. # It deletes most, but not all, of the files made by compilation. # It does not delete gcc.lib or its parts, so it won't have to be recompiled. # `clean' deletes everything made by running `make all'. # `distclean' also deletes the files made by config. # `realclean' also deletes everything that could be regenerated automatically. mostlyclean: bytecode.mostlyclean -rm -f $(STAGESTUFF) # Clean the objc subdir if we created one. if [ -d objc ]; then \ srcdir1=`cd $(srcdir); pwd`; \ cd objc; $(MAKE) -f $$srcdir1\objc\Makefile mostlyclean; \ else true; fi -rm -f objc.lib # Delete the temporary source copies for cross compilation. -rm -f $(HOST_PREFIX_1)rtl.c $(HOST_PREFIX_1)rtlanal.c -rm -f $(HOST_PREFIX_1)alloca.c $(HOST_PREFIX_1)malloc.c -rm -f $(HOST_PREFIX_1)obstack.c # Delete the temp files made in the course of building gcc.lib. -rm -f tmpgcc?.bak tmpcopy xlimits.h for name in $(LIB1FUNCS); do rm -f $${name}.c; done # Delete other temporary files. -rm -f tmp-float.h tmp-gcc.xtar.Z -rm -f tmp-foo1 tmp-foo2 tmp-proto.* tmp-unproto.1 tmp-SYSCALLS.s # Delete the stamp files. -rm -f stamp-* tmp-* # Delete debugging dump files. -rm -f *.greg *.lreg *.combine *.flow *.cse *.jump *.rtl *.tree *.loop -rm -f *.dbr *.jump2 *.sched *.cse2 *.sched2 *.stack # Delete some files made during installation. -rm -f specs float.h enquire.exe SYSCALLS.c.X SYSCALLS.c -rm -f collect collect2 ld mips-tfile mips-tdump alloca.s # Delete files generated for fixproto -rm -rf patch-header.exe xsys-protos.h deduced.h tmp-deduced.h \ gen-protos.exe fixproto.list fixtmp.* fixhdr.ready # Delete unwanted output files from TeX. -rm -f *.toc *.log *.vr *.fn *.cp *.tp *.ky *.pg # Delete sorted indices we don't actually use. -rm -f gcc.vrs gcc.kys gcc.tps gcc.pgs gcc.fns # Delete core dumps. -rm -f core config\core # Delete all files made by compilation # that don't exist in the distribution. clean: mostlyclean bytecode.clean # It may not be quite desirable to delete unprotoize.c here, # but the spec for `make clean' requires it. # Using unprotoize.c is not quite right in the first place, # but what better way is there? -rm -f gcc.lib gcc1.lib gcc2.lib libgcc2.ready libgcc1.null -rm -f *.dvi -if [ -f md.pre-cpp ]; then \ rm -f md ; \ fi # Delete the include directory. -rm -rf stmp-* fixinc.ready include objc-headers # Delete all files that users would normally create # while building and installing GCC. distclean: clean bytecode.distclean -rm -f tm.h aux-output.c config.h config.status tconfig.h hconfig.h -rm -f md md.pre-cpp -rm -f Makefile *.oaux -rm -fr stage1 stage2 stage3 stage4 -rm -f cp-parse.output -rm -f objc-parse.output -rm -f c-parse.output # Delete anything likely to be found in the source directory # that shouldn't be in the distribution. extraclean: distclean -rm -rf =* .\"#"* *~* config\=* config\"#"* config\*~* -rm -f patch* *.orig *.rej config\patch* config\*.orig config\*.rej -rm -f config\*\=* config\*\"#"* config\*\*~* -rm -f config\*\*.orig config\*\*.rej -rm -f objc\=* objc\"#"* objc\*~* -rm -f objc\*.orig objc\*.rej -rm -f *.dvi *.oaux *.d *.[zZ] *.gz -rm -f *.tar *.xtar *diff *.diff.* *.tar.* *.xtar.* *diffs -rm -f *lose config\*lose config\*\*lose -rm -f *.s *.s[0-9] *.i install1.texi config\ChangeLog -rm -f djefoo # Get rid of every file that's generated from some other file. # Most of these files ARE PRESENT in the GCC distribution. realclean: distclean bytecode.realclean -rm -f c-parse.y objc-parse.y -rm -f cp-parse.c cp-parse.h cp-parse.output -rm -f objc-parse.c objc-parse.output -rm -f c-parse.c c-parse.h c-parse.output -rm -f cexp.c cexp.output TAGS -rm -f cpp.info* cpp.??s cpp.*aux -rm -f gcc.info* gcc.??s gcc.*aux -rm -f gplus.info* gplus.??s gplus.*aux # Entry points `install' and `uninstall'. # Also temporarily `install-fixincludes' could replace `install-headers'. # Also use `install-collect2' to install collect2 when the config files don't. # The semicolon is to prevent the install.sh -> install default rule # from doing anything. install: $(INSTALL_TARGET) ; # Copy the files of native compiler into directories where they will be run. install-normal: install-common $(INSTALL_HEADERS) $(INSTALL_LIBGCC) \ install-man install-info # Copy the files of cross compiler into directories where they will be run. install-cross: install-common install-common-headers \ install-man install-cross-tools install-libgcc # Do nothing while making gcc with a cross-compiler. The person who # makes gcc for the target machine has to know how to put a complete # gcc together by hand. install-build: force @echo You have to install gcc on your target machine by hand. # Install the tools, libraries and header files for the target machine # where cross-compilation will look for them. # Use tooldir to find them. install-cross-tools: install-dir # The first if makes this a no-op except for a cross compiler. # The /. after the dirname causes test to follow symlinks. # Before making a link or an indirection script, # we verify the desired file does not already exist. # If a symlink does exist, then making a symlink would certainly fail, # leading us to overwrite the real file through the symlink. -if [ -f gcc-cross ] ; \ then \ if [ -d $(tooldir)/. ] ; \ then \ for file in as ld ar nm ranlib; do \ if [ -f $(libsubdir)/$$file ] ; \ then true; \ else \ rm -rf $(libsubdir)/$$file; \ $(SYMLINK) $(tooldir)/bin/$$file $(libsubdir)/$$file \ || (echo "#!/bin/sh"; echo $(tooldir)/bin/$$file "$$@") > $(libsubdir)/$$file; \ fi; \ done; \ for file in $(tooldir)/lib/*; do \ if [ -f $$file ] ; \ then \ if [ -f $(libsubdir)/`basename $$file` ] ; \ then true; \ else \ rm -rf $(libsubdir)/`basename $$file`; \ $(SYMLINK) $$file $(libsubdir)/`basename $$file` \ || $(INSTALL_DATA) $$file $(libsubdir)/`basename $$file`; \ fi; \ else true; \ fi; \ done; \ if [ -d $(tooldir)/include/. ] ; then \ rm -rf $(libsubdir)/sys-include; \ $(SYMLINK) $(tooldir)/include $(libsubdir)/sys-include \ || (if [ -d $(libsubdir)/sys-include ] ; then true ; else mkdir $(libsubdir)/sys-include ; fi; \ (cd $(tooldir)/include; tar cf - .) | (cd $(libsubdir)/sys-include; tar xpf -)); \ else true; fi; \ else true; \ fi; \ else true; \ fi; # Run this on the target machine # to finish installation of cross compiler. install-cross-rest: install-float-h-cross # Install float.h for cross compiler. # Run this on the target machine! install-float-h-cross: install-dir # if [ -f enquire ] ; then true; else false; fi # Note: don't use -. We should fail right away if enquire was not made. ./enquire -f > $(tmpdir)/float.h -rm -f $(libsubdir)/include/float.h $(INSTALL_DATA) $(tmpdir)/float.h $(libsubdir)/include/float.h -rm -f $(tmpdir)/float.h chmod a-x $(libsubdir)/include/float.h # Create the installation directory. install-dir: -if [ -d $(libdir) ] ; then true ; else mkdir $(libdir) ; fi -if [ -d $(libdir)\gcc-lib ] ; then true ; else mkdir $(libdir)\gcc-lib ; fi # This dir isn't currently searched by cpp. # -if [ -d $(libdir)\gcc-lib\include ] ; then true ; else mkdir $(libdir)\gcc-lib\include ; fi -if [ -d $(libdir)\gcc-lib\$(target) ] ; then true ; else mkdir $(libdir)\gcc-lib\$(target) ; fi -if [ -d $(libdir)\gcc-lib\$(target)\$(version) ] ; then true ; else mkdir $(libdir)\gcc-lib\$(target)\$(version) ; fi -if [ -d $(libdir)\gcc-lib\$(target)\$(version)\include ] ; then true ; else mkdir $(libdir)\gcc-lib\$(target)\$(version)\include ; fi -if [ -d $(bindir) ] ; then true ; else mkdir $(bindir) ; fi -if [ -d $(includedir) ] ; then true ; else mkdir $(includedir) ; fi -if [ -d $(tooldir) ] ; then true ; else mkdir $(tooldir) ; fi -if [ -d $(assertdir) ] ; then true ; else mkdir $(assertdir) ; fi -if [ -d $(infodir) ] ; then true ; else mkdir $(infodir) ; fi # We don't use mkdir -p to create the parents of mandir, # because some systems don't support it. # Instead, we use this technique to create the immediate parent of mandir. -parent=`echo $(mandir)|sed -e 's@/[^/]*$$@@'`; \ if [ -d $$parent ] ; then true ; else mkdir $$parent ; fi -if [ -d $(mandir) ] ; then true ; else mkdir $(mandir) ; fi # Install the compiler executables built during cross compilation. install-common: native install-dir xgcc.exe $(EXTRA_PARTS) for file in $(COMPILERS); do \ if [ -f $$file ] ; then \ rm -f $(libsubdir)/$$file; \ $(INSTALL_PROGRAM) $$file $(libsubdir)/$$file; \ else true; \ fi; \ done for file in $(EXTRA_PASSES) $(EXTRA_PARTS) $(EXTRA_PROGRAMS) $(USE_COLLECT2) ..; do \ if [ x"$$file" != x.. ]; then \ rm -f $(libsubdir)/$$file; \ $(INSTALL_PROGRAM) $$file $(libsubdir)/$$file; \ else true; fi; \ done # Don't mess with specs if it doesn't exist yet. -if [ -f specs ] ; then \ rm -f $(libsubdir)/specs; \ $(INSTALL_DATA) specs $(libsubdir)/specs; \ fi # Install the driver program as gcc-$(target) # and also as either gcc (if native) or $(tooldir)/bin/gcc. -if [ -f gcc-cross ] ; then \ $(INSTALL_PROGRAM) gcc-cross $(bindir)/gcc-$(target); \ if [ -d $(tooldir)/bin/. ] ; then \ rm -f $(tooldir)/bin/gcc; \ $(INSTALL_PROGRAM) gcc-cross $(tooldir)/bin/gcc; \ else true; fi; \ if [ -f cc1plus ] ; then \ rm -f $(bindir)/$(target)-g++; \ $(INSTALL_PROGRAM) g++-cross $(bindir)/$(target)-g++; \ chmod a+x $(bindir)/$(target)-g++; \ rm -f $(bindir)/$(target)-c++; \ ln $(bindir)/$(target)-g++ $(bindir)/$(target)-c++; \ fi ; \ else \ rm -f $(bindir)/gcc; \ $(INSTALL_PROGRAM) xgcc $(bindir)/gcc; \ rm -f $(bindir)/gcc-$(target)-1; \ ln $(bindir)/gcc $(bindir)/gcc-$(target)-1; \ mv $(bindir)/gcc-$(target)-1 $(bindir)/gcc-$(target); \ if [ -f gnat1 ] ; then \ rm -f $(bindir)/gnatbind; \ $(INSTALL_PROGRAM) gnatbind $(bindir)/gnatbind; \ chmod a+x $(bindir)/gnatbind; \ fi; \ if [ -f cc1plus ] ; then \ rm -f $(bindir)/g++; \ $(INSTALL_PROGRAM) g++ $(bindir)/g++; \ chmod a+x $(bindir)/g++; \ rm -f $(bindir)/c++; \ ln $(bindir)/g++ $(bindir)/c++; \ fi ; \ fi # Install protoize if it was compiled. -if [ -f protoize ]; \ then \ rm -f $(bindir)\protoize; \ $(INSTALL_PROGRAM) protoize $(bindir)\protoize; \ rm -f $(bindir)\unprotoize; \ $(INSTALL_PROGRAM) unprotoize $(bindir)\unprotoize; \ rm -f $(libsubdir)\SYSCALLS.c.X; \ $(INSTALL_DATA) SYSCALLS.c.X $(libsubdir)\SYSCALLS.c.X; \ chmod a-x $(libsubdir)\SYSCALLS.c.X; \ fi -rm -f $(libsubdir)\cpp $(INSTALL_PROGRAM) cpp $(libsubdir)\cpp # Install the info files. install-info: doc install-dir -rm -f $(infodir)\cpp.info* $(infodir)\gcc.info* cd $(srcdir); for f in cpp.info* gcc.info*; \ do $(INSTALL_DATA) $$f $(infodir)/$$f; done -chmod a-x $(infodir)/cpp.info* $(infodir)/gcc.info* # Install the man pages. install-man: install-dir $(srcdir)\gcc.1 $(srcdir)\cccp.1 $(srcdir)\g++.1 -rm -f $(mandir)\gcc$(manext) -$(INSTALL_DATA) $(srcdir)\gcc.1 $(mandir)\gcc$(manext) -chmod a-x $(mandir)\gcc$(manext) -rm -f $(mandir)\cccp$(manext) -$(INSTALL_DATA) $(srcdir)\cccp.1 $(mandir)\cccp$(manext) -chmod a-x $(mandir)\cccp$(manext) -$(INSTALL_DATA) $(srcdir)\g++.1 $(mandir)\g++$(manext) -chmod a-x $(mandir)\g++$(manext) # Install the library. install-libgcc: gcc.lib install-dir -if [ -f gcc.lib ] ; then \ rm -f $(libsubdir)\gcc.lib; \ $(INSTALL_DATA) gcc.lib $(libsubdir)\gcc.lib; \ # if $(RANLIB_TEST) ; then \ # (cd $(libsubdir); $(RANLIB) gcc.lib); else true; fi; \ chmod a-x $(libsubdir)\gcc.lib; \ else true; fi # Install the objc run time library. install-libobjc: objc.lib install-dir -if [ -f objc.lib ] ; then \ rm -f $(libsubdir)\objc.lib; \ $(INSTALL_DATA) objc.lib $(libsubdir)\objc.lib; \ # if $(RANLIB_TEST) ; then \ # (cd $(libsubdir); $(RANLIB) objc.lib); else true; fi; \ chmod a-x $(libsubdir)\objc.lib; \ else true; fi # Install all the header files built in the include subdirectory. install-headers: install-include-dir $(INSTALL_HEADERS_DIR) install-assert-h # Fix symlinks to absolute paths in the installed include directory to # point to the installed directory, not the build directory. -files=`cd $(libsubdir)/include; find . -type l -print 2>/dev/null`; \ if [ $$? -eq 0 ]; then \ dir=`cd include; pwd`; \ for i in $$files; do \ dest=`ls -ld $(libsubdir)/include/$$i | sed -n 's/.*-> //p'`; \ if expr "$$dest" : "$$dir.*" > /dev/null; then \ rm -f $(libsubdir)/include/$$i; \ ln -s `echo $$i | sed "s|/[^/]*|/..|g" | sed 's|/..$$||'``echo "$$dest" | sed "s|$$dir||"` $(libsubdir)/include/$$i; \ fi; \ done; \ fi # Create or recreate the gcc private include file directory. install-include-dir: install-dir -rm -rf $(libsubdir)\include mkdir $(libsubdir)\include -chmod a+rx $(libsubdir)\include # Install the include directory using tar. install-headers-tar: stmp-headers $(STMP_FIXPROTO) install-include-dir cd include; \ (tar cf - .; exit 0) | (cd $(libsubdir)/include; tar $(TAROUTOPTS) - ) # /bin/sh on some systems returns the status of the first tar, # and that can lose with GNU tar which always writes a full block. # So use `exit 0' to ignore its exit status. # Install the include directory using cpio. install-headers-cpio: stmp-headers $(STMP_FIXPROTO) install-include-dir cd include; find . -print | cpio -pdum $(libsubdir)/include # Put assert.h where it won't override GNU libc's assert.h. # It goes in a dir that is searched after GNU libc's headers; # thus, the following conditionals are no longer needed. # But it's not worth deleting them now. ## Don't replace the assert.h already there if it is not from GCC. ## This code would be simpler if it tested for -f ... && ! grep ... ## but supposedly the ! operator is missing in sh on some systems. install-assert-h: assert.h install-dir if [ -f $(assertdir)/assert.h ]; \ then \ if grep "__eprintf" $(assertdir)/assert.h >/dev/null; \ then \ rm -f $(assertdir)/assert.h; \ $(INSTALL_DATA) $(srcdir)/assert.h $(assertdir)/assert.h; \ chmod a-x $(assertdir)/assert.h; \ else true; \ fi; \ else \ rm -f $(assertdir)/assert.h; \ $(INSTALL_DATA) $(srcdir)/assert.h $(assertdir)/assert.h; \ chmod a-x $(assertdir)/assert.h; \ fi # Use this target to install the program `collect2' under the name `ld'. install-collect2: collect2 install-dir $(INSTALL_PROGRAM) collect2 $(libsubdir)\ld # Install the driver program as $(libsubdir)\gcc for collect2. $(INSTALL_PROGRAM) xgcc $(libsubdir)\gcc # Cancel installation by deleting the installed files. uninstall: -rm -rf $(libsubdir) -rm -rf $(bindir)\gcc -rm -rf $(bindir)\protoize -rm -rf $(bindir)\unprotoize -rm -rf $(mandir)\gcc$(manext) -rm -rf $(mandir)\cccp$(manext) -rm -rf $(mandir)\protoize$(manext) -rm -rf $(mandir)\unprotoize$(manext) # These exist for maintenance purposes. # Update the tags table. TAGS: force cd $(srcdir); \ mkdir temp; \ mv -f c-parse.[ch] cp-parse.[ch] objc-parse.c cexp.c =*.[chy] temp; \ etags *.y *.h *.c; \ mv temp\* .; \ rmdir temp # Create the distribution tar file. #dist: gcc-$(version).tar.gz dist: gcc.xtar.gz gcc.xtar.gz: gcc.xtar gzip < gcc.xtar > tmp-gcc.xtar.gz mv tmp-gcc.xtar.gz gcc.xtar.gz #gcc-$(version).tar.gz: gcc-$(version).tar # gzip < gcc-$(version).tar > gcc-$(version).tar.gz #gcc-$(version).tar: gcc.xtar: distdir # Make the distribution. tar chf gcc.xtar gcc-$(version) distdir: doc $(srcdir)\INSTALL c-parse.y objc-parse.y cp-parse.y \ c-parse.c cp-parse.c objc-parse.c cexp.c @if grep -s "for version $(mainversion)" gcc.texi > /dev/null; \ then true; \ else echo "You must update the version number in \`gcc.texi'"; sleep 10;\ fi # Update the version number in README awk '$$1 " " $$2 " " $$3 == "This directory contains" \ { $$6 = version; print $$0 } \ $$1 " " $$2 " " $$3 != "This directory contains"' \ version=$(version) README > tmp.README mv tmp.README README -rm -rf gcc-$(version) tmp # Put all the files in a temporary subdirectory # which has the name that we want to have in the tar file. mkdir tmp mkdir tmp\config mkdir tmp\objc for file in *[0-9a-zA-Z+]; do \ ln $$file tmp > \dev\null 2>&1 || cp $$file tmp; \ done cd config; \ for file in *[0-9a-zA-Z+]; do \ ln $$file ..\tmp\config >\dev\null 2>&1 || cp $$file ..\tmp\config; \ done cd objc; \ for file in *[0-9a-zA-Z+]; do \ ln $$file ..\tmp\objc >\dev\null 2>&1 || cp $$file ..\tmp\objc; \ done ln .gdbinit tmp mv tmp gcc-$(version) # Get rid of everything we don't want in the distribution. cd gcc-$(version); make -f Makefile.in extraclean # Make the distribution. tar chf gcc.xtar gcc-$(version) # Get rid of the temporary directory. rm -rf gcc-$(version) # make diff oldversion=M.N # creates a diff file between an older distribution and this one. # The -P option assumes this is GNU diff. diff: diff -rc2P -x c-parse.y -x c-parse.c -x c-parse.h -x objc-parse.y \ -x cp-parse.c -x cp-parse.h -x cexp.c -x bi-parser.c \ -x objc-parse.c -x TAGS -x "gcc.??" -x "gcc.??s" -x gcc.aux \ -x "cpp.??s" -x "cpp.??" -x cpp.aux -x "cpp.info*" -x "gcc.info*" \ gcc-$(oldversion) gcc-$(version) > diffs # do make -f ..\gcc\Makefile maketest DIR=..\gcc # in the intended test directory to make it a suitable test directory. # THIS IS OBSOLETE; use the -srcdir operand in configure instead. maketest: ln -s $(DIR)\*.[chy] . ln -s $(DIR)\configure . ln -s $(DIR)\*.def . -rm -f =* ln -s $(DIR)\.gdbinit . ln -s $(DIR)\$(FIXINCLUDES) . -ln -s $(DIR)\bison.simple . ln -s $(DIR)\config . ln -s $(DIR)\move-if-change.cmd . # The then and else were swapped to avoid a problem on Ultrix. if [ ! -f Makefile ] ; then ln -s $(DIR)\Makefile .; else false; fi -rm tm.h aux-output.c config.h md make clean # You must then run config to set up for compilation. bootstrap: force # Only build the C compiler for stage1, because that is the only one that # we can guarantee will build with the native compiler, and also it is the # only thing useful for building stage2. # [However, we are providing fully bootstrapped OS/2 executables, so it's # OK to build both the C and Ada compilers for stage1.] $(MAKE) LANGUAGES="$(LANGUAGES)" $(MAKE) stage1 # This used to define ALLOCA as empty, but that would lead to bad results # for a subsequent `make install' since that would not have ALLOCA empty. # To prevent `make install' from compiling alloca.obj and then relinking cc1 # because alloca.obj is newer, we permit these recursive makes to compile # alloca.obj. Then cc1 is newer, so it won't have to be relinked. # $(MAKE) CC="stage1\xgcc" CFLAGS="-Bstage1\ $(BOOT_CFLAGS)" libdir=$(libdir) LANGUAGES="$(LANGUAGES)" $(MAKE) CC="stage1\xgcc" CFLAGS="-Bstage1\ $(BOOT_CFLAGS)" XCFLAGS="" GNATBIND=stage1\gnatbind LANGUAGES="$(LANGUAGES)" $(MAKE) stage2 $(MAKE) CC="stage2\xgcc" CFLAGS="-Bstage2\ $(BOOT_CFLAGS)" XCFLAGS="" GNATBIND=stage2\gnatbind LANGUAGES="$(LANGUAGES)" # $(MAKE) CC="stage2\xgcc" CFLAGS="-Bstage2\ $(BOOT_CFLAGS)" libdir=$(libdir) LANGUAGES="$(LANGUAGES)" bootstrap2: force # $(MAKE) CC="stage1\xgcc" CFLAGS="-Bstage1\ $(BOOT_CFLAGS)" libdir=$(libdir) LANGUAGES="$(LANGUAGES)" $(MAKE) CC="stage1\xgcc" CFLAGS="-Bstage1\ $(BOOT_CFLAGS)" XCFLAGS="" GNATBIND=stage1\gnatbind LANGUAGES="$(LANGUAGES)" $(MAKE) stage2 $(MAKE) CC="stage2\xgcc" CFLAGS="-Bstage2\ $(BOOT_CFLAGS)" XCFLAGS="" GNATBIND=stage2\gnatbind LANGUAGES="$(LANGUAGES)" # $(MAKE) CC="stage2\xgcc" CFLAGS="-Bstage2\ $(BOOT_CFLAGS)" libdir=$(libdir) LANGUAGES="$(LANGUAGES)" bootstrap3: force # $(MAKE) CC="stage2\xgcc" CFLAGS="-Bstage2\ $(BOOT_CFLAGS)" libdir=$(libdir) LANGUAGES="$(LANGUAGES)" $(MAKE) CC="stage2\xgcc" CFLAGS="-Bstage2\ $(BOOT_CFLAGS)" XCFLAGS="" GNATBIND=stage2\gnatbind LANGUAGES="$(LANGUAGES)" bootstrap4: force $(MAKE) CC="stage3\xgcc" CFLAGS="-Bstage3\ $(BOOT_CFLAGS)" XCFLAGS="" GNATBIND=stage3\gnatbind LANGUAGES="$(LANGUAGES)" bootstrapgnat: force $(MAKE) gnat1.exe gnatbind.exe $(MAKE) gnatstage1 $(MAKE) gnat1.exe gnatbind.exe CC="$(CC)" CFLAGS="-Bstage1\ $(BOOT_CFLAGS)" XCFLAGS="" GNATBIND=stage1\gnatbind $(MAKE) gnatstage2 $(MAKE) gnat1.exe gnatbind.exe CC="$(CC)" CFLAGS="-Bstage2\ $(BOOT_CFLAGS)" XCFLAGS="" GNATBIND=stage2\gnatbind comp gnat*.exe stage2 tmp-foo1; \ tail +16c stage2\$$file > tmp-foo2 2>\dev\null \ && (cmp tmp-foo1 tmp-foo2 || echo $$file differs); \ done -rm -f tmp-foo* # Similar, but compare with stage3 directory compare3: force for file in *.obj; do \ tail +16c $$file > tmp-foo1; \ tail +16c stage3\$$file > tmp-foo2 2>\dev\null \ && (cmp tmp-foo1 tmp-foo2 || echo $$file differs); \ done -rm -f tmp-foo* # Copy the object files from a particular stage into a subdirectory. stage1: force # The following three lines may not be desirable. -for %%f in (tmpgcc1.bak tmpgcc2.bak libgcc2.ready $(LIBGCC2) *.lnk) do \ rm -f %%f -rm -fr stage1 -mkdir stage1 -if exist bind_gnat*.c move bind_gnat*.c stage1 -if exist *.ali move *.ali stage1 -if exist *.obj move *.obj stage1 -if exist *.exe move *.exe stage1 -if exist insn-* move insn-* stage1 -if exist stamp* move stamp* stage1 -for %%f in (specs $(FLOAT_H)) do if exist %%f move %%f stage1 -rm -f stage1\gcc.lib -copy gcc.lib stage1 # -if $(RANLIB_TEST) ; then $(RANLIB) stage1\gcc.lib; else true; fi stage2: force # The following three lines may not be desirable. -for %%f in (tmpgcc1.bak tmpgcc2.bak libgcc2.ready $(LIBGCC2) *.lnk) do \ rm -f %%f -rm -fr stage2 -mkdir stage2 -if exist bind_gnat*.c move bind_gnat*.c stage2 -if exist *.ali move *.ali stage2 -if exist *.obj move *.obj stage2 -if exist *.exe move *.exe stage2 -if exist insn-* move insn-* stage2 -if exist stamp* move stamp* stage2 -for %%f in (specs $(FLOAT_H)) do if exist %%f move %%f stage2 -rm -f stage2\gcc.lib -copy gcc.lib stage2 # -if $(RANLIB_TEST) ; then $(RANLIB) stage2\gcc.lib; else true; fi stage3: force # The following three lines may not be desirable. -for %%f in (tmpgcc1.bak tmpgcc2.bak libgcc2.ready $(LIBGCC2) *.lnk) do \ rm -f %%f -rm -fr stage3 -mkdir stage3 -if exist bind_gnat*.c move bind_gnat*.c stage3 -if exist *.ali move *.ali stage3 -if exist *.obj move *.obj stage3 -if exist *.exe move *.exe stage3 -if exist insn-* move insn-* stage3 -if exist stamp* move stamp* stage3 -for %%f in (specs $(FLOAT_H)) do if exist %%f move %%f stage3 -rm -f stage3\gcc.lib -copy gcc.lib stage3 # -if $(RANLIB_TEST) ; then $(RANLIB) stage3\gcc.lib; else true; fi stage4: force # The following three lines may not be desirable. -for %%f in (tmpgcc1.bak tmpgcc2.bak libgcc2.ready $(LIBGCC2) *.lnk) do \ rm -f %%f -rm -fr stage4 -mkdir stage4 -if exist bind_gnat*.c move bind_gnat*.c stage4 -if exist *.ali move *.ali stage4 -if exist *.obj move *.obj stage4 -if exist *.exe move *.exe stage4 -if exist insn-* move insn-* stage4 -if exist stamp* move stamp* stage4 -for %%f in (specs $(FLOAT_H)) do if exist %%f move %%f stage4 -rm -f stage4\gcc.lib -copy gcc.lib stage4 # -if $(RANLIB_TEST) ; then $(RANLIB) stage4\gcc.lib; else true; fi gnatstage1: force # The following two lines may not be desirable. -rm -f *.lnk -rm -fr stage1 -mkdir stage1 -if exist bind_gnat*.c move bind_gnat*.c stage1 -if exist *.ali move *.ali stage1 -for %%f in ($(GNAT_ADA_OBJS1)) do if exist %%f move %%f stage1 -for %%f in ($(GNAT_ADA_OBJS2)) do if exist %%f move %%f stage1 -for %%f in ($(GNAT_ADA_OBJS3)) do if exist %%f move %%f stage1 -for %%f in ($(GNAT_ADA_OBJS4)) do if exist %%f move %%f stage1 -for %%f in ($(GNAT_ADA_OBJS5)) do if exist %%f move %%f stage1 -for %%f in ($(GNAT_ADA_OBJS6)) do if exist %%f move %%f stage1 -for %%f in ($(GNAT1_ADA_OBJS1)) do if exist %%f move %%f stage1 -for %%f in ($(GNATBIND_OBJS1)) do if exist %%f move %%f stage1 -for %%f in ($(GNATBIND_OBJS2)) do if exist %%f move %%f stage1 -if exist gnat*.exe move gnat*.exe stage1 gnatstage2: force # The following two lines may not be desirable. -rm -f *.lnk -rm -fr stage2 -mkdir stage2 -if exist bind_gnat*.c move bind_gnat*.c stage2 -if exist *.ali move *.ali stage2 -for %%f in ($(GNAT_ADA_OBJS1)) do if exist %%f move %%f stage2 -for %%f in ($(GNAT_ADA_OBJS2)) do if exist %%f move %%f stage2 -for %%f in ($(GNAT_ADA_OBJS3)) do if exist %%f move %%f stage2 -for %%f in ($(GNAT_ADA_OBJS4)) do if exist %%f move %%f stage2 -for %%f in ($(GNAT_ADA_OBJS5)) do if exist %%f move %%f stage2 -for %%f in ($(GNAT_ADA_OBJS6)) do if exist %%f move %%f stage2 -for %%f in ($(GNAT1_ADA_OBJS1)) do if exist %%f move %%f stage2 -for %%f in ($(GNATBIND_OBJS1)) do if exist %%f move %%f stage2 -for %%f in ($(GNATBIND_OBJS2)) do if exist %%f move %%f stage2 -if exist gnat*.exe move gnat*.exe stage2 gnatstage3: force # The following two lines may not be desirable. -rm -f *.lnk -rm -fr stage3 -mkdir stage3 -if exist bind_gnat*.c move bind_gnat*.c stage3 -if exist *.ali move *.ali stage3 -for %%f in ($(GNAT_ADA_OBJS1)) do if exist %%f move %%f stage3 -for %%f in ($(GNAT_ADA_OBJS2)) do if exist %%f move %%f stage3 -for %%f in ($(GNAT_ADA_OBJS3)) do if exist %%f move %%f stage3 -for %%f in ($(GNAT_ADA_OBJS4)) do if exist %%f move %%f stage3 -for %%f in ($(GNAT_ADA_OBJS5)) do if exist %%f move %%f stage3 -for %%f in ($(GNAT_ADA_OBJS6)) do if exist %%f move %%f stage3 -for %%f in ($(GNAT1_ADA_OBJS1)) do if exist %%f move %%f stage3 -for %%f in ($(GNATBIND_OBJS1)) do if exist %%f move %%f stage3 -for %%f in ($(GNATBIND_OBJS2)) do if exist %%f move %%f stage3 -if exist gnat*.exe move gnat*.exe stage3 gnatstage4: force # The following two lines may not be desirable. -rm -f *.lnk -rm -fr stage4 -mkdir stage4 -if exist bind_gnat*.c move bind_gnat*.c stage4 -if exist *.ali move *.ali stage4 -for %%f in ($(GNAT_ADA_OBJS1)) do if exist %%f move %%f stage4 -for %%f in ($(GNAT_ADA_OBJS2)) do if exist %%f move %%f stage4 -for %%f in ($(GNAT_ADA_OBJS3)) do if exist %%f move %%f stage4 -for %%f in ($(GNAT_ADA_OBJS4)) do if exist %%f move %%f stage4 -for %%f in ($(GNAT_ADA_OBJS5)) do if exist %%f move %%f stage4 -for %%f in ($(GNAT_ADA_OBJS6)) do if exist %%f move %%f stage4 -for %%f in ($(GNAT1_ADA_OBJS1)) do if exist %%f move %%f stage4 -for %%f in ($(GNATBIND_OBJS1)) do if exist %%f move %%f stage4 -for %%f in ($(GNATBIND_OBJS2)) do if exist %%f move %%f stage4 -if exist gnat*.exe move gnat*.exe stage4 # Copy just the executable files from a particular stage into a subdirectory, # and delete the object files. Use this if you're just verifying a version # that is pretty sure to work, and you are short of disk space. risky-stage1: force -if [ -d stage1 ] ; then true ; else mkdir stage1 ; fi -mv cc1.exe cpp.exe cccp.exe gcc.exe stage1 -rm -f stage1\gcc.lib -copy gcc.lib stage1 # && $(RANLIB) stage1\gcc.lib -make clean risky-stage2: force -if [ -d stage2 ] ; then true ; else mkdir stage2 ; fi -mv cc1.exe cpp.exe cccp.exe gcc.exe stage2 -rm -f stage2\gcc.lib -copy gcc.lib stage2 # && $(RANLIB) stage2\gcc.lib -make clean risky-stage3: force -if [ -d stage3 ] ; then true ; else mkdir stage3 ; fi -mv cc1.exe cpp.exe cccp.exe gcc.exe stage3 -rm -f stage3\gcc.lib -copy gcc.lib stage3 # && $(RANLIB) stage3\gcc.lib -make clean risky-stage4: force -if [ -d stage4 ] ; then true ; else mkdir stage4 ; fi -mv cc1.exe cpp.exe cccp.exe gcc.exe stage4 -rm -f stage4\gcc.lib -copy gcc.lib stage4 # && $(RANLIB) stage4\gcc.lib -make clean #In GNU Make, ignore whether `stage*' exists. .PHONY: stage1 stage2 stage3 stage4 clean realclean TAGS bootstrap .PHONY: risky-stage1 risky-stage2 risky-stage3 risky-stage4 force: KE) gnat1.exe gnatbind.exe CC="$(CC)" CFLAGS="-Bstage1\ $(BOOT_CFLAGS)" XCFLAGS="" GNATBIND=stage1\gnatbind $(MAKE) gnatstage2 $(MAKE) gnat1.exe gnatbind.exe CC="$(CC)" CFLAGS="-Bstage2\ $(BOOT_CFLAGS)" XCFLAGS="" GNATBIND=stage2\gnatbind comp gnat*.exe stage2 addtolib1.cmd ECHO @CALL rm -f %%1.obj ^|^| GOTO END >>addtolib1.cmd ECHO @%%3 -c %%4 %%5 %%6 %%7 %%8 %%9 -DL%%1 %%2 ^|^| GOTO END >>addtolib1.cmd ECHO @MOVE libgcc1.obj %%1.* ^|^| GOTO END >>addtolib1.cmd ECHO @LIB tmpgcc1 %%1; ^|^| GOTO END >>addtolib1.cmd ECHO @CALL rm -f %%1.obj ^|^| GOTO END >>addtolib1.cmd ECHO @ECHO %%1: done >>addtolib1.cmd ECHO :END >>addtolib1.cmd REM Create the command file addtolib2.cmd, which is used in building gcc2.lib. IF EXIST addtolib2.cmd ATTRIB -H -S -R addtolib2.cmd ECHO @ECHO %%1 >addtolib2.cmd ECHO @%%3 -c -I. -Iconfig %%4 %%5 %%6 %%7 %%8 %%9 -g1 -DL%%1 -o %%1.obj %%2 ^|^| GOTO END >>addtolib2.cmd ECHO @LIB tmpgcc2 -+%%1; ^|^| GOTO END >>addtolib2.cmd ECHO @CALL rm -f %%1.obj ^|^| GOTO END >>addtolib2.cmd ECHO @ECHO %%1: done >>addtolib2.cmd ECHO :END >>addtolib2.cmd REM Create a file called config.status to satisfy the makefile. IF EXIST config.status ATTRIB -H -S -R config.status ECHO. >config.status REM Create the command file move-if-change.cmd, whose purpose is to simulate the REM gcc shell script called move-if-change. IF EXIST move-if-change.cmd ATTRIB -H -S -R move-if-change.cmd ECHO @IF NOT EXIST %%2 GOTO MOVE >move-if-change.cmd ECHO @COMP %%1 %%2 ^NUL 2^>^&1 >>move-if-change.cmd ECHO @IF ERRORLEVEL 4 GOTO DELETE >>move-if-change.cmd ECHO @IF ERRORLEVEL 2 ECHO ERROR COMPARING "%%1" TO "%%2" ^& GOTO END >>move-if-change.cmd ECHO @IF ERRORLEVEL 1 GOTO DELETE >>move-if-change.cmd ECHO @ECHO %%2 is unchanged >>move-if-change.cmd ECHO @rm -f %%1 >>move-if-change.cmd ECHO @REM GOTO END IMPLICIT >>move-if-change.cmd ECHO :DELETE >>move-if-change.cmd ECHO @CALL rm -f %%2 >>move-if-change.cmd ECHO :MOVE >>move-if-change.cmd ECHO @MOVE %%1 %%2 >>move-if-change.cmd ECHO :END >>move-if-change.cmd REM Create the command file mv.cmd, whose purpose is to emulate the UNIX mv REM command. IF EXIST mv.cmd ATTRIB -H -S -R mv.cmd ECHO @ECHO OFF >mv.cmd ECHO IF EXIST %%2 DEL %%2 ^>mv.cmd ECHO MOVE %%1 %%2 >>mv.cmd REM Create a file called no containing a number of n's, to be used as input to REM the OS/2 COMP command. IF EXIST no ATTRIB -H -S -R no & DEL no FOR %%i IN (0 1 2 3 4 5 6 7 8 9) DO ECHO n>>no REM Create the command file rm.cmd, whose purpose is to emulate the UNIX rm REM command. IF EXIST rm.cmd ATTRIB -H -S -R rm.cmd ECHO @IF %%1.==-f. (IF EXIST %%2 ATTRIB -H -S -R %%2) ^& DEL %%2 ^rm.cmd ECHO @IF %%1.==-r. (IF EXIST %%2\* DEL %%2 ^>rm.cmd ECHO @IF %%1.==-fr. (IF EXIST %%2\* ATTRIB -H -S -R %%2\* ^& DEL %%2 ^>rm.cmd ECHO @IF %%1.==-rf. (IF EXIST %%2\* ATTRIB -H -S -R %%2\* ^& DEL %%2 ^>rm.cmd ECHO @DEL %%1 ^>rm.cmd ECHO :END >>rm.cmd REM Create the command file touch.cmd, whose purpose is to emulate the UNIX REM touch command. IF EXIST touch.cmd ATTRIB -H -S -R touch.cmd ECHO @IF EXIST %%1 COPY %%1 /B + ,, >touch.cmd ECHO @IF NOT EXIST %%1 ECHO. ^>%%1 >>touch.cmd REM Create a file called yes containing a number of y's, to be used as input to REM the OS/2 COMP command. IF EXIST yes ATTRIB -H -S -R yes & DEL yes FOR %%i IN (0 1 2 3 4 5 6 7 8 9) DO ECHO y>>yes *.c stage2 -if exist *.ali move *.ali stage2 -if exist *.obj move *.obj stage2 -if exist *.exe move *.exe stage2 -if exist insn-* move insn-* stage2 -if exist stamp* move stamp* stage2 -for %%f in (specs $(FLOAT_H)) do if exist %%f move %%f gnat-1.67-src/src/patches-gas138.os2 440 10015 7640 40564 5506244514 12223 *** Makefile.old Thu Oct 18 16:26:42 1990 --- Makefile Tue Sep 28 01:47:36 1993 *************** *** 20,32 **** # This makefile may be used to make the VAX, 68020, 80386, # SPARC, ns32k, or i860 assembler(s). ! BINDIR = /usr/local/bin ! #CC=gcc # If you are on a BSD system, un-comment the next two lines, and comment out # the lines for SystemV and HPUX below ! G0 = -g -I. #-O -Wall ! LDFLAGS = $(CFLAGS) # # To compile gas on a System Five machine, comment out the two lines above # and un-comment out the next three lines --- 20,40 ---- # This makefile may be used to make the VAX, 68020, 80386, # SPARC, ns32k, or i860 assembler(s). ! .c.obj: ! $(CC) $(CFLAGS) $(CPPFLAGS) -c $< + BINDIR = /gcc/bin + CC=gcc + # CC=icc + O_SWITCH=-o + # O_SWITCH=-Fe + # If you are on a BSD system, un-comment the next two lines, and comment out # the lines for SystemV and HPUX below ! G0 = -g -I. #-O -Wall ! # G0 = -DUSG -Ti -I. ! LDFLAGS = -static #$(CFLAGS) ! # LDFLAGS = -Ti # # To compile gas on a System Five machine, comment out the two lines above # and un-comment out the next three lines *************** *** 108,124 **** # (This option is automatically enabled when building the sparc assembler. # ! O1 = -DNO_VARARGS ! O2 = # -DNON_BROKEN_WORDS O3 = # -Dm68851 O4 = # -DEXEC_VERSION=1 ! O5 = # -DSIGTY=void O6 = # -DNS32532 O6 = # -DNS32381 O7 = # -DDOT_LABEL_PREFIX O8 = # -DSEQUENT_COMPATABILITY O9 = # -DREGISTER_PREFIX=\'%\' ! O10= # -DOTHER_ALIGN G1 = # -DUSE_SYSTEM_HDR G2 = # -DUSE_HP_HDR --- 116,132 ---- # (This option is automatically enabled when building the sparc assembler. # ! O1 = # -DNO_VARARGS ! O2 = -DNON_BROKEN_WORDS O3 = # -Dm68851 O4 = # -DEXEC_VERSION=1 ! O5 = -DSIGTY=void O6 = # -DNS32532 O6 = # -DNS32381 O7 = # -DDOT_LABEL_PREFIX O8 = # -DSEQUENT_COMPATABILITY O9 = # -DREGISTER_PREFIX=\'%\' ! O10= -DOTHER_ALIGN G1 = # -DUSE_SYSTEM_HDR G2 = # -DUSE_HP_HDR *************** *** 131,137 **** # # To make the 68020 assembler compile as the default, un-comment the next # line, and comment out all the other lines that start with DEFAULT_GAS ! DEFAULT_GAS=a68 # # To make the VAX assembler compile as the default, un-comment the next # line and commment out all the other lines that start with DEFAULT_GAS --- 139,145 ---- # # To make the 68020 assembler compile as the default, un-comment the next # line, and comment out all the other lines that start with DEFAULT_GAS ! #DEFAULT_GAS=a68 # # To make the VAX assembler compile as the default, un-comment the next # line and commment out all the other lines that start with DEFAULT_GAS *************** *** 139,145 **** # # To make the 80386 assembler compile as the default, un-comment the next # line and commment out all the other lines that start with DEFAULT_GAS ! #DEFAULT_GAS=a386 # # To make the ns32k assembler compile as the default, un-comment the next # line and commment out all the other lines that start with DEFAULT_GAS --- 147,153 ---- # # To make the 80386 assembler compile as the default, un-comment the next # line and commment out all the other lines that start with DEFAULT_GAS ! DEFAULT_GAS=a386.exe # # To make the ns32k assembler compile as the default, un-comment the next # line and commment out all the other lines that start with DEFAULT_GAS *************** *** 156,260 **** # Global Sources ------------------------------------------------------------- a =\ ! as.o xrealloc.o xmalloc.o hash.o hex-value.o \ ! atof-generic.o append.o messages.o expr.o app.o \ ! frags.o input-file.o input-scrub.o output-file.o \ ! subsegs.o symbols.o version.o \ ! flonum-const.o flonum-copy.o flonum-mult.o strstr.o bignum-copy.o \ ! obstack.o ! #gdb.o gdb-file.o gdb-symbols.o gdb-blocks.o gdb-lines.o ! a: $(DEFAULT_GAS) ! @rm -f a ! @ln $(DEFAULT_GAS) a # I860 GAS ------------------------------------------------------------------ ! u = i860.o atof-ieee.o write-i860.o read-i860.o U = i860.c i860.h i860-opcode.h ! i860.o: i860.c i860.h i860-opcode.h as.h frags.h struc-symbol.h ! i860.o: flonum.h expr.h hash.h md.h write.h read.h symbols.h $(CC) -c $(CFLAGS) -DI860 i860.c ! atof-ieee.o: flonum.h ! write-i860.o: write.c i860.h $(CC) -c -DI860 $(CFLAGS) write.c ! mv write.o write-i860.o ! read-i860.o: read.c i860.h $(CC) -c -DI860 $(CFLAGS) read.c ! mv read.o read-i860.o a860: $a $u $(CC) -o a860 $(LDFLAGS) $a $u $(LOADLIBES) # SPARC GAS ------------------------------------------------------------------ ! v = sparc.o atof-ieee.o write-sparc.o read-sparc.o V = sparc.c sparc.h sparc-opcode.h ! atof-ieee.o: flonum.h ! sparc.o: sparc.c sparc.h sparc-opcode.h as.h frags.h struc-symbol.h ! sparc.o: flonum.h expr.h hash.h md.h write.h read.h symbols.h $(CC) -c $(CFLAGS) -DSPARC sparc.c ! write-sparc.o: write.c $(CC) -c -DSPARC $(CFLAGS) write.c ! mv write.o write-sparc.o ! read-sparc.o: read.c $(CC) -c -DSPARC $(CFLAGS) read.c ! mv read.o read-sparc.o asparc: $a $v $(CC) -o asparc $(LDFLAGS) $a $v $(LOADLIBES) # NS32K GAS ------------------------------------------------------------------ ! w = ns32k.o atof-ieee.o write-ns32k.o read-ns32k.o W = ns32k.c ns32k-opcode.h ! atof-ieee.o: flonum.h ! ns32k.o: as.h frags.h struc-symbol.h flonum.h expr.h md.h hash.h ! ns32k.o: write.h symbols.h ns32k-opcode.h ns32k.c $(CC) $(CFLAGS) $(OPTIONS) -c ns32k.c ! write-ns32k.o: write.c $(CC) -c -DNS32K $(CFLAGS) write.c ! mv write.o write-ns32k.o ! read-ns32k.o: $(CC) -c -DNS32K $(CFLAGS) read.c ! mv read.o read-ns32k.o a32k: $a $w $(CC) -o a32k $(LDFLAGS) $a $w $(LOADLIBES) # 80386 GAS ------------------------------------------------------------------ ! x = i386.o atof-ieee.o write.o read.o X = i386.c i386.h i386-opcode.h ! i386.o: i386.c as.h read.h flonum.h frags.h struc-symbol.h expr.h ! i386.o: symbols.h hash.h md.h i386.h i386-opcode.h $(CC) $(CFLAGS) $(OPTIONS) -c i386.c ! atof-ieee.o: flonum.h ! a386: $a $x ! $(CC) -o a386 $(LDFLAGS) $a $x $(LOADLIBES) # 68020 GAS ------------------------------------------------------------------ ! y = m68k.o atof-ieee.o write.o read.o Y = m68k.c atof-ieee.c m68k-opcode.h m-hpux.h m-sun3.h m-generic.h ! atof-ieee.o: flonum.h ! m68k.o: m68k.c a.out.gnu.h as.h expr.h flonum.h frags.h hash.h ! m68k.o: m68k-opcode.h m68k.h md.h obstack.h struc-symbol.h $(CC) $(CFLAGS) $(OPTIONS) -c m68k.c a68: $a $y --- 164,265 ---- # Global Sources ------------------------------------------------------------- a =\ ! as.obj xrealloc.obj xmalloc.obj hash.obj hex-value.obj \ ! atof-generic.obj append.obj messages.obj expr.obj \ ! app.obj frags.obj input-file.obj input-scrub.obj output-file.obj \ ! subsegs.obj symbols.obj version.obj flonum-const.obj \ ! flonum-copy.obj flonum-mult.obj strstr.obj bignum-copy.obj obstack.obj \ ! #gdb.obj gdb-file.obj gdb-symbols.obj gdb-blocks.obj gdb-lines.obj ! a : $(DEFAULT_GAS) # I860 GAS ------------------------------------------------------------------ ! u = i860.obj atof-ieee.obj write-i860.obj read-i860.obj U = i860.c i860.h i860-opcode.h ! i860.obj: i860.c i860.h i860-opcode.h as.h frags.h struc-symbol.h ! i860.obj: flonum.h expr.h hash.h md.h write.h read.h symbols.h $(CC) -c $(CFLAGS) -DI860 i860.c ! atof-ieee.obj: flonum.h ! write-i860.obj: write.c i860.h $(CC) -c -DI860 $(CFLAGS) write.c ! mv write.obj write-i860.obj ! read-i860.obj: read.c i860.h $(CC) -c -DI860 $(CFLAGS) read.c ! mv read.obj read-i860.obj a860: $a $u $(CC) -o a860 $(LDFLAGS) $a $u $(LOADLIBES) # SPARC GAS ------------------------------------------------------------------ ! v = sparc.obj atof-ieee.obj write-sparc.obj read-sparc.obj V = sparc.c sparc.h sparc-opcode.h ! atof-ieee.obj: flonum.h ! sparc.obj: sparc.c sparc.h sparc-opcode.h as.h frags.h struc-symbol.h ! sparc.obj: flonum.h expr.h hash.h md.h write.h read.h symbols.h $(CC) -c $(CFLAGS) -DSPARC sparc.c ! write-sparc.obj: write.c $(CC) -c -DSPARC $(CFLAGS) write.c ! mv write.obj write-sparc.obj ! read-sparc.obj: read.c $(CC) -c -DSPARC $(CFLAGS) read.c ! mv read.obj read-sparc.obj asparc: $a $v $(CC) -o asparc $(LDFLAGS) $a $v $(LOADLIBES) # NS32K GAS ------------------------------------------------------------------ ! w = ns32k.obj atof-ieee.obj write-ns32k.obj read-ns32k.obj W = ns32k.c ns32k-opcode.h ! atof-ieee.obj: flonum.h ! ns32k.obj: as.h frags.h struc-symbol.h flonum.h expr.h md.h hash.h ! ns32k.obj: write.h symbols.h ns32k-opcode.h ns32k.c $(CC) $(CFLAGS) $(OPTIONS) -c ns32k.c ! write-ns32k.obj: write.c $(CC) -c -DNS32K $(CFLAGS) write.c ! mv write.obj write-ns32k.obj ! read-ns32k.obj: $(CC) -c -DNS32K $(CFLAGS) read.c ! mv read.obj read-ns32k.obj a32k: $a $w $(CC) -o a32k $(LDFLAGS) $a $w $(LOADLIBES) # 80386 GAS ------------------------------------------------------------------ ! x = i386.obj atof-ieee.obj write.obj read.obj X = i386.c i386.h i386-opcode.h ! i386.obj: i386.c as.h read.h flonum.h frags.h struc-symbol.h expr.h ! i386.obj: symbols.h hash.h md.h i386.h i386-opcode.h $(CC) $(CFLAGS) $(OPTIONS) -c i386.c ! atof-ieee.obj: flonum.h ! a386.exe: $a $x ! $(CC) $(O_SWITCH)a386.exe $(LDFLAGS) $a $x $(LOADLIBES) # 68020 GAS ------------------------------------------------------------------ ! y = m68k.obj atof-ieee.obj write.obj read.obj Y = m68k.c atof-ieee.c m68k-opcode.h m-hpux.h m-sun3.h m-generic.h ! atof-ieee.obj: flonum.h ! m68k.obj: m68k.c a.out.gnu.h as.h expr.h flonum.h frags.h hash.h ! m68k.obj: m68k-opcode.h m68k.h md.h obstack.h struc-symbol.h $(CC) $(CFLAGS) $(OPTIONS) -c m68k.c a68: $a $y *************** *** 261,274 **** $(CC) -o a68 $(LDFLAGS) $a $y $(LOADLIBES) # VAX GAS -------------------------------------------------------------------- ! z = vax.o atof-vax.o write.o read.o Z = vax.c atof-vax.c vax-opcode.h vax-inst.h \ make-gas.com objrecdef.h vms.c vms-dbg.c README-vms-dbg ! vax.o: vax.c a.out.gnu.h as.h expr.h flonum.h frags.h md.h obstack.h ! vax.o: read.h struc-symbol.h symbols.h vax-inst.h vax-opcode.h ! atof-vax.o: as.h flonum.h read.h avax: $a $z $(CC) -o avax $(LDFLAGS) $a $z $(LOADLIBES) --- 266,279 ---- $(CC) -o a68 $(LDFLAGS) $a $y $(LOADLIBES) # VAX GAS -------------------------------------------------------------------- ! z = vax.obj atof-vax.obj write.obj read.obj Z = vax.c atof-vax.c vax-opcode.h vax-inst.h \ make-gas.com objrecdef.h vms.c vms-dbg.c README-vms-dbg ! vax.obj: vax.c a.out.gnu.h as.h expr.h flonum.h frags.h md.h obstack.h ! vax.obj: read.h struc-symbol.h symbols.h vax-inst.h vax-opcode.h ! atof-vax.obj: as.h flonum.h read.h avax: $a $z $(CC) -o avax $(LDFLAGS) $a $z $(LOADLIBES) *************** *** 275,293 **** # global files --------------------------------------------------------------- ! as.o: as.c $(CC) $(CFLAGS) $(OPTIONS) -c as.c ! messages.o: messages.c $(CC) $(CFLAGS) $(OPTIONS) -c messages.c ! hash.o: hash.c $(CC) $(CFLAGS) -Derror=as_fatal -c hash.c ! xmalloc.o: xmalloc.c $(CC) $(CFLAGS) -Derror=as_fatal -c xmalloc.c ! xrealloc.o: xrealloc.c $(CC) $(CFLAGS) -Derror=as_fatal -c xrealloc.c A =\ --- 280,298 ---- # global files --------------------------------------------------------------- ! as.obj: as.c $(CC) $(CFLAGS) $(OPTIONS) -c as.c ! messages.obj: messages.c $(CC) $(CFLAGS) $(OPTIONS) -c messages.c ! hash.obj: hash.c $(CC) $(CFLAGS) -Derror=as_fatal -c hash.c ! xmalloc.obj: xmalloc.c $(CC) $(CFLAGS) -Derror=as_fatal -c xmalloc.c ! xrealloc.obj: xrealloc.c $(CC) $(CFLAGS) -Derror=as_fatal -c xrealloc.c A =\ *************** *** 316,356 **** -rm .fname clean: ! rm -f a avax a68 a386 a32k asparc $a $v $w $x $y $z a core gmon.out bugs a.out install: a cp a $(BINDIR)/gas ! # General .o-->.h dependencies ! app.o: as.h ! as.o: a.out.gnu.h as.h read.h struc-symbol.h write.h ! atof-generic.o: flonum.h ! bignum-copy.o: bignum.h ! expr.o: a.out.gnu.h as.h expr.h flonum.h obstack.h read.h struc-symbol.h ! expr.o: symbols.h ! flonum-const.o: flonum.h ! flonum-copy.o: flonum.h ! flonum-mult.o: flonum.h ! flonum-normal.o:flonum.h ! flonum-print.o: flonum.h ! frags.o: a.out.gnu.h as.h frags.h obstack.h struc-symbol.h subsegs.h ! #gdb.o: as.h ! #gdb-blocks.o: as.h ! #gdb-lines.o: as.h frags.h obstack.h ! #gdb-symbols.o: a.out.gnu.h as.h struc-symbol.h ! hash.o: hash.h ! input-file.o: input-file.h ! input-scrub.o: as.h input-file.h read.h ! messages.o: as.h ! obstack.o: obstack.h ! read.o: a.out.gnu.h as.h expr.h flonum.h frags.h hash.h md.h obstack.h ! read.o: read.h struc-symbol.h symbols.h ! subsegs.o: a.out.gnu.h as.h frags.h obstack.h struc-symbol.h subsegs.h write.h ! symbols.o: a.out.gnu.h as.h frags.h hash.h obstack.h struc-symbol.h symbols.h ! write.o: a.out.gnu.h as.h md.h obstack.h struc-symbol.h subsegs.h ! write.o: symbols.h write.h flonum.h: bignum.h --- 321,361 ---- -rm .fname clean: ! rm -f a avax a68 a386.exe a32k asparc $a $v $w $x $y $z a core gmon.out bugs a.out install: a cp a $(BINDIR)/gas ! # General .obj-->.h dependencies ! app.obj: as.h ! as.obj: a.out.gnu.h as.h read.h struc-symbol.h write.h ! atof-generic.obj: flonum.h ! bignum-copy.obj: bignum.h ! expr.obj: a.out.gnu.h as.h expr.h flonum.h obstack.h read.h struc-symbol.h ! expr.obj: symbols.h ! flonum-const.obj: flonum.h ! flonum-copy.obj: flonum.h ! flonum-mult.obj: flonum.h ! flonum-normal.obj:flonum.h ! flonum-print.obj: flonum.h ! frags.obj: a.out.gnu.h as.h frags.h obstack.h struc-symbol.h subsegs.h ! #gdb.obj: as.h ! #gdb-blocks.obj: as.h ! #gdb-lines.obj: as.h frags.h obstack.h ! #gdb-symbols.obj: a.out.gnu.h as.h struc-symbol.h ! hash.obj: hash.h ! input-file.obj: input-file.h ! input-scrub.obj: as.h input-file.h read.h ! messages.obj: as.h ! obstack.obj: obstack.h ! read.obj: a.out.gnu.h as.h expr.h flonum.h frags.h hash.h md.h obstack.h ! read.obj: read.h struc-symbol.h symbols.h ! subsegs.obj: a.out.gnu.h as.h frags.h obstack.h struc-symbol.h subsegs.h write.h ! symbols.obj: a.out.gnu.h as.h frags.h hash.h obstack.h struc-symbol.h symbols.h ! write.obj: a.out.gnu.h as.h md.h obstack.h struc-symbol.h subsegs.h ! write.obj: symbols.h write.h flonum.h: bignum.h *** as.c.old Thu Oct 11 12:26:17 1990 --- as.c Tue Sep 21 23:36:46 1993 *************** *** 68,74 **** char **work_argv; /* variable copy of argv */ char *arg; /* an arg to program */ char a; /* an arg flag (after -) */ ! static const int sig[] = { SIGHUP, SIGINT, SIGPIPE, SIGTERM, 0}; extern int bad_error; /* Did we hit a bad error ? */ --- 68,87 ---- char **work_argv; /* variable copy of argv */ char *arg; /* an arg to program */ char a; /* an arg flag (after -) */ ! static const int sig[] = { ! #ifdef SIGHUP ! SIGHUP, ! #endif ! #ifdef SIGINT ! SIGINT, ! #endif ! #ifdef SIGPIPE ! SIGPIPE, ! #endif ! #ifdef SIGTERM ! SIGTERM, ! #endif ! 0}; extern int bad_error; /* Did we hit a bad error ? */ *** i386-opcode.h.old Tue Jan 23 14:26:34 1990 --- i386-opcode.h Thu Sep 23 01:16:56 1993 *************** *** 48,54 **** {"push", 1, 0x50, _, ShortForm, WordReg,0,0 }, {"push", 1, 0xff, 0x6, Modrm, WordReg|WordMem, 0, 0 }, {"push", 1, 0x6a, _, NoModrm, Imm8S, 0, 0}, ! {"push", 1, 0x68, _, NoModrm, Imm32, 0, 0}, {"push", 1, 0x06, _, Seg2ShortForm, SReg2,0,0 }, {"push", 1, 0x0fa0, _, Seg3ShortForm, SReg3,0,0 }, /* push all */ --- 48,54 ---- {"push", 1, 0x50, _, ShortForm, WordReg,0,0 }, {"push", 1, 0xff, 0x6, Modrm, WordReg|WordMem, 0, 0 }, {"push", 1, 0x6a, _, NoModrm, Imm8S, 0, 0}, ! {"push", 1, 0x68, _, NoModrm, Imm16|Imm32, 0, 0}, {"push", 1, 0x06, _, Seg2ShortForm, SReg2,0,0 }, {"push", 1, 0x0fa0, _, Seg3ShortForm, SReg3,0,0 }, /* push all */ *** output-file.c.old Fri Jan 4 13:12:56 1991 --- output-file.c Fri Mar 5 21:23:54 1993 *************** *** 38,44 **** { if(name[0]=='-' && name[1]=='\0') stdoutput=stdout; ! else if ( ! (stdoutput = fopen( name, "w" )) ) { as_perror ("FATAL: Can't create %s", name); exit(42); --- 38,44 ---- { if(name[0]=='-' && name[1]=='\0') stdoutput=stdout; ! else if ( ! (stdoutput = fopen( name, "wb" )) ) { as_perror ("FATAL: Can't create %s", name); exit(42); atof-ieee.obj write-ns32k.obj read-ns32k.obj W = ns32k.c ns32k-opcode.h ! atof-ieee.obj: flonum.h ! ns32k.obj: as.h frags.h struc-gnat-1.67-src/src/patches-gcc257.os2 440 10015 7640 30214 5506244515 12177 *** gcc.old Fri Nov 26 15:57:21 1993 --- gcc.c Wed Dec 1 18:06:58 1993 *************** *** 455,460 **** --- 455,461 ---- %{traditional-cpp:-traditional}\ %{g*} %{W*} %{w} %{pedantic*} %{H} %{d*} %C %{D*} %{U*} %{i*}\ %i %{!M:%{!MM:%{!E:%{!pipe:%g.i}}}}%{E:%W{o*}}%{M:%W{o*}}%{MM:%W{o*}} |\n", + #ifdef OS2 "%{!M:%{!MM:%{!E:cc1 %{!pipe:%g.i} %1 \ %{!Q:-quiet} -dumpbase %b.c %{d*} %{m*} %{a}\ %{g*} %{O*} %{W*} %{w} %{pedantic*} %{ansi} \ *************** *** 462,470 **** --- 463,483 ---- %{aux-info*}\ %{pg:%{fomit-frame-pointer:%e-pg and -fomit-frame-pointer are incompatible}}\ %{S:%W{o*}%{!o*:-o %b.s}}%{!S:-o %{|!pipe:%g.s}} |\n\ + %{!S:as %{R} %{j} %{J} %{h} %{d2} %a %Y -o %g.o \ + %{!pipe:%g.s} %A\n o2obj \ + %{c:%W{o*}%{!o*:-o %w%b.obj}}%{!c:-o %g%w.obj} %g.o\n }}}}"}, + #else + "%{!M:%{!MM:%{!E:cc1 %{!pipe:%g.i} %1 \ + %{!Q:-quiet} -dumpbase %b.c %{d*} %{m*} %{a}\ + %{g*} %{O*} %{W*} %{w} %{pedantic*} %{ansi} \ + %{traditional} %{v:-version} %{pg:-p} %{p} %{f*}\ + %{aux-info*}\ + %{pg:%{fomit-frame-pointer:%e-pg and -fomit-frame-pointer are incompatible}}\ + %{S:%W{o*}%{!o*:-o %b.s}}%{!S:-o %{|!pipe:%g.s}} |\n\ %{!S:as %{R} %{j} %{J} %{h} %{d2} %a %Y\ %{c:%W{o*}%{!o*:-o %w%b.o}}%{!c:-o %d%w%u.o}\ %{!pipe:%g.s} %A\n }}}}"}, + #endif {"-", "%{E:cpp -lang-c %{nostdinc*} %{C} %{v} %{A*} %{I*} %{P} %I\ %{C:%{!E:%eGNU C does not support -C without using -E}}\ *************** *** 489,494 **** --- 502,508 ---- %{traditional-cpp:-traditional}\ %{g*} %{W*} %{w} %{pedantic*} %{H} %{d*} %C %{D*} %{U*} %{i*}\ %i %{!M:%{!MM:%{!E:%{!pipe:%g.i}}}}%{E:%W{o*}}%{M:%W{o*}}%{MM:%W{o*}} |\n", + #ifdef OS2 "%{!M:%{!MM:%{!E:cc1obj %{!pipe:%g.i} %1 \ %{!Q:-quiet} -dumpbase %b.m %{d*} %{m*} %{a}\ %{g*} %{O*} %{W*} %{w} %{pedantic*} %{ansi} \ *************** *** 497,505 **** --- 511,532 ---- %{aux-info*}\ %{pg:%{fomit-frame-pointer:%e-pg and -fomit-frame-pointer are incompatible}}\ %{S:%W{o*}%{!o*:-o %b.s}}%{!S:-o %{|!pipe:%g.s}} |\n\ + %{!S:as %{R} %{j} %{J} %{h} %{d2} %a %Y -o %g.o \ + %{!pipe:%g.s} %A\n o2obj \ + %{c:%W{o*}%{!o*:-o %w%b.obj}}%{!c:-o %g%w.obj} %g.o\n }}}}"}, + #else + "%{!M:%{!MM:%{!E:cc1obj %{!pipe:%g.i} %1 \ + %{!Q:-quiet} -dumpbase %b.m %{d*} %{m*} %{a}\ + %{g*} %{O*} %{W*} %{w} %{pedantic*} %{ansi} \ + %{traditional} %{v:-version} %{pg:-p} %{p} %{f*} \ + -lang-objc %{gen-decls} \ + %{aux-info*}\ + %{pg:%{fomit-frame-pointer:%e-pg and -fomit-frame-pointer are incompatible}}\ + %{S:%W{o*}%{!o*:-o %b.s}}%{!S:-o %{|!pipe:%g.s}} |\n\ %{!S:as %{R} %{j} %{J} %{h} %{d2} %a %Y\ %{c:%W{o*}%{!o*:-o %w%b.o}}%{!c:-o %d%w%u.o}\ %{!pipe:%g.s} %A\n }}}}"}, + #endif {".h", "@c-header"}, {"@c-header", "%{!E:%eCompilation of header file requested} \ *************** *** 526,531 **** --- 553,559 ---- %{traditional-cpp:-traditional} %{trigraphs}\ %{g*} %{W*} %{w} %{pedantic*} %{H} %{d*} %C %{D*} %{U*} %{i*}\ %i %{!M:%{!MM:%{!E:%{!pipe:%g.i}}}}%{E:%W{o*}}%{M:%W{o*}}%{MM:%W{o*}} |\n", + #ifdef OS2 "%{!M:%{!MM:%{!E:cc1plus %{!pipe:%g.i} %1 %2\ %{!Q:-quiet} -dumpbase %b.cc %{d*} %{m*} %{a}\ %{g*} %{O*} %{W*} %{w} %{pedantic*} %{ansi} %{traditional}\ *************** *** 533,543 **** --- 561,584 ---- %{aux-info*}\ %{pg:%{fomit-frame-pointer:%e-pg and -fomit-frame-pointer are incompatible}}\ %{S:%W{o*}%{!o*:-o %b.s}}%{!S:-o %{|!pipe:%g.s}} |\n\ + %{!S:as %{R} %{j} %{J} %{h} %{d2} %a %Y -o %g.o \ + %{!pipe:%g.s} %A\n o2obj \ + %{c:%W{o*}%{!o*:-o %w%b.obj}}%{!c:-o %g%w.obj} %g.o\n }}}}"}, + #else + "%{!M:%{!MM:%{!E:cc1plus %{!pipe:%g.i} %1 %2\ + %{!Q:-quiet} -dumpbase %b.cc %{d*} %{m*} %{a}\ + %{g*} %{O*} %{W*} %{w} %{pedantic*} %{ansi} %{traditional}\ + %{v:-version} %{pg:-p} %{p} %{f*} %{+e*}\ + %{aux-info*}\ + %{pg:%{fomit-frame-pointer:%e-pg and -fomit-frame-pointer are incompatible}}\ + %{S:%W{o*}%{!o*:-o %b.s}}%{!S:-o %{|!pipe:%g.s}} |\n\ %{!S:as %{R} %{j} %{J} %{h} %{d2} %a %Y\ %{c:%W{o*}%{!o*:-o %w%b.o}}%{!c:-o %d%w%u.o}\ %{!pipe:%g.s} %A\n }}}}"}, + #endif {".i", "@cpp-output"}, {"@cpp-output", + #ifdef OS2 "cc1 %i %1 %{!Q:-quiet} %{d*} %{m*} %{a}\ %{g*} %{O*} %{W*} %{w} %{pedantic*} %{ansi} %{traditional}\ %{v:-version} %{pg:-p} %{p} %{f*}\ *************** *** 545,553 **** --- 586,606 ---- %{pg:%{fomit-frame-pointer:%e-pg and -fomit-frame-pointer are incompatible}}\ %{S:%W{o*}%{!o*:-o %b.s}}%{!S:-o %{|!pipe:%g.s}} |\n\ %{!S:as %{R} %{j} %{J} %{h} %{d2} %a %Y\ + -o %g.o %{!pipe:%g.s} %A\n o2obj \ + %{c:%W{o*}%{!o*:-o %w%b.obj}}%{!c:-o %g%w.obj} %g.o\n }"}, + #else + "cc1 %i %1 %{!Q:-quiet} %{d*} %{m*} %{a}\ + %{g*} %{O*} %{W*} %{w} %{pedantic*} %{ansi} %{traditional}\ + %{v:-version} %{pg:-p} %{p} %{f*}\ + %{aux-info*}\ + %{pg:%{fomit-frame-pointer:%e-pg and -fomit-frame-pointer are incompatible}}\ + %{S:%W{o*}%{!o*:-o %b.s}}%{!S:-o %{|!pipe:%g.s}} |\n\ + %{!S:as %{R} %{j} %{J} %{h} %{d2} %a %Y\ %{c:%W{o*}%{!o*:-o %w%b.o}}%{!c:-o %d%w%u.o} %{!pipe:%g.s} %A\n }"}, + #endif {".ii", "@c++-cpp-output"}, {"@c++-cpp-output", + #ifdef OS2 "cc1plus %i %1 %2 %{!Q:-quiet} %{d*} %{m*} %{a}\ %{g*} %{O*} %{W*} %{w} %{pedantic*} %{ansi} %{traditional}\ %{v:-version} %{pg:-p} %{p} %{f*} %{+e*}\ *************** *** 554,566 **** --- 607,636 ---- %{aux-info*}\ %{pg:%{fomit-frame-pointer:%e-pg and -fomit-frame-pointer are incompatible}}\ %{S:%W{o*}%{!o*:-o %b.s}}%{!S:-o %{|!pipe:%g.s}} |\n\ + %{!S:as %{R} %{j} %{J} %{h} %{d2} %a %Y -o %g.o \ + %{!pipe:%g.s} %A\n o2obj \ + %{c:%W{o*}%{!o*:-o %w%b.obj}}%{!c:-o %g%w.obj} %g.o\n }"}, + #else + "cc1plus %i %1 %2 %{!Q:-quiet} %{d*} %{m*} %{a}\ + %{g*} %{O*} %{W*} %{w} %{pedantic*} %{ansi} %{traditional}\ + %{v:-version} %{pg:-p} %{p} %{f*} %{+e*}\ + %{aux-info*}\ + %{pg:%{fomit-frame-pointer:%e-pg and -fomit-frame-pointer are incompatible}}\ + %{S:%W{o*}%{!o*:-o %b.s}}%{!S:-o %{|!pipe:%g.s}} |\n\ %{!S:as %{R} %{j} %{J} %{h} %{d2} %a %Y\ %{c:%W{o*}%{!o*:-o %w%b.o}}%{!c:-o %d%w%u.o}\ %{!pipe:%g.s} %A\n }"}, + #endif {".s", "@assembler"}, {"@assembler", + #ifdef OS2 "%{!S:as %{R} %{j} %{J} %{h} %{d2} %a %Y\ + -o %g.o %i %A\n o2obj \ + %{c:%W{o*}%{!o*:-o %w%b.obj}}%{!c:-o %g%w.obj} %g.o\n }"}, + #else + "%{!S:as %{R} %{j} %{J} %{h} %{d2} %a %Y\ %{c:%W{o*}%{!o*:-o %w%b.o}}%{!c:-o %d%w%u.o} %i %A\n }"}, + #endif {".S", "@assembler-with-cpp"}, {"@assembler-with-cpp", "cpp -lang-asm %{nostdinc*} %{C} %{v} %{A*} %{I*} %{P} %I\ *************** *** 571,579 **** --- 641,655 ---- %{traditional-cpp:-traditional}\ %{g*} %{W*} %{w} %{pedantic*} %{H} %{d*} %C %{D*} %{U*} %{i*}\ %i %{!M:%{!MM:%{!E:%{!pipe:%g.s}}}}%{E:%W{o*}}%{M:%W{o*}}%{MM:%W{o*}} |\n", + #ifdef OS2 + "%{!M:%{!MM:%{!E:%{!S:as %{R} %{j} %{J} %{h} %{d2} %a %Y -o %g.o \ + %{!pipe:%g.s} %A\n o2obj \ + %{c:%W{o*}%{!o*:-o %w%b.obj}}%{!c:-o %g%w.obj} %g.o\n }}}}"}, + #else "%{!M:%{!MM:%{!E:%{!S:as %{R} %{j} %{J} %{h} %{d2} %a %Y\ %{c:%W{o*}%{!o*:-o %w%b.o}}%{!c:-o %d%w%u.o}\ %{!pipe:%g.s} %A\n }}}}"}, + #endif {".ads", "@ada"}, {".adb", "@ada"}, {".ada", "@ada"}, *************** *** 583,591 **** --- 659,675 ---- %{g*} %{O*} %{p} %{pg:-p} %{f*} %{d*}\ %{pg:%{fomit-frame-pointer:%e-pg and -fomit-frame-pointer are incompatible}}\ %i %{S:%W{o*}%{!o*:-o %b.s}}%{!S:-o %{|!pipe:%g.s}} | \n", + #ifdef OS2 + "%{!S:%{!gnatc:%{!gnats:as %{R} %{j} %{J} %{h} %{d2} %a %Y -o %g.o \ + %{!pipe:%g.s} %A\n o2obj \ + %{c:%W{o*}%{!o*:-o %w%b.obj}}%{!c:-o %g%w.obj} %g.o\n}}} "}, + {".o", + "o2obj %{c:%d%w%g.o}%{!c:%d%w%g.o}"}, + #else "%{!S:%{!gnatc:%{!gnats:as %{R} %{j} %{J} %{h} %{d2} %a %Y\ %{c:%W{o*}%{!o*:-o %w%b.o}}%{!c:-o %d%w%u.o}\ %{!pipe:%g.s} %A\n}}} "}, + #endif /* Mark end of table */ {0, 0} }; *************** *** 600,605 **** --- 684,698 ---- /* -u* was put back because both BSD and SysV seem to support it. */ /* %{static:} simply prevents an error message if the target machine doesn't handle -static. */ + #ifdef OS2 + static char *link_command_spec = "\ + %{!fsyntax-only: \ + %{!c:%{!M:%{!MM:%{!E:%{!S:link386 %l %X /st:786432/pm:vio/noi/a:16/e/bas:65536 \ + %{A:} %{d:} %{e*:} %{g:/de} %{m:} %{N:} %{n:} \ + %{r:} %{s:} %{T*:} %{t:/i} %{u*:} %{x:} %{z:}\ + %o , %{o*:%*}%{!o*:%b} %{!A:%{!nostartfiles:%{!nostdlib:%S}}} %{static:}, NUL, \ + %{L*:%*} %{!nostdlib:libc.lib%s %{!A:%E}} os2;\n }}}}}}"; + #else /* We want %{T*} after %{L*} and %D so that it can be used to specify linker scripts which exist in user specified directories, or in standard directories. */ *************** *** 630,635 **** --- 723,729 ---- %{L*} %D %{T*} %o %{!nostdlib:-lgcc %L -lgcc %{!A:%E}}\n }}}}}}"; #endif #endif + #endif /* A vector of options to give to the linker. These options are accumulated by -Xlinker and -Wl, *************** *** 872,878 **** read_specs (filename) char *filename; { ! int desc; struct stat statbuf; char *buffer; register char *p; --- 966,972 ---- read_specs (filename) char *filename; { ! int desc, bytes_read; struct stat statbuf; char *buffer; register char *p; *************** *** 889,896 **** /* Read contents of file into BUFFER. */ buffer = xmalloc ((unsigned) statbuf.st_size + 1); ! read (desc, buffer, (unsigned) statbuf.st_size); ! buffer[statbuf.st_size] = 0; close (desc); /* Scan BUFFER for specs, putting them in the vector. */ --- 983,990 ---- /* Read contents of file into BUFFER. */ buffer = xmalloc ((unsigned) statbuf.st_size + 1); ! bytes_read = read (desc, buffer, (unsigned) statbuf.st_size); ! buffer[bytes_read] = 0; close (desc); /* Scan BUFFER for specs, putting them in the vector. */ *************** *** 1403,1415 **** --- 1497,1522 ---- /* If all else fails, use the current directory! */ if (base == (char *)0) + #ifdef OS2 + base = ".\\"; + #else base = "./"; + #endif len = strlen (base); temp_filename = xmalloc (len + sizeof("/ccXXXXXX") + 1); strcpy (temp_filename, base); + #ifdef OS2 + /* Although it may be desirable to always use '\' to separate the components + of a path under OS/2, using '\' here and here only is sufficient to allow + one to compile and link (load) with one command - the OS/2 linker does + not accept '/' to separate the components of a path. */ + if (len > 0 && temp_filename[len-1] != '/' && temp_filename[len-1] != '\\') + temp_filename[len++] = '\\'; + #else if (len > 0 && temp_filename[len-1] != '/') temp_filename[len++] = '/'; + #endif strcpy (temp_filename + len, "ccXXXXXX"); mktemp (temp_filename); *************** *** 3689,3695 **** --- 3796,3806 ---- char *p; p = argv[0] + strlen (argv[0]); + #ifdef OS2 + while (p != argv[0] && p[-1] != '/' && p[-1] != '\\') --p; + #else while (p != argv[0] && p[-1] != '/') --p; + #endif programname = p; if (signal (SIGINT, SIG_IGN) != SIG_IGN) *** cccp.old Fri Nov 5 17:28:28 1993 --- cccp.c Wed Dec 1 18:16:51 1993 *************** *** 1091,1097 **** --- 1091,1101 ---- #endif p = argv[0] + strlen (argv[0]); + #ifdef OS2 + while (p != argv[0] && p[-1] != '/' && p[-1] != '\\') --p; + #else while (p != argv[0] && p[-1] != '/') --p; + #endif progname = p; #ifdef VMS *** toplev.old Sat Oct 30 04:21:39 1993 --- toplev.c Wed Dec 1 18:23:01 1993 *************** *** 2931,2937 **** --- 2931,2941 ---- save_argv = argv; p = argv[0] + strlen (argv[0]); + #ifdef OS2 + while (p != argv[0] && p[-1] != '/' && p[-1] != '\\') --p; + #else while (p != argv[0] && p[-1] != '/') --p; + #endif progname = p; #ifdef RLIMIT_STACK patible}}\ + %{S:%W{o*}%{!o*:-o %b.s}}%{!S:-o %{|!pipe:%g.s}} |\n\ + %{!S:as %{R} %{j} %{J} %{h} %{d2} %a %Y\ %{c:%W{o*}%{!o*:-o %w%b.o}}%{!c:-o %d%w%u.o} %{!pipe:%g.s} %A\n }"}, + #endif {".ii", "@c++-cpp-output"}, {"@c++-cpp-output", + #ifdef OS2 "cc1plus %i %1 %2 %{!Q:-quiet} %{d*} %{m*} %{a}\ %{g*} %{O*} %{W*} %{w} %{pedantic*}gnat-1.67-src/src/sysid.ads 644 10015 7640 5354 5506244515 10754 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S Y S I D -- -- -- -- S p e c -- -- (UNIX Version) -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ package Sysid is -- This package contains the flag that shows what operating system is used MS_DOS : constant Boolean := False; -- This flag is True if operating under MS/DOS or an operating system that -- shares its conventions (such as OS/2). It affects the output format of -- library information files (CR/LF at end of lines, and EOF at end of -- file), the default character set (PC), and the output of the usage -- information (switch character displayed as slash instead of minus). -- Note that the handling of input files is not dependent on the setting -- of this flag. For input source and library information files, the line -- terminator may be either CR/LF or LF alone, and the EOF character is -- optional, but will be recognized as signalling the end of file (and -- no further information will be read) if it is encountered. end Sysid; on: 1.2 $ -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -gnat-1.67-src/src/Makefile.in.diff 644 10015 7640 105724 5506244516 12147 *** ../currentbase/Makefile.in Thu Nov 25 18:08:52 1993 --- Makefile.in Wed Dec 22 23:40:15 1993 *************** *** 29,35 **** # See below for how to change them for certain systems. # Selection of languages to be made. ! LANGUAGES = c c++ objective-c proto ALLOCA = ALLOCA_FLAGS = --- 29,35 ---- # See below for how to change them for certain systems. # Selection of languages to be made. ! LANGUAGES = c c++ objective-c ada proto ALLOCA = ALLOCA_FLAGS = *************** *** 392,398 **** # Lists of files for various purposes. # A list of all the language-specific executables. ! COMPILERS = cc1 cc1plus cc1obj # Language-specific object files for C. C_OBJS = c-parse.o c-lang.o c-lex.o c-pragma.o \ --- 392,398 ---- # Lists of files for various purposes. # A list of all the language-specific executables. ! COMPILERS = cc1 cc1plus cc1obj gnat1 # Language-specific object files for C. C_OBJS = c-parse.o c-lang.o c-lex.o c-pragma.o \ *************** *** 410,415 **** --- 410,443 ---- cp-expr.o cp-pt.o cp-edsel.o cp-xref.o \ $(CPLUS_INPUT) cp-spew.o c-common.o cp-error.o cp-errfn.o + # Languages-specific object files for Ada. + GNAT1_C_OBJS = bind_gnat1drv.o a-adaint.o a-gtran3.o a-misc.o a-trans3.o \ + a-trans4.o a-trans.o a-uint.o + + GNAT_ADA_OBJS = alloc.o atree.o casing.o comperr.o csets.o debug.o \ + debug_sem.o einfo.o errcount.o errout.o excep.o expand.o exp_attr.o \ + exp_ch2.o exp_ch3.o \ + exp_ch4.o exp_ch5.o exp_ch6.o exp_ch7.o exp_ch8.o exp_ch9.o exp_ch10.o \ + exp_ch11.o exp_ch12.o exp_ch13.o exp_prag.o exp_util.o fname.o frontend.o \ + gnatvsn.o lib.o libfmt.o limits.o namet.o nmake.o opt.o osint.o output.o \ + par.o rtsfind.o scans.o scn.o sem.o sem_attr.o sem_ch3.o sem_ch4.o \ + sem_ch5.o sem_ch6.o sem_ch7.o sem_ch8.o sem_ch9.o sem_ch10.o sem_ch11.o \ + sem_ch12.o sem_ch13.o sem_disp.o sem_eval.o sem_prag.o sem_res.o sem_type.o \ + sem_util.o sinfo.o sinfo-change.o sinput.o snames.o sprint.o stand.o \ + stringt.o switch.o sysid.o system.o system-assertions.o system-traceback.o \ + system_environment.o tbuild.o treepr.o \ + treeprs.o ttypes.o types.o uintp.o uname.o unixlib.o usage.o + + GNATF_OBJS = $(GNAT_ADA_OBJS) frontdrv.o xref.o xref_tab.o a-adaint.o + GNAT1_ADA_OBJS = $(GNAT_ADA_OBJS) back_end.o gnat1drv.o + GNAT1_OBJS = $(GNAT1_C_OBJS) $(GNAT1_ADA_OBJS) + + GNATBIND_OBJS = gnatbind.o ali.o alloc.o bcheck.o binde.o binderr.o bindgen.o \ + bindusg.o butil.o debug.o errcount.o excep.o gnatvsn.o libfmt.o \ + limits.o namet.o opt.o osint.o output.o switch.o sysid.o system.o \ + system-assertions.o system-traceback.o system_environment.o \ + types.o unixlib.o a-adaint.o + # Files specific to the C interpreter bytecode compiler(s). BC_OBJS = bc-emit.o bc-optab.o *************** *** 484,489 **** --- 512,531 ---- # Avoid a lot of time thinking about remaking Makefile.in and *.def. .SUFFIXES: .in .def + # Say how to compile Ada programs. + .SUFFIXES: .ada .adb .ads + + AFLAGS= -g -gnatg -gnata + BOOT_AFLAGS= -O2 $(AFLAGS) + GNATBIND= gnatbind + + .ada.o: + $(CC) -c $(AFLAGS) $< + .adb.o: + $(CC) -c $(AFLAGS) $< + .ads.o: + $(CC) -c $(AFLAGS) $< + Makefile: $(srcdir)/Makefile.in $(srcdir)/configure $(srcdir)/version.c \ $(srcdir)/config/$(xmake_file) $(srcdir)/config/$(tmake_file) sh config.status *************** *** 514,519 **** --- 556,562 ---- # The next two ought to depend on objc-runtime, but that doesn't work yet. OBJC objc: cc1obj OBJECTIVE-C objective-c: cc1obj + Ada ada: gnat1 ; PROTO: proto # Really, really stupid make features, such as SUN's KEEP_STATE, may force *************** *** 576,581 **** --- 619,640 ---- cc1obj: $(P) $(OBJC_OBJS) $(OBJS) $(BC_OBJS) $(LIBDEPS) $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o cc1obj $(OBJC_OBJS) $(OBJS) $(BC_OBJS) $(LIBS) + # Needs to be built with CC=gcc + gnat1: $(P) $(GNAT1_OBJS) $(OBJS) $(BC_OBJS) $(LIBDEPS) + $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o gnat1 $(GNAT1_OBJS) $(OBJS) $(BC_OBJS) $(LIBS) + + gnatf: $(P) $(GNATF_OBJS) bind_frontdrv.o + $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o gnatf $(GNATF_OBJS) bind_frontdrv.o + + + gnatbind: $(P) $(GNATBIND_OBJS) bind_gnatbind.o + $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o gnatbind $(GNATBIND_OBJS)\ + bind_gnatbind.o + + # .s files for cross-building + gnat-cross: force + make $(GNAT1_ADA_OBJS) CC="gcc -Bstage1/" CFLAGS="-S -gnatp" + # Copy float.h from its source. gfloat.h: $(FLOAT_H) cp $(FLOAT_H) gfloat.h *************** *** 869,874 **** --- 928,1497 ---- g++.o : g++.c $(CONFIG_H) gvarargs.h + # Ada language specific files. + + ada_extra_files : treeprs.ads sysid.ads a-einfo.h a-sinfo.h nmake.adb \ + nmake.ads + + bind_gnat1drv.c : $(GNAT1_ADA_OBJS) + $(GNATBIND) -n -t gnat1drv.ali + bind_gnat1drv.o : bind_gnat1drv.c + + bind_frontdrv.c : $(GNATF_OBJS) + $(GNATBIND) -t frontdrv.ali + + bind_frontdrv.o : bind_frontdrv.c + + + bind_gnatbind.c : $(GNATBIND_OBJS) + $(GNATBIND) -t gnatbind.ali + bind_gnatbind.o : bind_gnatbind.c + + treeprs.ads : treeprs.adt sinfo.ads xtreeprs.spt + spitbol xtreeprs.spt + + sysid.ads : sysid~u.ads + /bin/rm -f sysid.ads + cp sysid~u.ads sysid.ads + + a-einfo.h : einfo.ads einfo.adb xeinfo.spt + spitbol xeinfo.spt + + a-sinfo.h : sinfo.ads xsinfo.spt + spitbol xsinfo.spt + + nmake.adb : nmake.adt sinfo.ads xnmake.spt + spitbol xnmake.spt -b + + nmake.ads : nmake.adt sinfo.ads xnmake.spt + spitbol xnmake.spt -s + + mk-ttypes.o : mk-ttypes.c hconfig.h machmode.h + $(HOST_CC) -c $(HOST_CFLAGS) $(HOST_CPPFLAGS) $(INCLUDES) $(srcdir)/mk-ttypes.c + mk-ttypes : mk-ttypes.o $(HOST_LIBDEPS) + $(HOST_CC) $(HOST_CFLAGS) $(HOST_LDFLAGS) -o mk-ttypes \ + mk-ttypes.o $(HOST_LIBS) + + ttypes.ads: stamp-ttypes ; @true + stamp-ttypes : ttypes.adt mk-ttypes $(srcdir)/move-if-change + ./mk-ttypes ttypes.adt > tmp-ttypes.ads + $(srcdir)/move-if-change tmp-ttypes.ads ttypes.ads + touch stamp-ttypes + + A_MISC_H = a-misc.h a-tree.def + + a-adaint.o : $(CONFIG_H) + + a-gtran3.o : $(CONFIG_H) $(TREE_H) obstack.h flags.h convert.h a-ada.h \ + a-types.h a-atree.h a-sinfo.h a-einfo.h a-namet.h a-string.h a-uint.h \ + a-trans.h a-trans3.h a-trans4.h a-gtran3.h $(A_MISC_H) a-rtree.h + + a-ptypes.o : $(CONFIG_H) + + a-misc.o : $(CONFIG_H) $(TREE_H) a-ada.h a-types.h a-atree.h a-sinfo.h \ + a-einfo.h a-namet.h a-string.h a-uint.h a-trans.h a-trans3.h $(A_MISC_H) \ + a-rtree.h flags.h $(RTL_H) expr.h insn-codes.h + + a-trans3.o : $(CONFIG_H) $(TREE_H) flags.h a-ada.h a-types.h a-atree.h \ + a-sinfo.h a-einfo.h a-namet.h a-string.h a-uint.h a-trans.h a-gtran3.h \ + a-trans3.h a-trans4.h $(A_MISC_H) a-rtree.h convert.h + + a-trans4.o : $(CONFIG_H) $(TREE_H) flags.h a-ada.h a-types.h a-atree.h \ + a-sinfo.h a-einfo.h a-namet.h a-string.h a-uint.h a-trans.h a-trans3.h \ + a-trans4.h $(A_MISC_H) + + a-trans.o : $(CONFIG_H) $(TREE_H) flags.h a-ada.h a-types.h a-atree.h \ + a-sinfo.h a-einfo.h a-namet.h a-string.h a-uint.h a-trans.h a-trans3.h \ + a-gtran3.h a-trans4.h $(A_MISC_H) a-rtree.h + + a-uint.o : $(CONFIG_H) $(TREE_H) a-ada.h a-types.h a-atree.h a-sinfo.h \ + a-einfo.h a-namet.h a-string.h a-uint.h + + ali.o : ali.ads ali.adb alloc.ads binderr.ads butil.ads debug.ads \ + limits.ads namet.ads opt.ads osint.ads output.ads system.ads table.ads \ + table.adb types.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + alloc.o : alloc.ads + + atree.o : alloc.ads atree.ads atree.adb atree-ts.adb comperr.ads debug.ads \ + einfo.ads output.ads sinfo.ads system.ads system-assertions.ads \ + table.ads table.adb types.ads unchecked_conversion.ads \ + unchecked_conversion.adb unchecked_deallocation.ads \ + unchecked_deallocation.adb + + back_end.o : alloc.ads atree.ads back_end.ads back_end.adb casing.ads \ + debug.ads einfo.ads lib.ads limits.ads namet.ads output.ads sinfo.ads \ + stringt.ads system.ads table.ads table.adb types.ads uintp.ads \ + unchecked_deallocation.ads unchecked_deallocation.adb + + bcheck.o : ali.ads alloc.ads bcheck.ads bcheck.adb binderr.ads debug.ads \ + gnatvsn.ads libfmt.ads limits.ads namet.ads opt.ads output.ads \ + system.ads table.ads table.adb types.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + binde.o : ali.ads alloc.ads binde.ads binde.adb binderr.ads butil.ads \ + debug.ads limits.ads namet.ads opt.ads output.ads system.ads table.ads \ + table.adb types.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + binderr.o : alloc.ads binderr.ads binderr.adb butil.ads debug.ads \ + errcount.ads excep.ads limits.ads namet.ads opt.ads osint.ads \ + output.ads system.ads system-traceback.ads table.ads table.adb \ + types.ads unchecked_deallocation.ads unchecked_deallocation.adb + + bindgen.o : ali.ads alloc.ads binde.ads bindgen.ads bindgen.adb debug.ads \ + limits.ads namet.ads opt.ads osint.ads output.ads system.ads table.ads \ + table.adb types.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + bindusg.o : bindusg.ads bindusg.adb osint.ads output.ads sysid.ads \ + system.ads types.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + butil.o : alloc.ads butil.ads butil.adb debug.ads limits.ads namet.ads \ + output.ads system.ads table.ads table.adb types.ads \ + unchecked_deallocation.ads unchecked_deallocation.adb + + casing.o : alloc.ads casing.ads casing.adb csets.ads debug.ads limits.ads \ + namet.ads output.ads scans.ads system.ads table.ads table.adb types.ads \ + unchecked_deallocation.ads unchecked_deallocation.adb + + comperr.o : comperr.ads comperr.adb debug.ads errcount.ads excep.ads \ + osint.ads output.ads system.ads system-traceback.ads treepr.ads \ + types.ads unchecked_deallocation.ads unchecked_deallocation.adb + + csets.o : csets.ads csets.adb opt.ads system.ads types.ads \ + unchecked_deallocation.ads unchecked_deallocation.adb + + debug.o : debug.ads debug.adb output.ads system.ads types.ads \ + unchecked_deallocation.ads unchecked_deallocation.adb + + debug_sem.o : alloc.ads atree.ads debug.ads debug_sem.ads debug_sem.adb \ + einfo.ads output.ads sinfo.ads sinput.ads system.ads table.ads \ + table.adb types.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + einfo.o : alloc.ads atree.ads comperr.ads debug.ads einfo.ads einfo.adb \ + limits.ads namet.ads output.ads sinfo.ads snames.ads system.ads \ + system-assertions.ads table.ads table.adb types.ads \ + unchecked_deallocation.ads unchecked_deallocation.adb + + errcount.o : errcount.ads system.ads types.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + errout.o : alloc.ads atree.ads casing.ads csets.ads debug.ads einfo.ads \ + errcount.ads errout.ads errout.adb excep.ads exp_util.ads lib.ads \ + limits.ads namet.ads opt.ads output.ads scans.ads sinfo.ads sinput.ads \ + stand.ads system.ads table.ads table.adb types.ads uintp.ads uname.ads \ + unchecked_deallocation.ads unchecked_deallocation.adb + + excep.o : excep.ads + + exp_attr.o : alloc.ads atree.ads debug.ads einfo.ads exp_attr.ads \ + exp_attr.adb exp_ch9.ads limits.ads namet.ads nmake.ads opt.ads \ + output.ads rtsfind.ads sem.ads sem_res.ads sinfo.ads snames.ads \ + stand.ads system.ads table.ads table.adb tbuild.ads ttypes.ads \ + types.ads uintp.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + exp_ch10.o : exp_ch10.ads + + exp_ch11.o : exp_ch11.ads + + exp_ch12.o : exp_ch12.ads + + exp_ch13.o : alloc.ads atree.ads debug.ads einfo.ads exp_ch13.ads \ + exp_ch13.adb exp_ch3.ads nmake.ads output.ads rtsfind.ads sinfo.ads \ + snames.ads system.ads table.ads table.adb tbuild.ads types.ads \ + unchecked_deallocation.ads unchecked_deallocation.adb + + exp_ch2.o : alloc.ads atree.ads debug.ads einfo.ads exp_ch2.ads \ + exp_ch2.adb output.ads sinfo.ads system.ads table.ads table.adb \ + types.ads unchecked_deallocation.ads unchecked_deallocation.adb + + exp_ch3.o : alloc.ads atree.ads comperr.ads debug.ads einfo.ads \ + exp_ch3.ads exp_ch3.adb exp_ch9.ads exp_util.ads limits.ads namet.ads \ + nmake.ads opt.ads output.ads rtsfind.ads sem.ads sem_ch3.ads \ + sem_res.ads sem_util.ads sinfo.ads snames.ads stand.ads system.ads \ + system-assertions.ads table.ads table.adb tbuild.ads types.ads \ + uintp.ads unchecked_deallocation.ads unchecked_deallocation.adb + + exp_ch4.o : alloc.ads atree.ads comperr.ads debug.ads einfo.ads \ + exp_ch4.ads exp_ch4.adb exp_ch9.ads exp_util.ads limits.ads namet.ads \ + nmake.ads opt.ads output.ads rtsfind.ads sem.ads sem_eval.ads \ + sem_res.ads sem_util.ads sinfo.ads snames.ads stand.ads system.ads \ + table.ads table.adb tbuild.ads types.ads uintp.ads \ + unchecked_deallocation.ads unchecked_deallocation.adb + + exp_ch5.o : alloc.ads atree.ads debug.ads einfo.ads exp_ch5.ads \ + exp_ch5.adb exp_ch9.ads exp_util.ads nmake.ads opt.ads output.ads \ + rtsfind.ads sem.ads sem_util.ads sinfo.ads snames.ads system.ads \ + table.ads table.adb tbuild.ads types.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + exp_ch6.o : alloc.ads atree.ads comperr.ads debug.ads einfo.ads errout.ads \ + exp_ch6.ads exp_ch6.adb exp_ch9.ads exp_util.ads limits.ads namet.ads \ + nmake.ads opt.ads output.ads rtsfind.ads sem.ads sem_ch3.ads \ + sem_disp.ads sem_util.ads sinfo.ads snames.ads stand.ads system.ads \ + system-assertions.ads table.ads table.adb tbuild.ads types.ads \ + uintp.ads unchecked_deallocation.ads unchecked_deallocation.adb + + exp_ch7.o : exp_ch7.ads exp_ch7.adb exp_ch9.ads system.ads types.ads \ + unchecked_deallocation.ads unchecked_deallocation.adb + + exp_ch8.o : exp_ch8.ads + + exp_ch9.o : alloc.ads atree.ads comperr.ads debug.ads einfo.ads \ + exp_ch3.ads exp_ch9.ads exp_ch9.adb exp_util.ads limits.ads namet.ads \ + nmake.ads opt.ads output.ads rtsfind.ads sem.ads sem_res.ads sinfo.ads \ + snames.ads stand.ads system.ads system-assertions.ads table.ads \ + table.adb tbuild.ads types.ads uintp.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + exp_prag.o : alloc.ads atree.ads comperr.ads debug.ads einfo.ads \ + exp_prag.ads exp_prag.adb exp_util.ads nmake.ads opt.ads output.ads \ + rtsfind.ads sem.ads sinfo.ads snames.ads system.ads \ + system-assertions.ads table.ads table.adb tbuild.ads types.ads \ + unchecked_deallocation.ads unchecked_deallocation.adb + + exp_util.o : alloc.ads atree.ads casing.ads debug.ads einfo.ads \ + errcount.ads exp_util.ads exp_util.adb lib.ads limits.ads namet.ads \ + nmake.ads opt.ads output.ads rtsfind.ads sem.ads sem_ch13.ads \ + sem_res.ads sem_util.ads sinfo.ads sinput.ads snames.ads stand.ads \ + system.ads system-assertions.ads table.ads table.adb tbuild.ads \ + ttypes.ads types.ads uintp.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + expand.o : alloc.ads atree.ads debug.ads debug_sem.ads einfo.ads \ + exp_attr.ads exp_ch10.ads exp_ch11.ads exp_ch12.ads exp_ch13.ads \ + exp_ch2.ads exp_ch3.ads exp_ch4.ads exp_ch5.ads exp_ch6.ads exp_ch7.ads \ + exp_ch8.ads exp_ch9.ads exp_prag.ads exp_util.ads expand.ads expand.adb \ + opt.ads output.ads sinfo.ads sinput.ads system.ads table.ads table.adb \ + types.ads unchecked_deallocation.ads unchecked_deallocation.adb + + fname.o : alloc.ads comperr.ads csets.ads debug.ads fname.ads fname.adb \ + limits.ads namet.ads opt.ads osint.ads output.ads system.ads \ + system-assertions.ads table.ads table.adb types.ads \ + unchecked_deallocation.ads unchecked_deallocation.adb + + frontend.o : alloc.ads atree.ads casing.ads debug.ads einfo.ads errout.ads \ + frontend.ads frontend.adb lib.ads limits.ads namet.ads opt.ads \ + output.ads par.ads rtsfind.ads scn.ads sem.ads sinfo.ads snames.ads \ + sprint.ads stand.ads stringt.ads system.ads table.ads table.adb \ + treepr.ads types.ads uintp.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb usage.ads + + gnat1drv.o : alloc.ads atree.ads back_end.ads casing.ads comperr.ads \ + csets.ads debug.ads einfo.ads errcount.ads errout.ads excep.ads \ + frontend.ads gnat1drv.ads gnat1drv.adb gnatvsn.ads lib.ads limits.ads \ + namet.ads opt.ads osint.ads output.ads par.ads sinfo.ads system.ads \ + system-assertions.ads table.ads table.adb types.ads \ + unchecked_deallocation.ads unchecked_deallocation.adb usage.ads + + gnatbind.o : ali.ads alloc.ads bcheck.ads binde.ads binderr.ads \ + bindgen.ads bindusg.ads butil.ads debug.ads errcount.ads excep.ads \ + gnatbind.adb gnatvsn.ads libfmt.ads limits.ads namet.ads opt.ads \ + osint.ads output.ads system.ads table.ads table.adb types.ads \ + unchecked_deallocation.ads unchecked_deallocation.adb + + gnatvsn.o : gnatvsn.ads system.ads types.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + lib.o : alloc.ads atree.ads casing.ads debug.ads einfo.ads errout.ads \ + fname.ads gnatvsn.ads lib.ads lib.adb lib-list.adb lib-load.adb \ + lib-sort.adb lib-writ.adb libfmt.ads limits.ads namet.ads osint.ads \ + output.ads par.ads scn.ads sinfo.ads system.ads table.ads table.adb \ + types.ads uname.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + libfmt.o : libfmt.ads system.ads types.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + limits.o : limits.ads + + namet.o : alloc.ads debug.ads limits.ads namet.ads namet.adb namet-ch.adb \ + output.ads system.ads system-assertions.ads table.ads table.adb \ + types.ads unchecked_deallocation.ads unchecked_deallocation.adb + + nmake.o : alloc.ads atree.ads debug.ads einfo.ads nmake.ads nmake.adb \ + output.ads sinfo.ads snames.ads system.ads table.ads table.adb \ + types.ads unchecked_deallocation.ads unchecked_deallocation.adb + + opt.o : opt.ads system.ads types.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + osint.o : alloc.ads debug.ads limits.ads namet.ads opt.ads osint.ads \ + osint.adb output.ads switch.ads sysid.ads system.ads \ + system-assertions.ads system_environment.ads table.ads table.adb \ + types.ads unchecked_deallocation.ads unchecked_deallocation.adb \ + unixlib.ads + + output.o : output.ads output.adb system.ads types.ads \ + unchecked_deallocation.ads unchecked_deallocation.adb unixlib.ads + + par.o : alloc.ads atree.ads casing.ads comperr.ads csets.ads debug.ads \ + einfo.ads errout.ads excep.ads fname.ads lib.ads limits.ads namet.ads \ + nmake.ads opt.ads output.ads par.ads par.adb par-ch10.adb par-ch11.adb \ + par-ch12.adb par-ch13.adb par-ch2.adb par-ch3.adb par-ch4.adb \ + par-ch5.adb par-ch6.adb par-ch7.adb par-ch8.adb par-ch9.adb \ + par-endh.adb par-labl.adb par-load.adb par-prag.adb par-sync.adb \ + par-tchk.adb par-util.adb scans.ads scn.ads sinfo.ads sinfo-change.ads \ + sinput.ads snames.ads system.ads table.ads table.adb tbuild.ads \ + types.ads uintp.ads uname.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + rtsfind.o : alloc.ads atree.ads casing.ads comperr.ads csets.ads debug.ads \ + einfo.ads excep.ads fname.ads lib.ads limits.ads namet.ads nmake.ads \ + opt.ads output.ads rtsfind.ads rtsfind.adb sem.ads sem_util.ads \ + sinfo.ads snames.ads system.ads table.ads table.adb tbuild.ads \ + types.ads unchecked_deallocation.ads unchecked_deallocation.adb + + scans.o : scans.ads scans.adb system.ads types.ads \ + unchecked_deallocation.ads unchecked_deallocation.adb + + scn.o : alloc.ads atree.ads casing.ads csets.ads debug.ads einfo.ads \ + errout.ads lib.ads limits.ads namet.ads opt.ads output.ads scans.ads \ + scn.ads scn.adb scn-nlit.adb scn-slit.adb sinfo.ads sinput.ads \ + snames.ads stringt.ads system.ads table.ads table.adb types.ads \ + uintp.ads unchecked_deallocation.ads unchecked_deallocation.adb + + sem.o : alloc.ads atree.ads casing.ads comperr.ads debug.ads debug_sem.ads \ + einfo.ads errout.ads exp_util.ads expand.ads lib.ads limits.ads \ + namet.ads opt.ads output.ads sem.ads sem.adb sem_attr.ads sem_ch10.ads \ + sem_ch11.ads sem_ch12.ads sem_ch13.ads sem_ch3.ads sem_ch4.ads \ + sem_ch5.ads sem_ch6.ads sem_ch7.ads sem_ch8.ads sem_ch9.ads \ + sem_prag.ads sem_util.ads sinfo.ads sinput.ads snames.ads stand.ads \ + system.ads table.ads table.adb types.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + sem_attr.o : alloc.ads atree.ads debug.ads einfo.ads errout.ads limits.ads \ + namet.ads nmake.ads opt.ads output.ads rtsfind.ads sem.ads sem_attr.ads \ + sem_attr.adb sem_ch6.ads sem_ch8.ads sem_eval.ads sem_res.ads \ + sem_type.ads sem_util.ads sinfo.ads snames.ads stand.ads system.ads \ + table.ads table.adb tbuild.ads types.ads uintp.ads \ + unchecked_deallocation.ads unchecked_deallocation.adb + + sem_ch10.o : alloc.ads atree.ads casing.ads debug.ads einfo.ads \ + errcount.ads errout.ads lib.ads limits.ads namet.ads nmake.ads opt.ads \ + output.ads sem.ads sem_ch10.ads sem_ch10.adb sem_ch6.ads sem_ch7.ads \ + sem_ch8.ads sem_util.ads sinfo.ads sinfo-change.ads snames.ads \ + stand.ads stringt.ads system.ads table.ads table.adb tbuild.ads \ + types.ads uname.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + sem_ch11.o : alloc.ads atree.ads debug.ads einfo.ads errout.ads limits.ads \ + namet.ads opt.ads output.ads sem_ch11.ads sem_ch11.adb sem_ch5.ads \ + sem_ch8.ads sem_util.ads sinfo.ads stand.ads system.ads table.ads \ + table.adb types.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + sem_ch12.o : alloc.ads atree.ads casing.ads comperr.ads debug.ads \ + einfo.ads errout.ads exp_util.ads lib.ads limits.ads namet.ads opt.ads \ + output.ads sem.ads sem_ch10.ads sem_ch12.ads sem_ch12.adb sem_ch13.ads \ + sem_ch3.ads sem_ch6.ads sem_ch7.ads sem_ch8.ads sem_res.ads \ + sem_util.ads sinfo.ads snames.ads stand.ads system.ads table.ads \ + table.adb tbuild.ads types.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + sem_ch13.o : alloc.ads atree.ads debug.ads einfo.ads errout.ads excep.ads \ + limits.ads namet.ads nmake.ads opt.ads output.ads rtsfind.ads sem.ads \ + sem_ch13.ads sem_ch13.adb sem_ch3.ads sem_ch8.ads sem_eval.ads \ + sem_res.ads sem_util.ads sinfo.ads snames.ads stand.ads system.ads \ + table.ads table.adb ttypes.ads types.ads uintp.ads \ + unchecked_deallocation.ads unchecked_deallocation.adb + + sem_ch3.o : alloc.ads atree.ads comperr.ads debug.ads einfo.ads errout.ads \ + exp_util.ads limits.ads namet.ads nmake.ads opt.ads output.ads \ + rtsfind.ads sem.ads sem_ch12.ads sem_ch13.ads sem_ch3.ads sem_ch3.adb \ + sem_ch5.ads sem_ch6.ads sem_ch7.ads sem_ch8.ads sem_ch9.ads \ + sem_eval.ads sem_res.ads sem_type.ads sem_util.ads sinfo.ads snames.ads \ + stand.ads system.ads system-assertions.ads table.ads table.adb \ + tbuild.ads ttypes.ads types.ads uintp.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + sem_ch4.o : alloc.ads atree.ads debug.ads einfo.ads errout.ads \ + exp_util.ads limits.ads namet.ads nmake.ads opt.ads output.ads sem.ads \ + sem_ch3.ads sem_ch4.ads sem_ch4.adb sem_ch8.ads sem_type.ads \ + sem_util.ads sinfo.ads snames.ads stand.ads system.ads table.ads \ + table.adb tbuild.ads types.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + sem_ch5.o : alloc.ads atree.ads comperr.ads debug.ads einfo.ads errout.ads \ + limits.ads namet.ads opt.ads output.ads sem.ads sem_ch3.ads sem_ch5.ads \ + sem_ch5.adb sem_ch8.ads sem_disp.ads sem_eval.ads sem_res.ads \ + sem_type.ads sem_util.ads sinfo.ads snames.ads stand.ads system.ads \ + table.ads table.adb types.ads uintp.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + sem_ch6.o : alloc.ads atree.ads casing.ads debug.ads einfo.ads errout.ads \ + exp_util.ads lib.ads limits.ads namet.ads nmake.ads opt.ads output.ads \ + rtsfind.ads sem.ads sem_ch3.ads sem_ch4.ads sem_ch6.ads sem_ch6.adb \ + sem_ch8.ads sem_ch9.ads sem_disp.ads sem_res.ads sem_util.ads sinfo.ads \ + sinfo-change.ads snames.ads stand.ads stringt.ads system.ads table.ads \ + table.adb tbuild.ads types.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + sem_ch7.o : alloc.ads atree.ads casing.ads debug.ads einfo.ads errout.ads \ + lib.ads limits.ads namet.ads opt.ads output.ads sem.ads sem_ch13.ads \ + sem_ch3.ads sem_ch7.ads sem_ch7.adb sem_ch8.ads sem_util.ads sinfo.ads \ + snames.ads stand.ads system.ads table.ads table.adb types.ads \ + unchecked_deallocation.ads unchecked_deallocation.adb + + sem_ch8.o : alloc.ads atree.ads comperr.ads debug.ads einfo.ads errout.ads \ + limits.ads namet.ads nmake.ads opt.ads output.ads sem.ads sem_attr.ads \ + sem_ch3.ads sem_ch4.ads sem_ch5.ads sem_ch6.ads sem_ch8.ads sem_ch8.adb \ + sem_res.ads sem_type.ads sem_util.ads sinfo.ads sinfo-change.ads \ + snames.ads stand.ads system.ads table.ads table.adb tbuild.ads \ + types.ads unchecked_deallocation.ads unchecked_deallocation.adb + + sem_ch9.o : alloc.ads atree.ads debug.ads einfo.ads errout.ads limits.ads \ + namet.ads opt.ads output.ads sem.ads sem_ch3.ads sem_ch4.ads \ + sem_ch5.ads sem_ch6.ads sem_ch8.ads sem_ch9.ads sem_ch9.adb sem_res.ads \ + sem_util.ads sinfo.ads snames.ads stand.ads system.ads table.ads \ + table.adb tbuild.ads ttypes.ads types.ads uintp.ads \ + unchecked_deallocation.ads unchecked_deallocation.adb + + sem_disp.o : alloc.ads atree.ads debug.ads einfo.ads errout.ads \ + exp_ch6.ads output.ads sem_disp.ads sem_disp.adb sem_util.ads sinfo.ads \ + system.ads table.ads table.adb types.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + sem_eval.o : alloc.ads atree.ads comperr.ads debug.ads debug_sem.ads \ + einfo.ads errout.ads excep.ads limits.ads namet.ads output.ads \ + sem_eval.ads sem_eval.adb sem_util.ads sinfo.ads sinput.ads snames.ads \ + stand.ads stringt.ads system.ads system-assertions.ads table.ads \ + table.adb tbuild.ads types.ads uintp.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + sem_prag.o : alloc.ads atree.ads debug.ads einfo.ads errout.ads limits.ads \ + namet.ads nmake.ads opt.ads output.ads rtsfind.ads sem.ads sem_ch8.ads \ + sem_eval.ads sem_prag.ads sem_prag.adb sem_res.ads sem_util.ads \ + sinfo.ads snames.ads stand.ads system.ads table.ads table.adb \ + tbuild.ads types.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + sem_res.o : alloc.ads atree.ads comperr.ads debug.ads debug_sem.ads \ + einfo.ads errout.ads expand.ads limits.ads namet.ads nmake.ads opt.ads \ + output.ads rtsfind.ads sem.ads sem_attr.ads sem_ch3.ads sem_ch4.ads \ + sem_ch5.ads sem_disp.ads sem_eval.ads sem_res.ads sem_res.adb \ + sem_type.ads sem_util.ads sinfo.ads sinput.ads snames.ads stand.ads \ + stringt.ads system.ads table.ads table.adb tbuild.ads types.ads \ + uintp.ads unchecked_deallocation.ads unchecked_deallocation.adb + + sem_type.o : alloc.ads atree.ads comperr.ads debug.ads einfo.ads \ + errout.ads limits.ads namet.ads output.ads sem_ch6.ads sem_ch8.ads \ + sem_type.ads sem_type.adb sem_util.ads sinfo.ads snames.ads stand.ads \ + system.ads system-assertions.ads table.ads table.adb types.ads \ + unchecked_deallocation.ads unchecked_deallocation.adb + + sem_util.o : alloc.ads atree.ads casing.ads comperr.ads csets.ads \ + debug.ads einfo.ads errout.ads lib.ads limits.ads namet.ads nmake.ads \ + opt.ads output.ads sem.ads sem_eval.ads sem_res.ads sem_type.ads \ + sem_util.ads sem_util.adb sinfo.ads sinput.ads snames.ads stand.ads \ + system.ads table.ads table.adb tbuild.ads types.ads uintp.ads \ + unchecked_deallocation.ads unchecked_deallocation.adb + + sinfo-change.o : alloc.ads atree.ads debug.ads einfo.ads output.ads \ + sinfo.ads sinfo-change.ads sinfo-change.adb system.ads table.ads \ + table.adb types.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + sinfo.o : alloc.ads atree.ads comperr.ads debug.ads einfo.ads output.ads \ + sinfo.ads sinfo.adb system.ads system-assertions.ads table.ads \ + table.adb types.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + sinput.o : alloc.ads casing.ads debug.ads lib.ads limits.ads namet.ads \ + output.ads scans.ads sinput.ads sinput.adb system.ads table.ads \ + table.adb types.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + snames.o : alloc.ads comperr.ads debug.ads limits.ads namet.ads output.ads \ + snames.ads snames.adb system.ads table.ads table.adb types.ads \ + unchecked_deallocation.ads unchecked_deallocation.adb + + sprint.o : alloc.ads atree.ads casing.ads csets.ads debug.ads einfo.ads \ + lib.ads limits.ads namet.ads opt.ads output.ads sinfo.ads sprint.ads \ + sprint.adb stand.ads stringt.ads system.ads table.ads table.adb \ + types.ads uintp.ads uname.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + stand.o : alloc.ads atree.ads csets.ads debug.ads einfo.ads limits.ads \ + namet.ads nmake.ads opt.ads output.ads sinfo.ads snames.ads stand.ads \ + stand.adb stringt.ads system.ads table.ads table.adb ttypes.ads \ + types.ads uintp.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + stringt.o : alloc.ads debug.ads output.ads stringt.ads stringt.adb \ + system.ads system-assertions.ads table.ads table.adb types.ads \ + unchecked_deallocation.ads unchecked_deallocation.adb + + switch.o : debug.ads opt.ads osint.ads output.ads switch.ads switch.adb \ + sysid.ads system.ads types.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + sysid.o : sysid.ads + + system-assertions.o : system.ads system-assertions.ads + + system-traceback.o : debug.ads system.ads system-traceback.ads \ + system-traceback.adb types.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb + + system.o : system.ads + + system_environment.o : system.ads system_environment.ads \ + system_environment.adb + + tbuild.o : alloc.ads atree.ads debug.ads einfo.ads errout.ads limits.ads \ + namet.ads nmake.ads output.ads sinfo.ads snames.ads stand.ads \ + system.ads table.ads table.adb tbuild.ads tbuild.adb types.ads \ + unchecked_deallocation.ads unchecked_deallocation.adb + + treepr.o : alloc.ads atree.ads casing.ads csets.ads debug.ads einfo.ads \ + lib.ads limits.ads namet.ads opt.ads output.ads sinfo.ads sinput.ads \ + stand.ads stringt.ads system.ads table.ads table.adb treepr.ads \ + treepr.adb treeprs.ads types.ads uintp.ads uname.ads \ + unchecked_deallocation.ads unchecked_deallocation.adb + + treeprs.o : sinfo.ads system.ads treeprs.ads types.ads \ + unchecked_deallocation.ads unchecked_deallocation.adb + + ttypes.o : ttypes.ads + + types.o : system.ads types.ads types.adb unchecked_deallocation.ads \ + unchecked_deallocation.adb + + uintp.o : alloc.ads comperr.ads debug.ads limits.ads namet.ads output.ads \ + system.ads system-assertions.ads table.ads table.adb types.ads \ + uintp.ads uintp.adb unchecked_deallocation.ads \ + unchecked_deallocation.adb + + uname.o : alloc.ads atree.ads casing.ads comperr.ads debug.ads einfo.ads \ + lib.ads limits.ads namet.ads output.ads sinfo.ads system.ads \ + system-assertions.ads table.ads table.adb types.ads uname.ads uname.adb \ + unchecked_deallocation.ads unchecked_deallocation.adb + + unixlib.o : system.ads types.ads unchecked_deallocation.ads \ + unchecked_deallocation.adb unixlib.ads unixlib.adb + + usage.o : opt.ads osint.ads output.ads sysid.ads system.ads types.ads \ + unchecked_deallocation.ads unchecked_deallocation.adb usage.ads \ + usage.adb + + xref.o : alloc.ads atree.ads casing.ads debug.ads einfo.ads lib.ads \ + limits.ads namet.ads osint.ads output.ads sinfo.ads sprint.ads \ + stand.ads system.ads table.ads table.adb types.ads \ + unchecked_deallocation.ads unchecked_deallocation.adb xref.ads xref.adb \ + xref_tab.ads + + xref_tab.o : alloc.ads atree.ads casing.ads debug.ads einfo.ads lib.ads \ + limits.ads namet.ads osint.ads output.ads sinfo.ads sinput.ads \ + stand.ads system.ads table.ads table.adb types.ads \ + unchecked_deallocation.ads unchecked_deallocation.adb xref_tab.ads \ + xref_tab.adb + # To make a configuration always use collect2, set USE_COLLECT2 to ld. ld: collect2 rm -f ld *************** *** 1853,1858 **** --- 2476,2486 ---- rm -f $(bindir)/$(target)-gcc-1; \ ln $(bindir)/gcc $(bindir)/$(target)-gcc-1; \ mv $(bindir)/$(target)-gcc-1 $(bindir)/$(target)-gcc; \ + if [ -f gnat1 ] ; then \ + rm -f $(bindir)/gnatbind; \ + $(INSTALL_PROGRAM) gnatbind $(bindir)/gnatbind; \ + chmod a+x $(bindir)/gnatbind; \ + fi; \ if [ -f cc1plus ] ; then \ rm -f $(bindir)/g++; \ $(INSTALL_PROGRAM) g++ $(bindir)/g++; \ *************** *** 2161,2166 **** --- 2789,2835 ---- -rm -f stage4/libgcc.a -cp libgcc.a stage4 -if $(RANLIB_TEST) ; then $(RANLIB) stage4/libgcc.a; else true; fi + + # gnat bootstrapping targets - use the same stage directories + gnatboot: force + $(MAKE) CC=gcc gnat1 AFLAGS="$(AFLAGS)" + $(MAKE) CC=gcc gnatbind AFLAGS="$(AFLAGS)" + $(MAKE) gnatstage1 + $(MAKE) CC="gcc -Bstage1/" AFLAGS="$(BOOT_AFLAGS)" LDFLAGS="$(BOOT_LDFLAGS)" GNATBIND=stage1/gnatbind gnat1 + $(MAKE) CC="gcc -Bstage1/" AFLAGS="$(BOOT_AFLAGS)" LDFLAGS="$(BOOT_LDFLAGS)" GNATBIND=stage1/gnatbind gnatbind + $(MAKE) gnatstage2 + $(MAKE) CC="gcc -Bstage2/" AFLAGS="$(BOOT_AFLAGS)" LDFLAGS="$(BOOT_LDFLAGS)" GNATBIND=stage2/gnatbind gnat1 + $(MAKE) CC="gcc -Bstage2/" AFLAGS="$(BOOT_AFLAGS)" LDFLAGS="$(BOOT_LDFLAGS)" GNATBIND=stage2/gnatbind gnatbind + + gnatboot2: force + $(MAKE) CC="gcc -Bstage1/" AFLAGS="$(BOOT_AFLAGS)" LDFLAGS="$(BOOT_LDFLAGS)" GNATBIND=stage1/gnatbind gnat1 + $(MAKE) CC="gcc -Bstage1/" AFLAGS="$(BOOT_AFLAGS)" LDFLAGS="$(BOOT_LDFLAGS)" GNATBIND=stage1/gnatbind gnatbind + $(MAKE) gnatstage2 + $(MAKE) CC="gcc -Bstage2/" AFLAGS="$(BOOT_AFLAGS)" LDFLAGS="$(BOOT_LDFLAGS)" GNATBIND=stage2/gnatbind gnat1 + $(MAKE) CC="gcc -Bstage2/" AFLAGS="$(BOOT_AFLAGS)" LDFLAGS="$(BOOT_LDFLAGS)" GNATBIND=stage2/gnatbind gnatbind + + gnatboot3: force + $(MAKE) CC="gcc -Bstage2/" AFLAGS="$(BOOT_AFLAGS)" LDFLAGS="$(BOOT_LDFLAGS)" GNATBIND=stage2/gnatbind gnat1 + $(MAKE) CC="gcc -Bstage2/" AFLAGS="$(BOOT_AFLAGS)" LDFLAGS="$(BOOT_LDFLAGS)" GNATBIND=stage2/gnatbind gnatbind + + gnatcompare: force + for file in $(GNAT1_ADA_OBJS); do \ + tail +16c $$file > tmp-foo1; \ + tail +16c stage2/$$file > tmp-foo2 2>/dev/null \ + && (cmp tmp-foo1 tmp-foo2 || echo $$file differs); \ + done + -rm -f tmp-foo* + + gnatstage1: force + -if [ -d stage1 ] ; then true ; else mkdir stage1 ; fi + -mv -f $(GNAT1_ADA_OBJS) $(GNATBIND_OBJS) gnat1 gnatbind stage1 + + gnatstage2: force + -if [ -d stage2 ] ; then true ; else mkdir stage2 ; fi + -mv -f $(GNAT1_ADA_OBJS) $(GNATBIND_OBJS) gnat1 gnatbind stage2 + + gnatclean: force + rm -f $(GNAT1_OBJS) $(GNATF_OBJS) $(GNATBIND_OBJS) *.ali gnat1 gnatbind # Copy just the executable files from a particular stage into a subdirectory, # and delete the object files. Use this if you're just verifying a version ds sem_type.adb sem_util.ads sinfo.ads snamegnat-1.67-src/src/GCC-BASE 644 10015 7640 6 5506244517 10066 2.5.7 ” Ü• ed_dܹqGCC-BASEð¹r a-einfo.hn.¹s README.SPARC¹t a-sinfo.hÎ)0¹u nmake.adb ¹v nmake.adsg adb + + uintp.o : alloc.ads comperr.ads debug.ads limits.ads namet.ads output.ads \ + system.ads system-assertions.ads table.ads table.adb types.ads \ + uintp.ads uintp.adb unchecked_deallocation.ads \ + unchecked_deallocation.adb + + uname.o : alloc.ads atree.ads casing.ads comperr.ads debug.ads einfo.ads \ + lib.gnat-1.67-src/src/a-einfo.h 644 10015 7640 62605 5506244520 10635 /*--------------------------------------------------------------------------*/ /* */ /* GNAT COMPILER COMPONENTS */ /* */ /* E I N F O */ /* */ /* C Header File */ /* */ /* Generated by xeinfo revision 1.17 using */ /* einfo.ads revision 1.155 */ /* einfo.adb revision 1.146 */ /* */ /* Copyright (c) 1992,1993, NYU, All Rights Reserved */ /* */ /* 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 */ /* Software Foundation; either version 2, or (at your option) any later */ /* version. GNAT is distributed in the hope that it will be useful, but */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- */ /* ABILITY 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 GNAT; see file COPYING. If not, write */ /* to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* */ /*--------------------------------------------------------------------------*/ #define E_Void 0 #define E_Variable 1 #define E_Component 2 #define E_Constant 3 #define E_Named_Integer 4 #define E_Named_Real 5 #define E_Enumeration_Type 6 #define E_Enumeration_Subtype 7 #define E_Character_Type 8 #define E_Boolean_Type 9 #define E_Integer_Type 10 #define E_Integer_Subtype 11 #define E_Modular_Type 12 #define E_Modular_Subtype 13 #define E_Float_Type 14 #define E_Float_Subtype 15 #define E_Fixed_Type 16 #define E_Fixed_Subtype 17 #define E_Decimal_Type 18 #define E_Decimal_Subtype 19 #define E_Access_Type 20 #define E_Access_Subtype 21 #define E_Allocator_Type 22 #define E_General_Access_Type 23 #define E_Access_Subprogram_Type 24 #define E_Anonymous_Access_Type 25 #define E_Array_Type 26 #define E_Array_Subtype 27 #define E_String_Type 28 #define E_String_Subtype 29 #define E_String_Literal_Subtype 30 #define E_Enum_Table_Type 31 #define E_Slice_Subtype 32 #define E_Record_Type 33 #define E_Class_Subtype 34 #define E_Class_Type 35 #define E_Record_Subtype 36 #define E_Incomplete_Type 37 #define E_Private_Type 38 #define E_Limited_Private_Type 39 #define E_Limited_Type 40 #define E_Task_Type 41 #define E_Task_Subtype 42 #define E_Protected_Type 43 #define E_Protected_Subtype 44 #define E_Exception_Type 45 #define E_Subprogram_Type 46 #define E_Discriminant 47 #define E_Loop 48 #define E_Loop_Parameter 49 #define E_Block 50 #define E_Label 51 #define E_Enumeration_Literal 52 #define E_Function 53 #define E_Operator 54 #define E_Procedure 55 #define E_Entry 56 #define E_In_Parameter 57 #define E_Out_Parameter 58 #define E_In_Out_Parameter 59 #define E_Package 60 #define E_Package_Body 61 #define E_Protected_Body 62 #define E_Protected_Object 63 #define E_Entry_Family 64 #define E_Exception 65 #define E_Generic_Package 66 #define E_Generic_Function 67 #define E_Generic_Procedure 68 #define E_Generic_In_Parameter 69 #define E_Generic_In_Out_Parameter 70 #define E_Formal_Derived_Type 71 #define E_Formal_Generic_Package 72 #define E_Task_Body 73 #define E_Subprogram_Body 74 SUBTYPE (Type_Kind, Entity_Kind, E_Enumeration_Type, E_Subprogram_Type) SUBTYPE (Boolean_Kind, Entity_Kind, E_Boolean_Type, E_Boolean_Type) SUBTYPE (Integer_Kind, Entity_Kind, E_Integer_Type, E_Modular_Subtype) SUBTYPE (Signed_Integer_Kind, Entity_Kind, E_Integer_Type, E_Integer_Subtype) SUBTYPE (Modular_Kind, Entity_Kind, E_Modular_Type, E_Modular_Subtype) SUBTYPE (Discrete_Kind, Entity_Kind, E_Enumeration_Type, E_Modular_Subtype) SUBTYPE (Enumeration_Kind, Entity_Kind, E_Enumeration_Type, E_Boolean_Type) SUBTYPE (Real_Kind, Entity_Kind, E_Float_Type, E_Decimal_Subtype) SUBTYPE (Float_Kind, Entity_Kind, E_Float_Type, E_Float_Subtype) SUBTYPE (Fixed_Kind, Entity_Kind, E_Fixed_Type, E_Decimal_Subtype) SUBTYPE (Protected_Kind, Entity_Kind, E_Protected_Type, E_Protected_Subtype) SUBTYPE (Task_Kind, Entity_Kind, E_Task_Type, E_Task_Subtype) SUBTYPE (Numeric_Kind, Entity_Kind, E_Integer_Type, E_Decimal_Subtype) SUBTYPE (Scalar_Kind, Entity_Kind, E_Enumeration_Type, E_Decimal_Subtype) SUBTYPE (Access_Kind, Entity_Kind, E_Access_Type, E_Anonymous_Access_Type) SUBTYPE (Incomplete_Kind, Entity_Kind, E_Incomplete_Type, E_Limited_Type) SUBTYPE (Private_Kind, Entity_Kind, E_Private_Type, E_Limited_Private_Type) SUBTYPE (Overloaded_Kind, Entity_Kind, E_Enumeration_Literal, E_Entry) SUBTYPE (Subprogram_Kind, Entity_Kind, E_Function, E_Procedure) SUBTYPE (Formal_Kind, Entity_Kind, E_In_Parameter, E_In_Out_Parameter) SUBTYPE (Named_Kind, Entity_Kind, E_Named_Integer, E_Named_Real) SUBTYPE (Array_Kind, Entity_Kind, E_Array_Type, E_Slice_Subtype) SUBTYPE (Record_Kind, Entity_Kind, E_Record_Type, E_Record_Subtype) SUBTYPE (String_Kind, Entity_Kind, E_String_Type, E_String_Literal_Subtype) SUBTYPE (Composite_Kind, Entity_Kind, E_Array_Type, E_Protected_Subtype) INLINE Entity_Id Corresponding_Task_Type (Entity_Id Id); INLINE Entity_Id Homonym (Entity_Id Id); INLINE Entity_Id Scope (Entity_Id Id); INLINE Entity_Id Next_Entity (Entity_Id Id); INLINE Entity_Id First_Entity (Entity_Id Scope_Id); INLINE Entity_Id Last_Entity (Entity_Id Scope_Id); INLINE Entity_Id Master_Id (Entity_Id Access_Id); INLINE Boolean Is_Directly_Visible (Entity_Id Id); INLINE Boolean Is_Use_Visible (Entity_Id Id); INLINE Boolean Has_Homonym (Entity_Id Id); INLINE Boolean Has_Completion (Entity_Id Id); INLINE Boolean Has_Master_Entity (Entity_Id Id); INLINE Boolean Has_Tasks (Entity_Id Id); #define Constant_Value einfo__constant_value Node_Id Constant_Value (Entity_Id Constant_Id); INLINE Node_Id Renamed_Object (Entity_Id Id); #define Root_Type einfo__root_type Entity_Id Root_Type (Entity_Id Type_Id); INLINE Uint Esize (Entity_Id Type_Id); INLINE Boolean Is_Delayed (Entity_Id E); INLINE Boolean Is_Generic_Type (Entity_Id Type_Id); INLINE Boolean Is_Frozen (Entity_Id Type_Id); INLINE Entity_Id First_Literal (Entity_Id Type_Id); INLINE Entity_Id Next_Literal (Entity_Id Id); INLINE Entity_Id Lit_Name_Table (Entity_Id Id); INLINE Node_Id Scalar_Range (Entity_Id Type_Id); INLINE Uint Modulus (Entity_Id Type_Id); INLINE Node_Id Type_Low_Bound (Entity_Id Type_Id); INLINE Node_Id Type_High_Bound (Entity_Id Type_Id); #define Number_Dimensions einfo__number_dimensions Pos Number_Dimensions (Entity_Id Array_Id); INLINE Entity_Id Component_Type (Entity_Id Array_Id); INLINE Node_Id First_Index (Entity_Id Array_Id); INLINE Node_Id Next_Index (Entity_Id Index_Id); INLINE Boolean Is_Constrained (Entity_Id Type_Id); INLINE Boolean Has_Discriminants (Entity_Id Type_Id); #define First_Discriminant einfo__first_discriminant Entity_Id First_Discriminant (Entity_Id Type_Id); #define Next_Discriminant einfo__next_discriminant Entity_Id Next_Discriminant (Entity_Id Id); INLINE Entity_Id Init_Proc (Entity_Id Type_Id); #define Base_Init_Proc einfo__base_init_proc Entity_Id Base_Init_Proc (Entity_Id Type_Id); INLINE Elist_Id Primitive_Operations (Entity_Id Id); INLINE Elist_Id Discriminant_Constraint (Entity_Id Type_Id); INLINE Entity_Id Internal_Access_Disp_Table (Entity_Id Component_Id); INLINE Entity_Id Access_Disp_Table (Entity_Id Rec_Id); INLINE Boolean Is_Dispatching_Operation (Entity_Id Overloaded_Id); #define Tag_Component einfo__tag_component Entity_Id Tag_Component (Entity_Id Rec_Id); #define First_Component einfo__first_component Entity_Id First_Component (Entity_Id Rec_Id); #define Next_Component einfo__next_component Entity_Id Next_Component (Entity_Id Id); INLINE Entity_Id Directly_Designated_Type (Entity_Id Access_Id); #define Designated_Type einfo__designated_type Entity_Id Designated_Type (Entity_Id Access_Id); #define Full_Declaration einfo__full_declaration Entity_Id Full_Declaration (Entity_Id Private_Id); INLINE Entity_Id Discriminant_Checking_Func (Entity_Id Id); INLINE Node_Id Discriminant_Default_Value (Entity_Id Id); INLINE Node_Id Discriminal (Entity_Id Id); INLINE Boolean Has_Address_Clause (Entity_Id Id); INLINE Boolean Has_Size_Clause (Entity_Id Id); INLINE Boolean Has_Storage_Size_Clause (Entity_Id Id); #define Is_Elementary_Type einfo__is_elementary_type Boolean Is_Elementary_Type (Entity_Id Type_Id); INLINE Boolean Is_Scalar_Type (Entity_Id Type_Id); INLINE Boolean Is_Discrete_Type (Entity_Id Type_Id); INLINE Boolean Is_Enumeration_Type (Entity_Id Type_Id); INLINE Boolean Is_Boolean_Type (Entity_Id Type_Id); INLINE Boolean Is_Character_Type (Entity_Id Type_Id); INLINE Boolean Is_Integer_Type (Entity_Id Type_Id); INLINE Boolean Is_Real_Type (Entity_Id Type_Id); INLINE Boolean Is_Fixed_Type (Entity_Id Type_Id); INLINE Boolean Is_Float_Type (Entity_Id Type_Id); INLINE Boolean Is_Numeric_Type (Entity_Id Type_Id); INLINE Boolean Is_Composite_Type (Entity_Id Type_Id); INLINE Boolean Is_Array_Type (Entity_Id Type_Id); #define Is_String_Type einfo__is_string_type Boolean Is_String_Type (Entity_Id Type_Id); INLINE Boolean Is_Record_Type (Entity_Id Type_Id); INLINE Boolean Is_Access_Type (Entity_Id Type_Id); INLINE Boolean Is_Task_Type (Entity_Id Type_Id); INLINE Boolean Is_Tagged_Type (Entity_Id Type_Id); INLINE Boolean Is_Task_Record_Type (Entity_Id Type_Id); INLINE Boolean Is_Protected_Type (Entity_Id Type_Id); INLINE Boolean Is_Limited_Type (Entity_Id Type_Id); INLINE Boolean Is_Incomplete_Type (Entity_Id Type_Id); INLINE Boolean Is_Internal (Entity_Id Type_Id); INLINE Boolean Is_Packed (Entity_Id Type_Id); INLINE Boolean Is_Private_Type (Entity_Id Type_Id); INLINE Boolean Is_Subprogram (Entity_Id Type_Id); INLINE Boolean Is_Named_Number (Entity_Id Type_Id); INLINE Boolean Is_Abstract (Entity_Id Id); INLINE Boolean Is_Aliased (Entity_Id Id); INLINE Boolean Is_Imported (Entity_Id Id); INLINE Boolean Is_Inlined (Entity_Id Id); INLINE Boolean Is_Private (Entity_Id Id); INLINE Boolean Is_Public (Entity_Id Id); INLINE Boolean Is_Pure (Entity_Id Proc_Id); INLINE Boolean Is_Type (Entity_Id Id); INLINE Boolean Is_Volatile (Entity_Id Id); INLINE Entity_Id Parent_Subtype (Entity_Id Id); INLINE Boolean Reachable (Entity_Id Label_Id); INLINE Node_Id Slice_Range (Entity_Id Id); INLINE Uint String_Literal_Length (Entity_Id Id); #define Subtype_Kind einfo__subtype_kind Entity_Kind Subtype_Kind (Entity_Kind K); INLINE Node_Id Table_High_Bound (Entity_Id Id); INLINE Boolean Needs_Discr_Check (Entity_Id Id); INLINE Boolean Has_Exit (Entity_Id Loop_Id); #define First_Formal einfo__first_formal Entity_Id First_Formal (Entity_Id Overloaded_Id); #define Next_Formal einfo__next_formal Entity_Id Next_Formal (Entity_Id Formal_Id); INLINE Formal_Kind Parameter_Mode (Entity_Id Formal_Id); INLINE Entity_Id Next_Overloads (Entity_Id Overloaded_Id); INLINE Entity_Id Alias (Entity_Id Overloaded_Id); INLINE Boolean Needs_No_Actuals (Entity_Id Overloaded_Id); INLINE Node_Id Interface_Name (Entity_Id Proc_Id); INLINE Boolean Is_Intrinsic (Entity_Id Proc_Id); #define First_Actual einfo__first_actual Node_Id First_Actual (Node_Id Node); #define Next_Actual einfo__next_actual Node_Id Next_Actual (Node_Id Actual_Id); INLINE Boolean Is_Overloadable (Entity_Id Id); #define Entry_Index einfo__entry_index Uint Entry_Index (Entity_Id Id); INLINE Uint Enumeration_Pos (Entity_Id Enum_Id); INLINE Uint Enumeration_Rep (Entity_Id Enum_Id); INLINE Boolean Has_Subprogram_Body (Entity_Id Subprogram_Id); INLINE Node_Id Default_Value (Entity_Id In_Id); INLINE Boolean Is_Package_Body (Entity_Id Package_Id); INLINE Boolean In_Private_Part (Entity_Id Package_Id); INLINE Boolean In_Use (Entity_Id Package_Id); INLINE Boolean Is_Private_Descendant (Entity_Id Id); #define Base_Type einfo__base_type Entity_Id Base_Type (Entity_Id Type_Id); INLINE Entity_Id First_Private_Entity (Entity_Id Package_Id); /********************************/ /* Bodies for Inlined Functions */ /********************************/ INLINE Entity_Id Corresponding_Task_Type (Entity_Id Id) { return Node7 (Id); } INLINE Entity_Id Homonym (Entity_Id Id) { return Node4 (Id); } INLINE Boolean Has_Completion (Entity_Id Id) { return Flag26 (Id); } INLINE Boolean Has_Tasks (Entity_Id Id) { return Flag30 (Id); } INLINE Boolean Has_Master_Entity (Entity_Id Id) { return Flag21 (Id); } INLINE Boolean Has_Address_Clause (Entity_Id Id) { return Flag28 (Id); } INLINE Boolean Has_Homonym (Entity_Id Id) { return Flag12 (Id); } INLINE Boolean Has_Size_Clause (Entity_Id Id) { return Flag29 (Id); } INLINE Boolean Has_Storage_Size_Clause (Entity_Id Id) { return Flag23 (Id); } INLINE Entity_Id Next_Entity (Entity_Id Id) { return Node6 (Id); } INLINE Entity_Id First_Entity (Entity_Id Scope_Id) { return Node9 (Scope_Id); } INLINE Entity_Id Last_Entity (Entity_Id Scope_Id) { return Node10 (Scope_Id); } INLINE Entity_Id Master_Id (Entity_Id Access_Id) { return Node9 (Access_Id); } INLINE Entity_Id Scope (Entity_Id Id) { return Node3 (Id); } INLINE Uint Esize (Entity_Id Type_Id) { return Uint12 (Type_Id); } INLINE Boolean Is_Delayed (Entity_Id E) { return Flag18 (E); } INLINE Boolean Is_Generic_Type (Entity_Id Type_Id) { return Flag6 (Type_Id); } INLINE Boolean Is_Frozen (Entity_Id Type_Id) { return Flag4 (Type_Id); } INLINE Entity_Id First_Literal (Entity_Id Type_Id) { return Node9 (Type_Id); } INLINE Entity_Id Next_Literal (Entity_Id Id) { return Next (Id); } INLINE Entity_Id Lit_Name_Table (Entity_Id Id) { return Node7 (Id); } INLINE Boolean Has_Subprogram_Body (Entity_Id Subprogram_Id) { return Flag5 (Subprogram_Id); } INLINE Node_Id Scalar_Range (Entity_Id Type_Id) { return Node10 (Type_Id); } INLINE Uint Modulus (Entity_Id Type_Id) { return Uint9 (Type_Id); } INLINE Node_Id Type_Low_Bound (Entity_Id Type_Id) { return Low_Bound (Scalar_Range (Type_Id)); } INLINE Node_Id Type_High_Bound (Entity_Id Type_Id) { return High_Bound (Scalar_Range (Type_Id)); } INLINE Entity_Id Component_Type (Entity_Id Array_Id) { return Node10 (Array_Id); } INLINE Node_Id First_Index (Entity_Id Array_Id) { return Node9 (Array_Id); } INLINE Node_Id Next_Index (Entity_Id Index_Id) { return Next (Index_Id); } INLINE Boolean Is_Constrained (Entity_Id Type_Id) { return Flag3 (Type_Id); } INLINE Elist_Id Discriminant_Constraint (Entity_Id Type_Id) { return Elist2 (Type_Id); } INLINE Entity_Id Init_Proc (Entity_Id Type_Id) { return Node8 (Type_Id); } INLINE Elist_Id Primitive_Operations (Entity_Id Id) { return Elist7 (Id); } INLINE Entity_Id Internal_Access_Disp_Table (Entity_Id Component_Id) { return Node11 (Component_Id); } INLINE Entity_Id Access_Disp_Table (Entity_Id Rec_Id) { return Internal_Access_Disp_Table (Tag_Component (Rec_Id)); } INLINE Boolean Has_Discriminants (Entity_Id Type_Id) { return Flag5 (Type_Id); } INLINE Entity_Id Directly_Designated_Type (Entity_Id Access_Id) { return Node10 (Access_Id); } INLINE Entity_Id Discriminant_Checking_Func (Entity_Id Id) { return Node10 (Id); } INLINE Boolean Is_Directly_Visible (Entity_Id Id) { return Flag7 (Id); } INLINE Boolean Is_Use_Visible (Entity_Id Id) { return Flag9 (Id); } INLINE Node_Id Renamed_Object (Entity_Id Id) { return Node7 (Id); } INLINE Node_Id Discriminant_Default_Value (Entity_Id Id) { return Node10 (Id); } INLINE Node_Id Discriminal (Entity_Id Id) { return Node9 (Id); } INLINE Boolean Is_Type (Entity_Id Id) { return IN (Ekind (Id), Type_Kind); } INLINE Entity_Id Parent_Subtype (Entity_Id Id) { return Node11 (Id); } INLINE Boolean Is_Scalar_Type (Entity_Id Type_Id) { return IN (Ekind (Type_Id), Scalar_Kind); } INLINE Boolean Is_Discrete_Type (Entity_Id Type_Id) { return IN (Ekind (Type_Id), Discrete_Kind); } INLINE Boolean Is_Enumeration_Type (Entity_Id Type_Id) { return IN (Ekind (Type_Id), Enumeration_Kind); } INLINE Boolean Is_Boolean_Type (Entity_Id Type_Id) { return Ekind (Base_Type (Type_Id)) == E_Boolean_Type; } INLINE Boolean Is_Character_Type (Entity_Id Type_Id) { return Ekind (Base_Type (Type_Id)) == E_Character_Type; } INLINE Boolean Is_Integer_Type (Entity_Id Type_Id) { return IN (Ekind (Type_Id), Integer_Kind); } INLINE Boolean Is_Real_Type (Entity_Id Type_Id) { return IN (Ekind (Type_Id), Real_Kind); } INLINE Boolean Is_Fixed_Type (Entity_Id Type_Id) { return IN (Ekind (Type_Id), Fixed_Kind); } INLINE Boolean Is_Float_Type (Entity_Id Type_Id) { return IN (Ekind (Type_Id), Float_Kind); } INLINE Boolean Is_Numeric_Type (Entity_Id Type_Id) { return IN (Ekind (Type_Id), Numeric_Kind); } INLINE Boolean Is_Composite_Type (Entity_Id Type_Id) { return IN (Ekind (Type_Id), Composite_Kind); } INLINE Boolean Is_Array_Type (Entity_Id Type_Id) { return IN (Ekind (Type_Id), Array_Kind); } INLINE Boolean Is_Record_Type (Entity_Id Type_Id) { return IN (Ekind (Type_Id), Record_Kind); } INLINE Boolean Is_Access_Type (Entity_Id Type_Id) { return IN (Ekind (Type_Id), Access_Kind); } INLINE Boolean Is_Abstract (Entity_Id Id) { return Flag19 (Id); } INLINE Boolean Is_Aliased (Entity_Id Id) { return Flag15 (Id); } INLINE Boolean Is_Subprogram (Entity_Id Type_Id) { return IN (Ekind (Type_Id), Subprogram_Kind); } INLINE Boolean Is_Named_Number (Entity_Id Type_Id) { return IN (Ekind (Type_Id), Named_Kind); } INLINE Boolean Is_Task_Type (Entity_Id Type_Id) { return IN (Ekind (Type_Id), Task_Kind); } INLINE Boolean Is_Protected_Type (Entity_Id Type_Id) { return IN (Ekind (Type_Id), Protected_Kind); } INLINE Boolean Is_Tagged_Type (Entity_Id Type_Id) { return Flag8 (Type_Id); } INLINE Boolean Is_Task_Record_Type (Entity_Id Type_Id) { return Flag20 (Type_Id); } INLINE Boolean Is_Limited_Type (Entity_Id Type_Id) { return Flag25 (Type_Id); } INLINE Boolean Is_Incomplete_Type (Entity_Id Type_Id) { return IN (Ekind (Type_Id), Incomplete_Kind); } INLINE Boolean Is_Internal (Entity_Id Type_Id) { return Flag2 (Type_Id); } INLINE Boolean Is_Packed (Entity_Id Type_Id) { return Flag11 (Type_Id); } INLINE Boolean Is_Private (Entity_Id Id) { return Flag13 (Id); } INLINE Boolean Is_Private_Type (Entity_Id Type_Id) { return Flag14 (Type_Id); } INLINE Boolean Is_Public (Entity_Id Id) { return Flag10 (Id); } INLINE Boolean Is_Pure (Entity_Id Proc_Id) { return Flag3 (Proc_Id); } INLINE Boolean Is_Imported (Entity_Id Id) { return Flag24 (Id); } INLINE Boolean Is_Inlined (Entity_Id Id) { return Flag11 (Id); } INLINE Boolean Is_Volatile (Entity_Id Id) { return Flag16 (Id); } INLINE Entity_Id Original_Record_Component (Entity_Id Id) { return Node8 (Id); } INLINE Entity_Id Task_Value_Type (Entity_Id Id) { return Node7 (Id); } INLINE Boolean Reachable (Entity_Id Label_Id) { return Flag5 (Label_Id); } INLINE Node_Id Slice_Range (Entity_Id Id) { return Node11 (Id); } INLINE Uint String_Literal_Length (Entity_Id Id) { return Uint11 (Id); } INLINE Node_Id Table_High_Bound (Entity_Id Id) { return Node11 (Id); } INLINE Boolean Needs_Discr_Check (Entity_Id Id) { return Flag5 (Id); } INLINE Boolean Has_Exit (Entity_Id Loop_Id) { return Flag5 (Loop_Id); } INLINE Formal_Kind Parameter_Mode (Entity_Id Formal_Id) { return Ekind (Formal_Id); } INLINE Entity_Id Next_Overloads (Entity_Id Overloaded_Id) { return Homonym (Overloaded_Id); } INLINE Entity_Id Alias (Entity_Id Overloaded_Id) { return Node7 (Overloaded_Id); } INLINE Boolean Needs_No_Actuals (Entity_Id Overloaded_Id) { return Flag8 (Overloaded_Id); } INLINE Boolean Is_Intrinsic (Entity_Id Proc_Id) { return Flag27 (Proc_Id); } INLINE Node_Id Interface_Name (Entity_Id Proc_Id) { return Node12 (Proc_Id); } INLINE Boolean Is_Overloadable (Entity_Id Id) { return IN (Ekind (Id), Overloaded_Kind); } INLINE Uint Enumeration_Pos (Entity_Id Enum_Id) { return Uint11 (Enum_Id); } INLINE Uint Enumeration_Rep (Entity_Id Enum_Id) { return Uint12 (Enum_Id); } INLINE Node_Id Default_Value (Entity_Id In_Id) { return Node10 (In_Id); } INLINE Boolean Is_Package_Body (Entity_Id Package_Id) { return Flag5 (Package_Id); } INLINE Boolean In_Private_Part (Entity_Id Package_Id) { return Flag4 (Package_Id); } INLINE Boolean In_Use (Entity_Id Package_Id) { return Flag8 (Package_Id); } INLINE Boolean Is_Private_Descendant (Entity_Id Id) { return Flag14 (Id); } INLINE Entity_Id First_Private_Entity (Entity_Id Package_Id) { return Node11 (Package_Id); } INLINE Boolean Suppress_Access_Checks (Entity_Id E) { return Flag31 (E); } INLINE Boolean Suppress_Accessibility_Checks (Entity_Id E) { return Flag32 (E); } INLINE Boolean Suppress_Discriminant_Checks (Entity_Id E) { return Flag33 (E); } INLINE Boolean Suppress_Division_Checks (Entity_Id E) { return Flag34 (E); } INLINE Boolean Suppress_Elaboration_Checks (Entity_Id E) { return Flag35 (E); } INLINE Boolean Suppress_Index_Checks (Entity_Id E) { return Flag36 (E); } INLINE Boolean Suppress_Length_Checks (Entity_Id E) { return Flag37 (E); } INLINE Boolean Suppress_Overflow_Checks (Entity_Id E) { return Flag38 (E); } INLINE Boolean Suppress_Range_Checks (Entity_Id E) { return Flag39 (E); } INLINE Boolean Suppress_Storage_Checks (Entity_Id E) { return Flag40 (E); } INLINE Boolean Suppress_Tag_Checks (Entity_Id E) { return Flag41 (E); } INLINE Entity_Id Equivalent_Type (Entity_Id Sub_Class) { return Node7 (Sub_Class); } /* End of einfo.h (C version of Einfo package specification) */ Type_Id) { return Elist2 (Type_Id); } INLINE Entity_Id Init_Proc (Entity_Id Type_Id) { return Nodegnat-1.67-src/src/README.SPARC 444 10015 7640 2460 5506244520 10644 This directory contains the sources necessary to build and run GNAT as a set of additions to and diffs from gcc release whose version number is named in the file GCC-BASE. Building GNAT from these sources requires an executable GNAT and the GCC-BASE version of gcc. It is presumed that you have built gcc-GCC-BASE. You will be building and installing two executables: gnat1 and gnatbind. The file gnat1 should be placed in the GNAT_BASE directory along with cc1 and the other executables called from gcc. The file gnatbind should be placed in a directory on user's PATH (e.g. where gcc is placed). To build gnat1 and gnatbind: copy the files from this directory into the directory containing the GCC-BASE sources and use patch to apply any pathces that are in this directory (e.g. Makefile.in.diff); rerun configure; (unless you have spitbol) do "touch treeprs.ads a-[es]info.h, and nmake.ad[bs]"; run "make CC=gcc gnat1" or "make CC=gcc gnatboot" (if you want to go through an entire bootstrap -- can be followed by "make gnatcompare" to check its success) to make gnat1; run "make gnatbind" to make gnatbind. Warning: older versions of gas for the SPARC had a bug. If building fails with messages such as "/usr/tmp/xxx.s Error: Illegal operands", your gcc is using this older gas, and you need to pick up gas-2.2. (Base_Type (Type_Id)) == E_Character_Type; } INLINE Boolean Is_Integer_Type (Entity_Id Type_Id) { return IN (Ekind (Type_Id), Integer_Kind); } INLINE Boolean Is_Real_Type (Entity_Id Tygnat-1.67-src/src/a-sinfo.h 644 10015 7640 65111 5506244521 10647 /*--------------------------------------------------------------------------*/ /* */ /* GNAT COMPILER COMPONENTS */ /* */ /* S I N F O */ /* */ /* C Header File */ /* */ /* Generated by xsinfo revision 1.11 using */ /* sinfo.ads revision 1.128 */ /* */ /* Copyright (c) 1992,1993, NYU, All Rights Reserved */ /* */ /* 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 */ /* Software Foundation; either version 2, or (at your option) any later */ /* version. GNAT is distributed in the hope that it will be useful, but */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- */ /* ABILITY 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 GNAT; see file COPYING. If not, write */ /* to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* */ /*--------------------------------------------------------------------------*/ #define N_Unused_At_Start 0 #define N_Empty 1 #define N_Error 2 #define N_Defining_Identifier 3 #define N_Defining_Character_Literal 4 #define N_Defining_Operator_Symbol 5 #define N_Expanded_Name 6 #define N_Identifier 7 #define N_Character_Literal 8 #define N_Operator_Symbol 9 #define N_Op_And 10 #define N_Op_And_Then 11 #define N_Op_Or 12 #define N_Op_Or_Else 13 #define N_Op_Xor 14 #define N_Op_In 15 #define N_Op_Not_In 16 #define N_Op_Eq 17 #define N_Op_Ne 18 #define N_Op_Lt 19 #define N_Op_Le 20 #define N_Op_Gt 21 #define N_Op_Ge 22 #define N_Op_Add 23 #define N_Op_Subtract 24 #define N_Op_Concat 25 #define N_Op_Multiply 26 #define N_Op_Divide 27 #define N_Op_Mod 28 #define N_Op_Rem 29 #define N_Op_Expon 30 #define N_Op_Plus 31 #define N_Op_Minus 32 #define N_Op_Abs 33 #define N_Op_Not 34 #define N_Integer_Literal 35 #define N_Real_Literal 36 #define N_String_Literal 37 #define N_Explicit_Dereference 38 #define N_Indexed_Component 39 #define N_Slice 40 #define N_Function_Call 41 #define N_Selected_Component 42 #define N_Attribute_Reference 43 #define N_Aggregate 44 #define N_Extension_Aggregate 45 #define N_Null 46 #define N_Parenthesized_Expression 47 #define N_Reference 48 #define N_Type_Conversion 49 #define N_Qualified_Expression 50 #define N_Allocator 51 #define N_Concat_Multiple 52 #define N_Expression_Actions 53 #define N_Range 54 #define N_Procedure_Call_Statement 55 #define N_Subtype_Indication 56 #define N_Access_Function_Definition 57 #define N_Access_Procedure_Definition 58 #define N_Unconstrained_Array_Definition 59 #define N_Constrained_Array_Definition 60 #define N_Subprogram_Body_Stub 61 #define N_Package_Body_Stub 62 #define N_Task_Body_Stub 63 #define N_Protected_Body_Stub 64 #define N_Package_Instantiation 65 #define N_Procedure_Instantiation 66 #define N_Function_Instantiation 67 #define N_Subprogram_Body 68 #define N_Package_Body 69 #define N_Task_Body 70 #define N_Subprogram_Declaration 71 #define N_Package_Declaration 72 #define N_Task_Type_Declaration 73 #define N_Single_Task_Declaration 74 #define N_Implicit_Label_Declaration 75 #define N_Use_Package_Clause 76 #define N_Pragma 77 #define N_Generic_Package_Declaration 78 #define N_Generic_Subprogram_Declaration 79 #define N_Formal_Object_Declaration 80 #define N_Formal_Type_Declaration 81 #define N_Formal_Subprogram_Declaration 82 #define N_Formal_Package_Declaration 83 #define N_Object_Renaming_Declaration 84 #define N_Exception_Renaming_Declaration 85 #define N_Package_Renaming_Declaration 86 #define N_Subprogram_Renaming_Declaration 87 #define N_Generic_Package_Renaming_Declaration 88 #define N_Generic_Procedure_Renaming_Declaration 89 #define N_Generic_Function_Renaming_Declaration 90 #define N_Attribute_Definition_Clause 91 #define N_Enumeration_Representation_Clause 92 #define N_Record_Representation_Clause 93 #define N_Mod_Clause 94 #define N_Component_Clause 95 #define N_At_Clause 96 #define N_Function_Specification 97 #define N_Procedure_Specification 98 #define N_Abort_Statement 99 #define N_Accept_Statement 100 #define N_Assignment_Statement 101 #define N_Block_Statement 102 #define N_Case_Statement 103 #define N_Code_Statement 104 #define N_Delay_Relative_Statement 105 #define N_Delay_Until_Statement 106 #define N_Entry_Call_Statement 107 #define N_Exit_Statement 108 #define N_Goto_Statement 109 #define N_If_Statement 110 #define N_Loop_Statement 111 #define N_Null_Statement 112 #define N_Raise_Statement 113 #define N_Requeue_Statement 114 #define N_Return_Statement 115 #define N_Abortable_Part 116 #define N_Abstract_Subprogram_Declaration 117 #define N_Accept_Alternative 118 #define N_Access_Definition 119 #define N_Access_To_Object_Definition 120 #define N_Asynchronous_Select 121 #define N_Case_Statement_Alternative 122 #define N_Compilation_Unit 123 #define N_Component_Association 124 #define N_Component_Declaration 125 #define N_Component_List 126 #define N_Conditional_Entry_Call 127 #define N_Derived_Type_Definition 128 #define N_Decimal_Fixed_Point_Definition 129 #define N_Defining_Program_Unit_Name 130 #define N_Delay_Alternative 131 #define N_Delta_Constraint 132 #define N_Designator 133 #define N_Digits_Constraint 134 #define N_Discriminant_Association 135 #define N_Discriminant_Specification 136 #define N_Elsif_Part 137 #define N_Enumeration_Type_Definition 138 #define N_Entry_Body 139 #define N_Entry_Body_Formal_Part 140 #define N_Entry_Call_Alternative 141 #define N_Entry_Declaration 142 #define N_Entry_Index_Specification 143 #define N_Exception_Declaration 144 #define N_Exception_Handler 145 #define N_Floating_Point_Definition 146 #define N_Formal_Decimal_Fixed_Point_Definition 147 #define N_Formal_Derived_Type_Definition 148 #define N_Formal_Discrete_Type_Definition 149 #define N_Formal_Floating_Point_Definition 150 #define N_Formal_Modular_Type_Definition 151 #define N_Formal_Ordinary_Fixed_Point_Definition 152 #define N_Formal_Private_Type_Definition 153 #define N_Formal_Signed_Integer_Type_Definition 154 #define N_Freeze_Entity 155 #define N_Full_Type_Declaration 156 #define N_Generic_Association 157 #define N_Handled_Sequence_Of_Statements 158 #define N_Implicit_Type 159 #define N_Incomplete_Type_Declaration 160 #define N_Index_Or_Discriminant_Constraint 161 #define N_Iteration_Scheme 162 #define N_Label 163 #define N_Loop_Parameter_Specification 164 #define N_Modular_Type_Definition 165 #define N_Number_Declaration 166 #define N_Object_Declaration 167 #define N_Ordinary_Fixed_Point_Definition 168 #define N_Others_Choice 169 #define N_Package_Specification 170 #define N_Parameter_Association 171 #define N_Parameter_Specification 172 #define N_Pragma_Argument_Association 173 #define N_Private_Extension_Declaration 174 #define N_Private_Type_Declaration 175 #define N_Protected_Body 176 #define N_Protected_Definition 177 #define N_Protected_Type_Declaration 178 #define N_Range_Constraint 179 #define N_Real_Range_Specification 180 #define N_Record_Definition 181 #define N_Selective_Accept 182 #define N_Signed_Integer_Type_Definition 183 #define N_Single_Protected_Declaration 184 #define N_Subtype_Declaration 185 #define N_Subunit 186 #define N_Task_Definition 187 #define N_Terminate_Alternative 188 #define N_Timed_Entry_Call 189 #define N_Triggering_Alternative 190 #define N_Use_Type_Clause 191 #define N_Variant 192 #define N_Variant_Part 193 #define N_With_Clause 194 #define N_Unused_At_End 195 #define Number_Node_Kinds 196 SUBTYPE (N_Access_To_Subprogram_Definition, Node_Kind, N_Access_Function_Definition, N_Access_Procedure_Definition) SUBTYPE (N_Array_Type_Definition, Node_Kind, N_Unconstrained_Array_Definition, N_Constrained_Array_Definition) SUBTYPE (N_Binary_Op, Node_Kind, N_Op_And, N_Op_Expon) SUBTYPE (N_Body_Stub, Node_Kind, N_Subprogram_Body_Stub, N_Protected_Body_Stub) SUBTYPE (N_Concurrent_Body_Stub, Node_Kind, N_Task_Body_Stub, N_Protected_Body_Stub) SUBTYPE (N_Direct_Name, Node_Kind, N_Identifier, N_Operator_Symbol) SUBTYPE (N_Entity, Node_Kind, N_Defining_Identifier, N_Defining_Operator_Symbol) SUBTYPE (N_Generic_Instantiation, Node_Kind, N_Package_Instantiation, N_Function_Instantiation) SUBTYPE (N_Generic_Parameter_Declaration, Node_Kind, N_Formal_Object_Declaration, N_Formal_Package_Declaration) SUBTYPE (N_Has_Chars, Node_Kind, N_Empty, N_Op_Not) SUBTYPE (N_Has_Etype, Node_Kind, N_Defining_Identifier, N_Subtype_Indication) SUBTYPE (N_Later_Decl_Item, Node_Kind, N_Subprogram_Body_Stub, N_Generic_Subprogram_Declaration) SUBTYPE (N_Unit_Body, Node_Kind, N_Subprogram_Body, N_Package_Body) SUBTYPE (N_Generic_Declaration, Node_Kind, N_Generic_Package_Declaration, N_Generic_Subprogram_Declaration) SUBTYPE (N_Op, Node_Kind, N_Op_And, N_Op_Not) SUBTYPE (N_Renaming_Declaration, Node_Kind, N_Object_Renaming_Declaration, N_Generic_Function_Renaming_Declaration) SUBTYPE (N_Generic_Renaming_Declaration, Node_Kind, N_Generic_Package_Renaming_Declaration, N_Generic_Function_Renaming_Declaration) SUBTYPE (N_Representation_Clause, Node_Kind, N_Attribute_Definition_Clause, N_At_Clause) SUBTYPE (N_Statement, Node_Kind, N_Abort_Statement, N_Return_Statement) SUBTYPE (N_Subexpr, Node_Kind, N_Expanded_Name, N_Procedure_Call_Statement) SUBTYPE (N_Entity_Name, Node_Kind, N_Expanded_Name, N_Identifier) SUBTYPE (N_Subprogram_Specification, Node_Kind, N_Function_Specification, N_Procedure_Specification) SUBTYPE (N_Unary_Op, Node_Kind, N_Op_Plus, N_Op_Not) INLINE Boolean Abort_Present (Node_Id N) { return Flag1 (N); } INLINE Node_Id Abortable_Part (Node_Id N) { return Node2 (N); } INLINE Boolean Abstract_Present (Node_Id N) { return Flag4 (N); } INLINE Node_Id Accept_Name (Node_Id N) { return Node1 (N); } INLINE Node_Id Accept_Statement (Node_Id N) { return Node2 (N); } INLINE List_Id Actions (Node_Id N) { return List1 (N); } INLINE Node_Id Activation_Chain_Entity (Node_Id N) { return Node2 (N); } INLINE Boolean Acts_As_Spec (Node_Id N) { return Flag4 (N); } INLINE Node_Id Actual_Parameter (Node_Id N) { return Node2 (N); } INLINE Boolean Aliased_Present (Node_Id N) { return Flag1 (N); } INLINE Boolean All_Present (Node_Id N) { return Flag1 (N); } INLINE List_Id Alternatives (Node_Id N) { return List4 (N); } INLINE Boolean Analyzed (Node_Id N) { return Flag19 (N); } INLINE Node_Id Array_Aggregate (Node_Id N) { return Node4 (N); } INLINE Boolean Assignment_OK (Node_Id N) { return Flag5 (N); } INLINE Boolean Bad_Is_Detected (Node_Id N) { return Flag1 (N); } INLINE Boolean Body_Required (Node_Id N) { return Flag3 (N); } INLINE Boolean Box_Present (Node_Id N) { return Flag1 (N); } INLINE Char_Code Char_Literal_Value (Node_Id N) { return Char_Code2 (N); } INLINE Name_Id Chars (Node_Id N) { return Name1 (N); } INLINE Node_Id Choice_Parameter (Node_Id N) { return Node2 (N); } INLINE List_Id Choices (Node_Id N) { return List1 (N); } INLINE List_Id Component_Associations (Node_Id N) { return List4 (N); } INLINE List_Id Component_Clauses (Node_Id N) { return List3 (N); } INLINE List_Id Component_Declarations (Node_Id N) { return List3 (N); } INLINE Node_Id Component_List (Node_Id N) { return Node1 (N); } INLINE Node_Id Component_Name (Node_Id N) { return Node1 (N); } INLINE Node_Id Condition (Node_Id N) { return Node5 (N); } INLINE Boolean Constant_Present (Node_Id N) { return Flag2 (N); } INLINE Node_Id Constraint (Node_Id N) { return Node3 (N); } INLINE List_Id Constraints (Node_Id N) { return List1 (N); } INLINE Boolean Context_Installed (Node_Id N) { return Flag3 (N); } INLINE List_Id Context_Items (Node_Id N) { return List1 (N); } INLINE Node_Id Controlling_Argument (Node_Id N) { return Node1 (N); } INLINE Node_Id Corresponding_Body (Node_Id N) { return Node5 (N); } INLINE Node_Id Corresponding_Spec (Node_Id N) { return Node5 (N); } INLINE Node_Id Debug_Statement (Node_Id N) { return Node3 (N); } INLINE Boolean Decimal (Node_Id N) { return Flag2 (N); } INLINE List_Id Declarations (Node_Id N) { return List3 (N); } INLINE Node_Id Default_Name (Node_Id N) { return Node2 (N); } INLINE Node_Id Defining_Identifier (Node_Id N) { return Node1 (N); } INLINE Node_Id Defining_Unit_Name (Node_Id N) { return Node1 (N); } INLINE Node_Id Delay_Alternative (Node_Id N) { return Node4 (N); } INLINE Node_Id Delay_Statement (Node_Id N) { return Node2 (N); } INLINE Node_Id Delta_Expression (Node_Id N) { return Node3 (N); } INLINE Uint Denominator (Node_Id N) { return Uint4 (N); } INLINE Node_Id Digits_Expression (Node_Id N) { return Node2 (N); } INLINE List_Id Discrete_Choices (Node_Id N) { return List4 (N); } INLINE Node_Id Discrete_Range (Node_Id N) { return Node4 (N); } INLINE Node_Id Discrete_Subtype_Definition (Node_Id N) { return Node4 (N); } INLINE List_Id Discrete_Subtype_Definitions (Node_Id N) { return List2 (N); } INLINE List_Id Discriminant_Specifications (Node_Id N) { return List2 (N); } INLINE Node_Id Discriminant_Type (Node_Id N) { return Node2 (N); } INLINE Boolean Do_Access_Check (Node_Id N) { return Flag2 (N); } INLINE Boolean Do_Accessibility_Check (Node_Id N) { return Flag3 (N); } INLINE Boolean Do_Discriminant_Check (Node_Id N) { return Flag3 (N); } INLINE Boolean Do_Division_Check (Node_Id N) { return Flag3 (N); } INLINE Boolean Do_Elaboration_Check (Node_Id N) { return Flag2 (N); } INLINE Boolean Do_Length_Check (Node_Id N) { return Flag4 (N); } INLINE Boolean Do_Overflow_Check (Node_Id N) { return Flag2 (N); } INLINE Boolean Do_Range_Check (Node_Id N) { return Flag9 (N); } INLINE Boolean Do_Storage_Check (Node_Id N) { return Flag2 (N); } INLINE Boolean Do_Tag_Check (Node_Id N) { return Flag3 (N); } INLINE Boolean Elaborate_Present (Node_Id N) { return Flag4 (N); } INLINE Boolean Elaborate_All_Present (Node_Id N) { return Flag1 (N); } INLINE Boolean Elaborate_Body_Present (Node_Id N) { return Flag7 (N); } INLINE List_Id Else_Statements (Node_Id N) { return List4 (N); } INLINE List_Id Elsif_Parts (Node_Id N) { return List3 (N); } INLINE Node_Id Enclosing_Variant (Node_Id N) { return Node2 (N); } INLINE Node_Id Entity (Node_Id N) { return Node4 (N); } INLINE Node_Id Entry_Body_Formal_Part (Node_Id N) { return Node2 (N); } INLINE Node_Id Entry_Call_Alternative (Node_Id N) { return Node1 (N); } INLINE Node_Id Entry_Call_Statement (Node_Id N) { return Node1 (N); } INLINE Node_Id Entry_Index (Node_Id N) { return Node5 (N); } INLINE Node_Id Entry_Index_Specification (Node_Id N) { return Node1 (N); } INLINE Boolean Error_Posted (Node_Id N) { return Flag20 (N); } INLINE Node_Id Etype (Node_Id N) { return Node5 (N); } INLINE Boolean Evaluate_Once (Node_Id N) { return Flag10 (N); } INLINE List_Id Exception_Choices (Node_Id N) { return List4 (N); } INLINE List_Id Exception_Handlers (Node_Id N) { return List4 (N); } INLINE Node_Id Explicit_Generic_Actual_Parameter (Node_Id N) { return Node2 (N); } INLINE Node_Id Expression (Node_Id N) { return Node3 (N); } INLINE List_Id Expressions (Node_Id N) { return List3 (N); } INLINE Node_Id First_Bit (Node_Id N) { return Node3 (N); } INLINE Boolean First_Name (Node_Id N) { return Flag5 (N); } INLINE Node_Id First_Named_Actual (Node_Id N) { return Node4 (N); } INLINE List_Id Following_Pragmas (Node_Id N) { return List3 (N); } INLINE Node_Id Formal_Type_Definition (Node_Id N) { return Node3 (N); } INLINE List_Id Generic_Associations (Node_Id N) { return List3 (N); } INLINE List_Id Generic_Formal_Declarations (Node_Id N) { return List3 (N); } INLINE Node_Id Generic_Parent (Node_Id N) { return Node5 (N); } INLINE Node_Id Handled_Statement_Sequence (Node_Id N) { return Node4 (N); } INLINE Boolean Has_Created_Identifier (Node_Id N) { return Flag1 (N); } INLINE Boolean Has_No_Side_Effects (Node_Id N) { return Flag8 (N); } INLINE Boolean Has_Priority_Pragma (Node_Id N) { return Flag6 (N); } INLINE Boolean Has_Task_Stack_Size_Pragma (Node_Id N) { return Flag5 (N); } INLINE Boolean Has_Unknown_Discriminants (Node_Id N) { return Flag3 (N); } INLINE Node_Id High_Bound (Node_Id N) { return Node2 (N); } INLINE Node_Id Identifier (Node_Id N) { return Node1 (N); } INLINE List_Id Implicit_Types (Node_Id N) { return List2 (N); } INLINE Boolean Implicit_With (Node_Id N) { return Flag2 (N); } INLINE Boolean In_Present (Node_Id N) { return Flag1 (N); } INLINE Uint Intval (Node_Id N) { return Uint3 (N); } INLINE Boolean Is_Evaluated (Node_Id N) { return Flag7 (N); } INLINE Boolean Is_Overloaded (Node_Id N) { return Flag5 (N); } INLINE Boolean Is_Task_Master (Node_Id N) { return Flag5 (N); } INLINE Boolean Is_Static (Node_Id N) { return Flag6 (N); } INLINE Node_Id Iteration_Scheme (Node_Id N) { return Node2 (N); } INLINE Node_Id Left_Opnd (Node_Id N) { return Node2 (N); } INLINE Node_Id Label (Node_Id N) { return Node2 (N); } INLINE Node_Id Last_Bit (Node_Id N) { return Node4 (N); } INLINE Boolean Last_Name (Node_Id N) { return Flag6 (N); } INLINE Node_Id Library_Unit (Node_Id N) { return Node4 (N); } INLINE List_Id Literals (Node_Id N) { return List1 (N); } INLINE Boolean Limited_Present (Node_Id N) { return Flag2 (N); } INLINE Node_Id Loop_Parameter_Specification (Node_Id N) { return Node2 (N); } INLINE Node_Id Low_Bound (Node_Id N) { return Node1 (N); } INLINE Node_Id Mod_Clause (Node_Id N) { return Node2 (N); } INLINE Boolean More_Ids (Node_Id N) { return Flag5 (N); } INLINE Node_Id Name (Node_Id N) { return Node2 (N); } INLINE List_Id Names (Node_Id N) { return List2 (N); } INLINE Node_Id Next_Named_Actual (Node_Id N) { return Node4 (N); } INLINE Boolean Null_Present (Node_Id N) { return Flag3 (N); } INLINE Boolean Null_Record_Present (Node_Id N) { return Flag2 (N); } INLINE Uint Numerator (Node_Id N) { return Uint3 (N); } INLINE Node_Id Object_Definition (Node_Id N) { return Node2 (N); } INLINE List_Id Others_Discrete_Choices (Node_Id N) { return List1 (N); } INLINE Boolean Out_Present (Node_Id N) { return Flag2 (N); } INLINE List_Id Parameter_Associations (Node_Id N) { return List3 (N); } INLINE List_Id Parameter_Specifications (Node_Id N) { return List2 (N); } INLINE Node_Id Parameter_Type (Node_Id N) { return Node2 (N); } INLINE Boolean Parens (Node_Id N) { return Flag1 (N); } INLINE Node_Id Parent_Spec (Node_Id N) { return Node4 (N); } INLINE Node_Id Position (Node_Id N) { return Node2 (N); } INLINE List_Id Pragma_Argument_Associations (Node_Id N) { return List2 (N); } INLINE Boolean Preelaborable (Node_Id N) { return Flag2 (N); } INLINE Node_Id Prefix (Node_Id N) { return Node2 (N); } INLINE Boolean Prev_Ids (Node_Id N) { return Flag6 (N); } INLINE List_Id Private_Declarations (Node_Id N) { return List4 (N); } INLINE Boolean Private_Present (Node_Id N) { return Flag1 (N); } INLINE Node_Id Proper_Body (Node_Id N) { return Node1 (N); } INLINE Node_Id Protected_Definition (Node_Id N) { return Node3 (N); } INLINE Boolean Protected_Present (Node_Id N) { return Flag1 (N); } INLINE Node_Id Range_Constraint (Node_Id N) { return Node4 (N); } INLINE Node_Id Range_Expression (Node_Id N) { return Node4 (N); } INLINE Node_Id Real_Range_Specification (Node_Id N) { return Node4 (N); } INLINE Node_Id Record_Extension_Part (Node_Id N) { return Node3 (N); } INLINE Boolean Redundant_Use (Node_Id N) { return Flag2 (N); } INLINE Boolean Reverse_Present (Node_Id N) { return Flag1 (N); } INLINE Node_Id Right_Opnd (Node_Id N) { return Node3 (N); } INLINE List_Id Selective_Accept_Alternatives (Node_Id N) { return List1 (N); } INLINE Node_Id Selector_Name (Node_Id N) { return Node3 (N); } INLINE List_Id Selector_Names (Node_Id N) { return List1 (N); } INLINE Node_Id Specification (Node_Id N) { return Node1 (N); } INLINE List_Id Statements (Node_Id N) { return List3 (N); } INLINE String_Id Strval (Node_Id N) { return Str3 (N); } INLINE Node_Id Subtype_Indication (Node_Id N) { return Node4 (N); } INLINE Node_Id Subtype_Mark (Node_Id N) { return Node4 (N); } INLINE List_Id Subtype_Marks (Node_Id N) { return List2 (N); } INLINE Boolean Tagged_Present (Node_Id N) { return Flag1 (N); } INLINE Node_Id Task_Definition (Node_Id N) { return Node3 (N); } INLINE List_Id Then_Statements (Node_Id N) { return List2 (N); } INLINE Node_Id Triggering_Alternative (Node_Id N) { return Node1 (N); } INLINE Node_Id Triggering_Statement (Node_Id N) { return Node1 (N); } INLINE Node_Id Type_Definition (Node_Id N) { return Node3 (N); } INLINE Boolean Unchecked_Conversion (Node_Id N) { return Flag11 (N); } INLINE Node_Id Unit (Node_Id N) { return Node2 (N); } INLINE Node_Id Variant_Part (Node_Id N) { return Node4 (N); } INLINE List_Id Variants (Node_Id N) { return List1 (N); } INLINE List_Id Visible_Declarations (Node_Id N) { return List2 (N); } INLINE Node_Id Explicit_Generic_Actual_Parameter (Node_Id N) { return Node2 (N); } INLINE Node_Id Expression (Node_Id N) { return Node3 (N); } INLINE List_Id Expressions (Node_Id N) { return List3 (N); } INLINE Node_Id First_Bit (Node_Id N) { return Node3 (N); } INLINE Boolean First_Name (Node_Id N) { retgnat-1.67-src/src/nmake.adb 644 10015 7640 255277 5506244522 10744 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- N M A K E -- -- -- -- B o d y -- -- -- -- Generated by xnmake revision 1.11 using -- -- sinfo.ads revision 1.128 -- -- nmake.adt revision 1.2 -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Sinfo; use Sinfo; with Snames; use Snames; with Types; use Types; package body Nmake is function Make_Unused_At_Start (Sloc : Source_Ptr) return Node_Id is N : constant Node_Id := New_Node (N_Unused_At_Start, Sloc); begin return N; end Make_Unused_At_Start; function Make_Unused_At_End (Sloc : Source_Ptr) return Node_Id is N : constant Node_Id := New_Node (N_Unused_At_End, Sloc); begin return N; end Make_Unused_At_End; function Make_Identifier (Sloc : Source_Ptr; Chars : Name_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Identifier, Sloc); begin Set_Chars (N, Chars); Set_Parens (N, Parens); return N; end Make_Identifier; function Make_Integer_Literal (Sloc : Source_Ptr; Intval : Uint; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Integer_Literal, Sloc); begin Set_Intval (N, Intval); Set_Parens (N, Parens); return N; end Make_Integer_Literal; function Make_Real_Literal (Sloc : Source_Ptr; Numerator : Uint; Denominator : Uint; Decimal : Boolean := False; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Real_Literal, Sloc); begin Set_Numerator (N, Numerator); Set_Denominator (N, Denominator); Set_Decimal (N, Decimal); Set_Parens (N, Parens); return N; end Make_Real_Literal; function Make_Character_Literal (Sloc : Source_Ptr; Chars : Name_Id; Char_Literal_Value : Char_Code; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Character_Literal, Sloc); begin Set_Chars (N, Chars); Set_Char_Literal_Value (N, Char_Literal_Value); Set_Parens (N, Parens); return N; end Make_Character_Literal; function Make_String_Literal (Sloc : Source_Ptr; Strval : String_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_String_Literal, Sloc); begin Set_Strval (N, Strval); Set_Parens (N, Parens); return N; end Make_String_Literal; function Make_Pragma (Sloc : Source_Ptr; Identifier : Node_Id; Pragma_Argument_Associations : List_Id := No_List) return Node_Id is N : constant Node_Id := New_Node (N_Pragma, Sloc); begin Set_Identifier (N, Identifier); Set_Pragma_Argument_Associations (N, Pragma_Argument_Associations); return N; end Make_Pragma; function Make_Pragma_Argument_Association (Sloc : Source_Ptr; Identifier : Node_Id := Empty; Expression : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Pragma_Argument_Association, Sloc); begin Set_Identifier (N, Identifier); Set_Expression (N, Expression); return N; end Make_Pragma_Argument_Association; function Make_Defining_Identifier (Sloc : Source_Ptr; Chars : Name_Id) return Node_Id is N : constant Node_Id := Extend_Node (New_Node (N_Defining_Identifier, Sloc)); begin Set_Chars (N, Chars); return N; end Make_Defining_Identifier; function Make_Full_Type_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Discriminant_Specifications : List_Id := No_List; Type_Definition : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Full_Type_Declaration, Sloc); begin Set_Defining_Identifier (N, Defining_Identifier); Set_Discriminant_Specifications (N, Discriminant_Specifications); Set_Type_Definition (N, Type_Definition); return N; end Make_Full_Type_Declaration; function Make_Subtype_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Subtype_Indication : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Subtype_Declaration, Sloc); begin Set_Defining_Identifier (N, Defining_Identifier); Set_Subtype_Indication (N, Subtype_Indication); return N; end Make_Subtype_Declaration; function Make_Subtype_Indication (Sloc : Source_Ptr; Subtype_Mark : Node_Id; Constraint : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Subtype_Indication, Sloc); begin Set_Subtype_Mark (N, Subtype_Mark); Set_Constraint (N, Constraint); return N; end Make_Subtype_Indication; function Make_Object_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Aliased_Present : Boolean := False; Constant_Present : Boolean := False; Object_Definition : Node_Id; Expression : Node_Id := Empty) return Node_Id is N : constant Node_Id := New_Node (N_Object_Declaration, Sloc); begin Set_Defining_Identifier (N, Defining_Identifier); Set_Aliased_Present (N, Aliased_Present); Set_Constant_Present (N, Constant_Present); Set_Object_Definition (N, Object_Definition); Set_Expression (N, Expression); return N; end Make_Object_Declaration; function Make_Number_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Expression : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Number_Declaration, Sloc); begin Set_Defining_Identifier (N, Defining_Identifier); Set_Expression (N, Expression); return N; end Make_Number_Declaration; function Make_Derived_Type_Definition (Sloc : Source_Ptr; Abstract_Present : Boolean := False; Subtype_Indication : Node_Id; Record_Extension_Part : Node_Id := Empty) return Node_Id is N : constant Node_Id := New_Node (N_Derived_Type_Definition, Sloc); begin Set_Abstract_Present (N, Abstract_Present); Set_Subtype_Indication (N, Subtype_Indication); Set_Record_Extension_Part (N, Record_Extension_Part); return N; end Make_Derived_Type_Definition; function Make_Range_Constraint (Sloc : Source_Ptr; Range_Expression : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Range_Constraint, Sloc); begin Set_Range_Expression (N, Range_Expression); return N; end Make_Range_Constraint; function Make_Range (Sloc : Source_Ptr; Low_Bound : Node_Id; High_Bound : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Range, Sloc); begin Set_Low_Bound (N, Low_Bound); Set_High_Bound (N, High_Bound); Set_Parens (N, Parens); return N; end Make_Range; function Make_Enumeration_Type_Definition (Sloc : Source_Ptr; Literals : List_Id) return Node_Id is N : constant Node_Id := New_Node (N_Enumeration_Type_Definition, Sloc); begin Set_Literals (N, Literals); return N; end Make_Enumeration_Type_Definition; function Make_Defining_Character_Literal (Sloc : Source_Ptr; Chars : Name_Id) return Node_Id is N : constant Node_Id := Extend_Node (New_Node (N_Defining_Character_Literal, Sloc)); begin Set_Chars (N, Chars); return N; end Make_Defining_Character_Literal; function Make_Signed_Integer_Type_Definition (Sloc : Source_Ptr; Low_Bound : Node_Id; High_Bound : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Signed_Integer_Type_Definition, Sloc); begin Set_Low_Bound (N, Low_Bound); Set_High_Bound (N, High_Bound); return N; end Make_Signed_Integer_Type_Definition; function Make_Modular_Type_Definition (Sloc : Source_Ptr; Expression : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Modular_Type_Definition, Sloc); begin Set_Expression (N, Expression); return N; end Make_Modular_Type_Definition; function Make_Floating_Point_Definition (Sloc : Source_Ptr; Digits_Expression : Node_Id; Real_Range_Specification : Node_Id := Empty) return Node_Id is N : constant Node_Id := New_Node (N_Floating_Point_Definition, Sloc); begin Set_Digits_Expression (N, Digits_Expression); Set_Real_Range_Specification (N, Real_Range_Specification); return N; end Make_Floating_Point_Definition; function Make_Real_Range_Specification (Sloc : Source_Ptr; Low_Bound : Node_Id; High_Bound : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Real_Range_Specification, Sloc); begin Set_Low_Bound (N, Low_Bound); Set_High_Bound (N, High_Bound); return N; end Make_Real_Range_Specification; function Make_Ordinary_Fixed_Point_Definition (Sloc : Source_Ptr; Delta_Expression : Node_Id; Real_Range_Specification : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Ordinary_Fixed_Point_Definition, Sloc); begin Set_Delta_Expression (N, Delta_Expression); Set_Real_Range_Specification (N, Real_Range_Specification); return N; end Make_Ordinary_Fixed_Point_Definition; function Make_Decimal_Fixed_Point_Definition (Sloc : Source_Ptr; Delta_Expression : Node_Id; Digits_Expression : Node_Id; Real_Range_Specification : Node_Id := Empty) return Node_Id is N : constant Node_Id := New_Node (N_Decimal_Fixed_Point_Definition, Sloc); begin Set_Delta_Expression (N, Delta_Expression); Set_Digits_Expression (N, Digits_Expression); Set_Real_Range_Specification (N, Real_Range_Specification); return N; end Make_Decimal_Fixed_Point_Definition; function Make_Digits_Constraint (Sloc : Source_Ptr; Digits_Expression : Node_Id; Range_Constraint : Node_Id := Empty) return Node_Id is N : constant Node_Id := New_Node (N_Digits_Constraint, Sloc); begin Set_Digits_Expression (N, Digits_Expression); Set_Range_Constraint (N, Range_Constraint); return N; end Make_Digits_Constraint; function Make_Delta_Constraint (Sloc : Source_Ptr; Delta_Expression : Node_Id; Range_Constraint : Node_Id := Empty) return Node_Id is N : constant Node_Id := New_Node (N_Delta_Constraint, Sloc); begin Set_Delta_Expression (N, Delta_Expression); Set_Range_Constraint (N, Range_Constraint); return N; end Make_Delta_Constraint; function Make_Unconstrained_Array_Definition (Sloc : Source_Ptr; Subtype_Marks : List_Id; Aliased_Present : Boolean := False; Subtype_Indication : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Unconstrained_Array_Definition, Sloc); begin Set_Subtype_Marks (N, Subtype_Marks); Set_Aliased_Present (N, Aliased_Present); Set_Subtype_Indication (N, Subtype_Indication); return N; end Make_Unconstrained_Array_Definition; function Make_Constrained_Array_Definition (Sloc : Source_Ptr; Discrete_Subtype_Definitions : List_Id; Aliased_Present : Boolean := False; Subtype_Indication : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Constrained_Array_Definition, Sloc); begin Set_Discrete_Subtype_Definitions (N, Discrete_Subtype_Definitions); Set_Aliased_Present (N, Aliased_Present); Set_Subtype_Indication (N, Subtype_Indication); return N; end Make_Constrained_Array_Definition; function Make_Discriminant_Specification (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Discriminant_Type : Node_Id; Expression : Node_Id := Empty) return Node_Id is N : constant Node_Id := New_Node (N_Discriminant_Specification, Sloc); begin Set_Defining_Identifier (N, Defining_Identifier); Set_Discriminant_Type (N, Discriminant_Type); Set_Expression (N, Expression); return N; end Make_Discriminant_Specification; function Make_Index_Or_Discriminant_Constraint (Sloc : Source_Ptr; Constraints : List_Id) return Node_Id is N : constant Node_Id := New_Node (N_Index_Or_Discriminant_Constraint, Sloc); begin Set_Constraints (N, Constraints); return N; end Make_Index_Or_Discriminant_Constraint; function Make_Discriminant_Association (Sloc : Source_Ptr; Selector_Names : List_Id; Expression : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Discriminant_Association, Sloc); begin Set_Selector_Names (N, Selector_Names); Set_Expression (N, Expression); return N; end Make_Discriminant_Association; function Make_Record_Definition (Sloc : Source_Ptr; Abstract_Present : Boolean := False; Tagged_Present : Boolean := False; Limited_Present : Boolean := False; Component_List : Node_Id; Null_Present : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Record_Definition, Sloc); begin Set_Abstract_Present (N, Abstract_Present); Set_Tagged_Present (N, Tagged_Present); Set_Limited_Present (N, Limited_Present); Set_Component_List (N, Component_List); Set_Null_Present (N, Null_Present); return N; end Make_Record_Definition; function Make_Component_List (Sloc : Source_Ptr; Component_Declarations : List_Id; Variant_Part : Node_Id := Empty; Null_Present : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Component_List, Sloc); begin Set_Component_Declarations (N, Component_Declarations); Set_Variant_Part (N, Variant_Part); Set_Null_Present (N, Null_Present); return N; end Make_Component_List; function Make_Component_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Aliased_Present : Boolean := False; Subtype_Indication : Node_Id; Expression : Node_Id := Empty) return Node_Id is N : constant Node_Id := New_Node (N_Component_Declaration, Sloc); begin Set_Defining_Identifier (N, Defining_Identifier); Set_Aliased_Present (N, Aliased_Present); Set_Subtype_Indication (N, Subtype_Indication); Set_Expression (N, Expression); return N; end Make_Component_Declaration; function Make_Variant_Part (Sloc : Source_Ptr; Name : Node_Id; Variants : List_Id) return Node_Id is N : constant Node_Id := New_Node (N_Variant_Part, Sloc); begin Set_Name (N, Name); Set_Variants (N, Variants); return N; end Make_Variant_Part; function Make_Variant (Sloc : Source_Ptr; Discrete_Choices : List_Id; Component_List : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Variant, Sloc); begin Set_Discrete_Choices (N, Discrete_Choices); Set_Component_List (N, Component_List); return N; end Make_Variant; function Make_Others_Choice (Sloc : Source_Ptr) return Node_Id is N : constant Node_Id := New_Node (N_Others_Choice, Sloc); begin return N; end Make_Others_Choice; function Make_Access_To_Object_Definition (Sloc : Source_Ptr; All_Present : Boolean := False; Subtype_Indication : Node_Id; Constant_Present : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Access_To_Object_Definition, Sloc); begin Set_All_Present (N, All_Present); Set_Subtype_Indication (N, Subtype_Indication); Set_Constant_Present (N, Constant_Present); return N; end Make_Access_To_Object_Definition; function Make_Access_Function_Definition (Sloc : Source_Ptr; Protected_Present : Boolean := False; Parameter_Specifications : List_Id := No_List; Subtype_Mark : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Access_Function_Definition, Sloc); begin Set_Protected_Present (N, Protected_Present); Set_Parameter_Specifications (N, Parameter_Specifications); Set_Subtype_Mark (N, Subtype_Mark); return N; end Make_Access_Function_Definition; function Make_Access_Procedure_Definition (Sloc : Source_Ptr; Protected_Present : Boolean := False; Parameter_Specifications : List_Id := No_List) return Node_Id is N : constant Node_Id := New_Node (N_Access_Procedure_Definition, Sloc); begin Set_Protected_Present (N, Protected_Present); Set_Parameter_Specifications (N, Parameter_Specifications); return N; end Make_Access_Procedure_Definition; function Make_Access_Definition (Sloc : Source_Ptr; Subtype_Mark : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Access_Definition, Sloc); begin Set_Subtype_Mark (N, Subtype_Mark); return N; end Make_Access_Definition; function Make_Incomplete_Type_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Discriminant_Specifications : List_Id := No_List; Has_Unknown_Discriminants : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Incomplete_Type_Declaration, Sloc); begin Set_Defining_Identifier (N, Defining_Identifier); Set_Discriminant_Specifications (N, Discriminant_Specifications); Set_Has_Unknown_Discriminants (N, Has_Unknown_Discriminants); return N; end Make_Incomplete_Type_Declaration; function Make_Explicit_Dereference (Sloc : Source_Ptr; Prefix : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Explicit_Dereference, Sloc); begin Set_Prefix (N, Prefix); Set_Parens (N, Parens); return N; end Make_Explicit_Dereference; function Make_Indexed_Component (Sloc : Source_Ptr; Prefix : Node_Id; Expressions : List_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Indexed_Component, Sloc); begin Set_Prefix (N, Prefix); Set_Expressions (N, Expressions); Set_Parens (N, Parens); return N; end Make_Indexed_Component; function Make_Slice (Sloc : Source_Ptr; Prefix : Node_Id; Discrete_Range : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Slice, Sloc); begin Set_Prefix (N, Prefix); Set_Discrete_Range (N, Discrete_Range); Set_Parens (N, Parens); return N; end Make_Slice; function Make_Selected_Component (Sloc : Source_Ptr; Prefix : Node_Id; Selector_Name : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Selected_Component, Sloc); begin Set_Prefix (N, Prefix); Set_Selector_Name (N, Selector_Name); Set_Parens (N, Parens); return N; end Make_Selected_Component; function Make_Attribute_Reference (Sloc : Source_Ptr; Prefix : Node_Id; Identifier : Node_Id; Expression : Node_Id := Empty; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Attribute_Reference, Sloc); begin Set_Prefix (N, Prefix); Set_Identifier (N, Identifier); Set_Expression (N, Expression); Set_Parens (N, Parens); return N; end Make_Attribute_Reference; function Make_Aggregate (Sloc : Source_Ptr; Expressions : List_Id; Component_Associations : List_Id := No_List; Null_Record_Present : Boolean := False; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Aggregate, Sloc); begin Set_Expressions (N, Expressions); Set_Component_Associations (N, Component_Associations); Set_Null_Record_Present (N, Null_Record_Present); Set_Parens (N, Parens); return N; end Make_Aggregate; function Make_Component_Association (Sloc : Source_Ptr; Choices : List_Id; Expression : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Component_Association, Sloc); begin Set_Choices (N, Choices); Set_Expression (N, Expression); return N; end Make_Component_Association; function Make_Extension_Aggregate (Sloc : Source_Ptr; Expression : Node_Id; Component_Associations : List_Id := No_List; Null_Record_Present : Boolean := False; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Extension_Aggregate, Sloc); begin Set_Expression (N, Expression); Set_Component_Associations (N, Component_Associations); Set_Null_Record_Present (N, Null_Record_Present); Set_Parens (N, Parens); return N; end Make_Extension_Aggregate; function Make_Null (Sloc : Source_Ptr; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Null, Sloc); begin Set_Parens (N, Parens); return N; end Make_Null; function Make_Parenthesized_Expression (Sloc : Source_Ptr; Expression : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Parenthesized_Expression, Sloc); begin Set_Expression (N, Expression); Set_Parens (N, Parens); return N; end Make_Parenthesized_Expression; function Make_Op_And (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Op_And, Sloc); begin Set_Left_Opnd (N, Left_Opnd); Set_Right_Opnd (N, Right_Opnd); Set_Parens (N, Parens); Set_Chars (N, Name_Op_And); return N; end Make_Op_And; function Make_Op_And_Then (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Op_And_Then, Sloc); begin Set_Left_Opnd (N, Left_Opnd); Set_Right_Opnd (N, Right_Opnd); Set_Parens (N, Parens); Set_Chars (N, Name_Op_And_Then); return N; end Make_Op_And_Then; function Make_Op_Or (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Op_Or, Sloc); begin Set_Left_Opnd (N, Left_Opnd); Set_Right_Opnd (N, Right_Opnd); Set_Parens (N, Parens); Set_Chars (N, Name_Op_Or); return N; end Make_Op_Or; function Make_Op_Or_Else (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Op_Or_Else, Sloc); begin Set_Left_Opnd (N, Left_Opnd); Set_Right_Opnd (N, Right_Opnd); Set_Parens (N, Parens); Set_Chars (N, Name_Op_Or_Else); return N; end Make_Op_Or_Else; function Make_Op_Xor (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Op_Xor, Sloc); begin Set_Left_Opnd (N, Left_Opnd); Set_Right_Opnd (N, Right_Opnd); Set_Parens (N, Parens); Set_Chars (N, Name_Op_Xor); return N; end Make_Op_Xor; function Make_Op_In (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Op_In, Sloc); begin Set_Left_Opnd (N, Left_Opnd); Set_Right_Opnd (N, Right_Opnd); Set_Parens (N, Parens); Set_Chars (N, Name_Op_In); return N; end Make_Op_In; function Make_Op_Not_In (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Op_Not_In, Sloc); begin Set_Left_Opnd (N, Left_Opnd); Set_Right_Opnd (N, Right_Opnd); Set_Parens (N, Parens); Set_Chars (N, Name_Op_Not_In); return N; end Make_Op_Not_In; function Make_Op_Eq (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Op_Eq, Sloc); begin Set_Left_Opnd (N, Left_Opnd); Set_Right_Opnd (N, Right_Opnd); Set_Parens (N, Parens); Set_Chars (N, Name_Op_Eq); return N; end Make_Op_Eq; function Make_Op_Ne (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Op_Ne, Sloc); begin Set_Left_Opnd (N, Left_Opnd); Set_Right_Opnd (N, Right_Opnd); Set_Parens (N, Parens); Set_Chars (N, Name_Op_Ne); return N; end Make_Op_Ne; function Make_Op_Lt (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Op_Lt, Sloc); begin Set_Left_Opnd (N, Left_Opnd); Set_Right_Opnd (N, Right_Opnd); Set_Parens (N, Parens); Set_Chars (N, Name_Op_Lt); return N; end Make_Op_Lt; function Make_Op_Le (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Op_Le, Sloc); begin Set_Left_Opnd (N, Left_Opnd); Set_Right_Opnd (N, Right_Opnd); Set_Parens (N, Parens); Set_Chars (N, Name_Op_Le); return N; end Make_Op_Le; function Make_Op_Gt (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Op_Gt, Sloc); begin Set_Left_Opnd (N, Left_Opnd); Set_Right_Opnd (N, Right_Opnd); Set_Parens (N, Parens); Set_Chars (N, Name_Op_Gt); return N; end Make_Op_Gt; function Make_Op_Ge (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Op_Ge, Sloc); begin Set_Left_Opnd (N, Left_Opnd); Set_Right_Opnd (N, Right_Opnd); Set_Parens (N, Parens); Set_Chars (N, Name_Op_Ge); return N; end Make_Op_Ge; function Make_Op_Add (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Op_Add, Sloc); begin Set_Left_Opnd (N, Left_Opnd); Set_Right_Opnd (N, Right_Opnd); Set_Parens (N, Parens); Set_Chars (N, Name_Op_Add); return N; end Make_Op_Add; function Make_Op_Subtract (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Op_Subtract, Sloc); begin Set_Left_Opnd (N, Left_Opnd); Set_Right_Opnd (N, Right_Opnd); Set_Parens (N, Parens); Set_Chars (N, Name_Op_Subtract); return N; end Make_Op_Subtract; function Make_Op_Concat (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Op_Concat, Sloc); begin Set_Left_Opnd (N, Left_Opnd); Set_Right_Opnd (N, Right_Opnd); Set_Parens (N, Parens); Set_Chars (N, Name_Op_Concat); return N; end Make_Op_Concat; function Make_Op_Multiply (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Op_Multiply, Sloc); begin Set_Left_Opnd (N, Left_Opnd); Set_Right_Opnd (N, Right_Opnd); Set_Parens (N, Parens); Set_Chars (N, Name_Op_Multiply); return N; end Make_Op_Multiply; function Make_Op_Divide (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Op_Divide, Sloc); begin Set_Left_Opnd (N, Left_Opnd); Set_Right_Opnd (N, Right_Opnd); Set_Parens (N, Parens); Set_Chars (N, Name_Op_Divide); return N; end Make_Op_Divide; function Make_Op_Mod (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Op_Mod, Sloc); begin Set_Left_Opnd (N, Left_Opnd); Set_Right_Opnd (N, Right_Opnd); Set_Parens (N, Parens); Set_Chars (N, Name_Op_Mod); return N; end Make_Op_Mod; function Make_Op_Rem (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Op_Rem, Sloc); begin Set_Left_Opnd (N, Left_Opnd); Set_Right_Opnd (N, Right_Opnd); Set_Parens (N, Parens); Set_Chars (N, Name_Op_Rem); return N; end Make_Op_Rem; function Make_Op_Expon (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Op_Expon, Sloc); begin Set_Left_Opnd (N, Left_Opnd); Set_Right_Opnd (N, Right_Opnd); Set_Parens (N, Parens); Set_Chars (N, Name_Op_Expon); return N; end Make_Op_Expon; function Make_Op_Plus (Sloc : Source_Ptr; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Op_Plus, Sloc); begin Set_Right_Opnd (N, Right_Opnd); Set_Parens (N, Parens); Set_Chars (N, Name_Op_Add); return N; end Make_Op_Plus; function Make_Op_Minus (Sloc : Source_Ptr; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Op_Minus, Sloc); begin Set_Right_Opnd (N, Right_Opnd); Set_Parens (N, Parens); Set_Chars (N, Name_Op_Subtract); return N; end Make_Op_Minus; function Make_Op_Abs (Sloc : Source_Ptr; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Op_Abs, Sloc); begin Set_Right_Opnd (N, Right_Opnd); Set_Parens (N, Parens); Set_Chars (N, Name_Op_Abs); return N; end Make_Op_Abs; function Make_Op_Not (Sloc : Source_Ptr; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Op_Not, Sloc); begin Set_Right_Opnd (N, Right_Opnd); Set_Parens (N, Parens); Set_Chars (N, Name_Op_Not); return N; end Make_Op_Not; function Make_Type_Conversion (Sloc : Source_Ptr; Subtype_Mark : Node_Id; Expression : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Type_Conversion, Sloc); begin Set_Subtype_Mark (N, Subtype_Mark); Set_Expression (N, Expression); Set_Parens (N, Parens); return N; end Make_Type_Conversion; function Make_Qualified_Expression (Sloc : Source_Ptr; Subtype_Mark : Node_Id; Expression : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Qualified_Expression, Sloc); begin Set_Subtype_Mark (N, Subtype_Mark); Set_Expression (N, Expression); Set_Parens (N, Parens); return N; end Make_Qualified_Expression; function Make_Allocator (Sloc : Source_Ptr; Expression : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Allocator, Sloc); begin Set_Expression (N, Expression); Set_Parens (N, Parens); return N; end Make_Allocator; function Make_Label (Sloc : Source_Ptr; Identifier : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Label, Sloc); begin Set_Identifier (N, Identifier); return N; end Make_Label; function Make_Implicit_Label_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Label : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Implicit_Label_Declaration, Sloc); begin Set_Defining_Identifier (N, Defining_Identifier); Set_Label (N, Label); return N; end Make_Implicit_Label_Declaration; function Make_Null_Statement (Sloc : Source_Ptr) return Node_Id is N : constant Node_Id := New_Node (N_Null_Statement, Sloc); begin return N; end Make_Null_Statement; function Make_Assignment_Statement (Sloc : Source_Ptr; Name : Node_Id; Expression : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Assignment_Statement, Sloc); begin Set_Name (N, Name); Set_Expression (N, Expression); return N; end Make_Assignment_Statement; function Make_If_Statement (Sloc : Source_Ptr; Condition : Node_Id; Then_Statements : List_Id; Elsif_Parts : List_Id := No_List; Else_Statements : List_Id := No_List) return Node_Id is N : constant Node_Id := New_Node (N_If_Statement, Sloc); begin Set_Condition (N, Condition); Set_Then_Statements (N, Then_Statements); Set_Elsif_Parts (N, Elsif_Parts); Set_Else_Statements (N, Else_Statements); return N; end Make_If_Statement; function Make_Elsif_Part (Sloc : Source_Ptr; Condition : Node_Id; Then_Statements : List_Id) return Node_Id is N : constant Node_Id := New_Node (N_Elsif_Part, Sloc); begin Set_Condition (N, Condition); Set_Then_Statements (N, Then_Statements); return N; end Make_Elsif_Part; function Make_Case_Statement (Sloc : Source_Ptr; Expression : Node_Id; Alternatives : List_Id) return Node_Id is N : constant Node_Id := New_Node (N_Case_Statement, Sloc); begin Set_Expression (N, Expression); Set_Alternatives (N, Alternatives); return N; end Make_Case_Statement; function Make_Case_Statement_Alternative (Sloc : Source_Ptr; Discrete_Choices : List_Id; Statements : List_Id) return Node_Id is N : constant Node_Id := New_Node (N_Case_Statement_Alternative, Sloc); begin Set_Discrete_Choices (N, Discrete_Choices); Set_Statements (N, Statements); return N; end Make_Case_Statement_Alternative; function Make_Loop_Statement (Sloc : Source_Ptr; Identifier : Node_Id; Iteration_Scheme : Node_Id := Empty; Statements : List_Id; Has_Created_Identifier : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Loop_Statement, Sloc); begin Set_Identifier (N, Identifier); Set_Iteration_Scheme (N, Iteration_Scheme); Set_Statements (N, Statements); Set_Has_Created_Identifier (N, Has_Created_Identifier); return N; end Make_Loop_Statement; function Make_Iteration_Scheme (Sloc : Source_Ptr; Condition : Node_Id := Empty; Loop_Parameter_Specification : Node_Id := Empty) return Node_Id is N : constant Node_Id := New_Node (N_Iteration_Scheme, Sloc); begin Set_Condition (N, Condition); Set_Loop_Parameter_Specification (N, Loop_Parameter_Specification); return N; end Make_Iteration_Scheme; function Make_Loop_Parameter_Specification (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Reverse_Present : Boolean := False; Discrete_Subtype_Definition : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Loop_Parameter_Specification, Sloc); begin Set_Defining_Identifier (N, Defining_Identifier); Set_Reverse_Present (N, Reverse_Present); Set_Discrete_Subtype_Definition (N, Discrete_Subtype_Definition); return N; end Make_Loop_Parameter_Specification; function Make_Block_Statement (Sloc : Source_Ptr; Identifier : Node_Id; Declarations : List_Id := No_List; Handled_Statement_Sequence : Node_Id; Has_Created_Identifier : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Block_Statement, Sloc); begin Set_Identifier (N, Identifier); Set_Declarations (N, Declarations); Set_Handled_Statement_Sequence (N, Handled_Statement_Sequence); Set_Has_Created_Identifier (N, Has_Created_Identifier); return N; end Make_Block_Statement; function Make_Exit_Statement (Sloc : Source_Ptr; Name : Node_Id := Empty; Condition : Node_Id := Empty) return Node_Id is N : constant Node_Id := New_Node (N_Exit_Statement, Sloc); begin Set_Name (N, Name); Set_Condition (N, Condition); return N; end Make_Exit_Statement; function Make_Goto_Statement (Sloc : Source_Ptr; Name : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Goto_Statement, Sloc); begin Set_Name (N, Name); return N; end Make_Goto_Statement; function Make_Subprogram_Declaration (Sloc : Source_Ptr; Specification : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Subprogram_Declaration, Sloc); begin Set_Specification (N, Specification); return N; end Make_Subprogram_Declaration; function Make_Abstract_Subprogram_Declaration (Sloc : Source_Ptr; Specification : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Abstract_Subprogram_Declaration, Sloc); begin Set_Specification (N, Specification); return N; end Make_Abstract_Subprogram_Declaration; function Make_Function_Specification (Sloc : Source_Ptr; Defining_Unit_Name : Node_Id; Parameter_Specifications : List_Id := No_List; Subtype_Mark : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Function_Specification, Sloc); begin Set_Defining_Unit_Name (N, Defining_Unit_Name); Set_Parameter_Specifications (N, Parameter_Specifications); Set_Subtype_Mark (N, Subtype_Mark); return N; end Make_Function_Specification; function Make_Procedure_Specification (Sloc : Source_Ptr; Defining_Unit_Name : Node_Id; Parameter_Specifications : List_Id := No_List) return Node_Id is N : constant Node_Id := New_Node (N_Procedure_Specification, Sloc); begin Set_Defining_Unit_Name (N, Defining_Unit_Name); Set_Parameter_Specifications (N, Parameter_Specifications); return N; end Make_Procedure_Specification; function Make_Designator (Sloc : Source_Ptr; Name : Node_Id; Identifier : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Designator, Sloc); begin Set_Name (N, Name); Set_Identifier (N, Identifier); return N; end Make_Designator; function Make_Defining_Program_Unit_Name (Sloc : Source_Ptr; Name : Node_Id; Defining_Identifier : Node_Id) return Node_Id is N : constant Node_Id := Extend_Node (New_Node (N_Defining_Program_Unit_Name, Sloc)); begin Set_Name (N, Name); Set_Defining_Identifier (N, Defining_Identifier); return N; end Make_Defining_Program_Unit_Name; function Make_Operator_Symbol (Sloc : Source_Ptr; Chars : Name_Id; Strval : String_Id) return Node_Id is N : constant Node_Id := New_Node (N_Operator_Symbol, Sloc); begin Set_Chars (N, Chars); Set_Strval (N, Strval); return N; end Make_Operator_Symbol; function Make_Defining_Operator_Symbol (Sloc : Source_Ptr; Chars : Name_Id) return Node_Id is N : constant Node_Id := Extend_Node (New_Node (N_Defining_Operator_Symbol, Sloc)); begin Set_Chars (N, Chars); return N; end Make_Defining_Operator_Symbol; function Make_Parameter_Specification (Sloc : Source_Ptr; Defining_Identifier : Node_Id; In_Present : Boolean := False; Out_Present : Boolean := False; Parameter_Type : Node_Id; Expression : Node_Id := Empty) return Node_Id is N : constant Node_Id := New_Node (N_Parameter_Specification, Sloc); begin Set_Defining_Identifier (N, Defining_Identifier); Set_In_Present (N, In_Present); Set_Out_Present (N, Out_Present); Set_Parameter_Type (N, Parameter_Type); Set_Expression (N, Expression); return N; end Make_Parameter_Specification; function Make_Subprogram_Body (Sloc : Source_Ptr; Specification : Node_Id; Declarations : List_Id; Handled_Statement_Sequence : Node_Id; Bad_Is_Detected : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Subprogram_Body, Sloc); begin Set_Specification (N, Specification); Set_Declarations (N, Declarations); Set_Handled_Statement_Sequence (N, Handled_Statement_Sequence); Set_Bad_Is_Detected (N, Bad_Is_Detected); return N; end Make_Subprogram_Body; function Make_Procedure_Call_Statement (Sloc : Source_Ptr; Name : Node_Id; Parameter_Associations : List_Id := No_List; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Procedure_Call_Statement, Sloc); begin Set_Name (N, Name); Set_Parameter_Associations (N, Parameter_Associations); Set_Parens (N, Parens); return N; end Make_Procedure_Call_Statement; function Make_Function_Call (Sloc : Source_Ptr; Name : Node_Id; Parameter_Associations : List_Id := No_List; Do_Elaboration_Check : Boolean := False; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Function_Call, Sloc); begin Set_Name (N, Name); Set_Parameter_Associations (N, Parameter_Associations); Set_Do_Elaboration_Check (N, Do_Elaboration_Check); Set_Parens (N, Parens); return N; end Make_Function_Call; function Make_Parameter_Association (Sloc : Source_Ptr; Selector_Name : Node_Id; Actual_Parameter : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Parameter_Association, Sloc); begin Set_Selector_Name (N, Selector_Name); Set_Actual_Parameter (N, Actual_Parameter); return N; end Make_Parameter_Association; function Make_Return_Statement (Sloc : Source_Ptr; Expression : Node_Id := Empty) return Node_Id is N : constant Node_Id := New_Node (N_Return_Statement, Sloc); begin Set_Expression (N, Expression); return N; end Make_Return_Statement; function Make_Package_Declaration (Sloc : Source_Ptr; Specification : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Package_Declaration, Sloc); begin Set_Specification (N, Specification); return N; end Make_Package_Declaration; function Make_Package_Specification (Sloc : Source_Ptr; Defining_Unit_Name : Node_Id; Visible_Declarations : List_Id; Private_Declarations : List_Id := No_List) return Node_Id is N : constant Node_Id := New_Node (N_Package_Specification, Sloc); begin Set_Defining_Unit_Name (N, Defining_Unit_Name); Set_Visible_Declarations (N, Visible_Declarations); Set_Private_Declarations (N, Private_Declarations); return N; end Make_Package_Specification; function Make_Package_Body (Sloc : Source_Ptr; Defining_Unit_Name : Node_Id; Declarations : List_Id; Handled_Statement_Sequence : Node_Id := Empty) return Node_Id is N : constant Node_Id := New_Node (N_Package_Body, Sloc); begin Set_Defining_Unit_Name (N, Defining_Unit_Name); Set_Declarations (N, Declarations); Set_Handled_Statement_Sequence (N, Handled_Statement_Sequence); return N; end Make_Package_Body; function Make_Private_Type_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Discriminant_Specifications : List_Id := No_List; Has_Unknown_Discriminants : Boolean := False; Abstract_Present : Boolean := False; Tagged_Present : Boolean := False; Limited_Present : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Private_Type_Declaration, Sloc); begin Set_Defining_Identifier (N, Defining_Identifier); Set_Discriminant_Specifications (N, Discriminant_Specifications); Set_Has_Unknown_Discriminants (N, Has_Unknown_Discriminants); Set_Abstract_Present (N, Abstract_Present); Set_Tagged_Present (N, Tagged_Present); Set_Limited_Present (N, Limited_Present); return N; end Make_Private_Type_Declaration; function Make_Private_Extension_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Discriminant_Specifications : List_Id := No_List; Has_Unknown_Discriminants : Boolean := False; Abstract_Present : Boolean := False; Subtype_Indication : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Private_Extension_Declaration, Sloc); begin Set_Defining_Identifier (N, Defining_Identifier); Set_Discriminant_Specifications (N, Discriminant_Specifications); Set_Has_Unknown_Discriminants (N, Has_Unknown_Discriminants); Set_Abstract_Present (N, Abstract_Present); Set_Subtype_Indication (N, Subtype_Indication); return N; end Make_Private_Extension_Declaration; function Make_Use_Package_Clause (Sloc : Source_Ptr; Names : List_Id) return Node_Id is N : constant Node_Id := New_Node (N_Use_Package_Clause, Sloc); begin Set_Names (N, Names); return N; end Make_Use_Package_Clause; function Make_Use_Type_Clause (Sloc : Source_Ptr; Subtype_Marks : List_Id) return Node_Id is N : constant Node_Id := New_Node (N_Use_Type_Clause, Sloc); begin Set_Subtype_Marks (N, Subtype_Marks); return N; end Make_Use_Type_Clause; function Make_Object_Renaming_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Subtype_Mark : Node_Id; Name : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Object_Renaming_Declaration, Sloc); begin Set_Defining_Identifier (N, Defining_Identifier); Set_Subtype_Mark (N, Subtype_Mark); Set_Name (N, Name); return N; end Make_Object_Renaming_Declaration; function Make_Exception_Renaming_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Name : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Exception_Renaming_Declaration, Sloc); begin Set_Defining_Identifier (N, Defining_Identifier); Set_Name (N, Name); return N; end Make_Exception_Renaming_Declaration; function Make_Package_Renaming_Declaration (Sloc : Source_Ptr; Defining_Unit_Name : Node_Id; Name : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Package_Renaming_Declaration, Sloc); begin Set_Defining_Unit_Name (N, Defining_Unit_Name); Set_Name (N, Name); return N; end Make_Package_Renaming_Declaration; function Make_Subprogram_Renaming_Declaration (Sloc : Source_Ptr; Specification : Node_Id; Name : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Subprogram_Renaming_Declaration, Sloc); begin Set_Specification (N, Specification); Set_Name (N, Name); return N; end Make_Subprogram_Renaming_Declaration; function Make_Generic_Package_Renaming_Declaration (Sloc : Source_Ptr; Defining_Unit_Name : Node_Id; Name : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Generic_Package_Renaming_Declaration, Sloc); begin Set_Defining_Unit_Name (N, Defining_Unit_Name); Set_Name (N, Name); return N; end Make_Generic_Package_Renaming_Declaration; function Make_Generic_Procedure_Renaming_Declaration (Sloc : Source_Ptr; Defining_Unit_Name : Node_Id; Name : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Generic_Procedure_Renaming_Declaration, Sloc); begin Set_Defining_Unit_Name (N, Defining_Unit_Name); Set_Name (N, Name); return N; end Make_Generic_Procedure_Renaming_Declaration; function Make_Generic_Function_Renaming_Declaration (Sloc : Source_Ptr; Defining_Unit_Name : Node_Id; Name : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Generic_Function_Renaming_Declaration, Sloc); begin Set_Defining_Unit_Name (N, Defining_Unit_Name); Set_Name (N, Name); return N; end Make_Generic_Function_Renaming_Declaration; function Make_Task_Type_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Discriminant_Specifications : List_Id := No_List; Task_Definition : Node_Id := Empty) return Node_Id is N : constant Node_Id := New_Node (N_Task_Type_Declaration, Sloc); begin Set_Defining_Identifier (N, Defining_Identifier); Set_Discriminant_Specifications (N, Discriminant_Specifications); Set_Task_Definition (N, Task_Definition); return N; end Make_Task_Type_Declaration; function Make_Single_Task_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Discriminant_Specifications : List_Id := No_List; Task_Definition : Node_Id := Empty) return Node_Id is N : constant Node_Id := New_Node (N_Single_Task_Declaration, Sloc); begin Set_Defining_Identifier (N, Defining_Identifier); Set_Discriminant_Specifications (N, Discriminant_Specifications); Set_Task_Definition (N, Task_Definition); return N; end Make_Single_Task_Declaration; function Make_Task_Definition (Sloc : Source_Ptr; Visible_Declarations : List_Id; Private_Declarations : List_Id := No_List) return Node_Id is N : constant Node_Id := New_Node (N_Task_Definition, Sloc); begin Set_Visible_Declarations (N, Visible_Declarations); Set_Private_Declarations (N, Private_Declarations); return N; end Make_Task_Definition; function Make_Task_Body (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Declarations : List_Id; Handled_Statement_Sequence : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Task_Body, Sloc); begin Set_Defining_Identifier (N, Defining_Identifier); Set_Declarations (N, Declarations); Set_Handled_Statement_Sequence (N, Handled_Statement_Sequence); return N; end Make_Task_Body; function Make_Protected_Type_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Discriminant_Specifications : List_Id := No_List; Protected_Definition : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Protected_Type_Declaration, Sloc); begin Set_Defining_Identifier (N, Defining_Identifier); Set_Discriminant_Specifications (N, Discriminant_Specifications); Set_Protected_Definition (N, Protected_Definition); return N; end Make_Protected_Type_Declaration; function Make_Single_Protected_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Discriminant_Specifications : List_Id := No_List; Protected_Definition : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Single_Protected_Declaration, Sloc); begin Set_Defining_Identifier (N, Defining_Identifier); Set_Discriminant_Specifications (N, Discriminant_Specifications); Set_Protected_Definition (N, Protected_Definition); return N; end Make_Single_Protected_Declaration; function Make_Protected_Definition (Sloc : Source_Ptr; Visible_Declarations : List_Id; Private_Declarations : List_Id := No_List) return Node_Id is N : constant Node_Id := New_Node (N_Protected_Definition, Sloc); begin Set_Visible_Declarations (N, Visible_Declarations); Set_Private_Declarations (N, Private_Declarations); return N; end Make_Protected_Definition; function Make_Protected_Body (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Declarations : List_Id) return Node_Id is N : constant Node_Id := New_Node (N_Protected_Body, Sloc); begin Set_Defining_Identifier (N, Defining_Identifier); Set_Declarations (N, Declarations); return N; end Make_Protected_Body; function Make_Entry_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Discrete_Subtype_Definition : Node_Id := Empty; Parameter_Specifications : List_Id) return Node_Id is N : constant Node_Id := New_Node (N_Entry_Declaration, Sloc); begin Set_Defining_Identifier (N, Defining_Identifier); Set_Discrete_Subtype_Definition (N, Discrete_Subtype_Definition); Set_Parameter_Specifications (N, Parameter_Specifications); return N; end Make_Entry_Declaration; function Make_Accept_Statement (Sloc : Source_Ptr; Accept_Name : Node_Id; Entry_Index : Node_Id := Empty; Declarations : List_Id := No_List; Parameter_Specifications : List_Id := No_List; Handled_Statement_Sequence : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Accept_Statement, Sloc); begin Set_Accept_Name (N, Accept_Name); Set_Entry_Index (N, Entry_Index); Set_Declarations (N, Declarations); Set_Parameter_Specifications (N, Parameter_Specifications); Set_Handled_Statement_Sequence (N, Handled_Statement_Sequence); return N; end Make_Accept_Statement; function Make_Entry_Body (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Entry_Body_Formal_Part : Node_Id; Declarations : List_Id; Handled_Statement_Sequence : Node_Id; Condition : Node_Id) return Node_Id is N : constant Node_Id := Extend_Node (New_Node (N_Entry_Body, Sloc)); begin Set_Defining_Identifier (N, Defining_Identifier); Set_Entry_Body_Formal_Part (N, Entry_Body_Formal_Part); Set_Declarations (N, Declarations); Set_Handled_Statement_Sequence (N, Handled_Statement_Sequence); Set_Condition (N, Condition); return N; end Make_Entry_Body; function Make_Entry_Body_Formal_Part (Sloc : Source_Ptr; Entry_Index_Specification : Node_Id := Empty; Parameter_Specifications : List_Id := No_List) return Node_Id is N : constant Node_Id := Extend_Node (New_Node (N_Entry_Body_Formal_Part, Sloc)); begin Set_Entry_Index_Specification (N, Entry_Index_Specification); Set_Parameter_Specifications (N, Parameter_Specifications); return N; end Make_Entry_Body_Formal_Part; function Make_Entry_Index_Specification (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Discrete_Subtype_Definition : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Entry_Index_Specification, Sloc); begin Set_Defining_Identifier (N, Defining_Identifier); Set_Discrete_Subtype_Definition (N, Discrete_Subtype_Definition); return N; end Make_Entry_Index_Specification; function Make_Entry_Call_Statement (Sloc : Source_Ptr; Name : Node_Id; Parameter_Associations : List_Id := No_List) return Node_Id is N : constant Node_Id := New_Node (N_Entry_Call_Statement, Sloc); begin Set_Name (N, Name); Set_Parameter_Associations (N, Parameter_Associations); return N; end Make_Entry_Call_Statement; function Make_Requeue_Statement (Sloc : Source_Ptr; Name : Node_Id; Abort_Present : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Requeue_Statement, Sloc); begin Set_Name (N, Name); Set_Abort_Present (N, Abort_Present); return N; end Make_Requeue_Statement; function Make_Delay_Until_Statement (Sloc : Source_Ptr; Expression : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Delay_Until_Statement, Sloc); begin Set_Expression (N, Expression); return N; end Make_Delay_Until_Statement; function Make_Delay_Relative_Statement (Sloc : Source_Ptr; Expression : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Delay_Relative_Statement, Sloc); begin Set_Expression (N, Expression); return N; end Make_Delay_Relative_Statement; function Make_Selective_Accept (Sloc : Source_Ptr; Selective_Accept_Alternatives : List_Id; Else_Statements : List_Id := No_List) return Node_Id is N : constant Node_Id := New_Node (N_Selective_Accept, Sloc); begin Set_Selective_Accept_Alternatives (N, Selective_Accept_Alternatives); Set_Else_Statements (N, Else_Statements); return N; end Make_Selective_Accept; function Make_Accept_Alternative (Sloc : Source_Ptr; Accept_Statement : Node_Id; Condition : Node_Id := Empty; Statements : List_Id := Empty_List) return Node_Id is N : constant Node_Id := New_Node (N_Accept_Alternative, Sloc); begin Set_Accept_Statement (N, Accept_Statement); Set_Condition (N, Condition); Set_Statements (N, Statements); return N; end Make_Accept_Alternative; function Make_Delay_Alternative (Sloc : Source_Ptr; Delay_Statement : Node_Id; Condition : Node_Id := Empty; Statements : List_Id := Empty_List) return Node_Id is N : constant Node_Id := New_Node (N_Delay_Alternative, Sloc); begin Set_Delay_Statement (N, Delay_Statement); Set_Condition (N, Condition); Set_Statements (N, Statements); return N; end Make_Delay_Alternative; function Make_Terminate_Alternative (Sloc : Source_Ptr; Condition : Node_Id := Empty) return Node_Id is N : constant Node_Id := New_Node (N_Terminate_Alternative, Sloc); begin Set_Condition (N, Condition); return N; end Make_Terminate_Alternative; function Make_Conditional_Entry_Call (Sloc : Source_Ptr; Entry_Call_Alternative : Node_Id; Else_Statements : List_Id) return Node_Id is N : constant Node_Id := New_Node (N_Conditional_Entry_Call, Sloc); begin Set_Entry_Call_Alternative (N, Entry_Call_Alternative); Set_Else_Statements (N, Else_Statements); return N; end Make_Conditional_Entry_Call; function Make_Entry_Call_Alternative (Sloc : Source_Ptr; Entry_Call_Statement : Node_Id; Statements : List_Id := Empty_List) return Node_Id is N : constant Node_Id := New_Node (N_Entry_Call_Alternative, Sloc); begin Set_Entry_Call_Statement (N, Entry_Call_Statement); Set_Statements (N, Statements); return N; end Make_Entry_Call_Alternative; function Make_Timed_Entry_Call (Sloc : Source_Ptr; Entry_Call_Alternative : Node_Id; Delay_Alternative : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Timed_Entry_Call, Sloc); begin Set_Entry_Call_Alternative (N, Entry_Call_Alternative); Set_Delay_Alternative (N, Delay_Alternative); return N; end Make_Timed_Entry_Call; function Make_Asynchronous_Select (Sloc : Source_Ptr; Triggering_Alternative : Node_Id; Abortable_Part : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Asynchronous_Select, Sloc); begin Set_Triggering_Alternative (N, Triggering_Alternative); Set_Abortable_Part (N, Abortable_Part); return N; end Make_Asynchronous_Select; function Make_Triggering_Alternative (Sloc : Source_Ptr; Triggering_Statement : Node_Id; Statements : List_Id := Empty_List) return Node_Id is N : constant Node_Id := New_Node (N_Triggering_Alternative, Sloc); begin Set_Triggering_Statement (N, Triggering_Statement); Set_Statements (N, Statements); return N; end Make_Triggering_Alternative; function Make_Abortable_Part (Sloc : Source_Ptr; Statements : List_Id) return Node_Id is N : constant Node_Id := New_Node (N_Abortable_Part, Sloc); begin Set_Statements (N, Statements); return N; end Make_Abortable_Part; function Make_Abort_Statement (Sloc : Source_Ptr; Names : List_Id) return Node_Id is N : constant Node_Id := New_Node (N_Abort_Statement, Sloc); begin Set_Names (N, Names); return N; end Make_Abort_Statement; function Make_Compilation_Unit (Sloc : Source_Ptr; Context_Items : List_Id; Private_Present : Boolean := False; Unit : Node_Id; Following_Pragmas : List_Id := No_List) return Node_Id is N : constant Node_Id := New_Node (N_Compilation_Unit, Sloc); begin Set_Context_Items (N, Context_Items); Set_Private_Present (N, Private_Present); Set_Unit (N, Unit); Set_Following_Pragmas (N, Following_Pragmas); return N; end Make_Compilation_Unit; function Make_With_Clause (Sloc : Source_Ptr; Name : Node_Id; First_Name : Boolean := True; Last_Name : Boolean := True) return Node_Id is N : constant Node_Id := New_Node (N_With_Clause, Sloc); begin Set_Name (N, Name); Set_First_Name (N, First_Name); Set_Last_Name (N, Last_Name); return N; end Make_With_Clause; function Make_Subprogram_Body_Stub (Sloc : Source_Ptr; Specification : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Subprogram_Body_Stub, Sloc); begin Set_Specification (N, Specification); return N; end Make_Subprogram_Body_Stub; function Make_Package_Body_Stub (Sloc : Source_Ptr; Defining_Identifier : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Package_Body_Stub, Sloc); begin Set_Defining_Identifier (N, Defining_Identifier); return N; end Make_Package_Body_Stub; function Make_Task_Body_Stub (Sloc : Source_Ptr; Defining_Identifier : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Task_Body_Stub, Sloc); begin Set_Defining_Identifier (N, Defining_Identifier); return N; end Make_Task_Body_Stub; function Make_Protected_Body_Stub (Sloc : Source_Ptr; Defining_Identifier : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Protected_Body_Stub, Sloc); begin Set_Defining_Identifier (N, Defining_Identifier); return N; end Make_Protected_Body_Stub; function Make_Subunit (Sloc : Source_Ptr; Name : Node_Id; Proper_Body : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Subunit, Sloc); begin Set_Name (N, Name); Set_Proper_Body (N, Proper_Body); return N; end Make_Subunit; function Make_Exception_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Exception_Declaration, Sloc); begin Set_Defining_Identifier (N, Defining_Identifier); return N; end Make_Exception_Declaration; function Make_Handled_Sequence_Of_Statements (Sloc : Source_Ptr; Statements : List_Id; Exception_Handlers : List_Id := No_List; Identifier : Node_Id := Empty) return Node_Id is N : constant Node_Id := New_Node (N_Handled_Sequence_Of_Statements, Sloc); begin Set_Statements (N, Statements); Set_Exception_Handlers (N, Exception_Handlers); Set_Identifier (N, Identifier); return N; end Make_Handled_Sequence_Of_Statements; function Make_Exception_Handler (Sloc : Source_Ptr; Choice_Parameter : Node_Id := Empty; Exception_Choices : List_Id; Statements : List_Id) return Node_Id is N : constant Node_Id := New_Node (N_Exception_Handler, Sloc); begin Set_Choice_Parameter (N, Choice_Parameter); Set_Exception_Choices (N, Exception_Choices); Set_Statements (N, Statements); return N; end Make_Exception_Handler; function Make_Raise_Statement (Sloc : Source_Ptr; Name : Node_Id := Empty) return Node_Id is N : constant Node_Id := New_Node (N_Raise_Statement, Sloc); begin Set_Name (N, Name); return N; end Make_Raise_Statement; function Make_Generic_Subprogram_Declaration (Sloc : Source_Ptr; Specification : Node_Id; Generic_Formal_Declarations : List_Id) return Node_Id is N : constant Node_Id := New_Node (N_Generic_Subprogram_Declaration, Sloc); begin Set_Specification (N, Specification); Set_Generic_Formal_Declarations (N, Generic_Formal_Declarations); return N; end Make_Generic_Subprogram_Declaration; function Make_Generic_Package_Declaration (Sloc : Source_Ptr; Specification : Node_Id; Generic_Formal_Declarations : List_Id) return Node_Id is N : constant Node_Id := New_Node (N_Generic_Package_Declaration, Sloc); begin Set_Specification (N, Specification); Set_Generic_Formal_Declarations (N, Generic_Formal_Declarations); return N; end Make_Generic_Package_Declaration; function Make_Package_Instantiation (Sloc : Source_Ptr; Defining_Unit_Name : Node_Id; Name : Node_Id; Generic_Associations : List_Id := No_List) return Node_Id is N : constant Node_Id := New_Node (N_Package_Instantiation, Sloc); begin Set_Defining_Unit_Name (N, Defining_Unit_Name); Set_Name (N, Name); Set_Generic_Associations (N, Generic_Associations); return N; end Make_Package_Instantiation; function Make_Procedure_Instantiation (Sloc : Source_Ptr; Defining_Unit_Name : Node_Id; Name : Node_Id; Generic_Associations : List_Id := No_List) return Node_Id is N : constant Node_Id := New_Node (N_Procedure_Instantiation, Sloc); begin Set_Defining_Unit_Name (N, Defining_Unit_Name); Set_Name (N, Name); Set_Generic_Associations (N, Generic_Associations); return N; end Make_Procedure_Instantiation; function Make_Function_Instantiation (Sloc : Source_Ptr; Defining_Unit_Name : Node_Id; Name : Node_Id; Generic_Associations : List_Id := No_List) return Node_Id is N : constant Node_Id := New_Node (N_Function_Instantiation, Sloc); begin Set_Defining_Unit_Name (N, Defining_Unit_Name); Set_Name (N, Name); Set_Generic_Associations (N, Generic_Associations); return N; end Make_Function_Instantiation; function Make_Generic_Association (Sloc : Source_Ptr; Selector_Name : Node_Id := Empty; Explicit_Generic_Actual_Parameter : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Generic_Association, Sloc); begin Set_Selector_Name (N, Selector_Name); Set_Explicit_Generic_Actual_Parameter (N, Explicit_Generic_Actual_Parameter); return N; end Make_Generic_Association; function Make_Formal_Object_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; In_Present : Boolean := False; Out_Present : Boolean := False; Subtype_Mark : Node_Id; Expression : Node_Id := Empty) return Node_Id is N : constant Node_Id := New_Node (N_Formal_Object_Declaration, Sloc); begin Set_Defining_Identifier (N, Defining_Identifier); Set_In_Present (N, In_Present); Set_Out_Present (N, Out_Present); Set_Subtype_Mark (N, Subtype_Mark); Set_Expression (N, Expression); return N; end Make_Formal_Object_Declaration; function Make_Formal_Type_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Formal_Type_Definition : Node_Id; Discriminant_Specifications : List_Id := No_List; Has_Unknown_Discriminants : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Formal_Type_Declaration, Sloc); begin Set_Defining_Identifier (N, Defining_Identifier); Set_Formal_Type_Definition (N, Formal_Type_Definition); Set_Discriminant_Specifications (N, Discriminant_Specifications); Set_Has_Unknown_Discriminants (N, Has_Unknown_Discriminants); return N; end Make_Formal_Type_Declaration; function Make_Formal_Private_Type_Definition (Sloc : Source_Ptr; Abstract_Present : Boolean := False; Tagged_Present : Boolean := False; Limited_Present : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Formal_Private_Type_Definition, Sloc); begin Set_Abstract_Present (N, Abstract_Present); Set_Tagged_Present (N, Tagged_Present); Set_Limited_Present (N, Limited_Present); return N; end Make_Formal_Private_Type_Definition; function Make_Formal_Derived_Type_Definition (Sloc : Source_Ptr; Subtype_Mark : Node_Id; Private_Present : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Formal_Derived_Type_Definition, Sloc); begin Set_Subtype_Mark (N, Subtype_Mark); Set_Private_Present (N, Private_Present); return N; end Make_Formal_Derived_Type_Definition; function Make_Formal_Discrete_Type_Definition (Sloc : Source_Ptr) return Node_Id is N : constant Node_Id := New_Node (N_Formal_Discrete_Type_Definition, Sloc); begin return N; end Make_Formal_Discrete_Type_Definition; function Make_Formal_Signed_Integer_Type_Definition (Sloc : Source_Ptr) return Node_Id is N : constant Node_Id := New_Node (N_Formal_Signed_Integer_Type_Definition, Sloc); begin return N; end Make_Formal_Signed_Integer_Type_Definition; function Make_Formal_Modular_Type_Definition (Sloc : Source_Ptr) return Node_Id is N : constant Node_Id := New_Node (N_Formal_Modular_Type_Definition, Sloc); begin return N; end Make_Formal_Modular_Type_Definition; function Make_Formal_Floating_Point_Definition (Sloc : Source_Ptr) return Node_Id is N : constant Node_Id := New_Node (N_Formal_Floating_Point_Definition, Sloc); begin return N; end Make_Formal_Floating_Point_Definition; function Make_Formal_Ordinary_Fixed_Point_Definition (Sloc : Source_Ptr) return Node_Id is N : constant Node_Id := New_Node (N_Formal_Ordinary_Fixed_Point_Definition, Sloc); begin return N; end Make_Formal_Ordinary_Fixed_Point_Definition; function Make_Formal_Decimal_Fixed_Point_Definition (Sloc : Source_Ptr) return Node_Id is N : constant Node_Id := New_Node (N_Formal_Decimal_Fixed_Point_Definition, Sloc); begin return N; end Make_Formal_Decimal_Fixed_Point_Definition; function Make_Formal_Subprogram_Declaration (Sloc : Source_Ptr; Specification : Node_Id; Default_Name : Node_Id := Empty; Box_Present : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Formal_Subprogram_Declaration, Sloc); begin Set_Specification (N, Specification); Set_Default_Name (N, Default_Name); Set_Box_Present (N, Box_Present); return N; end Make_Formal_Subprogram_Declaration; function Make_Formal_Package_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Name : Node_Id; Generic_Associations : List_Id := No_List; Box_Present : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Formal_Package_Declaration, Sloc); begin Set_Defining_Identifier (N, Defining_Identifier); Set_Name (N, Name); Set_Generic_Associations (N, Generic_Associations); Set_Box_Present (N, Box_Present); return N; end Make_Formal_Package_Declaration; function Make_Attribute_Definition_Clause (Sloc : Source_Ptr; Name : Node_Id; Identifier : Node_Id; Expression : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Attribute_Definition_Clause, Sloc); begin Set_Name (N, Name); Set_Identifier (N, Identifier); Set_Expression (N, Expression); return N; end Make_Attribute_Definition_Clause; function Make_Enumeration_Representation_Clause (Sloc : Source_Ptr; Identifier : Node_Id; Array_Aggregate : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Enumeration_Representation_Clause, Sloc); begin Set_Identifier (N, Identifier); Set_Array_Aggregate (N, Array_Aggregate); return N; end Make_Enumeration_Representation_Clause; function Make_Record_Representation_Clause (Sloc : Source_Ptr; Identifier : Node_Id; Mod_Clause : Node_Id := Empty; Component_Clauses : List_Id) return Node_Id is N : constant Node_Id := New_Node (N_Record_Representation_Clause, Sloc); begin Set_Identifier (N, Identifier); Set_Mod_Clause (N, Mod_Clause); Set_Component_Clauses (N, Component_Clauses); return N; end Make_Record_Representation_Clause; function Make_Mod_Clause (Sloc : Source_Ptr; Expression : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Mod_Clause, Sloc); begin Set_Expression (N, Expression); return N; end Make_Mod_Clause; function Make_Component_Clause (Sloc : Source_Ptr; Component_Name : Node_Id; Position : Node_Id; First_Bit : Node_Id; Last_Bit : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Component_Clause, Sloc); begin Set_Component_Name (N, Component_Name); Set_Position (N, Position); Set_First_Bit (N, First_Bit); Set_Last_Bit (N, Last_Bit); return N; end Make_Component_Clause; function Make_At_Clause (Sloc : Source_Ptr; Identifier : Node_Id; Expression : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_At_Clause, Sloc); begin Set_Identifier (N, Identifier); Set_Expression (N, Expression); return N; end Make_At_Clause; function Make_Code_Statement (Sloc : Source_Ptr; Expression : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Code_Statement, Sloc); begin Set_Expression (N, Expression); return N; end Make_Code_Statement; function Make_Concat_Multiple (Sloc : Source_Ptr; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Concat_Multiple, Sloc); begin Set_Parens (N, Parens); return N; end Make_Concat_Multiple; function Make_Expanded_Name (Sloc : Source_Ptr; Chars : Name_Id; Prefix : Node_Id; Selector_Name : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Expanded_Name, Sloc); begin Set_Chars (N, Chars); Set_Prefix (N, Prefix); Set_Selector_Name (N, Selector_Name); Set_Parens (N, Parens); return N; end Make_Expanded_Name; function Make_Expression_Actions (Sloc : Source_Ptr; Actions : List_Id; Expression : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Expression_Actions, Sloc); begin Set_Actions (N, Actions); Set_Expression (N, Expression); Set_Parens (N, Parens); return N; end Make_Expression_Actions; function Make_Freeze_Entity (Sloc : Source_Ptr) return Node_Id is N : constant Node_Id := New_Node (N_Freeze_Entity, Sloc); begin return N; end Make_Freeze_Entity; function Make_Implicit_Type (Sloc : Source_Ptr; Defining_Identifier : Node_Id) return Node_Id is N : constant Node_Id := New_Node (N_Implicit_Type, Sloc); begin Set_Defining_Identifier (N, Defining_Identifier); return N; end Make_Implicit_Type; function Make_Reference (Sloc : Source_Ptr; Expression : Node_Id; Parens : Boolean := False) return Node_Id is N : constant Node_Id := New_Node (N_Reference, Sloc); begin Set_Expression (N, Expression); Set_Parens (N, Parens); return N; end Make_Reference; end Nmake; Id is N : constant Node_Id := New_Node (N_Formal_Derived_Type_Definition, Sloc); begin Set_Subtype_Mark (N, Subtype_Mark); Set_Private_Present (N, Private_Present); return N; end Make_Formal_Derived_Type_Definition; function Make_Formal_Discrete_Type_Definition (Sloc : Sognat-1.67-src/src/nmake.ads 644 10015 7640 140664 5506244523 10757 ------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- N M A K E -- -- -- -- S p e c -- -- -- -- Generated by xnmake revision 1.11 using -- -- sinfo.ads revision 1.128 -- -- nmake.adt revision 1.2 -- -- -- -- Copyright (c) 1992,1993, NYU, All Rights Reserved -- -- -- -- 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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. GNAT is distributed in the hope that it will be useful, but -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANT- -- -- ABILITY 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 GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Sinfo; use Sinfo; with Snames; use Snames; with Types; use Types; package Nmake is -- This package contains a set of routines used to construct tree nodes -- using a functional style. There is one routine for each node type defined -- in Sinfo with the general interface: -- function Make_xxx (Sloc : Source_Ptr, -- Field_Name_1 : Field_Name_1_Type [:= default] -- Field_Name_2 : Field_Name_2_Type [:= default] -- ...) -- return Node_Id -- Only syntactic fields are included (i.e. fields marked as "-Sem" or "-Lib" -- in the Sinfo spec are excluded). -- Default values are provided only for flag fields (where the default is -- False), and for optional fields. An optional field is one where the -- comment line describing the field contains the string "(set to xxx if". -- For such fields, a default value of xxx is provided." -- Warning: since calls to Make_xxx routines are normal function calls, the -- arguments can be evaluated in any order. This means that at most one such -- argument can have side effects (e.g. be a call to a parse routine). function Make_Unused_At_Start (Sloc : Source_Ptr) return Node_Id; pragma Inline (Make_Unused_At_Start); function Make_Unused_At_End (Sloc : Source_Ptr) return Node_Id; pragma Inline (Make_Unused_At_End); function Make_Identifier (Sloc : Source_Ptr; Chars : Name_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Identifier); function Make_Integer_Literal (Sloc : Source_Ptr; Intval : Uint; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Integer_Literal); function Make_Real_Literal (Sloc : Source_Ptr; Numerator : Uint; Denominator : Uint; Decimal : Boolean := False; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Real_Literal); function Make_Character_Literal (Sloc : Source_Ptr; Chars : Name_Id; Char_Literal_Value : Char_Code; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Character_Literal); function Make_String_Literal (Sloc : Source_Ptr; Strval : String_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_String_Literal); function Make_Pragma (Sloc : Source_Ptr; Identifier : Node_Id; Pragma_Argument_Associations : List_Id := No_List) return Node_Id; pragma Inline (Make_Pragma); function Make_Pragma_Argument_Association (Sloc : Source_Ptr; Identifier : Node_Id := Empty; Expression : Node_Id) return Node_Id; pragma Inline (Make_Pragma_Argument_Association); function Make_Defining_Identifier (Sloc : Source_Ptr; Chars : Name_Id) return Node_Id; pragma Inline (Make_Defining_Identifier); function Make_Full_Type_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Discriminant_Specifications : List_Id := No_List; Type_Definition : Node_Id) return Node_Id; pragma Inline (Make_Full_Type_Declaration); function Make_Subtype_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Subtype_Indication : Node_Id) return Node_Id; pragma Inline (Make_Subtype_Declaration); function Make_Subtype_Indication (Sloc : Source_Ptr; Subtype_Mark : Node_Id; Constraint : Node_Id) return Node_Id; pragma Inline (Make_Subtype_Indication); function Make_Object_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Aliased_Present : Boolean := False; Constant_Present : Boolean := False; Object_Definition : Node_Id; Expression : Node_Id := Empty) return Node_Id; pragma Inline (Make_Object_Declaration); function Make_Number_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Expression : Node_Id) return Node_Id; pragma Inline (Make_Number_Declaration); function Make_Derived_Type_Definition (Sloc : Source_Ptr; Abstract_Present : Boolean := False; Subtype_Indication : Node_Id; Record_Extension_Part : Node_Id := Empty) return Node_Id; pragma Inline (Make_Derived_Type_Definition); function Make_Range_Constraint (Sloc : Source_Ptr; Range_Expression : Node_Id) return Node_Id; pragma Inline (Make_Range_Constraint); function Make_Range (Sloc : Source_Ptr; Low_Bound : Node_Id; High_Bound : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Range); function Make_Enumeration_Type_Definition (Sloc : Source_Ptr; Literals : List_Id) return Node_Id; pragma Inline (Make_Enumeration_Type_Definition); function Make_Defining_Character_Literal (Sloc : Source_Ptr; Chars : Name_Id) return Node_Id; pragma Inline (Make_Defining_Character_Literal); function Make_Signed_Integer_Type_Definition (Sloc : Source_Ptr; Low_Bound : Node_Id; High_Bound : Node_Id) return Node_Id; pragma Inline (Make_Signed_Integer_Type_Definition); function Make_Modular_Type_Definition (Sloc : Source_Ptr; Expression : Node_Id) return Node_Id; pragma Inline (Make_Modular_Type_Definition); function Make_Floating_Point_Definition (Sloc : Source_Ptr; Digits_Expression : Node_Id; Real_Range_Specification : Node_Id := Empty) return Node_Id; pragma Inline (Make_Floating_Point_Definition); function Make_Real_Range_Specification (Sloc : Source_Ptr; Low_Bound : Node_Id; High_Bound : Node_Id) return Node_Id; pragma Inline (Make_Real_Range_Specification); function Make_Ordinary_Fixed_Point_Definition (Sloc : Source_Ptr; Delta_Expression : Node_Id; Real_Range_Specification : Node_Id) return Node_Id; pragma Inline (Make_Ordinary_Fixed_Point_Definition); function Make_Decimal_Fixed_Point_Definition (Sloc : Source_Ptr; Delta_Expression : Node_Id; Digits_Expression : Node_Id; Real_Range_Specification : Node_Id := Empty) return Node_Id; pragma Inline (Make_Decimal_Fixed_Point_Definition); function Make_Digits_Constraint (Sloc : Source_Ptr; Digits_Expression : Node_Id; Range_Constraint : Node_Id := Empty) return Node_Id; pragma Inline (Make_Digits_Constraint); function Make_Delta_Constraint (Sloc : Source_Ptr; Delta_Expression : Node_Id; Range_Constraint : Node_Id := Empty) return Node_Id; pragma Inline (Make_Delta_Constraint); function Make_Unconstrained_Array_Definition (Sloc : Source_Ptr; Subtype_Marks : List_Id; Aliased_Present : Boolean := False; Subtype_Indication : Node_Id) return Node_Id; pragma Inline (Make_Unconstrained_Array_Definition); function Make_Constrained_Array_Definition (Sloc : Source_Ptr; Discrete_Subtype_Definitions : List_Id; Aliased_Present : Boolean := False; Subtype_Indication : Node_Id) return Node_Id; pragma Inline (Make_Constrained_Array_Definition); function Make_Discriminant_Specification (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Discriminant_Type : Node_Id; Expression : Node_Id := Empty) return Node_Id; pragma Inline (Make_Discriminant_Specification); function Make_Index_Or_Discriminant_Constraint (Sloc : Source_Ptr; Constraints : List_Id) return Node_Id; pragma Inline (Make_Index_Or_Discriminant_Constraint); function Make_Discriminant_Association (Sloc : Source_Ptr; Selector_Names : List_Id; Expression : Node_Id) return Node_Id; pragma Inline (Make_Discriminant_Association); function Make_Record_Definition (Sloc : Source_Ptr; Abstract_Present : Boolean := False; Tagged_Present : Boolean := False; Limited_Present : Boolean := False; Component_List : Node_Id; Null_Present : Boolean := False) return Node_Id; pragma Inline (Make_Record_Definition); function Make_Component_List (Sloc : Source_Ptr; Component_Declarations : List_Id; Variant_Part : Node_Id := Empty; Null_Present : Boolean := False) return Node_Id; pragma Inline (Make_Component_List); function Make_Component_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Aliased_Present : Boolean := False; Subtype_Indication : Node_Id; Expression : Node_Id := Empty) return Node_Id; pragma Inline (Make_Component_Declaration); function Make_Variant_Part (Sloc : Source_Ptr; Name : Node_Id; Variants : List_Id) return Node_Id; pragma Inline (Make_Variant_Part); function Make_Variant (Sloc : Source_Ptr; Discrete_Choices : List_Id; Component_List : Node_Id) return Node_Id; pragma Inline (Make_Variant); function Make_Others_Choice (Sloc : Source_Ptr) return Node_Id; pragma Inline (Make_Others_Choice); function Make_Access_To_Object_Definition (Sloc : Source_Ptr; All_Present : Boolean := False; Subtype_Indication : Node_Id; Constant_Present : Boolean := False) return Node_Id; pragma Inline (Make_Access_To_Object_Definition); function Make_Access_Function_Definition (Sloc : Source_Ptr; Protected_Present : Boolean := False; Parameter_Specifications : List_Id := No_List; Subtype_Mark : Node_Id) return Node_Id; pragma Inline (Make_Access_Function_Definition); function Make_Access_Procedure_Definition (Sloc : Source_Ptr; Protected_Present : Boolean := False; Parameter_Specifications : List_Id := No_List) return Node_Id; pragma Inline (Make_Access_Procedure_Definition); function Make_Access_Definition (Sloc : Source_Ptr; Subtype_Mark : Node_Id) return Node_Id; pragma Inline (Make_Access_Definition); function Make_Incomplete_Type_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Discriminant_Specifications : List_Id := No_List; Has_Unknown_Discriminants : Boolean := False) return Node_Id; pragma Inline (Make_Incomplete_Type_Declaration); function Make_Explicit_Dereference (Sloc : Source_Ptr; Prefix : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Explicit_Dereference); function Make_Indexed_Component (Sloc : Source_Ptr; Prefix : Node_Id; Expressions : List_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Indexed_Component); function Make_Slice (Sloc : Source_Ptr; Prefix : Node_Id; Discrete_Range : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Slice); function Make_Selected_Component (Sloc : Source_Ptr; Prefix : Node_Id; Selector_Name : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Selected_Component); function Make_Attribute_Reference (Sloc : Source_Ptr; Prefix : Node_Id; Identifier : Node_Id; Expression : Node_Id := Empty; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Attribute_Reference); function Make_Aggregate (Sloc : Source_Ptr; Expressions : List_Id; Component_Associations : List_Id := No_List; Null_Record_Present : Boolean := False; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Aggregate); function Make_Component_Association (Sloc : Source_Ptr; Choices : List_Id; Expression : Node_Id) return Node_Id; pragma Inline (Make_Component_Association); function Make_Extension_Aggregate (Sloc : Source_Ptr; Expression : Node_Id; Component_Associations : List_Id := No_List; Null_Record_Present : Boolean := False; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Extension_Aggregate); function Make_Null (Sloc : Source_Ptr; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Null); function Make_Parenthesized_Expression (Sloc : Source_Ptr; Expression : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Parenthesized_Expression); function Make_Op_And (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Op_And); function Make_Op_And_Then (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Op_And_Then); function Make_Op_Or (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Op_Or); function Make_Op_Or_Else (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Op_Or_Else); function Make_Op_Xor (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Op_Xor); function Make_Op_In (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Op_In); function Make_Op_Not_In (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Op_Not_In); function Make_Op_Eq (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Op_Eq); function Make_Op_Ne (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Op_Ne); function Make_Op_Lt (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Op_Lt); function Make_Op_Le (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Op_Le); function Make_Op_Gt (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Op_Gt); function Make_Op_Ge (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Op_Ge); function Make_Op_Add (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Op_Add); function Make_Op_Subtract (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Op_Subtract); function Make_Op_Concat (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Op_Concat); function Make_Op_Multiply (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Op_Multiply); function Make_Op_Divide (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Op_Divide); function Make_Op_Mod (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Op_Mod); function Make_Op_Rem (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Op_Rem); function Make_Op_Expon (Sloc : Source_Ptr; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Op_Expon); function Make_Op_Plus (Sloc : Source_Ptr; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Op_Plus); function Make_Op_Minus (Sloc : Source_Ptr; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Op_Minus); function Make_Op_Abs (Sloc : Source_Ptr; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Op_Abs); function Make_Op_Not (Sloc : Source_Ptr; Right_Opnd : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Op_Not); function Make_Type_Conversion (Sloc : Source_Ptr; Subtype_Mark : Node_Id; Expression : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Type_Conversion); function Make_Qualified_Expression (Sloc : Source_Ptr; Subtype_Mark : Node_Id; Expression : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Qualified_Expression); function Make_Allocator (Sloc : Source_Ptr; Expression : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Allocator); function Make_Label (Sloc : Source_Ptr; Identifier : Node_Id) return Node_Id; pragma Inline (Make_Label); function Make_Implicit_Label_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Label : Node_Id) return Node_Id; pragma Inline (Make_Implicit_Label_Declaration); function Make_Null_Statement (Sloc : Source_Ptr) return Node_Id; pragma Inline (Make_Null_Statement); function Make_Assignment_Statement (Sloc : Source_Ptr; Name : Node_Id; Expression : Node_Id) return Node_Id; pragma Inline (Make_Assignment_Statement); function Make_If_Statement (Sloc : Source_Ptr; Condition : Node_Id; Then_Statements : List_Id; Elsif_Parts : List_Id := No_List; Else_Statements : List_Id := No_List) return Node_Id; pragma Inline (Make_If_Statement); function Make_Elsif_Part (Sloc : Source_Ptr; Condition : Node_Id; Then_Statements : List_Id) return Node_Id; pragma Inline (Make_Elsif_Part); function Make_Case_Statement (Sloc : Source_Ptr; Expression : Node_Id; Alternatives : List_Id) return Node_Id; pragma Inline (Make_Case_Statement); function Make_Case_Statement_Alternative (Sloc : Source_Ptr; Discrete_Choices : List_Id; Statements : List_Id) return Node_Id; pragma Inline (Make_Case_Statement_Alternative); function Make_Loop_Statement (Sloc : Source_Ptr; Identifier : Node_Id; Iteration_Scheme : Node_Id := Empty; Statements : List_Id; Has_Created_Identifier : Boolean := False) return Node_Id; pragma Inline (Make_Loop_Statement); function Make_Iteration_Scheme (Sloc : Source_Ptr; Condition : Node_Id := Empty; Loop_Parameter_Specification : Node_Id := Empty) return Node_Id; pragma Inline (Make_Iteration_Scheme); function Make_Loop_Parameter_Specification (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Reverse_Present : Boolean := False; Discrete_Subtype_Definition : Node_Id) return Node_Id; pragma Inline (Make_Loop_Parameter_Specification); function Make_Block_Statement (Sloc : Source_Ptr; Identifier : Node_Id; Declarations : List_Id := No_List; Handled_Statement_Sequence : Node_Id; Has_Created_Identifier : Boolean := False) return Node_Id; pragma Inline (Make_Block_Statement); function Make_Exit_Statement (Sloc : Source_Ptr; Name : Node_Id := Empty; Condition : Node_Id := Empty) return Node_Id; pragma Inline (Make_Exit_Statement); function Make_Goto_Statement (Sloc : Source_Ptr; Name : Node_Id) return Node_Id; pragma Inline (Make_Goto_Statement); function Make_Subprogram_Declaration (Sloc : Source_Ptr; Specification : Node_Id) return Node_Id; pragma Inline (Make_Subprogram_Declaration); function Make_Abstract_Subprogram_Declaration (Sloc : Source_Ptr; Specification : Node_Id) return Node_Id; pragma Inline (Make_Abstract_Subprogram_Declaration); function Make_Function_Specification (Sloc : Source_Ptr; Defining_Unit_Name : Node_Id; Parameter_Specifications : List_Id := No_List; Subtype_Mark : Node_Id) return Node_Id; pragma Inline (Make_Function_Specification); function Make_Procedure_Specification (Sloc : Source_Ptr; Defining_Unit_Name : Node_Id; Parameter_Specifications : List_Id := No_List) return Node_Id; pragma Inline (Make_Procedure_Specification); function Make_Designator (Sloc : Source_Ptr; Name : Node_Id; Identifier : Node_Id) return Node_Id; pragma Inline (Make_Designator); function Make_Defining_Program_Unit_Name (Sloc : Source_Ptr; Name : Node_Id; Defining_Identifier : Node_Id) return Node_Id; pragma Inline (Make_Defining_Program_Unit_Name); function Make_Operator_Symbol (Sloc : Source_Ptr; Chars : Name_Id; Strval : String_Id) return Node_Id; pragma Inline (Make_Operator_Symbol); function Make_Defining_Operator_Symbol (Sloc : Source_Ptr; Chars : Name_Id) return Node_Id; pragma Inline (Make_Defining_Operator_Symbol); function Make_Parameter_Specification (Sloc : Source_Ptr; Defining_Identifier : Node_Id; In_Present : Boolean := False; Out_Present : Boolean := False; Parameter_Type : Node_Id; Expression : Node_Id := Empty) return Node_Id; pragma Inline (Make_Parameter_Specification); function Make_Subprogram_Body (Sloc : Source_Ptr; Specification : Node_Id; Declarations : List_Id; Handled_Statement_Sequence : Node_Id; Bad_Is_Detected : Boolean := False) return Node_Id; pragma Inline (Make_Subprogram_Body); function Make_Procedure_Call_Statement (Sloc : Source_Ptr; Name : Node_Id; Parameter_Associations : List_Id := No_List; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Procedure_Call_Statement); function Make_Function_Call (Sloc : Source_Ptr; Name : Node_Id; Parameter_Associations : List_Id := No_List; Do_Elaboration_Check : Boolean := False; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Function_Call); function Make_Parameter_Association (Sloc : Source_Ptr; Selector_Name : Node_Id; Actual_Parameter : Node_Id) return Node_Id; pragma Inline (Make_Parameter_Association); function Make_Return_Statement (Sloc : Source_Ptr; Expression : Node_Id := Empty) return Node_Id; pragma Inline (Make_Return_Statement); function Make_Package_Declaration (Sloc : Source_Ptr; Specification : Node_Id) return Node_Id; pragma Inline (Make_Package_Declaration); function Make_Package_Specification (Sloc : Source_Ptr; Defining_Unit_Name : Node_Id; Visible_Declarations : List_Id; Private_Declarations : List_Id := No_List) return Node_Id; pragma Inline (Make_Package_Specification); function Make_Package_Body (Sloc : Source_Ptr; Defining_Unit_Name : Node_Id; Declarations : List_Id; Handled_Statement_Sequence : Node_Id := Empty) return Node_Id; pragma Inline (Make_Package_Body); function Make_Private_Type_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Discriminant_Specifications : List_Id := No_List; Has_Unknown_Discriminants : Boolean := False; Abstract_Present : Boolean := False; Tagged_Present : Boolean := False; Limited_Present : Boolean := False) return Node_Id; pragma Inline (Make_Private_Type_Declaration); function Make_Private_Extension_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Discriminant_Specifications : List_Id := No_List; Has_Unknown_Discriminants : Boolean := False; Abstract_Present : Boolean := False; Subtype_Indication : Node_Id) return Node_Id; pragma Inline (Make_Private_Extension_Declaration); function Make_Use_Package_Clause (Sloc : Source_Ptr; Names : List_Id) return Node_Id; pragma Inline (Make_Use_Package_Clause); function Make_Use_Type_Clause (Sloc : Source_Ptr; Subtype_Marks : List_Id) return Node_Id; pragma Inline (Make_Use_Type_Clause); function Make_Object_Renaming_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Subtype_Mark : Node_Id; Name : Node_Id) return Node_Id; pragma Inline (Make_Object_Renaming_Declaration); function Make_Exception_Renaming_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Name : Node_Id) return Node_Id; pragma Inline (Make_Exception_Renaming_Declaration); function Make_Package_Renaming_Declaration (Sloc : Source_Ptr; Defining_Unit_Name : Node_Id; Name : Node_Id) return Node_Id; pragma Inline (Make_Package_Renaming_Declaration); function Make_Subprogram_Renaming_Declaration (Sloc : Source_Ptr; Specification : Node_Id; Name : Node_Id) return Node_Id; pragma Inline (Make_Subprogram_Renaming_Declaration); function Make_Generic_Package_Renaming_Declaration (Sloc : Source_Ptr; Defining_Unit_Name : Node_Id; Name : Node_Id) return Node_Id; pragma Inline (Make_Generic_Package_Renaming_Declaration); function Make_Generic_Procedure_Renaming_Declaration (Sloc : Source_Ptr; Defining_Unit_Name : Node_Id; Name : Node_Id) return Node_Id; pragma Inline (Make_Generic_Procedure_Renaming_Declaration); function Make_Generic_Function_Renaming_Declaration (Sloc : Source_Ptr; Defining_Unit_Name : Node_Id; Name : Node_Id) return Node_Id; pragma Inline (Make_Generic_Function_Renaming_Declaration); function Make_Task_Type_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Discriminant_Specifications : List_Id := No_List; Task_Definition : Node_Id := Empty) return Node_Id; pragma Inline (Make_Task_Type_Declaration); function Make_Single_Task_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Discriminant_Specifications : List_Id := No_List; Task_Definition : Node_Id := Empty) return Node_Id; pragma Inline (Make_Single_Task_Declaration); function Make_Task_Definition (Sloc : Source_Ptr; Visible_Declarations : List_Id; Private_Declarations : List_Id := No_List) return Node_Id; pragma Inline (Make_Task_Definition); function Make_Task_Body (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Declarations : List_Id; Handled_Statement_Sequence : Node_Id) return Node_Id; pragma Inline (Make_Task_Body); function Make_Protected_Type_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Discriminant_Specifications : List_Id := No_List; Protected_Definition : Node_Id) return Node_Id; pragma Inline (Make_Protected_Type_Declaration); function Make_Single_Protected_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Discriminant_Specifications : List_Id := No_List; Protected_Definition : Node_Id) return Node_Id; pragma Inline (Make_Single_Protected_Declaration); function Make_Protected_Definition (Sloc : Source_Ptr; Visible_Declarations : List_Id; Private_Declarations : List_Id := No_List) return Node_Id; pragma Inline (Make_Protected_Definition); function Make_Protected_Body (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Declarations : List_Id) return Node_Id; pragma Inline (Make_Protected_Body); function Make_Entry_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Discrete_Subtype_Definition : Node_Id := Empty; Parameter_Specifications : List_Id) return Node_Id; pragma Inline (Make_Entry_Declaration); function Make_Accept_Statement (Sloc : Source_Ptr; Accept_Name : Node_Id; Entry_Index : Node_Id := Empty; Declarations : List_Id := No_List; Parameter_Specifications : List_Id := No_List; Handled_Statement_Sequence : Node_Id) return Node_Id; pragma Inline (Make_Accept_Statement); function Make_Entry_Body (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Entry_Body_Formal_Part : Node_Id; Declarations : List_Id; Handled_Statement_Sequence : Node_Id; Condition : Node_Id) return Node_Id; pragma Inline (Make_Entry_Body); function Make_Entry_Body_Formal_Part (Sloc : Source_Ptr; Entry_Index_Specification : Node_Id := Empty; Parameter_Specifications : List_Id := No_List) return Node_Id; pragma Inline (Make_Entry_Body_Formal_Part); function Make_Entry_Index_Specification (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Discrete_Subtype_Definition : Node_Id) return Node_Id; pragma Inline (Make_Entry_Index_Specification); function Make_Entry_Call_Statement (Sloc : Source_Ptr; Name : Node_Id; Parameter_Associations : List_Id := No_List) return Node_Id; pragma Inline (Make_Entry_Call_Statement); function Make_Requeue_Statement (Sloc : Source_Ptr; Name : Node_Id; Abort_Present : Boolean := False) return Node_Id; pragma Inline (Make_Requeue_Statement); function Make_Delay_Until_Statement (Sloc : Source_Ptr; Expression : Node_Id) return Node_Id; pragma Inline (Make_Delay_Until_Statement); function Make_Delay_Relative_Statement (Sloc : Source_Ptr; Expression : Node_Id) return Node_Id; pragma Inline (Make_Delay_Relative_Statement); function Make_Selective_Accept (Sloc : Source_Ptr; Selective_Accept_Alternatives : List_Id; Else_Statements : List_Id := No_List) return Node_Id; pragma Inline (Make_Selective_Accept); function Make_Accept_Alternative (Sloc : Source_Ptr; Accept_Statement : Node_Id; Condition : Node_Id := Empty; Statements : List_Id := Empty_List) return Node_Id; pragma Inline (Make_Accept_Alternative); function Make_Delay_Alternative (Sloc : Source_Ptr; Delay_Statement : Node_Id; Condition : Node_Id := Empty; Statements : List_Id := Empty_List) return Node_Id; pragma Inline (Make_Delay_Alternative); function Make_Terminate_Alternative (Sloc : Source_Ptr; Condition : Node_Id := Empty) return Node_Id; pragma Inline (Make_Terminate_Alternative); function Make_Conditional_Entry_Call (Sloc : Source_Ptr; Entry_Call_Alternative : Node_Id; Else_Statements : List_Id) return Node_Id; pragma Inline (Make_Conditional_Entry_Call); function Make_Entry_Call_Alternative (Sloc : Source_Ptr; Entry_Call_Statement : Node_Id; Statements : List_Id := Empty_List) return Node_Id; pragma Inline (Make_Entry_Call_Alternative); function Make_Timed_Entry_Call (Sloc : Source_Ptr; Entry_Call_Alternative : Node_Id; Delay_Alternative : Node_Id) return Node_Id; pragma Inline (Make_Timed_Entry_Call); function Make_Asynchronous_Select (Sloc : Source_Ptr; Triggering_Alternative : Node_Id; Abortable_Part : Node_Id) return Node_Id; pragma Inline (Make_Asynchronous_Select); function Make_Triggering_Alternative (Sloc : Source_Ptr; Triggering_Statement : Node_Id; Statements : List_Id := Empty_List) return Node_Id; pragma Inline (Make_Triggering_Alternative); function Make_Abortable_Part (Sloc : Source_Ptr; Statements : List_Id) return Node_Id; pragma Inline (Make_Abortable_Part); function Make_Abort_Statement (Sloc : Source_Ptr; Names : List_Id) return Node_Id; pragma Inline (Make_Abort_Statement); function Make_Compilation_Unit (Sloc : Source_Ptr; Context_Items : List_Id; Private_Present : Boolean := False; Unit : Node_Id; Following_Pragmas : List_Id := No_List) return Node_Id; pragma Inline (Make_Compilation_Unit); function Make_With_Clause (Sloc : Source_Ptr; Name : Node_Id; First_Name : Boolean := True; Last_Name : Boolean := True) return Node_Id; pragma Inline (Make_With_Clause); function Make_Subprogram_Body_Stub (Sloc : Source_Ptr; Specification : Node_Id) return Node_Id; pragma Inline (Make_Subprogram_Body_Stub); function Make_Package_Body_Stub (Sloc : Source_Ptr; Defining_Identifier : Node_Id) return Node_Id; pragma Inline (Make_Package_Body_Stub); function Make_Task_Body_Stub (Sloc : Source_Ptr; Defining_Identifier : Node_Id) return Node_Id; pragma Inline (Make_Task_Body_Stub); function Make_Protected_Body_Stub (Sloc : Source_Ptr; Defining_Identifier : Node_Id) return Node_Id; pragma Inline (Make_Protected_Body_Stub); function Make_Subunit (Sloc : Source_Ptr; Name : Node_Id; Proper_Body : Node_Id) return Node_Id; pragma Inline (Make_Subunit); function Make_Exception_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id) return Node_Id; pragma Inline (Make_Exception_Declaration); function Make_Handled_Sequence_Of_Statements (Sloc : Source_Ptr; Statements : List_Id; Exception_Handlers : List_Id := No_List; Identifier : Node_Id := Empty) return Node_Id; pragma Inline (Make_Handled_Sequence_Of_Statements); function Make_Exception_Handler (Sloc : Source_Ptr; Choice_Parameter : Node_Id := Empty; Exception_Choices : List_Id; Statements : List_Id) return Node_Id; pragma Inline (Make_Exception_Handler); function Make_Raise_Statement (Sloc : Source_Ptr; Name : Node_Id := Empty) return Node_Id; pragma Inline (Make_Raise_Statement); function Make_Generic_Subprogram_Declaration (Sloc : Source_Ptr; Specification : Node_Id; Generic_Formal_Declarations : List_Id) return Node_Id; pragma Inline (Make_Generic_Subprogram_Declaration); function Make_Generic_Package_Declaration (Sloc : Source_Ptr; Specification : Node_Id; Generic_Formal_Declarations : List_Id) return Node_Id; pragma Inline (Make_Generic_Package_Declaration); function Make_Package_Instantiation (Sloc : Source_Ptr; Defining_Unit_Name : Node_Id; Name : Node_Id; Generic_Associations : List_Id := No_List) return Node_Id; pragma Inline (Make_Package_Instantiation); function Make_Procedure_Instantiation (Sloc : Source_Ptr; Defining_Unit_Name : Node_Id; Name : Node_Id; Generic_Associations : List_Id := No_List) return Node_Id; pragma Inline (Make_Procedure_Instantiation); function Make_Function_Instantiation (Sloc : Source_Ptr; Defining_Unit_Name : Node_Id; Name : Node_Id; Generic_Associations : List_Id := No_List) return Node_Id; pragma Inline (Make_Function_Instantiation); function Make_Generic_Association (Sloc : Source_Ptr; Selector_Name : Node_Id := Empty; Explicit_Generic_Actual_Parameter : Node_Id) return Node_Id; pragma Inline (Make_Generic_Association); function Make_Formal_Object_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; In_Present : Boolean := False; Out_Present : Boolean := False; Subtype_Mark : Node_Id; Expression : Node_Id := Empty) return Node_Id; pragma Inline (Make_Formal_Object_Declaration); function Make_Formal_Type_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Formal_Type_Definition : Node_Id; Discriminant_Specifications : List_Id := No_List; Has_Unknown_Discriminants : Boolean := False) return Node_Id; pragma Inline (Make_Formal_Type_Declaration); function Make_Formal_Private_Type_Definition (Sloc : Source_Ptr; Abstract_Present : Boolean := False; Tagged_Present : Boolean := False; Limited_Present : Boolean := False) return Node_Id; pragma Inline (Make_Formal_Private_Type_Definition); function Make_Formal_Derived_Type_Definition (Sloc : Source_Ptr; Subtype_Mark : Node_Id; Private_Present : Boolean := False) return Node_Id; pragma Inline (Make_Formal_Derived_Type_Definition); function Make_Formal_Discrete_Type_Definition (Sloc : Source_Ptr) return Node_Id; pragma Inline (Make_Formal_Discrete_Type_Definition); function Make_Formal_Signed_Integer_Type_Definition (Sloc : Source_Ptr) return Node_Id; pragma Inline (Make_Formal_Signed_Integer_Type_Definition); function Make_Formal_Modular_Type_Definition (Sloc : Source_Ptr) return Node_Id; pragma Inline (Make_Formal_Modular_Type_Definition); function Make_Formal_Floating_Point_Definition (Sloc : Source_Ptr) return Node_Id; pragma Inline (Make_Formal_Floating_Point_Definition); function Make_Formal_Ordinary_Fixed_Point_Definition (Sloc : Source_Ptr) return Node_Id; pragma Inline (Make_Formal_Ordinary_Fixed_Point_Definition); function Make_Formal_Decimal_Fixed_Point_Definition (Sloc : Source_Ptr) return Node_Id; pragma Inline (Make_Formal_Decimal_Fixed_Point_Definition); function Make_Formal_Subprogram_Declaration (Sloc : Source_Ptr; Specification : Node_Id; Default_Name : Node_Id := Empty; Box_Present : Boolean := False) return Node_Id; pragma Inline (Make_Formal_Subprogram_Declaration); function Make_Formal_Package_Declaration (Sloc : Source_Ptr; Defining_Identifier : Node_Id; Name : Node_Id; Generic_Associations : List_Id := No_List; Box_Present : Boolean := False) return Node_Id; pragma Inline (Make_Formal_Package_Declaration); function Make_Attribute_Definition_Clause (Sloc : Source_Ptr; Name : Node_Id; Identifier : Node_Id; Expression : Node_Id) return Node_Id; pragma Inline (Make_Attribute_Definition_Clause); function Make_Enumeration_Representation_Clause (Sloc : Source_Ptr; Identifier : Node_Id; Array_Aggregate : Node_Id) return Node_Id; pragma Inline (Make_Enumeration_Representation_Clause); function Make_Record_Representation_Clause (Sloc : Source_Ptr; Identifier : Node_Id; Mod_Clause : Node_Id := Empty; Component_Clauses : List_Id) return Node_Id; pragma Inline (Make_Record_Representation_Clause); function Make_Mod_Clause (Sloc : Source_Ptr; Expression : Node_Id) return Node_Id; pragma Inline (Make_Mod_Clause); function Make_Component_Clause (Sloc : Source_Ptr; Component_Name : Node_Id; Position : Node_Id; First_Bit : Node_Id; Last_Bit : Node_Id) return Node_Id; pragma Inline (Make_Component_Clause); function Make_At_Clause (Sloc : Source_Ptr; Identifier : Node_Id; Expression : Node_Id) return Node_Id; pragma Inline (Make_At_Clause); function Make_Code_Statement (Sloc : Source_Ptr; Expression : Node_Id) return Node_Id; pragma Inline (Make_Code_Statement); function Make_Concat_Multiple (Sloc : Source_Ptr; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Concat_Multiple); function Make_Expanded_Name (Sloc : Source_Ptr; Chars : Name_Id; Prefix : Node_Id; Selector_Name : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Expanded_Name); function Make_Expression_Actions (Sloc : Source_Ptr; Actions : List_Id; Expression : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Expression_Actions); function Make_Freeze_Entity (Sloc : Source_Ptr) return Node_Id; pragma Inline (Make_Freeze_Entity); function Make_Implicit_Type (Sloc : Source_Ptr; Defining_Identifier : Node_Id) return Node_Id; pragma Inline (Make_Implicit_Type); function Make_Reference (Sloc : Source_Ptr; Expression : Node_Id; Parens : Boolean := False) return Node_Id; pragma Inline (Make_Reference); end Nmake; function Make_Exception_Declaration (Sloc : Source_Ptr; Defining_Identgnat-1.67-src/COPYING 644 10015 7640 43076 5506244524 7417 GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 675 Mass Ave, Cambridge, MA 02139, USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program 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 of the License, or (at your option) any later version. This program 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 this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19yy name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. he Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You mgnat-1.67-src/COPYING.LIB 644 10015 7640 61261 5506244525 10021 GNU LIBRARY GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1991 Free Software Foundation, Inc. 675 Mass Ave, Cambridge, MA 02139, USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the library GPL. It is numbered 2 because it goes with version 2 of the ordinary GPL.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Library General Public License, applies to some specially designated Free Software Foundation software, and to any other libraries whose authors decide to use it. You can use it for your libraries, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library, or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link a program with the library, you must provide complete object files to the recipients so that they can relink them with the library, after making changes to the library and recompiling it. And you must show them these terms so they know their rights. Our method of protecting your rights has two steps: (1) copyright the library, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the library. Also, for each distributor's protection, we want to make certain that everyone understands that there is no warranty for this free library. If the library is modified by someone else and passed on, we want its recipients to know that what they have is not the original version, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that companies distributing free software will individually obtain patent licenses, thus in effect transforming the program into proprietary software. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License, which was designed for utility programs. This license, the GNU Library General Public License, applies to certain designated libraries. This license is quite different from the ordinary one; be sure to read it in full, and don't assume that anything in it is the same as in the ordinary license. The reason we have a separate public license for some libraries is that they blur the distinction we usually make between modifying or adding to a program and simply using it. Linking a program with a library, without changing the library, is in some sense simply using the library, and is analogous to running a utility program or application program. However, in a textual and legal sense, the linked executable is a combined work, a derivative of the original library, and the ordinary General Public License treats it as such. Because of this blurred distinction, using the ordinary General Public License for libraries did not effectively promote software sharing, because most developers did not use the libraries. We concluded that weaker conditions might promote sharing better. However, unrestricted linking of non-free programs would deprive the users of those programs of all benefit from the free status of the libraries themselves. This Library General Public License is intended to permit developers of non-free programs to use free libraries, while preserving your freedom as a user of such programs to change the free libraries that are incorporated in them. (We have not seen how to achieve this as regards changes in header files, but we have achieved it as regards changes in the actual functions of the Library.) The hope is that this will lead to faster development of free libraries. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, while the latter only works together with the library. Note that it is possible for a library to be covered by the ordinary General Public License rather than by this special one. GNU LIBRARY GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Library General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also compile or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. c) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. d) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Library General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Libraries If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License). To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This library 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 Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Also add information on how to contact you by electronic and paper mail. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the library `Frob' (a library for tweaking knobs) written by James Random Hacker. , 1 April 1990 Ty Coon, President of Vice That's all there is to it! ned form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, partiyou must show them these terms so they know their rights. Our method of protecting your rights has two steps: (1) copyright the library, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the library. Also, for each distributor's protection, we want to make certain that everyone understands that there is no warranty for this free library. If the library is modified by someone else and passed on, we want its recipients to know that what they have is not the original version, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that companies distributing free software will individually obtain patent licenses, thus in effect transforming the program into proprietary software. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License, which was designed for utility programs. This license, the GNU Library General Public License, applies to certain designated libraries. This license is quite different from the ordinary one; be sure to read it in full, and don't assume that anything in it is the same as in the ordinary license. The reason we have a separate public license for some libraries is that they blur the distinction we usually make between modifying or adding to a program and simply using it. Linking a program with a library, without changing the library, is in some sense simply using the library, and is analogous to running a utility program or application program. However, in a textual and legal sense, the linked executable is a combined work, a derivative of the original library, and the ordinary General Public License treats it as such. Because of this blurred distinction, using the ordinary General Public License for libraries did not effectively promote software sharing, because most developers did not use the libraries. We concluded that weaker conditions might promote sharing better. However, unrestricted linking of non-free programs would deprive the users of those programs of all benefit from the free status of the libraries themselves. This Library General Public License is intended to permit developers of non-free programs to use free libraries, while preserving your freedom as a user of such programs to change the free libraries that are incorporated in them. (We have not seen how to achieve this as regards changes in header files, but we have achieved it as regards changes in the actual functions of the Library.) The hope is that this will lead to faster development of free libraries. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, while the latter only works together with the library. Note that it is possible for a library to be covered by the ordinary General Public License rather than by this special one. GNU LIBRARY GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Library General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty pr