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