1------------------------------------------------------------------------------ 2-- -- 3-- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- 4-- -- 5-- A 4 G . S T A N D -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1999-2015, Free Software Foundation, Inc. -- 10-- -- 11-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it -- 12-- under terms of the GNU General Public License as published by the Free -- 13-- Software Foundation; either version 3, or (at your option) any later -- 14-- version. ASIS-for-GNAT is distributed in the hope that it will be -- 15-- useful, but WITHOUT ANY WARRANTY; without even the implied warranty of -- 16-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- -- 19-- -- 20-- -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception distributed with GNAT; see -- 24-- the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- 28-- Software Engineering Laboratory of the Swiss Federal Institute of -- 29-- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- 30-- Scientific Research Computer Center of Moscow State University (SRCC -- 31-- MSU), Russia, with funding partially provided by grants from the Swiss -- 32-- National Science Foundation and the Swiss Academy of Engineering -- 33-- Sciences. ASIS-for-GNAT is now maintained by AdaCore -- 34-- (http://www.adacore.com). -- 35-- -- 36------------------------------------------------------------------------------ 37 38with Asis.Set_Get; use Asis.Set_Get; 39with A4G.A_Types; use A4G.A_Types; 40with A4G.Contt; use A4G.Contt; 41 42with Stand; use Stand; 43with Atree; use Atree; 44with Sinfo; use Sinfo; 45 46package body A4G.Stand is 47 48 -------------------------------- 49 -- Get_Numeric_Error_Renaming -- 50 -------------------------------- 51 52 function Get_Numeric_Error_Renaming return Asis.Element is 53 Result : Asis.Element := Numeric_Error_Template; 54 begin 55 Set_Encl_Tree (Result, Get_Current_Tree); 56 Set_Enclosing_Context (Result, Get_Current_Cont); 57 Set_Obtained (Result, A_OS_Time); 58 59 return Result; 60 end Get_Numeric_Error_Renaming; 61 62 --------------------------- 63 -- Is_Standard_Char_Type -- 64 --------------------------- 65 66 function Is_Standard_Char_Type (N : Node_Id) return Boolean is 67 Result : Boolean := False; 68 Type_Ent : Entity_Id; 69 begin 70 if Sloc (N) = Standard_Location and then 71 Nkind (N) = N_Enumeration_Type_Definition 72 then 73 Type_Ent := Defining_Identifier (Parent (N)); 74 75 if Type_Ent in Standard_Character .. Standard_Wide_Character then 76 Result := True; 77 end if; 78 79 end if; 80 81 return Result; 82 end Is_Standard_Char_Type; 83 84 ------------------------- 85 -- Standard_Char_Decls -- 86 ------------------------- 87 88 function Standard_Char_Decls 89 (Type_Definition : Asis.Type_Definition; 90 Implicit : Boolean := False) 91 return Asis.Element_List 92 is 93 Arg_Node : constant Node_Id := Node (Type_Definition); 94 Rel_Len : Asis.ASIS_Positive; 95 Type_Ent : Entity_Id; 96 Tmp_Template : Element := Char_Literal_Spec_Template; 97 begin 98 -- Adjusting the template for the artificial character literal 99 -- specification: 100 101 Set_Encl_Unit_Id (Tmp_Template, Encl_Unit_Id (Type_Definition)); 102 Set_Encl_Tree (Tmp_Template, Encl_Tree (Type_Definition)); 103 Set_Node (Tmp_Template, Arg_Node); 104 Set_R_Node (Tmp_Template, Arg_Node); 105 Set_Enclosing_Context (Tmp_Template, Encl_Cont_Id (Type_Definition)); 106 Set_Obtained (Tmp_Template, A_OS_Time); 107 Set_From_Instance (Tmp_Template, Is_From_Instance (Type_Definition)); 108 Set_From_Implicit (Tmp_Template, Implicit); 109 Set_From_Inherited (Tmp_Template, Implicit); 110 111 if Implicit then 112 Set_Node_Field_1 (Tmp_Template, Parent (Arg_Node)); 113 end if; 114 115 Type_Ent := Defining_Identifier (Parent (Arg_Node)); 116 117 while Type_Ent /= Etype (Type_Ent) loop 118 Type_Ent := Etype (Type_Ent); 119 end loop; 120 121 if Type_Ent = Standard_Character then 122 Rel_Len := 256; 123 else 124 Rel_Len := 65536; 125 end if; 126 127 declare 128 Result : Asis.Element_List (1 .. Rel_Len) := (others => Tmp_Template); 129 begin 130 131 for J in 1 .. Rel_Len loop 132 Set_Character_Code (Result (J), Char_Code (J - 1)); 133 end loop; 134 135 return Result; 136 137 end; 138 139 end Standard_Char_Decls; 140 141end A4G.Stand; 142