1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
|
------------------------------------------------------------------------------
-- XML/Ada - An XML suite for Ada95 --
-- --
-- Copyright (C) 2010-2017, 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 --
-- <http://www.gnu.org/licenses/>. --
-- --
------------------------------------------------------------------------------
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;
|
