- end Register_Type;
-
- -- Unregister an Ada_Defined_Field_Type given by it's tag
- procedure Unregister_Type (T : in Ada_Defined_Field_Type'Class)
- is
- function Free_Fieldtype (Ft : C_Field_Type) return C_Int;
- pragma Import (C, Free_Fieldtype, "free_fieldtype");
-
- P : Tag_Pair_Access := External_Pair_Htable.Get (T'Tag);
- Ft : C_Field_Type;
- Res : C_Int;
- begin
- if P = null then
- raise Form_Exception;
- else
- Ft := P.Cft;
- External_Pair_Htable.Remove (T'Tag);
- Free_Tag_Type_Pair (P);
- Res := Free_Fieldtype (Ft);
- if Res /= E_Ok then
- Eti_Exception (Res);
- end if;
- end if;
- end Unregister_Type;
-
-----------------------------------------------------------------------------
- -- |
- -- |
- -- |
- procedure Set_Type (Fld : Field;
- Fld_Type : Ada_Defined_Field_Type)
- is
- function Set_Fld_Type (F : Field := Fld;
- Ct : C_Field_Type;
- Arg1 : Ada_Defined_Field_Type'Class)
- return C_Int;
- pragma Import (C, Set_Fld_Type, "set_field_type");
- function Field_Userptr (Fld : Field)
- return Field_User_Wrapper_Access;
- pragma Import (C, Field_Userptr, "field_userptr");
-
- Res : Eti_Error;
- C : constant C_Field_Type := Search_Type (Fld_Type);
- begin
- if C = Null_Field_Type then
- raise Form_Exception;
- else
- Res := Set_Fld_Type (Fld, C, Fld_Type);
- if Res /= E_Ok then
- Eti_Exception (Res);
- end if;
- end if;
- end Set_Type;
- -- |
- -- |
- -- |
- function Native_Type (Ftype : Ada_Defined_Field_Type)
- return C_Field_Type
- is
- C : constant C_Field_Type := Search_Type (Ftype);
- begin
- if C = Null_Field_Type then
- raise Form_Exception;
- else
- return C;
- end if;
- end Native_Type;
- -- |
- -- |
- -- |
- function Native_Type (Ftype : Alpha_Field)
- return C_Field_Type
- is
- C_Alpha_Field_Type : C_Field_Type;
- pragma Import (C, C_Alpha_Field_Type, "TYPE_ALPHA");
- begin
- return C_Alpha_Field_Type;
- end Native_Type;
- pragma Inline (Native_Type);
- -- |
- -- |
- -- |
- procedure Set_Type (Fld : in Field;
- Fld_Type : in Alpha_Field)
- is
- function Set_Fld_Type (F : Field := Fld;
- Cft : C_Field_Type := Native_Type (Fld_Type);
- Arg1 : C_Int) return C_Int;
- pragma Import (C, Set_Fld_Type, "set_field_type");
- function Field_Userptr (Fld : Field)
- return Field_User_Wrapper_Access;
- pragma Import (C, Field_Userptr, "field_userptr");
-
- A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
- Res : Eti_Error;
- begin
- Res := Set_Fld_Type (Arg1 => C_Int (Fld_Type.Minimum_Field_Width));
- if Res /= E_Ok then
- Eti_Exception (Res);
- else
- A.T := new Alpha_Field'(Fld_Type);
- end if;
- end Set_Type;
- -- |
- -- |
- -- |
- function Native_Type (Ftype : Alpha_Numeric_Field)
- return C_Field_Type
- is
- C_Alpha_Numeric_Field_Type : C_Field_Type;
- pragma Import (C, C_Alpha_Numeric_Field_Type, "TYPE_ALNUM");
- begin
- return C_Alpha_Numeric_Field_Type;
- end Native_Type;
- pragma Inline (Native_Type);
- -- |
- -- |
- -- |
- procedure Set_Type (Fld : in Field;
- Fld_Type : in Alpha_Numeric_Field)
- is
- function Set_Fld_Type (F : Field := Fld;
- Cft : C_Field_Type := Native_Type (Fld_Type);
- Arg1 : C_Int) return C_Int;
- pragma Import (C, Set_Fld_Type, "set_field_type");
- function Field_Userptr (Fld : Field)
- return Field_User_Wrapper_Access;
- pragma Import (C, Field_Userptr, "field_userptr");
-
- A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
- Res : Eti_Error;
- begin
- Res := Set_Fld_Type (Arg1 => C_Int (Fld_Type.Minimum_Field_Width));
- if Res /= E_Ok then
- Eti_Exception (Res);
- else
- A.T := new Alpha_Numeric_Field'(Fld_Type);
- end if;
- end Set_Type;
- -- |
- -- |
- -- |
- function Native_Type (Ftype : Integer_Field)
- return C_Field_Type
- is
- C_Integer_Field_Type : C_Field_Type;
- pragma Import (C, C_Integer_Field_Type, "TYPE_INTEGER");
- begin
- return C_Integer_Field_Type;
- end Native_Type;
- pragma Inline (Native_Type);
- -- |
- -- |
- -- |
- procedure Set_Type (Fld : in Field;
- Fld_Type : in Integer_Field)
- is
- function Set_Fld_Type (F : Field := Fld;
- Cft : C_Field_Type := Native_Type (Fld_Type);
- Arg1 : C_Int;
- Arg2 : C_Long_Int;
- Arg3 : C_Long_Int) return C_Int;
- pragma Import (C, Set_Fld_Type, "set_field_type");
- function Field_Userptr (Fld : Field)
- return Field_User_Wrapper_Access;
- pragma Import (C, Field_Userptr, "field_userptr");
-
- A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
- Res : Eti_Error;
- begin
- Res := Set_Fld_Type (Arg1 => C_Int (Fld_Type.Precision),
- Arg2 => C_Long_Int (Fld_Type.Lower_Limit),
- Arg3 => C_Long_Int (Fld_Type.Upper_Limit));
- if Res /= E_Ok then
- Eti_Exception (Res);
- else
- A.T := new Integer_Field'(Fld_Type);
- end if;
- end Set_Type;
- -- |
- -- |
- -- |
- function Native_Type (Ftype : Numeric_Field)
- return C_Field_Type
- is
- C_Numeric_Field_Type : C_Field_Type;
- pragma Import (C, C_Numeric_Field_Type, "TYPE_NUMERIC");
- begin
- return C_Numeric_Field_Type;
- end Native_Type;
- pragma Inline (Native_Type);
- -- |
- -- |
- -- |
- procedure Set_Type (Fld : in Field;
- Fld_Type : in Numeric_Field)
- is
- type Double is new Interfaces.C.double;
-
- function Set_Fld_Type (F : Field := Fld;
- Cft : C_Field_Type := Native_Type (Fld_Type);
- Arg1 : Double;
- Arg2 : Double;
- Arg3 : Double) return C_Int;
- pragma Import (C, Set_Fld_Type, "set_field_type");
- function Field_Userptr (Fld : Field)
- return Field_User_Wrapper_Access;
- pragma Import (C, Field_Userptr, "field_userptr");
-
- A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
- Res : Eti_Error;
- begin
- Res := Set_Fld_Type (Arg1 => Double (Fld_Type.Precision),
- Arg2 => Double (Fld_Type.Lower_Limit),
- Arg3 => Double (Fld_Type.Upper_Limit));
- if Res /= E_Ok then
- Eti_Exception (Res);
- else
- A.T := new Numeric_Field'(Fld_Type);
- end if;
- end Set_Type;
- -- |
- -- |
- -- |
- function Native_Type (Ftype : Regular_Expression_Field)
- return C_Field_Type
- is
- C_Regexp_Field_Type : C_Field_Type;
- pragma Import (C, C_Regexp_Field_Type, "TYPE_REGEXP");
- begin
- return C_Regexp_Field_Type;
- end Native_Type;
- pragma Inline (Native_Type);
- -- |
- -- |
- -- |
- procedure Set_Type (Fld : in Field;
- Fld_Type : in Regular_Expression_Field)
- is
- type Char_Ptr is access all Interfaces.C.Char;
- function Set_Fld_Type (F : Field := Fld;
- Cft : C_Field_Type := Native_Type (Fld_Type);
- Arg1 : Char_Ptr) return C_Int;
- pragma Import (C, Set_Fld_Type, "set_field_type");
- function Field_Userptr (Fld : Field)
- return Field_User_Wrapper_Access;
- pragma Import (C, Field_Userptr, "field_userptr");
-
- A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
- Txt : char_array (0 .. Fld_Type.Regular_Expression.all'Length);
- Len : size_t;
- Res : Eti_Error;
- begin
- To_C (Fld_Type.Regular_Expression.all, Txt, Len);
- Res := Set_Fld_Type (Arg1 => Txt (Txt'First)'Access);
- if Res /= E_Ok then
- Eti_Exception (Res);
- else
- A.T := new Regular_Expression_Field'(Fld_Type);
- end if;
- end Set_Type;
- -- |
- -- |
- -- |
- function Native_Type (Ftype : Enumeration_Field)
- return C_Field_Type
- is
- C_Enum_Type : C_Field_Type;
- pragma Import (C, C_Enum_Type, "TYPE_ENUM");
- begin
- return C_Enum_Type;
- end Native_Type;
- pragma Inline (Native_Type);
- -- |
- -- |
- -- |
- function Create (Info : Enumeration_Info;
- Auto_Release_Names : Boolean := False)
- return Enumeration_Field
- is
- procedure Release_String is
- new Ada.Unchecked_Deallocation (String,
- String_Access);
- E : Enumeration_Field;
- L : constant size_t := 1 + size_t (Info.C);
- S : String_Access;
- begin
- E.Case_Sensitive := Info.Case_Sensitive;
- E.Match_Must_Be_Unique := Info.Match_Must_Be_Unique;
- E.Arr := new chars_ptr_array (size_t (1) .. L);
- for I in 1 .. Positive (L - 1) loop
- if Info.Names (I) = null then
- raise Form_Exception;
- end if;
- E.Arr (size_t (I)) := New_String (Info.Names (I).all);
- if Auto_Release_Names then
- S := Info.Names (I);
- Release_String (S);
- end if;
- end loop;
- E.Arr (L) := Null_Ptr;
- return E;
- end Create;
-
- procedure Release (Enum : in out Enumeration_Field)
- is
- I : size_t := 0;
- P : chars_ptr;
- begin
- loop
- P := Enum.Arr (I);
- exit when P = Null_Ptr;
- Free (P);
- Enum.Arr (I) := Null_Ptr;
- I := I + 1;
- end loop;
- Enum.Arr := null;
- end Release;
-
- procedure Set_Type (Fld : in Field;
- Fld_Type : in Enumeration_Field)
- is
- function Set_Fld_Type (F : Field := Fld;
- Cft : C_Field_Type := Native_Type (Fld_Type);
- Arg1 : chars_ptr_array;
- Arg2 : C_Int; -- case
- Arg3 : C_Int) return C_Int;
- pragma Import (C, Set_Fld_Type, "set_field_type");
- function Field_Userptr (Fld : Field)
- return Field_User_Wrapper_Access;
- pragma Import (C, Field_Userptr, "field_userptr");
-
- A : constant Field_User_Wrapper_Access := Field_Userptr (Fld);
- Res : Eti_Error;
- begin
- if Fld_Type.Arr = null then
- raise Form_Exception;
- end if;
- Res := Set_Fld_Type (Arg1 => Fld_Type.Arr.all,
- Arg2 => C_Int (Boolean'Pos
- (Fld_Type.Case_Sensitive)),
- Arg3 =>
- C_Int (Boolean'Pos
- (Fld_Type.Match_Must_Be_Unique)));
- if Res /= E_Ok then
- Eti_Exception (Res);
- else
- A.T := new Enumeration_Field'(Fld_Type);
- end if;
- end Set_Type;