1  with League.Strings.Hash;


2 


3  with Gela.Element_Visiters;


4  with Gela.Elements.Defining_Designators;


5  with Gela.Elements.Defining_Operator_Symbols;


6  with Gela.Elements.Function_Declarations;


7  with Gela.Lexical_Types;


8 


9  package body Gela.Plain_Value_Sets is


10 


11  


12   Concat 


13  


14 


15  overriding procedure Apply


16  (Self : in out Value_Set;


17  Name : Gela.Semantic_Types.Value_Index;


18  Args : Gela.Semantic_Types.Value_Index;


19  Value : out Gela.Semantic_Types.Value_Index)


20  is


21  use type League.Strings.Universal_String;


22  use type Gela.Semantic_Types.Value_Index;


23  Op : Gela.Semantic_Types.Static_Operator;


24  begin


25  Value := 0;


26 


27  if Args = 0 or Name = 0 then


28  return;


29  end if;


30 


31  declare


32  Item : constant Gela.Plain_Value_Sets.Value :=


33  Self.Vector.Element (Name);


34  begin


35  if Item.Kind = Denote_Function then


36  Op := Item.Op;


37  else


38  return;


39  end if;


40  end;


41 


42  declare


43  use type Gela.Arithmetic.Integers.Value;


44 


45  Item : constant Gela.Plain_Value_Sets.Value :=


46  Self.Vector.Element (Args);


47  Left : Gela.Plain_Value_Sets.Value;


48  Right : Gela.Plain_Value_Sets.Value;


49  begin


50  if Item.Kind /= List_Value then


51  Self.String_Literal


52  (League.Strings.To_Universal_String ("???"),


53  Value);


54  return;


55  end if;


56 


57  Left := Self.Vector.Element (Item.Head);


58  Right := Self.Vector.Element (Item.Tail);


59  case Op is


60  when Gela.Semantic_Types.Ampersand_Operator =>


61  if Left.Kind = String_Value and then


62  Right.Kind = String_Value


63  then


64  Self.String_Literal


65  (Left.String & Right.String,


66  Value);


67  end if;


68  when Gela.Semantic_Types.Hyphen_Operator =>


69  if Left.Kind = Integer_Value and then


70  Right.Kind = Integer_Value


71  then


72  Self.Put_Value


73  ((Integer_Value, Left.Integer  Right.Integer), Value);


74  end if;


75  when Gela.Semantic_Types.Plus_Operator =>


76  if Left.Kind = Integer_Value and then


77  Right.Kind = Integer_Value


78  then


79  Self.Put_Value


80  ((Integer_Value, Left.Integer + Right.Integer), Value);


81  end if;


82  when Gela.Semantic_Types.Star_Operator =>


83  if Left.Kind = Integer_Value and then


84  Right.Kind = Integer_Value


85  then


86  Self.Put_Value


87  ((Integer_Value, Left.Integer * Right.Integer), Value);


88  end if;


89  when Gela.Semantic_Types.Slash_Operator =>


90  if Left.Kind = Integer_Value and then


91  Right.Kind = Integer_Value and then


92  Right.Integer /= Gela.Arithmetic.Integers.Zero  FIXME


93  then


94  Self.Put_Value


95  ((Integer_Value, Left.Integer / Right.Integer), Value);


96  end if;


97  when Gela.Semantic_Types.Rem_Operator =>


98  if Left.Kind = Integer_Value and then


99  Right.Kind = Integer_Value and then


100  Right.Integer /= Gela.Arithmetic.Integers.Zero  FIXME


101  then


102  Self.Put_Value


103  ((Integer_Value, Left.Integer rem Right.Integer), Value);


104  end if;


105  when others =>


106  raise Constraint_Error with "unimplemeneted";


107  end case;


108  end;


109  end Apply;


110 


111  


112   List 


113  


114 


115  overriding procedure List


116  (Self : in out Value_Set;


117  Head : Gela.Semantic_Types.Value_Index;


118  Tail : Gela.Semantic_Types.Value_Index;


119  Value : out Gela.Semantic_Types.Value_Index)


120  is


121  use type Gela.Semantic_Types.Value_Index;


122  begin


123  if Tail = 0 then


124  Value := Head;


125  elsif Head = 0 then


126  Value := 0;


127  else


128  Self.Put_Value ((List_Value, Head, Tail), Value);


129  end if;


130  end List;


131 


132  


133   Name 


134  


135 


136  overriding procedure Name


137  (Self : in out Value_Set;


138  Name : Gela.Elements.Defining_Names.Defining_Name_Access;


139  Value : out Gela.Semantic_Types.Value_Index)


140  is


141 


142  package Get is


143  type Visiter is new Gela.Element_Visiters.Visiter with record


144  Result : Gela.Semantic_Types.Value_Index := 0;


145  end record;


146 


147  overriding procedure Defining_Operator_Symbol


148  (V : in out Visiter;


149  Node : not null Gela.Elements.Defining_Operator_Symbols.


150  Defining_Operator_Symbol_Access);


151 


152  overriding procedure Function_Declaration


153  (Self : in out Visiter;


154  Node : not null Gela.Elements.Function_Declarations.


155  Function_Declaration_Access);


156 


157  end Get;


