------------------------------------------------------------------------------ -- XML/Ada - An XML suite for Ada95 -- -- -- -- Copyright (C) 2010-2012, AdaCore -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, 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 MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- -- -- -- -- -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ pragma ada_05; with GNAT.Dynamic_Tables; with GNAT.Regpat; use GNAT.Regpat; with Sax.HTable; with Sax.Locators; use Sax.Locators; with Sax.Symbols; use Sax.Symbols; with Sax.Utils; use Sax.Utils; with Schema.Decimal; use Schema.Decimal; with Schema.Date_Time; use Schema.Date_Time; with Unicode.CES; use Unicode.CES; package Schema.Simple_Types is type simple_type_index is new Natural; No_Simple_Type_Index : constant simple_type_index := 0; type enumeration_index is new Natural; No_Enumeration_Index : constant enumeration_index := 0; max_types_in_union : constant := 9; -- Maximum number of types in a union. -- This is hard-coded to avoid memory allocations as much as possible. -- This value is chosen so that the case [Primitive_Union] does not make -- [Simple_Type_Descr] bigger than the other cases. type whitespace_restriction is (preserve, replace, collapse); function Convert_Regexp (Regexp : Unicode.CES.byte_sequence) return String; -- Return a regular expresssion that converts the XML-specification -- regexp Regexp to a GNAT.Regpat compatible one type primitive_simple_type_kind is (primitive_boolean, primitive_double, primitive_decimal, primitive_float, primitive_string, primitive_any_uri, primitive_qname, primitive_id, primitive_notation, primitive_nmtoken, primitive_language, primitive_nmtokens, primitive_name, primitive_ncname, primitive_ncnames, primitive_base64binary, primitive_hexbinary, primitive_time, primitive_datetime, primitive_gday, primitive_gmonthday, primitive_gmonth, primitive_gyearmonth, primitive_gyear, primitive_date, primitive_duration, primitive_union, primitive_list); type pattern_matcher_access is access GNAT.Regpat.Pattern_Matcher; type pattern_facet is record Str : Sax.Symbols.symbol; -- The pattern itself Pattern : pattern_matcher_access; -- The compiled pattern end record; type pattern_matcher_array is array (Natural range <>) of pattern_facet; type pattern_matcher_array_access is access all pattern_matcher_array; procedure Free (Arr : in out pattern_matcher_array_access); -- A type might be subject to multiple patterns: -- - When we extend a base type, we must match either the base's patterns -- or the patterns set in the extenstion. This does not increase the -- number of patterns, we just merge them with "|". -- - When we restrict a base type, we must match both the base's patterns -- and the patterns set in the extenstion. This increases the number of -- patterns type simple_type_array is array (Natural range <>) of simple_type_index; type facet_enum is (facet_whitespace, facet_enumeration, facet_pattern, facet_min_inclusive, facet_max_inclusive, facet_min_exclusive, facet_max_exclusive, facet_length, facet_min_length, facet_max_length, facet_total_digits, facet_fraction_digits); type facets_mask is array (facet_enum) of Boolean; type simple_type_descr (Kind : primitive_simple_type_kind := primitive_boolean) is record Mask : facets_mask := (others => False); Pattern : pattern_matcher_array_access := null; Whitespace : whitespace_restriction := collapse; Enumeration : enumeration_index := No_Enumeration_Index; case Kind is when primitive_union => Union : simple_type_array (1 .. max_types_in_union) := (others => No_Simple_Type_Index); when primitive_list => List_Item : simple_type_index; List_Length : Natural := Natural'last; List_Min_Length : Natural := 0; List_Max_Length : Natural := Natural'last; when primitive_string .. primitive_hexbinary => String_Length : Natural := Natural'last; String_Min_Length : Natural := 0; String_Max_Length : Natural := Natural'last; when primitive_boolean => null; when primitive_float | primitive_double => -- float, double Float_Min_Inclusive : xml_float := Unknown_Float; Float_Max_Inclusive : xml_float := Unknown_Float; Float_Min_Exclusive : xml_float := Unknown_Float; Float_Max_Exclusive : xml_float := Unknown_Float; when primitive_decimal => -- decimal Total_Digits : Positive := Positive'last; Fraction_Digits : Natural := Natural'last; Decimal_Min_Inclusive, Decimal_Max_Inclusive, Decimal_Min_Exclusive, Decimal_Max_Exclusive : arbitrary_precision_number := Undefined_Number; when primitive_time => Time_Min_Inclusive, Time_Min_Exclusive, Time_Max_Inclusive, Time_Max_Exclusive : time_t := No_Time_T; when primitive_datetime => DateTime_Min_Inclusive, DateTime_Min_Exclusive, DateTime_Max_Inclusive, DateTime_Max_Exclusive : date_time_t := No_Date_Time; when primitive_gday => GDay_Min_Inclusive, GDay_Min_Exclusive, GDay_Max_Inclusive, GDay_Max_Exclusive : gday_t := No_GDay; when primitive_gmonthday => GMonthDay_Min_Inclusive, GMonthDay_Min_Exclusive, GMonthDay_Max_Inclusive, GMonthDay_Max_Exclusive : gmonth_day_t := No_Month_Day; when primitive_gmonth => GMonth_Min_Inclusive, GMonth_Min_Exclusive, GMonth_Max_Inclusive, GMonth_Max_Exclusive : gmonth_t := No_Month; when primitive_gyearmonth => GYearMonth_Min_Inclusive, GYearMonth_Min_Exclusive, GYearMonth_Max_Inclusive, GYearMonth_Max_Exclusive : gyear_month_t := No_Year_Month; when primitive_gyear => GYear_Min_Inclusive, GYear_Min_Exclusive, GYear_Max_Inclusive, GYear_Max_Exclusive : gyear_t := No_Year; when primitive_date => Date_Min_Inclusive, Date_Min_Exclusive, Date_Max_Inclusive, Date_Max_Exclusive : date_t := No_Date_T; when primitive_duration => Duration_Min_Inclusive, Duration_Min_Exclusive, Duration_Max_Inclusive, Duration_Max_Exclusive : duration_t := No_Duration; end case; end record; Any_Simple_Type : constant simple_type_descr := (Kind => primitive_string, Whitespace => preserve, others => <>); function Copy (Descr : simple_type_descr) return simple_type_descr; -- return a deep copy of [Copy] (duplicates the pattern) package Simple_Type_Tables is new GNAT.Dynamic_Tables (Table_Component_Type => simple_type_descr, Table_Index_Type => simple_type_index, Table_Low_Bound => No_Simple_Type_Index + 1, Table_Initial => 100, Table_Increment => 100); subtype simple_type_table is Simple_Type_Tables.instance; type enumeration_descr is record Value : Sax.Symbols.symbol; Next : enumeration_index := No_Enumeration_Index; end record; package Enumeration_Tables is new GNAT.Dynamic_Tables (Table_Component_Type => enumeration_descr, Table_Index_Type => enumeration_index, Table_Low_Bound => No_Enumeration_Index + 1, Table_Initial => 30, Table_Increment => 20); generic type type_index is private; No_Type_Index : type_index; with function Register (Local : byte_sequence; Descr : simple_type_descr; Restriction_Of : type_index) return type_index; procedure Register_Predefined_Types (Symbols : Sax.Utils.symbol_table); -- Register all the predefined types function Get_Key (Id : Sax.Symbols.symbol) return Sax.Symbols.symbol; package Symbol_Htable is new Sax.HTable (element => Sax.Symbols.symbol, Empty_Element => Sax.Symbols.No_Symbol, key => Sax.Symbols.symbol, Get_Key => Get_Key, Hash => Sax.Symbols.Hash, Equal => Sax.Symbols."="); type symbol_htable_access is access Symbol_Htable.htable; -- This table is used to store the list of IDs that have been used in the -- document so far, and prevent their duplication in the document. procedure Free (Symbol_Table : in out symbol_htable_access); procedure Validate_Simple_Type (Simple_Types : simple_type_table; Enumerations : Enumeration_Tables.instance; Notations : Symbol_Htable.htable; Symbols : symbol_table; Id_Table : in out symbol_htable_access; Insert_Id : Boolean := True; Simple_Type : simple_type_index; Ch : Unicode.CES.byte_sequence; Error : in out symbol; XML_Version : xml_versions); -- Validate [Ch] for the simple type [Simple_Type]. -- Returns an error message in case of error, or No_Symbol otherwise. -- If [Insert_Id] is True and you are validating an ID, it will be inserted -- in Id_Table (and an error reported if it already exists) procedure Equal (Simple_Types : simple_type_table; Enumerations : Enumeration_Tables.instance; Notations : Symbol_Htable.htable; Symbols : symbol_table; Id_Table : in out symbol_htable_access; Simple_Type : simple_type_index; Ch1 : Sax.Symbols.symbol; Ch2 : Unicode.CES.byte_sequence; Is_Equal : out Boolean; XML_Version : xml_versions); -- Checks whether [Ch1]=[Ch2] according to the type. -- (This involves for instance normalizing whitespaces) type facet_value is record Value : Sax.Symbols.symbol := Sax.Symbols.No_Symbol; Enum : enumeration_index := No_Enumeration_Index; Loc : Sax.Locators.location; end record; No_Facet_Value : constant facet_value := (Sax.Symbols.No_Symbol, No_Enumeration_Index, Sax.Locators.No_Location); type all_facets is array (facet_enum) of facet_value; No_Facets : constant all_facets := (others => No_Facet_Value); -- A temporary record to hold facets defined in a schema, until we can -- merge them with the base's facets. It does not try to interpret the -- facets. procedure Add_Facet (Facets : in out all_facets; Symbols : Sax.Utils.symbol_table; Enumerations : in out Enumeration_Tables.instance; Facet_Name : Sax.Symbols.symbol; Value : Sax.Symbols.symbol; Loc : Sax.Locators.location); -- Set a specific facet in [Simple] procedure Override (Simple : in out simple_type_descr; Facets : all_facets; Symbols : Sax.Utils.symbol_table; As_Restriction : Boolean; Error : out Sax.Symbols.symbol; Error_Loc : out Sax.Locators.location); -- Override [Simple] with the facets defined in [Facets], but keep those -- facets that are not defined. Sets [Error] to a symbol if one of the -- facets is invalid for [Simple]. procedure Normalize_Whitespace (Whitespace : Schema.Simple_Types.whitespace_restriction; Val : in out Unicode.CES.byte_sequence; Last : in out Natural); -- Normalize in place the whitespaces in [Val (1 .. Last)], and change -- [Last] as appropriate (always smaller or equal to the input parameter) end Schema.Simple_Types;