ada/xmlada
0
0
Fork 0
mirror of https://github.com/AdaCore/xmlada.git synced 2026-02-12 12:30:28 -08:00
Code Issues Packages Projects Releases Wiki Activity
Files
master
xmlada/schema/schema-simple_types.adb
Vadim Godunko df941e6352 Escape - character inside character class expressions.
2025-01-30 17:42:28 +04:00

2588 lines
92 KiB
Ada
Raw Permalink Blame History

------------------------------------------------------------------------------
-- XML/Ada - An XML suite for Ada95 --
-- --
-- Copyright (C) 2010-2025, 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. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- 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 --
-- <http://www.gnu.org/licenses/>. --
-- --
------------------------------------------------------------------------------
pragma Ada_05;
with Ada.Unchecked_Deallocation;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Sax.Encodings; use Sax.Encodings;
with Unicode; use Unicode;
with Unicode.Names.Basic_Latin; use Unicode.Names.Basic_Latin;
package body Schema.Simple_Types is
use Simple_Type_Tables, Enumeration_Tables;
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(Pattern_Matcher_Array, Pattern_Matcher_Array_Access);
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(Pattern_Matcher, Pattern_Matcher_Access);
generic
with function Get_Length (Ch : Byte_Sequence) return Natural;
function Validate_Length_Facets
(Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence;
Mask : Facets_Mask;
Length, Min_Length, Max_Length : Integer) return Symbol;
-- Validate length facets
generic
type T is private;
with procedure Value (Symbols : Symbol_Table;
Ch : Byte_Sequence;
Val : out T;
Error : out Symbol) is <>;
with function Image (Val : T) return Byte_Sequence is <>;
with function "<" (T1, T2 : T) return Boolean is <>;
with function "<=" (T1, T2 : T) return Boolean is <>;
procedure Validate_Range
(Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence;
Mask : Facets_Mask;
Min_Inclusive : T;
Min_Exclusive : T;
Max_Inclusive : T;
Max_Exclusive : T;
Error : out Symbol;
Val : out T);
generic
type T is private;
with procedure Value (Symbols : Symbol_Table;
Ch : Byte_Sequence;
Val : out T;
Error : out Symbol) is <>;
procedure Override_Single_Range_Facet
(Symbols : Sax.Utils.Symbol_Table;
Facets : All_Facets;
Facet : Facet_Enum;
Mask : in out Facets_Mask;
Val : in out T;
Error : in out Symbol;
Error_Loc : in out Location);
generic
type T is private;
with procedure Value (Symbols : Symbol_Table;
Ch : Byte_Sequence;
Val : out T;
Error : out Symbol) is <>;
procedure Override_Range_Facets
(Symbols : Sax.Utils.Symbol_Table;
Facets : All_Facets;
Mask : in out Facets_Mask;
Min_Inclusive : in out T;
Min_Exclusive : in out T;
Max_Inclusive : in out T;
Max_Exclusive : in out T;
Error : out Symbol;
Error_Loc : out Location);
-- Override some range facets
procedure Override_Length_Facets
(Symbols : Sax.Utils.Symbol_Table;
Facets : All_Facets;
Mask : in out Facets_Mask;
Length : in out Integer;
Min_Length : in out Integer;
Max_Length : in out Integer;
Error : out Symbol;
Error_Loc : out Location);
-- Override some length facets
generic
type T is private;
with procedure Value (Symbols : Symbol_Table;
Ch : Byte_Sequence;
Val : out T;
Error : out Symbol) is <>;
with function "=" (T1, T2 : T) return Boolean is <>;
with function Image (T1 : T) return String is <>;
function Generic_Equal
(Symbols : Symbol_Table;
Val1 : Symbol;
Val2 : Byte_Sequence) return Boolean;
-- Compare two values, after possibly normalizing them given the type
-- definition (whitespaces, remove left-most 0 when appropriate,...).
-- This assumes [Val1] and [Val2] are valid values for the type (ie they
-- have already been validated).
function Validate_List_Facets
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence;
Length, Min_Length, Max_Length : Integer) return Symbol;
-- Validate the facets for a list
procedure Check_Id
(Symbols : Symbol_Table;
Id_Table : in out Symbol_Htable_Access;
Value : Unicode.CES.Byte_Sequence;
Error : in out Symbol);
-- Check whether Value is a unique ID in the document.
-- If yes, store it in Id_Table to ensure its future uniqueness.
-- Return the error message or [No_Symbol]
-------------------
-- Generic_Equal --
-------------------
function Generic_Equal
(Symbols : Symbol_Table;
Val1 : Symbol;
Val2 : Byte_Sequence) return Boolean
is
V1, V2 : T;
Error : Symbol;
begin
Value (Symbols, Get (Val1).all, V1, Error);
if Error /= No_Symbol then
if Debug then
Debug_Output ("Generic_Equal, could not convert Val1 "
& Get (Val1).all & " => " & Get (Error).all);
end if;
return False;
end if;
Value (Symbols, Val2, V2, Error);
if Error /= No_Symbol then
if Debug then
Debug_Output ("Generic_Equal, could not convert Val2 "
& Val2 & " => " & Get (Error).all);
end if;
return False;
end if;
if Debug then
Debug_Output ("Comparing " & Image (V1) & " != " & Image (V2));
end if;
return V1 = V2;
end Generic_Equal;
----------------------------
-- Validate_Length_Facets --
----------------------------
function Validate_Length_Facets
(Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence;
Mask : Facets_Mask;
Length, Min_Length, Max_Length : Integer) return Symbol
is
L : Integer := -1;
begin
-- Characters are always a string, nothing to check here but the facets
if Mask (Facet_Length)
or else Mask (Facet_Min_Length)
or else Mask (Facet_Max_Length)
then
L := Get_Length (Ch);
else
return No_Symbol;
end if;
if Mask (Facet_Length) then
if L /= Length then
return Find
(Symbols,
"Invalid length, must be"
& Integer'Image (Length) & " characters");
end if;
end if;
if Mask (Facet_Min_Length) then
if L < Min_Length then
return Find
(Symbols,
"String is too short, minimum length is"
& Integer'Image (Min_Length)
& " characters");
end if;
end if;
if Mask (Facet_Max_Length) then
if L > Max_Length then
return Find
(Symbols,
"String is too long, maximum length is"
& Integer'Image (Max_Length)
& " characters");
end if;
end if;
return No_Symbol;
end Validate_Length_Facets;
---------------------
-- Instantiations --
---------------------
function HexBinary_Get_Length
(Value : Unicode.CES.Byte_Sequence) return Natural;
function Base64Binary_Get_Length
(Value : Unicode.CES.Byte_Sequence) return Natural;
-- Return the length of a string
procedure Value (Symbols : Symbol_Table;
Ch : Byte_Sequence;
Val : out XML_Float;
Error : out Symbol);
-- Converts [Ch] into [Val]
function Validate_String
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol;
function Validate_HexBinary_Facets is new
Validate_Length_Facets (HexBinary_Get_Length);
function Validate_Base64Binary_Facets is new
Validate_Length_Facets (Base64Binary_Get_Length);
function Validate_NMTOKEN
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence;
XML_Version : XML_Versions) return Symbol;
function Validate_NMTOKENS
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence;
XML_Version : XML_Versions) return Symbol;
function Validate_Name
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence;
XML_Version : XML_Versions) return Symbol;
function Validate_NCName
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence;
XML_Version : XML_Versions) return Symbol;
function Validate_NCNames
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence;
XML_Version : XML_Versions) return Symbol;
function Validate_Language
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol;
function Validate_URI
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol;
function Validate_HexBinary
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol;
function Validate_Notation
(Notations : Symbol_Htable.HTable;
Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol;
function Validate_Base64Binary
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol;
function Validate_QName
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence;
XML_Version : XML_Versions) return Symbol;
function Validate_Boolean
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol;
function Validate_Double
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol;
function Validate_Decimal
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol;
function Validate_Duration
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol;
function Validate_Date_Time
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol;
function Validate_Date
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol;
function Validate_Time
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol;
function Validate_GDay
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol;
function Validate_GMonth_Day
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol;
function Validate_GMonth
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol;
function Validate_GYear
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol;
function Validate_GYear_Month
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol;
-- Check [Ch] for one of the primitive types, including facets
function Anchor (Str : String) return String;
-- Return an anchored version of Str ("^...$").
-- In XML, regexps are always anchored, as per the beginning of [G]
function Missing_End_Anchor (Str : String) return Boolean;
function Missing_Start_Anchor (Str : String) return Boolean;
-- Whether the regexp is missing the "^" or "$" anchors
procedure Boolean_Value
(Symbols : Symbol_Table;
Ch : Byte_Sequence;
Val : out Boolean;
Error : out Symbol);
-- Converts [Ch] to a boolean, and returns an error message if needed
function Equal_Boolean is new Generic_Equal (Boolean, Boolean_Value,
Image => Boolean'Image);
function Equal_Float is new Generic_Equal (XML_Float, Value);
function Equal_Decimal is new Generic_Equal (Arbitrary_Precision_Number);
function Equal_Duration is new Generic_Equal (Duration_T);
function Equal_Date_Time is new Generic_Equal (Date_Time_T);
function Equal_Date is new Generic_Equal (Date_T);
function Equal_Time is new Generic_Equal (Time_T);
function Equal_GDay is new Generic_Equal (GDay_T);
function Equal_GMonth_Day is new Generic_Equal (GMonth_Day_T);
function Equal_GMonth is new Generic_Equal (GMonth_T);
function Equal_GYear is new Generic_Equal (GYear_T);
function Equal_GYear_Month is new Generic_Equal (GYear_Month_T);
-------------------------------
-- Register_Predefined_Types --
-------------------------------
procedure Register_Predefined_Types (Symbols : Sax.Utils.Symbol_Table) is
Zero : constant Arbitrary_Precision_Number :=
Value (Find (Symbols, "0"));
One : constant Arbitrary_Precision_Number :=
Value (Find (Symbols, "1"));
Minus_One : constant Arbitrary_Precision_Number :=
Value (Find (Symbols, "-1"));
Max_Unsigned_Long : constant Arbitrary_Precision_Number :=
Value (Find (Symbols, "+18446744073709551615"));
Max_Long : constant Arbitrary_Precision_Number :=
Value (Find (Symbols, "+9223372036854775807"));
Min_Long : constant Arbitrary_Precision_Number :=
Value (Find (Symbols, "-9223372036854775808"));
Max_Int : constant Arbitrary_Precision_Number :=
Value (Find (Symbols, "+2147483647"));
Min_Int : constant Arbitrary_Precision_Number :=
Value (Find (Symbols, "-2147483648"));
Max_Short : constant Arbitrary_Precision_Number :=
Value (Find (Symbols, "+32767"));
Min_Short : constant Arbitrary_Precision_Number :=
Value (Find (Symbols, "-32768"));
Max_Byte : constant Arbitrary_Precision_Number :=
Value (Find (Symbols, "+127"));
Min_Byte : constant Arbitrary_Precision_Number :=
Value (Find (Symbols, "-128"));
Max_Unsigned_Int : constant Arbitrary_Precision_Number :=
Value (Find (Symbols, "+4294967295"));
Max_Unsigned_Short : constant Arbitrary_Precision_Number :=
Value (Find (Symbols, "+65535"));
Max_Unsigned_Byte : constant Arbitrary_Precision_Number :=
Value (Find (Symbols, "+255"));
Whitespace_Mask : constant Facets_Mask := (Facet_Whitespace => True,
others => False);
Fraction_Min_Mask : constant Facets_Mask :=
(Facet_Fraction_Digits => True,
Facet_Min_Inclusive => True,
others => False);
Fraction_Max_Mask : constant Facets_Mask :=
(Facet_Fraction_Digits => True,
Facet_Max_Inclusive => True,
others => False);
Fraction_Min_Max_Mask : constant Facets_Mask :=
(Facet_Fraction_Digits => True,
Facet_Min_Inclusive => True,
Facet_Max_Inclusive => True,
others => False);
Any_Simple_Type, Decimal, Integer, Long, Int, Short : Type_Index;
Non_Positive_Int, Non_Negative_Int : Type_Index;
Unsigned_Long, Unsigned_Int, Unsigned_Short : Type_Index;
Str, Normalized_Str, Token : Type_Index;
Name, NCName : Type_Index;
T : Type_Index;
pragma Unreferenced (T);
begin
Any_Simple_Type := Register
("anySimpleType",
(Kind => Primitive_String,
Mask => (Facet_Whitespace => True,
others => False),
Whitespace => Preserve,
others => <>), No_Type_Index);
Str := Register ("string", (Kind => Primitive_String,
Mask => Whitespace_Mask,
Whitespace => Preserve,
others => <>), Any_Simple_Type);
Normalized_Str :=
Register ("normalizedString", (Kind => Primitive_String,
Mask => Whitespace_Mask,
Whitespace => Replace,
others => <>), Str);
Token := Register ("token", (Kind => Primitive_String,
Mask => Whitespace_Mask,
Whitespace => Collapse,
others => <>), Normalized_Str);
T := Register ("language", (Kind => Primitive_Language,
Mask => Whitespace_Mask,
Whitespace => Collapse,
others => <>), Token);
T := Register ("boolean", (Kind => Primitive_Boolean, others => <>),
Any_Simple_Type);
T := Register ("QName", (Kind => Primitive_QName,
Mask => Whitespace_Mask,
others => <>),
Any_Simple_Type);
T := Register ("NOTATION", (Kind => Primitive_Notation, others => <>),
Any_Simple_Type);
T := Register ("float", (Kind => Primitive_Float, others => <>),
Any_Simple_Type);
T := Register ("NMTOKEN", (Kind => Primitive_NMTOKEN, others => <>),
Token);
T := Register ("NMTOKENS", (Kind => Primitive_NMTOKENS,
Mask => Whitespace_Mask,
others => <>),
Any_Simple_Type);
Name := Register ("Name", (Kind => Primitive_Name,
Mask => Whitespace_Mask,
Whitespace => Collapse,
others => <>), Token);
NCName := Register ("NCName", (Kind => Primitive_NCName,
Mask => Whitespace_Mask,
Whitespace => Collapse,
others => <>), Name);
T := Register ("ID", (Kind => Primitive_ID,
Mask => Whitespace_Mask,
Whitespace => Preserve,
others => <>), NCName);
T := Register ("IDREF", (Kind => Primitive_NCName,
Mask => Whitespace_Mask,
Whitespace => Preserve,
others => <>), NCName);
T := Register ("IDREFS", (Kind => Primitive_NCNames,
Mask => Whitespace_Mask,
Whitespace => Preserve,
others => <>), Any_Simple_Type);
T := Register ("ENTITY", (Kind => Primitive_NCName,
Mask => Whitespace_Mask,
Whitespace => Preserve,
others => <>), NCName);
T := Register ("ENTITIES", (Kind => Primitive_NCNames,
Mask => Whitespace_Mask,
Whitespace => Preserve,
others => <>), Any_Simple_Type);
T := Register ("anyURI", (Kind => Primitive_Any_URI,
Mask => Whitespace_Mask,
others => <>), Any_Simple_Type);
T := Register ("hexBinary", (Kind => Primitive_HexBinary,
others => <>), Any_Simple_Type);
T := Register ("base64Binary", (Kind => Primitive_Base64Binary,
others => <>), Any_Simple_Type);
Decimal := Register ("decimal",
(Kind => Primitive_Decimal, others => <>),
Any_Simple_Type);
Integer := Register ("integer",
(Kind => Primitive_Decimal,
Fraction_Digits => 0,
Whitespace => Collapse,
Pattern => new Pattern_Matcher_Array'
(1 => Pattern_Facet'(
Str => Find (Symbols, "[\-+]?[0-9]+"),
Pattern => new Pattern_Matcher'
(Compile ("[\-+]?[0-9]+")))),
Mask => (Facet_Fraction_Digits => True,
Facet_Pattern => True,
Facet_Whitespace => True,
others => False),
others => <>), Decimal);
Non_Negative_Int :=
Register ("nonNegativeInteger",
(Kind => Primitive_Decimal,
Fraction_Digits => 0,
Decimal_Min_Inclusive => Zero,
Mask => Fraction_Min_Mask,
others => <>), Integer);
Unsigned_Long :=
Register ("unsignedLong",
(Kind => Primitive_Decimal,
Mask => Fraction_Min_Max_Mask,
Fraction_Digits => 0,
Decimal_Min_Inclusive => Zero,
Decimal_Max_Inclusive => Max_Unsigned_Long,
others => <>), Non_Negative_Int);
T := Register ("positiveInteger",
(Kind => Primitive_Decimal,
Fraction_Digits => 0,
Decimal_Min_Inclusive => One,
Mask => Fraction_Min_Mask,
others => <>), Non_Negative_Int);
Non_Positive_Int :=
Register ("nonPositiveInteger",
(Kind => Primitive_Decimal,
Fraction_Digits => 0,
Decimal_Max_Inclusive => Zero,
Mask => Fraction_Max_Mask,
others => <>), Integer);
T := Register ("negativeInteger",
(Kind => Primitive_Decimal,
Fraction_Digits => 0,
Decimal_Max_Inclusive => Minus_One,
Mask => Fraction_Max_Mask,
others => <>), Non_Positive_Int);
Long := Register ("long",
(Kind => Primitive_Decimal,
Mask => Fraction_Min_Max_Mask,
Fraction_Digits => 0,
Decimal_Max_Inclusive => Max_Long,
Decimal_Min_Inclusive => Min_Long,
others => <>), Integer);
Int := Register ("int",
(Kind => Primitive_Decimal,
Mask => Fraction_Min_Max_Mask,
Fraction_Digits => 0,
Decimal_Max_Inclusive => Max_Int,
Decimal_Min_Inclusive => Min_Int,
others => <>), Long);
Short := Register ("short",
(Kind => Primitive_Decimal,
Mask => Fraction_Min_Max_Mask,
Fraction_Digits => 0,
Decimal_Max_Inclusive => Max_Short,
Decimal_Min_Inclusive => Min_Short,
others => <>), Int);
T := Register ("byte",
(Kind => Primitive_Decimal,
Mask => Fraction_Min_Max_Mask,
Fraction_Digits => 0,
Decimal_Max_Inclusive => Max_Byte,
Decimal_Min_Inclusive => Min_Byte,
others => <>), Short);
Unsigned_Int :=
Register ("unsignedInt",
(Kind => Primitive_Decimal,
Mask => Fraction_Min_Max_Mask,
Fraction_Digits => 0,
Decimal_Max_Inclusive => Max_Unsigned_Int,
Decimal_Min_Inclusive => Zero,
others => <>), Unsigned_Long);
Unsigned_Short :=
Register ("unsignedShort",
(Kind => Primitive_Decimal,
Mask => Fraction_Min_Max_Mask,
Fraction_Digits => 0,
Decimal_Max_Inclusive => Max_Unsigned_Short,
Decimal_Min_Inclusive => Zero,
others => <>), Unsigned_Int);
T :=
Register ("unsignedByte",
(Kind => Primitive_Decimal,
Mask => Fraction_Min_Max_Mask,
Fraction_Digits => 0,
Decimal_Max_Inclusive => Max_Unsigned_Byte,
Decimal_Min_Inclusive => Zero,
others => <>), Unsigned_Short);
T := Register ("float", (Kind => Primitive_Float, others => <>),
Any_Simple_Type);
T := Register ("double", (Kind => Primitive_Double, others => <>),
Any_Simple_Type);
T := Register ("time", (Kind => Primitive_Time, others => <>),
Any_Simple_Type);
T := Register ("dateTime", (Kind => Primitive_DateTime, others => <>),
Any_Simple_Type);
T := Register ("gDay", (Kind => Primitive_GDay, others => <>),
Any_Simple_Type);
T := Register ("gMonthDay", (Kind => Primitive_GMonthDay, others => <>),
Any_Simple_Type);
T := Register ("gMonth", (Kind => Primitive_GMonth, others => <>),
Any_Simple_Type);
T := Register ("gYearMonth",
(Kind => Primitive_GYearMonth, others => <>),
Any_Simple_Type);
T := Register ("gYear", (Kind => Primitive_GYear, others => <>),
Any_Simple_Type);
T := Register ("date", (Kind => Primitive_Date, others => <>),
Any_Simple_Type);
T := Register ("duration", (Kind => Primitive_Duration, others => <>),
Any_Simple_Type);
-- Missing attribute "xml:lang" of type "language"
end Register_Predefined_Types;
-----------
-- Equal --
-----------
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)
is
Descr : Simple_Type_Descr renames Simple_Types.Table (Simple_Type);
Error : Symbol;
begin
case Descr.Kind is
when Primitive_String .. Primitive_HexBinary =>
Is_Equal := Get (Ch1).all = Ch2;
when Primitive_Boolean =>
Is_Equal := Equal_Boolean (Symbols, Ch1, Ch2);
when Primitive_Float | Primitive_Double =>
Is_Equal := Equal_Float (Symbols, Ch1, Ch2);
when Primitive_Decimal =>
Is_Equal := Equal_Decimal (Symbols, Ch1, Ch2);
when Primitive_Time =>
Is_Equal := Equal_Time (Symbols, Ch1, Ch2);
when Primitive_DateTime =>
Is_Equal := Equal_Date_Time (Symbols, Ch1, Ch2);
when Primitive_GDay =>
Is_Equal := Equal_GDay (Symbols, Ch1, Ch2);
when Primitive_GMonth =>
Is_Equal := Equal_GMonth (Symbols, Ch1, Ch2);
when Primitive_GYear =>
Is_Equal := Equal_GYear (Symbols, Ch1, Ch2);
when Primitive_Date =>
Is_Equal := Equal_Date (Symbols, Ch1, Ch2);
when Primitive_Duration =>
Is_Equal := Equal_Duration (Symbols, Ch1, Ch2);
when Primitive_GMonthDay =>
Is_Equal := Equal_GMonth_Day (Symbols, Ch1, Ch2);
when Primitive_GYearMonth =>
Is_Equal := Equal_GYear_Month (Symbols, Ch1, Ch2);
when Primitive_Union =>
for S in Descr.Union'Range loop
if Descr.Union (S) /= No_Simple_Type_Index then
-- We need to do space normalization here: when there is
-- a single type (ie not a union), the normalization has
-- already been done for the "fixed" value, but this isn't
-- doable in the case of union where the normalization
-- depends on which member is selected.
-- We actually also need to validate the value since we
-- don't know precisely for which members it is valid.
declare
Norm : Byte_Sequence := Get (Ch1).all;
Last : Integer := Norm'Last;
begin
Normalize_Whitespace
(Whitespace =>
Simple_Types.Table (Descr.Union (S)).Whitespace,
Val => Norm,
Last => Last);
if Debug then
Debug_Output
("Equal for union, checking simpleType:"
& Descr.Union (S)'Img & " "
& Simple_Types.Table
(Descr.Union (S)).Whitespace'Img
& " Ch1=["
& Norm (Norm'First .. Last) & "]");
end if;
Validate_Simple_Type
(Simple_Types => Simple_Types,
Enumerations => Enumerations,
Notations => Notations,
Symbols => Symbols,
Id_Table => Id_Table,
Insert_Id => False,
Simple_Type => Descr.Union (S),
Ch => Norm (Norm'First .. Last),
Error => Error,
XML_Version => XML_Version);
if Debug and then Error /= No_Symbol then
Debug_Output
("Equal: member doesn't apply: "
& Get (Error).all);
end if;
if Error = No_Symbol then
Equal
(Simple_Types => Simple_Types,
Enumerations => Enumerations,
Notations => Notations,
Id_Table => Id_Table,
Symbols => Symbols,
Simple_Type => Descr.Union (S),
Ch1 => Find (Symbols, Norm (Norm'First .. Last)),
Ch2 => Ch2,
Is_Equal => Is_Equal,
XML_Version => XML_Version);
if Is_Equal then
return;
end if;
end if;
end;
end if;
end loop;
Is_Equal := False;
when Primitive_List =>
Is_Equal := Get (Ch1).all = Ch2;
end case;
end Equal;
-------------------------------------
-- Validate_Simple_Type_Characters --
-------------------------------------
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)
is
Descr : Simple_Type_Descr renames Simple_Types.Table (Simple_Type);
Index : Integer;
Char : Unicode_Char;
Matched : Match_Array (0 .. 0);
procedure Validate_List_Item (Str : Byte_Sequence);
procedure Validate_List_Item (Str : Byte_Sequence) is
begin
if Error = No_Symbol then
Validate_Simple_Type
(Simple_Types, Enumerations, Notations, Symbols, Id_Table,
Simple_Type => Descr.List_Item,
Ch => Str,
Error => Error,
XML_Version => XML_Version);
end if;
end Validate_List_Item;
procedure Validate_List_Items is new For_Each_Item (Validate_List_Item);
begin
Error := No_Symbol;
-- Check common facets
if Descr.Mask (Facet_Enumeration) then
declare
Enum : Enumeration_Index := Descr.Enumeration;
Found : Boolean := False;
begin
while Enum /= No_Enumeration_Index loop
Equal
(Simple_Types, Enumerations, Notations, Symbols, Id_Table,
Simple_Type,
Ch1 => Enumerations.Table (Enum).Value,
Ch2 => Ch,
Is_Equal => Found,
XML_Version => XML_Version);
exit when Found;
Enum := Enumerations.Table (Enum).Next;
end loop;
if not Found then
Error := Find (Symbols, "Value not in the enumeration set");
return;
end if;
end;
end if;
if Descr.Mask (Facet_Whitespace) then
case Descr.Whitespace is
when Preserve =>
null; -- Always valid
when Replace =>
for C in Ch'Range loop
if Ch (C) = ASCII.HT
or else Ch (C) = ASCII.LF
or else Ch (C) = ASCII.CR
then
Error :=
Find (Symbols, "HT, LF and CR characters not allowed");
return;
end if;
end loop;
when Collapse =>
for C in Ch'Range loop
if Ch (C) = ASCII.HT
or else Ch (C) = ASCII.LF
or else Ch (C) = ASCII.CR
then
Error :=
Find (Symbols, "HT, LF and CR characters not allowed");
return;
elsif Ch (C) = ' '
and then C < Ch'Last
and then Ch (C + 1) = ' '
then
Error := Find
(Symbols, "Duplicate space characters not allowed");
return;
end if;
end loop;
-- Leading or trailing white spaces are also forbidden
if Ch'Length /= 0 then
if Ch (Ch'First) = ' ' then
Error := Find
(Symbols, "Leading whitespaces not allowed");
return;
elsif Ch (Ch'Last) = ' ' then
Error := Find
(Symbols, "Trailing whitespaces not allowed");
return;
end if;
end if;
end case;
end if;
if Descr.Mask (Facet_Pattern) and then Descr.Pattern /= null then
-- Check whether we have unicode char outside of ASCII
Index := Ch'First;
while Index <= Ch'Last loop
Encoding.Read (Ch, Index, Char);
if Char > 127 then
-- Start with '#' because this is a non-implemented feature
Error := Find
(Symbols, "#Regexp matching with unicode not supported");
return;
end if;
end loop;
for P in Descr.Pattern'Range loop
Match (Descr.Pattern (P).Pattern.all, String (Ch), Matched);
if Matched (0).First /= Ch'First
or else Matched (0).Last /= Ch'Last
then
Error := Find
(Symbols,
"string pattern not matched: "
& Get (Descr.Pattern (P).Str).all);
return;
end if;
end loop;
end if;
-- Type-specific facets
case Descr.Kind is
when Primitive_String =>
Error := Validate_String (Descr, Symbols, Ch);
when Primitive_HexBinary =>
Error := Validate_HexBinary (Descr, Symbols, Ch);
when Primitive_Notation =>
Error := Validate_Notation (Notations, Descr, Symbols, Ch);
when Primitive_Base64Binary =>
Error := Validate_Base64Binary (Descr, Symbols, Ch);
when Primitive_Language =>
Error := Validate_Language (Descr, Symbols, Ch);
when Primitive_QName =>
Error := Validate_QName (Descr, Symbols, Ch, XML_Version);
when Primitive_NCName =>
Error := Validate_NCName (Descr, Symbols, Ch, XML_Version);
when Primitive_ID =>
Error := Validate_NCName (Descr, Symbols, Ch, XML_Version);
if Error = No_Symbol and then Insert_Id then
Check_Id (Symbols, Id_Table, Ch, Error);
end if;
when Primitive_NCNames =>
Error := Validate_NCNames (Descr, Symbols, Ch, XML_Version);
when Primitive_Name =>
Error := Validate_Name (Descr, Symbols, Ch, XML_Version);
when Primitive_Any_URI =>
Error := Validate_URI (Descr, Symbols, Ch);
when Primitive_NMTOKEN =>
Error := Validate_NMTOKEN (Descr, Symbols, Ch, XML_Version);
when Primitive_NMTOKENS =>
Error := Validate_NMTOKENS (Descr, Symbols, Ch, XML_Version);
when Primitive_Boolean =>
Error := Validate_Boolean (Descr, Symbols, Ch);
when Primitive_Decimal =>
Error := Validate_Decimal (Descr, Symbols, Ch);
when Primitive_Float | Primitive_Double =>
Error := Validate_Double (Descr, Symbols, Ch);
when Primitive_Time =>
Error := Validate_Time (Descr, Symbols, Ch);
when Primitive_DateTime =>
Error := Validate_Date_Time (Descr, Symbols, Ch);
when Primitive_GDay =>
Error := Validate_GDay (Descr, Symbols, Ch);
when Primitive_GMonthDay =>
Error := Validate_GMonth_Day (Descr, Symbols, Ch);
when Primitive_GMonth =>
Error := Validate_GMonth (Descr, Symbols, Ch);
when Primitive_GYearMonth =>
Error := Validate_GYear_Month (Descr, Symbols, Ch);
when Primitive_GYear =>
Error := Validate_GYear (Descr, Symbols, Ch);
when Primitive_Date =>
Error := Validate_Date (Descr, Symbols, Ch);
when Primitive_Duration =>
Error := Validate_Duration (Descr, Symbols, Ch);
when Primitive_Union =>
for S in Descr.Union'Range loop
if Descr.Union (S) /= No_Simple_Type_Index then
Validate_Simple_Type
(Simple_Types => Simple_Types,
Enumerations => Enumerations,
Symbols => Symbols,
Notations => Notations,
Id_Table => Id_Table,
Simple_Type => Descr.Union (S),
Ch => Ch,
Error => Error,
XML_Version => XML_Version);
if Error = No_Symbol then
return;
else
if Debug then
Debug_Output ("Checking union at index" & S'Img
& " => " & Get (Error).all);
end if;
end if;
end if;
end loop;
Error := Find (Symbols, "No matching type in the union");
when Primitive_List =>
Validate_List_Items (Ch);
if Error = No_Symbol then
Error := Validate_List_Facets
(Descr, Symbols, Ch,
Descr.List_Length, Descr.List_Min_Length,
Descr.List_Max_Length);
end if;
end case;
end Validate_Simple_Type;
--------------------------
-- HexBinary_Get_Length --
--------------------------
function HexBinary_Get_Length
(Value : Unicode.CES.Byte_Sequence) return Natural is
begin
return Sax.Encodings.Encoding.Length (Value) / 2;
end HexBinary_Get_Length;
-----------------------------
-- Base64Binary_Get_Length --
-----------------------------
function Base64Binary_Get_Length
(Value : Unicode.CES.Byte_Sequence) return Natural
is
Length : Natural := 0;
C : Unicode_Char;
Index : Positive := Value'First;
begin
while Index <= Value'Last loop
Sax.Encodings.Encoding.Read (Value, Index, C);
if C /= 16#20#
and then C /= 16#A#
and then C /= Character'Pos ('=')
then
Length := Length + 1;
end if;
end loop;
return Length * 3 / 4;
end Base64Binary_Get_Length;
----------------------
-- Validate_NMTOKEN --
----------------------
function Validate_NMTOKEN
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence;
XML_Version : XML_Versions) return Symbol is
begin
if not Is_Valid_Nmtoken (Ch, XML_Version) then
return Find (Symbols, "Invalid NMTOKEN: """ & Ch & """");
end if;
return Validate_String (Descr, Symbols, Ch);
end Validate_NMTOKEN;
-----------------------
-- Validate_NMTOKENS --
-----------------------
function Validate_NMTOKENS
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence;
XML_Version : XML_Versions) return Symbol is
begin
if not Is_Valid_Nmtokens (Ch, XML_Version) then
return Find (Symbols, "Invalid NMTOKENS: """ & Ch & """");
end if;
return Validate_List_Facets
(Descr, Symbols, Ch, Descr.String_Length,
Descr.String_Min_Length, Descr.String_Max_Length);
end Validate_NMTOKENS;
-------------------
-- Validate_Name --
-------------------
function Validate_Name
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence;
XML_Version : XML_Versions) return Symbol is
begin
if not Is_Valid_Name (Ch, XML_Version) then
return Find (Symbols, "Invalid Name: """ & Ch & """");
end if;
return Validate_String (Descr, Symbols, Ch);
end Validate_Name;
---------------------
-- Validate_NCName --
---------------------
function Validate_NCName
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence;
XML_Version : XML_Versions) return Symbol is
begin
if not Is_Valid_NCname (Ch, XML_Version) then
return Find (Symbols, "Invalid NCName: """ & Ch & """");
end if;
return Validate_String (Descr, Symbols, Ch);
end Validate_NCName;
----------------------
-- Validate_NCNames --
----------------------
function Validate_NCNames
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence;
XML_Version : XML_Versions) return Symbol is
begin
if not Is_Valid_NCnames (Ch, XML_Version) then
return Find (Symbols, "Invalid NCName: """ & Ch & """");
end if;
return Validate_List_Facets
(Descr, Symbols, Ch, Descr.String_Length,
Descr.String_Min_Length, Descr.String_Max_Length);
end Validate_NCNames;
-----------------------
-- Validate_Language --
-----------------------
function Validate_Language
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol is
begin
if not Is_Valid_Language_Name (Ch) then
return Find (Symbols, "Invalid language: """ & Ch & """");
end if;
return Validate_String (Descr, Symbols, Ch);
end Validate_Language;
--------------------
-- Validate_QName --
--------------------
function Validate_QName
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence;
XML_Version : XML_Versions) return Symbol is
begin
if not Is_Valid_QName (Ch, XML_Version) then
return Find (Symbols, "Invalid QName: """ & Ch & """");
end if;
return Validate_String (Descr, Symbols, Ch);
end Validate_QName;
------------------
-- Validate_URI --
------------------
function Validate_URI
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol is
begin
if not Is_Valid_URI (Ch) then
return Find (Symbols, "Invalid anyURI: """ & Ch & """");
end if;
return Validate_String (Descr, Symbols, Ch);
end Validate_URI;
---------------------
-- Validate_String --
---------------------
function Validate_String
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol
is
function Internal_Facets is new Validate_Length_Facets
(Encoding.Length.all);
begin
return Internal_Facets
(Symbols, Ch, Descr.Mask, Descr.String_Length,
Descr.String_Min_Length, Descr.String_Max_Length);
end Validate_String;
-----------------------
-- Validate_Notation --
-----------------------
function Validate_Notation
(Notations : Symbol_Htable.HTable;
Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol
is
Error : Symbol;
begin
Error := Validate_String (Descr, Symbols, Ch);
if Error /= No_Symbol then
return Error;
end if;
if Symbol_Htable.Get (Notations, Find (Symbols, Ch)) = No_Symbol then
Error := Find
(Symbols, "NOTATION """ & Ch & """ undefined in this document");
end if;
return Error;
end Validate_Notation;
------------------------
-- Validate_HexBinary --
------------------------
function Validate_HexBinary
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol is
begin
if Encoding.Length (Ch) mod 2 /= 0 then
return Find
(Symbols, "HexBinary length must be an even number of characters");
end if;
if not Is_Valid_HexBinary (Ch) then
return Find (Symbols, "Invalid hexBinary: """ & Ch & """");
end if;
return Validate_HexBinary_Facets
(Symbols, Ch, Descr.Mask,
Descr.String_Length, Descr.String_Min_Length, Descr.String_Max_Length);
end Validate_HexBinary;
---------------------------
-- Validate_Base64Binary --
---------------------------
function Validate_Base64Binary
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol is
begin
if not Is_Valid_Base64Binary (Ch) then
return Find (Symbols, "Invalid base64Binary: """ & Ch & """");
end if;
return Validate_Base64Binary_Facets
(Symbols, Ch, Descr.Mask,
Descr.String_Length, Descr.String_Min_Length, Descr.String_Max_Length);
end Validate_Base64Binary;
--------------------------
-- Validate_List_Facets --
--------------------------
function Validate_List_Facets
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence;
Length, Min_Length, Max_Length : Integer) return Symbol
is
function List_Get_Length
(Value : Unicode.CES.Byte_Sequence) return Natural;
function List_Get_Length
(Value : Unicode.CES.Byte_Sequence) return Natural
is
Length : Natural := 0;
C : Unicode_Char;
Index : Natural := Value'First;
begin
if Value = "" then
return 0;
end if;
while Index <= Value'Last loop
Encoding.Read (Value, Index, C);
while C = Unicode.Names.Basic_Latin.Space loop
Length := Length + 1;
Encoding.Read (Value, Index, C);
end loop;
end loop;
return Length + 1;
end List_Get_Length;
L : Natural;
begin
if Descr.Mask (Facet_Length)
or else Descr.Mask (Facet_Min_Length)
or else Descr.Mask (Facet_Max_Length)
then
L := List_Get_Length (Ch);
else
return No_Symbol;
end if;
if Descr.Mask (Facet_Length) then
if L /= Length then
return Find
(Symbols,
"Invalid size, must have"
& Integer'Image (Length) & " items");
end if;
end if;
if Descr.Mask (Facet_Min_Length) then
if L < Min_Length then
return Find
(Symbols,
"Not enough items, minimum number is"
& Integer'Image (Min_Length));
end if;
end if;
if Descr.Mask (Facet_Max_Length) then
if L > Max_Length then
return Find
(Symbols,
"Too many items, maximum number is"
& Integer'Image (Max_Length));
end if;
end if;
return No_Symbol;
end Validate_List_Facets;
-------------------
-- Boolean_Value --
-------------------
procedure Boolean_Value
(Symbols : Symbol_Table;
Ch : Byte_Sequence;
Val : out Boolean;
Error : out Symbol)
is
First : Integer;
Index : Integer;
C : Unicode_Char;
begin
Val := False;
if Ch = "" then
Error := Find (Symbols, "Invalid value for boolean type: """"");
return;
end if;
-- Check we do have a valid boolean representation (skip leading spaces)
First := Ch'First;
while First <= Ch'Last loop
Index := First;
Encoding.Read (Ch, First, C);
exit when not Is_White_Space (C);
end loop;
if C = Digit_Zero or C = Digit_One then
Val := C = Digit_One;
if First <= Ch'Last then
Encoding.Read (Ch, First, C);
end if;
elsif Index + True_Sequence'Length - 1 <= Ch'Last
and then Ch (Index .. Index + True_Sequence'Length - 1) = True_Sequence
then
First := Index + True_Sequence'Length;
Val := True;
elsif Index + False_Sequence'Length - 1 <= Ch'Last
and then Ch (Index .. Index + False_Sequence'Length - 1) =
False_Sequence
then
First := Index + False_Sequence'Length;
Val := False;
else
Error := Find
(Symbols, "Invalid value for boolean type: """ & Ch & """");
return;
end if;
-- Skip trailing spaces
while First <= Ch'Last loop
Encoding.Read (Ch, First, C);
if not Is_White_Space (C) then
Error := Find
(Symbols, "Invalid value for boolean type: """ & Ch & """");
return;
end if;
end loop;
Error := No_Symbol;
end Boolean_Value;
----------------------
-- Validate_Boolean --
----------------------
function Validate_Boolean
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol
is
pragma Unreferenced (Descr);
Val : Boolean;
Error : Symbol;
begin
Boolean_Value (Symbols, Ch, Val, Error);
if Error /= No_Symbol then
return Error;
end if;
return No_Symbol;
end Validate_Boolean;
-----------
-- Value --
-----------
procedure Value (Symbols : Symbol_Table;
Ch : Byte_Sequence;
Val : out XML_Float;
Error : out Symbol) is
begin
begin
Val := Value (Ch);
exception
when Constraint_Error =>
Error := Find (Symbols, "Invalid value: """ & Ch & """");
return;
end;
Error := No_Symbol;
end Value;
--------------------
-- Validate_Range --
--------------------
procedure Validate_Range
(Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence;
Mask : Facets_Mask;
Min_Inclusive : T;
Min_Exclusive : T;
Max_Inclusive : T;
Max_Exclusive : T;
Error : out Symbol;
Val : out T) is
begin
Value
(Symbols => Symbols,
Ch => Ch,
Val => Val,
Error => Error);
if Error /= No_Symbol then
return;
end if;
if Mask (Facet_Min_Inclusive) then
if Val < Min_Inclusive then
Error := Find
(Symbols,
Ch & " is smaller than minInclusive ("
& Image (Min_Inclusive) & ")");
return;
end if;
end if;
if Mask (Facet_Min_Exclusive) then
if Val <= Min_Exclusive then
Error := Find
(Symbols,
Ch & " is smaller than minExclusive ("
& Image (Min_Exclusive) & ")");
return;
end if;
end if;
if Mask (Facet_Max_Inclusive) then
if Max_Inclusive < Val then
Error := Find
(Symbols,
Ch & " is greater than maxInclusive ("
& Image (Max_Inclusive) & ")");
return;
end if;
end if;
if Mask (Facet_Max_Exclusive) then
if Max_Exclusive <= Val then
Error := Find
(Symbols,
Ch & " is greater than maxExclusive ("
& Image (Max_Exclusive) & ")");
return;
end if;
end if;
end Validate_Range;
procedure Validate_Double_Facets is new Validate_Range (XML_Float);
procedure Validate_Decimal_Facets is new Validate_Range
(Arbitrary_Precision_Number, Value => Value_No_Exponent);
procedure Validate_Duration_Facets is new Validate_Range (Duration_T);
procedure Validate_Date_Time_Facets is new Validate_Range (Date_Time_T);
procedure Validate_Date_Facets is new Validate_Range (Date_T);
procedure Validate_Time_Facets is new Validate_Range (Time_T);
procedure Validate_GDay_Facets is new Validate_Range (GDay_T);
procedure Validate_GMonth_Day_Facets is new Validate_Range (GMonth_Day_T);
procedure Validate_GMonth_Facets is new Validate_Range (GMonth_T);
procedure Validate_GYear_Facets is new Validate_Range (GYear_T);
procedure Validate_GYear_Month_Facets is new Validate_Range
(GYear_Month_T);
---------------------
-- Validate_Double --
---------------------
function Validate_Double
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol
is
Val : XML_Float;
Error : Symbol;
begin
Validate_Double_Facets
(Symbols, Ch, Descr.Mask, Descr.Float_Min_Inclusive,
Descr.Float_Min_Exclusive, Descr.Float_Max_Inclusive,
Descr.Float_Max_Exclusive, Error, Val);
return Error;
end Validate_Double;
-----------------------
-- Validate_Duration --
-----------------------
function Validate_Duration
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol
is
Val : Duration_T;
Error : Symbol;
begin
Validate_Duration_Facets
(Symbols, Ch, Descr.Mask,
Descr.Duration_Min_Inclusive, Descr.Duration_Min_Exclusive,
Descr.Duration_Max_Inclusive, Descr.Duration_Max_Exclusive,
Error, Val);
return Error;
end Validate_Duration;
------------------------
-- Validate_Date_Time --
------------------------
function Validate_Date_Time
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol
is
Val : Date_Time_T;
Error : Symbol;
begin
Validate_Date_Time_Facets
(Symbols, Ch, Descr.Mask,
Descr.DateTime_Min_Inclusive, Descr.DateTime_Min_Exclusive,
Descr.DateTime_Max_Inclusive, Descr.DateTime_Max_Exclusive,
Error, Val);
return Error;
end Validate_Date_Time;
-------------------
-- Validate_Date --
-------------------
function Validate_Date
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol
is
Val : Date_T;
Error : Symbol;
begin
Validate_Date_Facets
(Symbols, Ch, Descr.Mask,
Descr.Date_Min_Inclusive, Descr.Date_Min_Exclusive,
Descr.Date_Max_Inclusive, Descr.Date_Max_Exclusive,
Error, Val);
return Error;
end Validate_Date;
-------------------
-- Validate_Time --
-------------------
function Validate_Time
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol
is
Val : Time_T;
Error : Symbol;
begin
Validate_Time_Facets
(Symbols, Ch, Descr.Mask,
Descr.Time_Min_Inclusive, Descr.Time_Min_Exclusive,
Descr.Time_Max_Inclusive, Descr.Time_Max_Exclusive,
Error, Val);
return Error;
end Validate_Time;
-------------------
-- Validate_GDay --
-------------------
function Validate_GDay
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol
is
Val : GDay_T;
Error : Symbol;
begin
Validate_GDay_Facets
(Symbols, Ch, Descr.Mask,
Descr.GDay_Min_Inclusive, Descr.GDay_Min_Exclusive,
Descr.GDay_Max_Inclusive, Descr.GDay_Max_Exclusive,
Error, Val);
return Error;
end Validate_GDay;
-------------------------
-- Validate_GMonth_Day --
-------------------------
function Validate_GMonth_Day
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol
is
Val : GMonth_Day_T;
Error : Symbol;
begin
Validate_GMonth_Day_Facets
(Symbols, Ch, Descr.Mask,
Descr.GMonthDay_Min_Inclusive, Descr.GMonthDay_Min_Exclusive,
Descr.GMonthDay_Max_Inclusive, Descr.GMonthDay_Max_Exclusive,
Error, Val);
return Error;
end Validate_GMonth_Day;
---------------------
-- Validate_GMonth --
---------------------
function Validate_GMonth
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol
is
Val : GMonth_T;
Error : Symbol;
begin
Validate_GMonth_Facets
(Symbols, Ch, Descr.Mask,
Descr.GMonth_Min_Inclusive, Descr.GMonth_Min_Exclusive,
Descr.GMonth_Max_Inclusive, Descr.GMonth_Max_Exclusive,
Error, Val);
return Error;
end Validate_GMonth;
--------------------
-- Validate_GYear --
--------------------
function Validate_GYear
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol
is
Val : GYear_T;
Error : Symbol;
begin
Validate_GYear_Facets
(Symbols, Ch, Descr.Mask,
Descr.GYear_Min_Inclusive, Descr.GYear_Min_Exclusive,
Descr.GYear_Max_Inclusive, Descr.GYear_Max_Exclusive,
Error, Val);
return Error;
end Validate_GYear;
--------------------------
-- Validate_GYear_Month --
--------------------------
function Validate_GYear_Month
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol
is
Val : GYear_Month_T;
Error : Symbol;
begin
Validate_GYear_Month_Facets
(Symbols, Ch, Descr.Mask,
Descr.GYearMonth_Min_Inclusive, Descr.GYearMonth_Min_Exclusive,
Descr.GYearMonth_Max_Inclusive, Descr.GYearMonth_Max_Exclusive,
Error, Val);
return Error;
end Validate_GYear_Month;
----------------------
-- Validate_Decimal --
----------------------
function Validate_Decimal
(Descr : Simple_Type_Descr;
Symbols : Sax.Utils.Symbol_Table;
Ch : Unicode.CES.Byte_Sequence) return Symbol
is
Error : Symbol;
Val : Arbitrary_Precision_Number;
begin
Validate_Decimal_Facets
(Symbols, Ch, Descr.Mask,
Descr.Decimal_Min_Inclusive, Descr.Decimal_Min_Exclusive,
Descr.Decimal_Max_Inclusive, Descr.Decimal_Max_Exclusive,
Error, Val);
if Error /= No_Symbol then
return Error;
end if;
return Check_Digits
(Symbols => Symbols,
Num => Val,
Fraction_Digits => Descr.Fraction_Digits,
Total_Digits => Descr.Total_Digits);
end Validate_Decimal;
--------------------
-- Convert_Regexp --
--------------------
function Convert_Regexp
(Regexp : Unicode.CES.Byte_Sequence) return String
is
Result : Unbounded_String;
Tmp : Unbounded_String;
Pos : Integer := Regexp'First;
C : Character;
function Next_Char return Character;
-- Read the next char from the regexp, and check it is ASCII
function Next_Char return Character is
Char : Unicode_Char;
begin
Encoding.Read (Regexp, Pos, Char);
if Char > 127 then
Raise_Exception
(XML_Not_Implemented'Identity,
"Unicode regexps are not supported");
end if;
return Character'Val (Integer (Char));
end Next_Char;
begin
while Pos <= Regexp'Last loop
C := Next_Char;
if C = '[' then
Append (Result, C);
Tmp := Null_Unbounded_String;
while Pos <= Regexp'Last loop
C := Next_Char;
if C = ']' then
Append (Tmp, C);
exit;
elsif C = '\' and then Pos <= Regexp'Last then
C := Next_Char;
case C is
when 'i' =>
-- rule [99] in XMLSchema specifications
Append (Tmp, "A-Za-z:_");
when 'c' =>
Append (Tmp, "a-z:A-Z0-9._\-");
-- `-` is a special syntax character inside character
-- class expression, so escape it.
when 'w' =>
Append (Tmp, "a-zA-Z0-9`");
when 'I' | 'C' =>
Raise_Exception
(XML_Not_Implemented'Identity,
"Unsupported regexp construct: \" & C);
when 'P' | 'p' =>
if Pos <= Regexp'Last
and then Regexp (Pos) = '{'
then
Raise_Exception
(XML_Not_Implemented'Identity,
"Unsupported regexp construct: \P{...}");
else
Append (Tmp, '\' & C);
end if;
when others =>
Append (Tmp, '\' & C);
end case;
else
if C = '-'
and then Pos <= Regexp'Last
and then Regexp (Pos) = '['
then
Raise_Exception
(XML_Not_Implemented'Identity,
"Unsupported regexp construct: [...-[...]]");
end if;
Append (Tmp, C);
end if;
end loop;
Append (Result, Tmp);
-- ??? Some tests in the old w3c testsuite seem to imply that
-- \c and \i are valid even outside character classes. Not sure about
-- this though
elsif C = '\' and then Pos <= Regexp'Last then
C := Next_Char;
case C is
when 'i' =>
-- rule [99] in XMLSchema specifications
Append (Result, "[A-Za-z:_]");
when 'c' =>
Append (Result, "[a-z:A-Z0-9._-]");
when 'w' =>
Append (Result, "[a-zA-Z0-9`]");
when 'I' | 'C' =>
Raise_Exception
(XML_Not_Implemented'Identity,
"Unsupported regexp construct: \" & C);
when 'P' | 'p' =>
if Pos <= Regexp'Last
and then Regexp (Pos) = '{'
then
Raise_Exception
(XML_Not_Implemented'Identity,
"Unsupported regexp construct: \P{...}");
else
Append (Result, '\' & C);
end if;
when others =>
Append (Result, '\' & C);
end case;
else
Append (Result, C);
end if;
end loop;
return Anchor (To_String (Result));
end Convert_Regexp;
------------------------
-- Missing_End_Anchor --
------------------------
function Missing_End_Anchor (Str : String) return Boolean is
begin
-- Do not add '$' if Str ends with a single \, since it is
-- invalid anyway
return Str'Length = 0
or else
(Str (Str'Last) /= '$'
and then (Str (Str'Last) /= '\'
or else (Str'Length /= 1
and then Str (Str'Last - 1) = '\')));
end Missing_End_Anchor;
--------------------------
-- Missing_Start_Anchor --
--------------------------
function Missing_Start_Anchor (Str : String) return Boolean is
begin
-- Do not add '^' if we start with an operator, since Str is invalid
return Str'Length = 0
or else not (Str (Str'First) = '^'
or else Str (Str'First) = '*'
or else Str (Str'First) = '+'
or else Str (Str'First) = '?');
end Missing_Start_Anchor;
------------
-- Anchor --
------------
function Anchor (Str : String) return String is
Start : constant Boolean := Missing_Start_Anchor (Str);
Last : constant Boolean := Missing_End_Anchor (Str);
begin
if Start and Last then
return "^(" & Str & ")$";
elsif Start then
return "^" & Str;
elsif Last then
return Str & "$";
else
return Str;
end if;
end Anchor;
---------------
-- Add_Facet --
---------------
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)
is
Val : Symbol;
begin
if Get (Facet_Name).all = "pattern" then
-- Do not normalize the value
if Facets (Facet_Pattern).Value /= No_Symbol then
Facets (Facet_Pattern) :=
(Find
(Symbols,
'(' & Get (Facets (Facet_Pattern).Value).all
& ")|(" & Get (Value).all & ')'),
No_Enumeration_Index, Loc);
else
Facets (Facet_Pattern) := (Value, No_Enumeration_Index, Loc);
end if;
return;
end if;
Val := Find
(Symbols, Trim (Get (Value).all, Ada.Strings.Both));
if Get (Facet_Name).all = "whiteSpace" then
Facets (Facet_Whitespace) := (Val, No_Enumeration_Index, Loc);
elsif Get (Facet_Name).all = "enumeration" then
Append (Enumerations, (Value => Val,
Next => Facets (Facet_Enumeration).Enum));
Facets (Facet_Enumeration) := (No_Symbol, Last (Enumerations), Loc);
elsif Get (Facet_Name).all = "minInclusive" then
Facets (Facet_Min_Inclusive) := (Val, No_Enumeration_Index, Loc);
elsif Get (Facet_Name).all = "maxInclusive" then
Facets (Facet_Max_Inclusive) := (Val, No_Enumeration_Index, Loc);
elsif Get (Facet_Name).all = "minExclusive" then
Facets (Facet_Min_Exclusive) := (Val, No_Enumeration_Index, Loc);
elsif Get (Facet_Name).all = "maxExclusive" then
Facets (Facet_Max_Exclusive) := (Val, No_Enumeration_Index, Loc);
elsif Get (Facet_Name).all = "length" then
Facets (Facet_Length) := (Val, No_Enumeration_Index, Loc);
elsif Get (Facet_Name).all = "minLength" then
Facets (Facet_Min_Length) := (Val, No_Enumeration_Index, Loc);
elsif Get (Facet_Name).all = "maxLength" then
Facets (Facet_Max_Length) := (Val, No_Enumeration_Index, Loc);
elsif Get (Facet_Name).all = "totalDigits" then
Facets (Facet_Total_Digits) := (Val, No_Enumeration_Index, Loc);
elsif Get (Facet_Name).all = "fractionDigits" then
Facets (Facet_Fraction_Digits) := (Val, No_Enumeration_Index, Loc);
else
pragma Assert (False, "Invalid facet:");
null;
end if;
end Add_Facet;
---------------------------------
-- Override_Single_Range_Facet --
---------------------------------
procedure Override_Single_Range_Facet
(Symbols : Sax.Utils.Symbol_Table;
Facets : All_Facets;
Facet : Facet_Enum;
Mask : in out Facets_Mask;
Val : in out T;
Error : in out Symbol;
Error_Loc : in out Location) is
begin
if Error = No_Symbol and then Facets (Facet) /= No_Facet_Value then
Value
(Symbols,
Ch => Get (Facets (Facet).Value).all,
Val => Val,
Error => Error);
if Error /= No_Symbol then
Error_Loc := Facets (Facet).Loc;
else
Mask (Facet) := True;
end if;
end if;
end Override_Single_Range_Facet;
---------------------------
-- Override_Range_Facets --
---------------------------
procedure Override_Range_Facets
(Symbols : Sax.Utils.Symbol_Table;
Facets : All_Facets;
Mask : in out Facets_Mask;
Min_Inclusive : in out T;
Min_Exclusive : in out T;
Max_Inclusive : in out T;
Max_Exclusive : in out T;
Error : out Symbol;
Error_Loc : out Location)
is
procedure Do_Override is new Override_Single_Range_Facet (T, Value);
begin
Do_Override (Symbols, Facets, Facet_Max_Inclusive, Mask,
Max_Inclusive, Error, Error_Loc);
Do_Override (Symbols, Facets, Facet_Max_Exclusive, Mask,
Max_Exclusive, Error, Error_Loc);
Do_Override (Symbols, Facets, Facet_Min_Inclusive, Mask,
Min_Inclusive, Error, Error_Loc);
Do_Override (Symbols, Facets, Facet_Min_Exclusive, Mask,
Min_Exclusive, Error, Error_Loc);
end Override_Range_Facets;
procedure Override_Decimal_Facets
is new Override_Range_Facets (Arbitrary_Precision_Number);
procedure Override_Float_Facets is new Override_Range_Facets (XML_Float);
procedure Override_Duration_Facets
is new Override_Range_Facets (Duration_T);
procedure Override_Date_Time_Facets
is new Override_Range_Facets (Date_Time_T);
procedure Override_Date_Facets is new Override_Range_Facets (Date_T);
procedure Override_Time_Facets is new Override_Range_Facets (Time_T);
procedure Override_GDay_Facets is new Override_Range_Facets (GDay_T);
procedure Override_GMonth_Day_Facets
is new Override_Range_Facets (GMonth_Day_T);
procedure Override_GMonth_Facets is new Override_Range_Facets (GMonth_T);
procedure Override_GYear_Facets is new Override_Range_Facets (GYear_T);
procedure Override_GYear_Month_Facets
is new Override_Range_Facets (GYear_Month_T);
----------------------------
-- Override_Length_Facets --
----------------------------
procedure Override_Length_Facets
(Symbols : Sax.Utils.Symbol_Table;
Facets : All_Facets;
Mask : in out Facets_Mask;
Length : in out Integer;
Min_Length : in out Integer;
Max_Length : in out Integer;
Error : out Symbol;
Error_Loc : out Location)
is
begin
if Facets (Facet_Length) /= No_Facet_Value then
begin
Length := Natural'Value
(Get (Facets (Facet_Length).Value).all);
Mask (Facet_Length) := True;
exception
when Constraint_Error =>
Error := Find
(Symbols, "Expecting integer for length facet");
Error_Loc := Facets (Facet_Length).Loc;
end;
end if;
if Facets (Facet_Min_Length) /= No_Facet_Value then
begin
Min_Length := Natural'Value
(Get (Facets (Facet_Min_Length).Value).all);
Mask (Facet_Min_Length) := True;
exception
when Constraint_Error =>
Error := Find
(Symbols, "Expecting integer for minLength facet");
Error_Loc := Facets (Facet_Min_Length).Loc;
end;
end if;
if Facets (Facet_Max_Length) /= No_Facet_Value then
begin
Max_Length := Natural'Value
(Get (Facets (Facet_Max_Length).Value).all);
Mask (Facet_Max_Length) := True;
exception
when Constraint_Error =>
Error := Find
(Symbols, "Expecting integer for maxlength facet");
Error_Loc := Facets (Facet_Max_Length).Loc;
end;
end if;
end Override_Length_Facets;
--------------
-- Override --
--------------
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)
is
function Compile_Regexp (Str : Symbol) return Pattern_Matcher_Access;
function Compile_Regexp (Str : Symbol) return Pattern_Matcher_Access is
Convert : constant String := Convert_Regexp (Get (Str).all);
begin
if Debug then
Debug_Output ("Compiling regexp as " & Convert);
end if;
return new Pattern_Matcher'(Compile (Convert));
exception
when GNAT.Regpat.Expression_Error =>
Error_Loc := Facets (Facet_Pattern).Loc;
Error := Find
(Symbols,
"Invalid regular expression "
& Get (Str).all & " (converted to " & Convert & ")");
return null;
end Compile_Regexp;
Val : Symbol;
Tmp : Pattern_Matcher_Array_Access;
begin
if Facets (Facet_Whitespace) /= No_Facet_Value then
Val := Facets (Facet_Whitespace).Value;
if Get (Val).all = "preserve" then
Simple.Whitespace := Preserve;
elsif Get (Val).all = "replace" then
Simple.Whitespace := Replace;
elsif Get (Val).all = "collapse" then
Simple.Whitespace := Collapse;
else
Error_Loc := Facets (Facet_Whitespace).Loc;
Error := Find (Symbols, "Invalid value for whiteSpace facet: "
& Get (Val).all);
return;
end if;
Simple.Mask (Facet_Whitespace) := True;
end if;
if Facets (Facet_Pattern) /= No_Facet_Value then
Val := Facets (Facet_Pattern).Value;
begin
if As_Restriction then
-- We must match all patterns (from base and from extension),
-- and we cannot combine them. So we need to add one more
-- pattern to the facets.
-- [Simple] is a copy of the base type, and will be the new
-- restriction on exit.
if Simple.Pattern = null then
Simple.Pattern := new Pattern_Matcher_Array (1 .. 1);
else
Tmp := Simple.Pattern;
Simple.Pattern :=
new Pattern_Matcher_Array (Tmp'First .. Tmp'Last + 1);
Simple.Pattern (Tmp'Range) := Tmp.all;
Unchecked_Free (Tmp);
end if;
Simple.Pattern (Simple.Pattern'Last) :=
(Str => Val,
Pattern => Compile_Regexp (Val));
else
-- We must combine the base's patterns with the extension's
-- pattern, since the type must match either of those.
-- The number of patterns does not change
if Simple.Pattern = null then
Simple.Pattern := new Pattern_Matcher_Array'
(1 => (Str => Val, Pattern => Compile_Regexp (Val)));
else
for P in Simple.Pattern'Range loop
Simple.Pattern (P).Str := Find
(Symbols,
'(' & Get (Simple.Pattern (P).Str).all
& ")|(" & Get (Val).all & ')');
Unchecked_Free (Simple.Pattern (P).Pattern);
Simple.Pattern (P).Pattern :=
Compile_Regexp (Simple.Pattern (P).Str);
end loop;
end if;
end if;
exception
when E : XML_Not_Implemented =>
Error := Find (Symbols, '#' & Exception_Message (E));
Free (Simple.Pattern);
end;
if Error /= No_Symbol then
Error_Loc := Facets (Facet_Pattern).Loc;
return;
end if;
Simple.Mask (Facet_Pattern) := True;
end if;
if Facets (Facet_Enumeration) /= No_Facet_Value then
Simple.Enumeration := Facets (Facet_Enumeration).Enum;
Simple.Mask (Facet_Enumeration) := True;
end if;
Error := No_Symbol;
case Simple.Kind is
when Primitive_Union =>
null;
when Primitive_List =>
Override_Length_Facets
(Symbols, Facets, Simple.Mask,
Simple.List_Length, Simple.List_Min_Length,
Simple.List_Max_Length, Error, Error_Loc);
when Primitive_String .. Primitive_HexBinary =>
Override_Length_Facets
(Symbols, Facets, Simple.Mask,
Simple.String_Length, Simple.String_Min_Length,
Simple.String_Max_Length, Error, Error_Loc);
when Primitive_Boolean =>
null;
when Primitive_Float | Primitive_Double =>
Override_Float_Facets
(Symbols, Facets, Simple.Mask,
Simple.Float_Min_Inclusive, Simple.Float_Min_Exclusive,
Simple.Float_Max_Inclusive, Simple.Float_Max_Exclusive,
Error, Error_Loc);
when Primitive_Decimal =>
Override_Decimal_Facets
(Symbols, Facets, Simple.Mask,
Simple.Decimal_Min_Inclusive, Simple.Decimal_Min_Exclusive,
Simple.Decimal_Max_Inclusive, Simple.Decimal_Max_Exclusive,
Error, Error_Loc);
if Error = No_Symbol then
if Facets (Facet_Total_Digits) /= No_Facet_Value then
begin
Simple.Total_Digits := Positive'Value
(Get (Facets (Facet_Total_Digits).Value).all);
Simple.Mask (Facet_Total_Digits) := True;
exception
when Constraint_Error =>
Error := Find
(Symbols, "Expecting integer for totalDigits facet");
Error_Loc := Facets (Facet_Total_Digits).Loc;
end;
end if;
if Facets (Facet_Fraction_Digits) /= No_Facet_Value then
begin
Simple.Fraction_Digits := Natural'Value
(Get (Facets (Facet_Fraction_Digits).Value).all);
Simple.Mask (Facet_Fraction_Digits) := True;
exception
when Constraint_Error =>
Error := Find
(Symbols,
"Expecting integer for fractionDigits facet");
Error_Loc := Facets (Facet_Fraction_Digits).Loc;
end;
end if;
if Simple.Fraction_Digits /= Natural'Last
and then Simple.Total_Digits /= Positive'Last
and then Simple.Fraction_Digits > Simple.Total_Digits
then
Error_Loc := Facets (Facet_Fraction_Digits).Loc;
Error := Find
(Symbols,
"fractionDigits cannot be greater than totalDigits");
end if;
end if;
when Primitive_Time =>
Override_Time_Facets
(Symbols, Facets, Simple.Mask,
Simple.Time_Min_Inclusive, Simple.Time_Min_Exclusive,
Simple.Time_Max_Inclusive, Simple.Time_Max_Exclusive,
Error, Error_Loc);
when Primitive_DateTime =>
Override_Date_Time_Facets
(Symbols, Facets, Simple.Mask,
Simple.DateTime_Min_Inclusive, Simple.DateTime_Min_Exclusive,
Simple.DateTime_Max_Inclusive, Simple.DateTime_Max_Exclusive,
Error, Error_Loc);
when Primitive_GDay =>
Override_GDay_Facets
(Symbols, Facets, Simple.Mask,
Simple.GDay_Min_Inclusive, Simple.GDay_Min_Exclusive,
Simple.GDay_Max_Inclusive, Simple.GDay_Max_Exclusive,
Error, Error_Loc);
when Primitive_GMonthDay =>
Override_GMonth_Day_Facets
(Symbols, Facets, Simple.Mask,
Simple.GMonthDay_Min_Inclusive, Simple.GMonthDay_Min_Exclusive,
Simple.GMonthDay_Max_Inclusive, Simple.GMonthDay_Max_Exclusive,
Error, Error_Loc);
when Primitive_GMonth =>
Override_GMonth_Facets
(Symbols, Facets, Simple.Mask,
Simple.GMonth_Min_Inclusive, Simple.GMonth_Min_Exclusive,
Simple.GMonth_Max_Inclusive, Simple.GMonth_Max_Exclusive,
Error, Error_Loc);
when Primitive_GYearMonth =>
Override_GYear_Month_Facets
(Symbols, Facets, Simple.Mask,
Simple.GYearMonth_Min_Inclusive,
Simple.GYearMonth_Min_Exclusive,
Simple.GYearMonth_Max_Inclusive,
Simple.GYearMonth_Max_Exclusive,
Error, Error_Loc);
when Primitive_GYear =>
Override_GYear_Facets
(Symbols, Facets, Simple.Mask,
Simple.GYear_Min_Inclusive, Simple.GYear_Min_Exclusive,
Simple.GYear_Max_Inclusive, Simple.GYear_Max_Exclusive,
Error, Error_Loc);
when Primitive_Date =>
Override_Date_Facets
(Symbols, Facets, Simple.Mask,
Simple.Date_Min_Inclusive, Simple.Date_Min_Exclusive,
Simple.Date_Max_Inclusive, Simple.Date_Max_Exclusive,
Error, Error_Loc);
when Primitive_Duration =>
Override_Duration_Facets
(Symbols, Facets, Simple.Mask,
Simple.Duration_Min_Inclusive, Simple.Duration_Min_Exclusive,
Simple.Duration_Max_Inclusive, Simple.Duration_Max_Exclusive,
Error, Error_Loc);
end case;
-- ??? Should detect unused facets and report errors
end Override;
--------------------------
-- Normalize_Whitespace --
--------------------------
procedure Normalize_Whitespace
(Whitespace : Schema.Simple_Types.Whitespace_Restriction;
Val : in out Unicode.CES.Byte_Sequence;
Last : in out Natural)
is
begin
case Whitespace is
when Preserve =>
return; -- Nothing to do
when Replace =>
declare
Idx : Natural := Val'First;
First : Natural := Last + 1;
C : Unicode_Char;
begin
while Idx <= Last loop
First := Idx;
Encoding.Read (Val, Idx, C);
if Is_White_Space (C) then
-- Assumes all characters we replace are encoded as
-- single byte
Val (First) := ' ';
end if;
end loop;
-- Length of string does not change
end;
when Collapse =>
if Val = "" then
return; -- nothing to do
end if;
declare
C : Unicode_Char;
Idx, Idx_Output : Natural := Val'First;
First : Natural := Last + 1;
Tmp : Natural;
Last_Space : Natural := Last + 1;
Prev_Is_Whitespace : Boolean := False;
begin
-- Remove leading spaces.
loop
First := Idx;
Encoding.Read (Val, Idx, C);
exit when not Is_White_Space (C);
if Idx > Last then
Last := 0;
return; -- Empty string
end if;
end loop;
if First /= Val'First then
Val (Val'First .. Last - First + Val'First) :=
Val (First .. Last);
Last := Last - First + Val'First;
end if;
Idx := Val'First;
Idx_Output := Val'First;
-- Iterate and replace all whitespaces. Mark the spot of the
-- last whitespace so that we can ignore trailing spaces.
-- At the same time, we can copy to Idx_Output, since the
-- output string will always be at least as short as Val.
while Idx <= Last loop
Tmp := Idx;
Encoding.Read (Val, Idx, C);
-- Copy, if needed, the character we just read
if Is_White_Space (C) then
if not Prev_Is_Whitespace then
Val (Idx_Output) := ' ';
Last_Space := Idx_Output;
Idx_Output := Idx_Output + 1;
Prev_Is_Whitespace := True;
end if;
else
Val (Idx_Output .. Idx_Output + Idx - Tmp - 1) :=
Val (Tmp .. Idx - 1);
Idx_Output := Idx_Output + Idx - Tmp;
Last_Space := Idx_Output; -- after this char
Prev_Is_Whitespace := False;
end if;
end loop;
-- Now skip trailing whitespaces if any
Last := Last_Space - 1;
end;
end case;
end Normalize_Whitespace;
----------
-- Copy --
----------
function Copy (Descr : Simple_Type_Descr) return Simple_Type_Descr is
Result : Simple_Type_Descr := Descr;
begin
if Descr.Pattern /= null then
Result.Pattern := new Pattern_Matcher_Array (Descr.Pattern'Range);
for P in Descr.Pattern'Range loop
Result.Pattern (P) :=
(Str => Descr.Pattern (P).Str,
Pattern => new Pattern_Matcher'(Descr.Pattern (P).Pattern.all));
end loop;
end if;
return Result;
end Copy;
----------
-- Free --
----------
procedure Free (Arr : in out Pattern_Matcher_Array_Access) is
begin
if Arr /= null then
for A in Arr'Range loop
Unchecked_Free (Arr (A).Pattern);
end loop;
Unchecked_Free (Arr);
end if;
end Free;
-------------
-- Get_Key --
-------------
function Get_Key (Id : Symbol) return Symbol is
begin
return Id;
end Get_Key;
----------
-- Free --
----------
procedure Free (Symbol_Table : in out Symbol_Htable_Access) is
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(Symbol_Htable.HTable, Symbol_Htable_Access);
begin
if Symbol_Table /= null then
Symbol_Htable.Reset (Symbol_Table.all);
Unchecked_Free (Symbol_Table);
end if;
end Free;
--------------
-- Check_Id --
--------------
procedure Check_Id
(Symbols : Symbol_Table;
Id_Table : in out Symbol_Htable_Access;
Value : Unicode.CES.Byte_Sequence;
Error : in out Symbol)
is
Val : constant Symbol := Find (Symbols, Value);
begin
if Id_Table = null then
Id_Table := new Symbol_Htable.HTable (101);
else
if Symbol_Htable.Get (Id_Table.all, Val) /= No_Symbol then
Error := Find (Symbols, "ID """ & Value & """ already defined");
return;
end if;
end if;
Symbol_Htable.Set (Id_Table.all, Val);
Error := No_Symbol;
end Check_Id;
end Schema.Simple_Types;
Reference in New Issue View Git Blame Copy Permalink