158 


159  package body Get is


160 


161  overriding procedure Defining_Operator_Symbol


162  (V : in out Visiter;


163  Node : not null Gela.Elements.Defining_Operator_Symbols.


164  Defining_Operator_Symbol_Access)


165  is


166  use type Gela.Lexical_Types.Symbol;


167 


168  Symbol : constant Gela.Lexical_Types.Symbol := Node.Full_Name;


169  Op : constant Gela.Semantic_Types.Static_Operator :=


170  Gela.Semantic_Types.Static_Operator'Val (Symbol  1);


171  Item : constant Gela.Plain_Value_Sets.Value :=


172  (Denote_Function, Op);


173  begin


174  Put_Value (Self => Self,


175  Item => Item,


176  Value => V.Result);


177  end Defining_Operator_Symbol;


178 


179  overriding procedure Function_Declaration


180  (Self : in out Visiter;


181  Node : not null Gela.Elements.Function_Declarations.


182  Function_Declaration_Access)


183  is


184  Name : constant Gela.Elements.Defining_Designators.


185  Defining_Designator_Access := Node.Names;


186  begin


187  Name.Visit (Self);


188  end Function_Declaration;


189 


190  end Get;


191 


192  use type Gela.Elements.Element_Access;


193  use type Gela.Elements.Defining_Names.Defining_Name_Access;


194 


195  V : aliased Get.Visiter;


196  begin


197  if Name /= null and then Name.Enclosing_Element /= null then


198  Name.Enclosing_Element.Visit (V);


199  else


200   FIXME stub until name resolution ready


201  declare


202  Item : constant Gela.Plain_Value_Sets.Value :=


203  (Denote_Function, Gela.Semantic_Types.Ampersand_Operator);


204  begin


205  Put_Value (Self => Self,


206  Item => Item,


207  Value => V.Result);


208  end;


209  end if;


210 


211  Value := V.Result;


212  end Name;


213 


214  


215   Hash 


216  


217 


218  function Hash (X : Value) return Ada.Containers.Hash_Type is


219  use type Ada.Containers.Hash_Type;


220  begin


221  case X.Kind is


222  when Denote_Function =>


223  return Gela.Semantic_Types.Static_Operator'Pos (X.Op);


224  when Integer_Value =>


225  return Gela.Arithmetic.Integers.Hash (X.Integer);


226  when String_Value =>


227  return League.Strings.Hash (X.String);


228  when List_Value =>


229  return 65_213 * Ada.Containers.Hash_Type (X.Head) +


230  Ada.Containers.Hash_Type (X.Tail);


231  end case;


232  end Hash;


233 


234  


235   Image 


236  


237 


238  overriding function Image


239  (Self : Value_Set;


240  Value : Gela.Semantic_Types.Value_Index)


241  return League.Strings.Universal_String


242  is


243  Item : constant Gela.Plain_Value_Sets.Value :=


244  Self.Vector.Element (Value);


245  begin


246  case Item.Kind is


247  when String_Value =>


248  return Item.String;


249  when Integer_Value =>


250  return League.Strings.From_UTF_8_String


251  (Gela.Arithmetic.Integers.Image (Item.Integer));


252  when others =>


253  raise Constraint_Error;


254  end case;


255  end Image;


256 


257  


258   Is_String 


259  


260 


261  overriding function Is_String


262  (Self : Value_Set;


263  Value : Gela.Semantic_Types.Value_Index) return Boolean is


264  begin


265  return Self.Vector.Element (Value).Kind = String_Value;


266  end Is_String;


267 


268  


269   Numeric_Literal 


270  


271 


272  overriding procedure Numeric_Literal


273  (Self : in out Value_Set;


274  Image : League.Strings.Universal_String;


275  Value : out Gela.Semantic_Types.Value_Index)


276  is


277  X : constant Gela.Arithmetic.Integers.Value :=


278  Gela.Arithmetic.Integers.Literal (Image.To_UTF_8_String);


279  Item : constant Gela.Plain_Value_Sets.Value := (Integer_Value, X);


280  begin


281  Self.Put_Value (Item, Value);


282  end Numeric_Literal;


283 


284  


285   Put_Value 


286  


287 


288  not overriding procedure Put_Value


289  (Self : in out Value_Set;


290  Item : Value;


291  Value : out Gela.Semantic_Types.Value_Index)


292  is


293  Pos : constant Hash_Maps.Cursor := Self.Map.Find (Item);


294  begin


295  if Hash_Maps.Has_Element (Pos) then


296  Value := Hash_Maps.Element (Pos);


297  else


298  Self.Vector.Append (Item);


299  Value := Self.Vector.Last_Index;


300  Self.Map.Insert (Item, Value);


301  end if;


302  end Put_Value;


303 


304  


305   String_Literal 


306  


307 


308  overriding procedure String_Literal


309  (Self : in out Value_Set;


310  Image : League.Strings.Universal_String;


311  Value : out Gela.Semantic_Types.Value_Index)


312  is


313  Item : constant Gela.Plain_Value_Sets.Value := (String_Value, Image);


314  begin


315  Self.Put_Value (Item, Value);


316  end String_Literal;


317 


318 


319  end Gela.Plain_Value_Sets;

