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
github/pull/13
xmlada/schema/schema-schema_readers.adb
Valentine Reboul 1c7ee7d95d [PA07-083][Q831-010] cleanup of ineffective use-clauses 
Change-Id: I351103d11afd53b4c8c264a2e9df9711df8d35a0
2017-09-14 12:41:38 +02:00

4075 lines
141 KiB
Ada
Raw Permalink Blame History

------------------------------------------------------------------------------
-- XML/Ada - An XML suite for Ada95 --
-- --
-- Copyright (C) 2004-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. --
-- --
-- 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.Exceptions; use Ada.Exceptions;
with GNAT.Task_Lock; use GNAT.Task_Lock;
with Unicode; use Unicode;
with Unicode.CES; use Unicode.CES;
with Sax.Encodings; use Sax.Encodings;
with Sax.Exceptions; use Sax.Exceptions;
with Sax.Locators; use Sax.Locators;
with Sax.Symbols; use Sax.Symbols;
with Sax.Utils; use Sax.Utils;
with Schema.Simple_Types; use Schema.Simple_Types;
with Schema.Readers; use Schema.Readers;
with Ada.Unchecked_Deallocation;
with Ada.IO_Exceptions;
with Input_Sources.File; use Input_Sources.File;
package body Schema.Schema_Readers is
use Schema_State_Machines;
use Type_Tables, Element_HTables, Group_HTables;
use AttrGroup_HTables, Reference_HTables, Attribute_HTables;
Default_Contexts : constant := 30;
-- Default number of nested levels in a schema.
-- If the actual schema uses more, we will simply reallocate some memory.
Max_Max_Occurs : constant := 9_999;
-- Maximum value for maxOccurs.
-- Higher values result in an explosion in the number of states in the NFA,
-- so should not be used for now.
Max_Occurs_Warn : constant := 300;
-- Warn when maxOccurs is greater than this value, since this might
-- potentially result in a very large state machine. This is not a fatal
-- error though.
procedure Push_Context
(Handler : access Schema_Reader'Class; Ctx : Context);
-- Add a new context to the list
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(Attr_Array, Attr_Array_Access);
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(Context_Array, Context_Array_Access);
procedure Free (Shared : in out XSD_Data_Access);
-- Free [Shared] and its htables
procedure Free (Self : in out Type_Details_Access);
-- Free [Self], [Self.Next] and so on
procedure Create_NFA (Parser : access Schema_Reader);
-- Create the state machine from the registered elements and types
-- Return the start state for the current grammar (we do not use the
-- NFA's default start state, since each grammar has its own list of valid
-- toplevel elements.
function To_String (Final : Final_Status) return String;
function In_Redefine_Context
(Handler : Schema_Reader'Class) return Boolean;
-- Whether we are currently processing a <redefine> tag
function Resolve_QName
(Handler : access Schema_Reader'Class;
QName : Sax.Symbols.Symbol;
NS_If_Empty : Sax.Symbols.Symbol := Empty_String;
Loc : Location) return Qualified_Name;
-- Resolve namespaces for QName.
-- [NS_If_Empty] is used if no namespace was found for the element. This
-- will often be the target namespace of the schema.
procedure Internal_Parse
(Parser : in out Schema_Reader;
Input : in out Input_Sources.Input_Source'Class;
Default_Namespace : Symbol;
Do_Create_NFA : Boolean;
Do_Initialize_Shared : Boolean);
-- Internal version of [Parse], which allows reuse of the shared data.
-- This is useful while parsing a <include> XSD
procedure Insert_In_Type
(Handler : access Schema_Reader'Class;
Element : in out Type_Details_Access);
-- Insert Element in the type definition in [Handler.Contexts].
-- If there is an error inserting the element, an exception is raised and
-- [Element] is freed.
procedure Prepare_Type
(Handler : access Schema_Reader'Class;
Atts : Sax_Attribute_List;
Is_Simple : Boolean);
-- Prepare a type context (simpleType or complexType)
procedure Add_Type_Member
(Handler : access Schema_Reader'Class;
List : in out Type_Member_Array;
Member : Type_Member;
Loc : Location);
-- Add a new item in [List], and raise an exception if [List] is full.
procedure Compute_Blocks
(Atts : Sax_Attribute_List;
Handler : access Schema_Reader'Class;
Blocks : out Block_Status;
Is_Set : out Boolean;
Index : Integer);
-- Compute the list of blocked elements from the attribute "block".
function Compute_Final
(Atts : Sax_Attribute_List;
Handler : access Schema_Reader'Class;
Index : Integer) return Final_Status;
-- Compute the list of final attributes from value. Value is a list similar
-- to what is used for the "final" attribute of elements in a schema
function Compute_Form
(Atts : Sax_Attribute_List;
Handler : access Schema_Reader'Class;
Index : Integer) return Form_Type;
-- Parse the given attribute
procedure Append (List : in out Attr_Array_Access; Attr : Attr_Descr);
-- Add an attribute to the list
procedure Insert_Attribute
(Handler : access Schema_Reader'Class;
In_Context : Natural;
Attribute : Attr_Descr);
-- Insert attribute at the right location in In_Context.
function Process_Contents_From_Atts
(Handler : access Schema_Reader'Class;
Atts : Sax_Attribute_List;
Index : Integer) return Process_Contents_Type;
-- Get the value of processContents from the attributes
procedure Create_Element
(Handler : access Schema_Reader'Class; Atts : Sax_Attribute_List);
procedure Create_Notation
(Handler : access Schema_Reader'Class; Atts : Sax_Attribute_List);
procedure Create_Complex_Type
(Handler : access Schema_Reader'Class; Atts : Sax_Attribute_List);
procedure Create_Simple_Type
(Handler : access Schema_Reader'Class; Atts : Sax_Attribute_List);
procedure Create_Restriction
(Handler : access Schema_Reader'Class; Atts : Sax_Attribute_List);
procedure Create_All
(Handler : access Schema_Reader'Class; Atts : Sax_Attribute_List);
procedure Create_Sequence
(Handler : access Schema_Reader'Class; Atts : Sax_Attribute_List);
procedure Create_Attribute
(Handler : access Schema_Reader'Class; Atts : Sax_Attribute_List);
procedure Create_Schema
(Handler : access Schema_Reader'Class; Atts : Sax_Attribute_List);
procedure Create_Extension
(Handler : access Schema_Reader'Class; Atts : Sax_Attribute_List);
procedure Create_List
(Handler : access Schema_Reader'Class; Atts : Sax_Attribute_List);
procedure Create_Union
(Handler : access Schema_Reader'Class; Atts : Sax_Attribute_List);
procedure Create_Choice
(Handler : access Schema_Reader'Class; Atts : Sax_Attribute_List);
procedure Create_Redefine
(Handler : access Schema_Reader'Class; Atts : Sax_Attribute_List);
procedure Create_Include
(Handler : access Schema_Reader'Class; Atts : Sax_Attribute_List);
procedure Create_Group
(Handler : access Schema_Reader'Class; Atts : Sax_Attribute_List);
procedure Create_Attribute_Group
(Handler : access Schema_Reader'Class; Atts : Sax_Attribute_List);
procedure Create_Any
(Handler : access Schema_Reader'Class; Atts : Sax_Attribute_List);
procedure Create_Import
(Handler : access Schema_Reader'Class; Atts : Sax_Attribute_List);
procedure Create_Any_Attribute
(Handler : access Schema_Reader'Class; Atts : Sax_Attribute_List);
-- Create a new context for a specific tag:
-- resp. <element>, <complexType>, <restriction>, <all>, <sequence>,
-- <attribute>, <schema>, <extension>, <list>, <union>, <choice>,
-- <redefine>, <group>, <attributeGroup>, <any>, <import>, <anyAttribute>
procedure Finish_Element (Handler : access Schema_Reader'Class);
procedure Finish_Complex_Type (Handler : access Schema_Reader'Class);
procedure Finish_Simple_Type (Handler : access Schema_Reader'Class);
procedure Finish_Restriction (Handler : access Schema_Reader'Class);
procedure Finish_Extension (Handler : access Schema_Reader'Class);
procedure Finish_Attribute (Handler : access Schema_Reader'Class);
procedure Finish_Union (Handler : access Schema_Reader'Class);
procedure Finish_List (Handler : access Schema_Reader'Class);
procedure Finish_Group (Handler : access Schema_Reader'Class);
procedure Finish_Attribute_Group (Handler : access Schema_Reader'Class);
-- Finish the handling of various tags:
-- resp. <element>, <complexType>, <restriction>, <all>, <sequence>,
-- <extension>, <union>, <list>, <choice>, <group>
procedure Get_Occurs
(Handler : access Schema_Reader'Class;
Atts : Sax_Attribute_List;
Min_Occurs, Max_Occurs : out Occurrences);
-- Get the "minOccurs" and "maxOccurs" attributes
---------------
-- To_String --
---------------
function To_String (Final : Final_Status) return String is
begin
return "restr=" & Final (Final_Restriction)'Img
& " ext=" & Final (Final_Extension)'Img
& " union=" & Final (Final_Union)'Img
& " list=" & Final (Final_List)'Img;
end To_String;
-------------------------
-- In_Redefine_Context --
-------------------------
function In_Redefine_Context
(Handler : Schema_Reader'Class) return Boolean is
begin
for J in 1 .. Handler.Contexts_Last loop
if Handler.Contexts (J).Typ = Context_Redefine then
return True;
end if;
end loop;
return False;
end In_Redefine_Context;
----------------
-- Create_NFA --
----------------
procedure Create_NFA (Parser : access Schema_Reader) is
NFA : constant Schema_NFA_Access := Get_NFA (Get_Grammar (Parser.all));
Ref : constant Reference_HTable :=
Get_References (Get_Grammar (Parser.all));
Any_Simple_Type_Index : constant Type_Index :=
Get (Ref.all,
((Local => Parser.Any_Simple_Type,
NS => Parser.XML_Schema_URI), Ref_Type)).Typ;
Shared : XSD_Data_Access renames Parser.Shared;
package Type_HTables is new GNAT.Dynamic_HTables.Simple_HTable
(Header_Num => Header_Num,
Element => Internal_Type_Index,
No_Element => No_Internal_Type_Index,
Key => Qualified_Name,
Hash => Hash,
Equal => "=");
use Type_HTables;
Types : Type_HTables.Instance;
procedure Process_Global_Element
(Info : in out Element_Descr; Start_At : State);
procedure Process_Type (Info : in out Internal_Type_Descr);
procedure Process_Details
(In_Type : access Type_Descr;
Details : Type_Details_Access;
Start, From : State;
Nested_End : out State;
Mask : out Visited_All_Children);
-- [Start] is the start of the current nested.
-- [Mask] is the mask to apply to a closing transition out of a <all>
-- node. It is only set if Details.Kind = Type_All.
procedure Create_Element_State
(Info : in out Element_Descr;
Start, From : State;
Global : Boolean;
S1, S2 : out State;
Trans_Kind : Transition_Kind;
All_Child_Index : Integer := 0);
-- Create (and decorate) the nodes [S1]..[S2] corresponding to an
-- <element>. A link is created [From]->[S1].
-- [Start] is the first element of the current nested machine.
-- Trans_Kind is the kind of the first transition, from From to the
-- first created state. This transition is associated with the name of
-- the element.
-- All_Child_Index indicates the index of the created transition in all
-- the children of an <all> node. This is used to memory efficiently
-- which transitions have already been visited for this <all>.
type Type_Descr_Access is access all Type_Descr;
procedure Create_Simple_Type
(J : Internal_Type_Index;
Descr : out Type_Descr_Access;
Index : out Type_Index);
-- Create the new simple type info at index [J]
procedure Get_Type_Descr
(Name : Qualified_Name;
Loc : Location;
NFA_Type : out Type_Index;
Internal_Type : out Internal_Type_Index);
-- Lookup the type information in the grammar. This type information
-- could be in several places:
-- - Either defined in the current XSD and its <input>: in that case,
-- [Internal_Type] will be set.
-- - Or in a previously loaded XSD. In that case, it is set to
-- [No_Internal_Type_Index]
procedure Lookup_Simple_Type
(Name : Qualified_Name;
Loc : Location;
Descr : out Type_Descr_Access;
Index : out Type_Index);
-- Search for the simpleType [Name]
procedure Add_Attributes
(List : in out Attributes_List;
Attrs : Attr_Array_Access;
Processed_Groups : in out AttrGroup_HTables.Instance;
As_Restriction : Boolean;
Had_Any : in out Boolean);
-- Create List from the list of attributes or attribute groups in
-- [Attrs]. [Had_Any] is set to true if a <anyAttribute> was
-- encountered. The caller should first set it to False.
procedure Check_Unique_Particle_Attribution
(Details : Type_Details_Access);
-- Check that all elements in the content model are unique (we must not
-- have two elements that compete with each other).
procedure Create_Global_Attributes (Attr : Internal_Attribute_Descr);
-- Register a global attribute.
procedure Resolve_Attribute_Type
(Attr : in out Internal_Attribute_Descr;
Loc : Sax.Locators.Location);
-- Set [Attr.Descr.Simple_Type] to the appropriate value, after looking
-- up the type
--------------------------
-- Create_Element_State --
--------------------------
procedure Create_Element_State
(Info : in out Element_Descr;
Start, From : State;
Global : Boolean;
S1, S2 : out State;
Trans_Kind : Transition_Kind;
All_Child_Index : Integer := 0)
is
pragma Unreferenced (Start);
Real : Element_Descr;
Trans : Transition_Descr;
TRef : Global_Reference := No_Global_Reference;
S : State := No_State;
function Build_Trans
(N : Qualified_Name; F : Form_Type) return Transition_Descr;
function Build_Trans
(N : Qualified_Name; F : Form_Type) return Transition_Descr is
begin
case Trans_Kind is
when Transition_Symbol =>
return (Transition_Symbol, N, F, All_Child_Index => 0);
when Transition_Symbol_From_All =>
return (Transition_Symbol_From_All, N, F,
All_Child_Index => All_Child_Index);
when others =>
raise Program_Error with "Invalid transition type";
end case;
end Build_Trans;
begin
if Info.Is_Abstract then
-- ??? Should use the substitutionGroup elements, instead
S1 := No_State;
S2 := No_State;
Validation_Error
(Parser,
"Abstract elements not handled yet",
Except => XML_Not_Implemented'Identity);
return;
end if;
S1 := NFA.Add_State;
Info.S := S1;
if Debug then
Debug_Output ("Create_Element_State S1 for element "
& To_QName (Info.Name) & To_QName (Info.Ref)
& S1'Img);
end if;
-- Resolve element references
if Info.Name = No_Qualified_Name then
Real := Get (Shared.Global_Elements, Info.Ref);
if Real = No_Element_Descr then
TRef := Get (Ref.all, (Info.Ref, Ref_Element));
if TRef = No_Global_Reference then
Validation_Error
(Parser, "Unknown refed element " & To_QName (Info.Ref),
Info.Loc);
end if;
S := TRef.Element;
Trans := Build_Trans (Info.Ref, Info.Form);
else
Trans := Build_Trans (Real.Name, Info.Form);
S := Real.S;
end if;
if S /= No_State then
if Debug then
Debug_Output ("copying data from" & S'Img & " to" & S1'Img);
end if;
NFA.Get_Data (S1).all := NFA.Get_Data (S).all;
NFA.Set_Nested (S1, NFA.Get_Nested (S));
end if;
else
declare
NFA_Type : Type_Index;
Internal_Type : Internal_Type_Index;
Data : access State_Data;
begin
Real := Info;
Trans := Build_Trans (Real.Name, Info.Form);
-- Create nested NFA for the type, if needed
if Real.Typ /= No_Qualified_Name then
Get_Type_Descr (Real.Typ, Info.Loc, NFA_Type, Internal_Type);
elsif Real.Local_Type /= No_Internal_Type_Index then
Internal_Type := Real.Local_Type;
NFA_Type := Shared.Types.Table (Internal_Type).In_NFA;
else
-- "<anyType>" (3.3.2.1 {type definition})
NFA_Type := No_Type_Index;
end if;
if Info.Substitution_Group /= No_Qualified_Name then
-- ??? Handling of substitutionGroup: the type of the
-- element is the same as the head unless overridden.
Validation_Error
(Parser,
"substitutionGroup not supported",
Except => XML_Not_Implemented'Identity);
end if;
Data := NFA.Get_Data (S1);
if NFA_Type /= No_Type_Index then
Data.all := State_Data'(Simple => NFA_Type,
Fixed => No_Symbol, -- See below
Default => Info.Default,
Nillable => Info.Nillable,
Block => Info.Block);
NFA.Set_Nested
(S1, NFA.Create_Nested
(Get_Type_Descr (NFA, NFA_Type).Complex_Content));
else
NFA.Set_Nested (S1, NFA.Ur_Type (Process_Lax));
Data.Default := Info.Default;
Data.Block := Info.Block;
Data.Nillable := Info.Nillable;
end if;
-- Check that the fixed value is valid
if Info.Fixed /= No_Symbol
and then NFA.Get_Data (S1).Simple /= No_Type_Index
then
Normalize_And_Validate
(Parser => Parser,
Simple => Get_Type_Descr
(NFA, NFA.Get_Data (S1).Simple).Simple_Content,
Fixed => Info.Fixed,
Loc => Info.Loc);
end if;
Data.Fixed := Info.Fixed;
end;
end if;
-- Link with previous element
NFA.Add_Transition (From, S1, Trans);
S2 := NFA.Add_State;
if Debug then
Debug_Output ("Create_Element_State S2 for element "
& To_QName (Info.Name) & To_QName (Info.Ref)
& S2'Img);
end if;
if NFA.Get_Nested (S1) /= No_Nested then
NFA.On_Empty_Nested_Exit (S1, S2); -- a complexType
else
NFA.Add_Transition (S1, S2, (Kind => Transition_Close));
end if;
-- Save this element for later reuse in other namespaces
if Global then
if Debug then
Debug_Output ("Global elem: " & To_QName (Real.Name));
end if;
Set (Ref.all,
(Kind => Ref_Element, Name => Real.Name, Element => S1));
end if;
end Create_Element_State;
----------------------------
-- Process_Global_Element --
----------------------------
procedure Process_Global_Element
(Info : in out Element_Descr; Start_At : State)
is
S1, S2 : State;
begin
Create_Element_State
(Info, Start_At, Start_At, True, S1, S2, Transition_Symbol);
if S2 /= No_State then
NFA.Add_Empty_Transition (S2, Final_State);
end if;
end Process_Global_Element;
--------------------
-- Get_Type_Descr --
--------------------
procedure Get_Type_Descr
(Name : Qualified_Name;
Loc : Location;
NFA_Type : out Type_Index;
Internal_Type : out Internal_Type_Index)
is
TRef : Global_Reference;
begin
Internal_Type := Get (Types, Name);
if Internal_Type = No_Internal_Type_Index then
TRef := Get (Ref.all, (Name, Ref_Type));
if TRef = No_Global_Reference then
Validation_Error
(Parser, "Unknown type " & To_QName (Name), Loc);
end if;
NFA_Type := TRef.Typ;
else
NFA_Type := Shared.Types.Table (Internal_Type).In_NFA;
end if;
if Name = (NS => Parser.XML_Schema_URI, Local => Parser.IDREF)
or else
Name = (NS => Parser.XML_Schema_URI, Local => Parser.IDREFS)
then
Validation_Error
(Parser,
"Unsupported type IDREF and IDREFS",
Loc => Loc,
Except => XML_Not_Implemented'Identity);
end if;
end Get_Type_Descr;
------------------------
-- Lookup_Simple_Type --
------------------------
procedure Lookup_Simple_Type
(Name : Qualified_Name;
Loc : Location;
Descr : out Type_Descr_Access;
Index : out Type_Index)
is
TRef : Global_Reference;
Internal : Internal_Type_Index;
begin
TRef := Get (Ref.all, (Name, Ref_Type));
if TRef = No_Global_Reference then
Validation_Error
(Parser, "Unknown type " & To_QName (Name), Loc);
end if;
Index := TRef.Typ;
Descr := Type_Descr_Access (Get_Type_Descr (NFA, Index));
if Descr.Simple_Content = No_Simple_Type_Index then
if Debug then
Debug_Output ("Lookup_Simple_Type: generate "
& To_QName (Name) & " early");
end if;
Internal := Get (Types, Name);
if Internal = No_Internal_Type_Index then
Validation_Error
(Parser,
"Type is not a simple type: " & To_QName (Name), Loc);
end if;
Create_Simple_Type (Internal, Descr, Index);
end if;
end Lookup_Simple_Type;
---------------------------------------
-- Check_Unique_Particle_Attribution --
---------------------------------------
procedure Check_Unique_Particle_Attribution
(Details : Type_Details_Access)
is
Duplicates : Element_HTables.Instance;
-- Used to check for duplicate elements within a sequence or choice.
-- ??? Could use a htable of locations, so that we can point to the
-- two duplicate declarations.
T : Type_Details_Access;
Elem : Element_Descr;
begin
case Details.Kind is
when Type_Sequence =>
T := Details.First_In_Seq;
when Type_Choice =>
T := Details.First_In_Choice;
when Type_All =>
T := Details.First_In_All;
when others =>
raise Program_Error with "Internal error";
end case;
while T /= null loop
case T.Kind is
when Type_Element =>
if T.Element.Name /= No_Qualified_Name then
Elem := Element_HTables.Get (Duplicates, T.Element.Name);
if Elem /= No_Element_Descr then
-- It is always invalid to have an element with the
-- same name but with different types in the same
-- model, even if there is no ambiguity (for instance
-- in a sequence).
if Elem.Typ /= No_Qualified_Name
and then Elem.Typ /= T.Element.Typ
then
Validation_Error
(Parser,
"Multiple elements with name '"
& To_QName (T.Element.Name)
& "', with different types, appear in the model"
& " group",
Details.Loc);
end if;
-- In a <choice> or <all>, we cannot have the same
-- element multiple times, since that would be
-- ambiguous.
if Details.Kind = Type_Choice
or else Details.Kind = Type_All
then
Validation_Error
(Parser,
"'" & To_QName (T.Element.Name) & "' and '"
& To_QName (Elem.Name) & "' violate the Unique"
& " Particle Attribution rule, creating an"
& " ambiguity for the validation",
Details.Loc);
end if;
else
Element_HTables.Set
(Duplicates, T.Element.Name, T.Element);
end if;
end if;
when Type_Group =>
null;
when others =>
-- ??? Should check, in particular for groups or nested
-- sequences (we can have a Sequence that contains choices)
null;
end case;
T := T.Next;
end loop;
Reset (Duplicates);
exception
when others =>
Reset (Duplicates);
raise;
end Check_Unique_Particle_Attribution;
---------------------
-- Process_Details --
---------------------
procedure Process_Details
(In_Type : access Type_Descr;
Details : Type_Details_Access;
Start, From : State;
Nested_End : out State;
Mask : out Visited_All_Children)
is
S, S1 : State;
T : Type_Details_Access;
Gr : Group_Descr;
begin
Nested_End := From;
Mask := 0;
if Details = null then
return;
end if;
Details.In_Process := True;
case Details.Kind is
when Type_Empty =>
null;
when Type_Sequence =>
Check_Unique_Particle_Attribution (Details);
S := From;
T := Details.First_In_Seq;
while T /= null loop
Process_Details (In_Type, T, Start, S, Nested_End, Mask);
S1 := Nested_End;
-- We can have one element start exactly where the other
-- finishes. Otherwise we have issues with the following
-- sequence:
-- <sequence>
-- <element name="a" minOccurs="0" maxOccurs="unbounded"/>
-- <element name="b" minOccurs="0" maxOccurs="unbounded"/>
-- </sequence>
-- which would allow any number of a, any number of b, and
-- again any number of a (because of empty transition from
-- end of "b*" that goes back to the beginning of "b*",
-- which would be the same as end of "a*", which has empty
-- transition to "a*". The following empty transition
-- ensures that end of "a*" is not same as beginning of
-- "b*".
S := NFA.Add_State;
NFA.Add_Empty_Transition (S1, S);
T := T.Next;
end loop;
Nested_End := S;
when Type_Choice =>
Check_Unique_Particle_Attribution (Details);
T := Details.First_In_Choice;
Nested_End := NFA.Add_State;
while T /= null loop
S1 := NFA.Add_State;
NFA.Add_Empty_Transition (From, S1);
Process_Details (In_Type, T, Start, S1, S, Mask);
NFA.Add_Empty_Transition (S, Nested_End);
T := T.Next;
end loop;
when Type_All =>
Check_Unique_Particle_Attribution (Details);
if Details.First_In_All /= null then
declare
Count : Natural := 0;
begin
Mask := 0;
T := Details.First_In_All;
while T /= null loop
pragma Assert
(T.Kind = Type_Element,
"Children of <all> must be simple elements");
-- If the element has maxOccurs=0, there is no need to
-- put it in the state machine.
if T.Max_Occurs.Value /= 0 then
Create_Element_State
(T.Element, Start, From, False,
S1 => S1,
S2 => S,
Trans_Kind => Transition_Symbol_From_All,
All_Child_Index => Count);
if T.Min_Occurs.Value = 1 then
-- The child is mandatory
Mask := Mask or (2 ** Count);
end if;
Count := Count + 1;
-- All elements, after being processed, come back
-- to <all> itself. The latter is in charge of
-- deciding, through the subprogram Match, which
-- transitions are valid in the current state.
NFA.Add_Empty_Transition (S, Start);
end if;
T := T.Next;
end loop;
-- The actual end of <all> is through a conditional empty
-- transition controlled by Match.
Nested_End := NFA.Add_State;
NFA.Add_Empty_Transition (From, Nested_End);
end;
end if;
when Type_Element =>
Create_Element_State
(Details.Element, Start, From, False, S1, Nested_End,
Transition_Symbol);
when Type_Group =>
Gr := Get (Parser.Shared.Global_Groups, Details.Group.Ref);
if Gr = No_Group_Descr then
Validation_Error
(Parser,
"No group """ & To_QName (Details.Group.Ref) & '"',
Details.Group.Loc);
elsif Gr.Details.In_Process then
Validation_Error
(Parser,
"Circular group reference for "
& To_QName (Details.Group.Ref),
Details.Group.Loc);
end if;
Process_Details
(In_Type, Gr.Details, Start, From, Nested_End, Mask);
when Type_Extension =>
declare
NFA_Type : Type_Index; -- Attributes of the base type
Internal_Type : Internal_Type_Index;
Base_Descr : access Type_Descr;
begin
Get_Type_Descr
(Name => Details.Extension.Base,
Loc => Details.Extension.Loc,
NFA_Type => NFA_Type,
Internal_Type => Internal_Type);
Base_Descr := Get_Type_Descr (NFA, NFA_Type);
if Base_Descr.Final (Final_Extension) then
Validation_Error
(Parser,
To_QName (Base_Descr.Name)
& " is final for extensions",
Details.Extension.Loc);
end if;
if Base_Descr.Simple_Content = No_Simple_Type_Index then
if Internal_Type /= No_Internal_Type_Index then
-- We have all the details, and just have to copy them
-- Details might be null, for instance for an
-- <extension> that just adds attributes
if Shared.Types.Table (Internal_Type).Details /= null
and then
Shared.Types.Table (Internal_Type)
.Details.In_Process
then
Validation_Error
(Parser,
"Circular inheritance of type "
& To_QName (Details.Extension.Base),
Details.Extension.Loc);
end if;
Process_Details
(In_Type,
Shared.Types.Table (Internal_Type).Details,
Start, From, S, Mask);
else
-- ??? Should copy the nested NFA for TyS
Validation_Error
(Parser,
"Extension's base in a different file "
& To_QName (Details.Extension.Base),
Details.Extension.Loc,
XML_Not_Implemented'Identity);
end if;
Process_Details
(In_Type,
Details.Extension.Details, Start, S, Nested_End,
Mask);
else
-- ??? Should handle simple types
Nested_End := Start;
-- The test is correct. However, it makes
-- msData/particles/particlesZ031.xsd fails, because the
-- test is incorrect. The test pretends that the XSD is
-- valid, but later checkins in the testsuite have proven
-- it incorrect. The following Ada test would make the
-- test pass, but then
-- MS-Additional2006-07-15/addB036
-- fails
--
-- and then
-- (Internal_Type = No_Internal_Type_Index
-- or else Shared.Types.Table (Internal_Type).Is_Simple)
if not Details.Simple_Content then
Validation_Error
(Parser,
"base type specified in complexContent definition"
& " must be a complex type",
Details.Extension.Loc);
end if;
end if;
In_Type.Extension_Of := NFA_Type;
In_Type.Restriction_Of := No_Type_Index;
end;
when Type_Restriction =>
declare
Internal : Internal_Type_Index;
NFA_Type : Type_Index; -- Attributes of the base type
Base_Descr : access Type_Descr;
begin
Get_Type_Descr
(Name => Details.Restriction.Base,
Loc => No_Location,
NFA_Type => NFA_Type,
Internal_Type => Internal);
Base_Descr := Get_Type_Descr (NFA, NFA_Type);
if Base_Descr.Final (Final_Restriction) then
Validation_Error
(Parser,
To_QName (Base_Descr.Name)
& " is final for restrictions",
Details.Restriction.Loc);
end if;
if Base_Descr.Simple_Content = No_Simple_Type_Index then
if Internal /= No_Internal_Type_Index
and then Shared.Types.Table (Internal).Details /= null
and then
Shared.Types.Table (Internal).Details.In_Process
then
Validation_Error
(Parser,
"Circular inheritance of type "
& To_QName (Details.Restriction.Base),
Details.Restriction.Loc);
end if;
Process_Details
(In_Type,
Details.Restriction.Details, Start, From, Nested_End,
Mask);
else
-- ??? Should handle simple types
Nested_End := Start;
if not Details.Simple_Content_Restriction then
Validation_Error
(Parser,
"base type specified in complexContent definition"
& " must be a complex type",
Details.Restriction.Loc);
end if;
end if;
In_Type.Restriction_Of := NFA_Type;
In_Type.Extension_Of := No_Type_Index;
end;
when Type_Any =>
S := NFA.Add_State; -- ((Simple => 1, others => <>));
NFA.Set_Nested (S, Ur_Type (NFA, Details.Any.Process_Contents));
NFA.Add_Transition
(From, S, (Transition_Any,
Combine (Parser.Grammar, No_Any_Descr,
Local_Process => Details.Any.Process_Contents,
Local => Details.Any.Namespaces,
As_Restriction => False,
Target_NS => Details.Any.Target_NS)));
Nested_End := NFA.Add_State;
NFA.On_Empty_Nested_Exit (S, Nested_End);
end case;
-- For <all> elements, we can only have maxOccurs=1 and minOccurs=0
-- or 1. In the case of minOccurs=0, and since we use conditional
-- links there, we cannot create a direct empty transition from the
-- start state to the final state (since the
-- transition_close_from_all is on exit of that final state, and
-- thus would be *after* the new empty transition). So this case
-- is handled specially in Process_Type.
if Details.Kind /= Type_All then
if Details.Max_Occurs.Unbounded then
Nested_End := NFA.Repeat
(From, Nested_End, Details.Min_Occurs.Value,
Natural'Last);
else
Nested_End := NFA.Repeat
(From, Nested_End, Details.Min_Occurs.Value,
Details.Max_Occurs.Value);
end if;
end if;
Details.In_Process := False;
end Process_Details;
----------------------------
-- Resolve_Attribute_Type --
----------------------------
procedure Resolve_Attribute_Type
(Attr : in out Internal_Attribute_Descr;
Loc : Sax.Locators.Location)
is
TRef : Global_Reference;
NFA_Type : Type_Index; -- In NFA
begin
if Attr.Local_Type /= No_Internal_Type_Index then
NFA_Type := Shared.Types.Table (Attr.Local_Type).In_NFA;
Attr.Descr.Simple_Type :=
Get_Type_Descr (NFA, NFA_Type).Simple_Content;
elsif Attr.Typ = No_Qualified_Name then
-- ??? Type should be ur-type (3.2.2)
null;
else
TRef := Get (Ref.all, (Attr.Typ, Ref_Type));
if TRef = No_Global_Reference then
Validation_Error
(Parser,
"Unknown type: " & To_QName (Attr.Typ),
Loc);
else
Attr.Descr.Simple_Type :=
Get_Type_Descr (NFA, TRef.Typ).Simple_Content;
end if;
end if;
end Resolve_Attribute_Type;
--------------------
-- Add_Attributes --
--------------------
procedure Add_Attributes
(List : in out Attributes_List;
Attrs : Attr_Array_Access;
Processed_Groups : in out AttrGroup_HTables.Instance;
As_Restriction : Boolean;
Had_Any : in out Boolean)
is
Gr : AttrGroup_Descr;
TRef : Global_Reference;
begin
if Attrs /= null then
for A in Attrs'Range loop
case Attrs (A).Kind is
when Kind_Unset =>
null;
when Kind_Group =>
Gr := Get (Shared.Global_AttrGroups, Attrs (A).Group_Ref);
if Gr = No_AttrGroup_Descr then
Validation_Error
(Parser,
"Reference to undefined attributeGroup: "
& To_QName (Attrs (A).Group_Ref),
Attrs (A).Loc);
elsif Get (Processed_Groups, Gr.Name) /=
No_AttrGroup_Descr
then
Validation_Error
(Parser,
"attributeGroup """ & To_QName (Attrs (A).Group_Ref)
& """ has circular reference",
Attrs (A).Loc);
else
Set (Processed_Groups, Gr.Name, Gr);
Add_Attributes
(List, Gr.Attributes, Processed_Groups,
As_Restriction, Had_Any);
end if;
when Kind_Attribute =>
if Attrs (A).Attr.Ref /= No_Qualified_Name then
TRef := Get
(Ref.all, (Attrs (A).Attr.Ref, Ref_Attribute));
if TRef = No_Global_Reference then
Validation_Error
(Parser,
"Unknown referenced attribute: "
& To_QName (Attrs (A).Attr.Ref),
Attrs (A).Loc);
end if;
Add_Attribute
(Parser, List,
Attribute => Attrs (A).Attr.Descr,
Ref => TRef.Attributes.Named,
Loc => Attrs (A).Loc);
else
Resolve_Attribute_Type (Attrs (A).Attr, Attrs (A).Loc);
if Attrs (A).Attr.Any /= No_Internal_Any_Descr then
Had_Any := True;
Add_Any_Attribute
(Parser.Grammar, List, Attrs (A).Attr.Any,
As_Restriction);
else
Add_Attribute
(Parser, List, Attrs (A).Attr.Descr,
Loc => Attrs (A).Loc);
end if;
end if;
end case;
end loop;
end if;
end Add_Attributes;
------------------------
-- Create_Simple_Type --
------------------------
procedure Create_Simple_Type
(J : Internal_Type_Index;
Descr : out Type_Descr_Access;
Index : out Type_Index)
is
Info : Internal_Type_Descr renames Shared.Types.Table (J);
Simple : Simple_Type_Descr;
Index_In_Simple : Natural;
Internal : Internal_Simple_Type_Descr;
Result : Simple_Type_Index;
begin
Index := Info.In_NFA;
Descr := Type_Descr_Access (NFA.Get_Type_Descr (Index));
Result := Descr.Simple_Content;
if Result /= No_Simple_Type_Index then
if Debug then
Debug_Output ("Create_Simple_Type: already done "
& To_QName (Info.Properties.Name));
end if;
return;
end if;
Internal := Info.Simple;
if Internal.Kind = Simple_Type_None then
-- Not a simple type, nothing to do
Descr := null;
return;
end if;
if Internal.In_Process then
Validation_Error
(Parser,
"Circular inheritance of type "
& To_QName (Info.Properties.Name),
Info.Loc);
end if;
if Debug then
Debug_Output
("Create_Simple_Type " & To_QName (Info.Properties.Name)
& " " & Internal.Kind'Img);
end if;
Info.Simple.In_Process := True;
case Internal.Kind is
when Simple_Type_None =>
Descr := null;
return;
when Simple_Type =>
-- ??? Shouldn't we set Simple_Content as well ?
Descr.Restriction_Of := Any_Simple_Type_Index;
when Simple_Type_Union =>
Simple := (Kind => Primitive_Union,
Union => (others => No_Simple_Type_Index),
others => <>);
Index_In_Simple := Simple.Union'First;
for U in Internal.Union_Items'Range loop
declare
Member : constant Type_Member := Internal.Union_Items (U);
Item : Type_Descr_Access;
Index : Type_Index;
begin
exit when Member = No_Type_Member;
if Member.Name /= No_Qualified_Name then
Lookup_Simple_Type
(Member.Name, Internal.Loc, Item, Index);
if Item.Final (Final_Union) then
Validation_Error
(Parser,
To_QName (Member.Name) & " is final for union",
Internal.Loc);
end if;
else
Create_Simple_Type (Member.Local, Item, Index);
end if;
Simple.Union (Index_In_Simple) := Item.Simple_Content;
Index_In_Simple := Index_In_Simple + 1;
end;
end loop;
Result := Create_Simple_Type (NFA, Simple);
Descr.Simple_Content := Result;
Descr.Restriction_Of := Any_Simple_Type_Index;
when Simple_Type_List =>
Simple := (Kind => Primitive_List,
List_Item => No_Simple_Type_Index,
others => <>);
for U in Internal.List_Items'Range loop
declare
Member : constant Type_Member := Internal.List_Items (U);
Item : Type_Descr_Access;
Index : Type_Index;
begin
exit when Member = No_Type_Member;
if Member.Name /= No_Qualified_Name then
Lookup_Simple_Type
(Member.Name, Internal.Loc, Item, Index);
if Item.Final (Final_List) then
Validation_Error
(Parser,
To_QName (Member.Name) & " is final for list",
Internal.Loc);
end if;
else
Create_Simple_Type (Member.Local, Item, Index);
end if;
Simple.List_Item := Item.Simple_Content;
end;
end loop;
Result := Create_Simple_Type (NFA, Simple);
Descr.Simple_Content := Result;
Descr.Restriction_Of := Any_Simple_Type_Index;
when Simple_Type_Restriction | Simple_Type_Extension =>
declare
Base : Simple_Type_Descr;
Error : Symbol;
Loc : Location;
NFA_Simple : Type_Descr_Access;
NFA_Type : Type_Index;
begin
if Internal.Base.Name /= No_Qualified_Name then
Lookup_Simple_Type
(Internal.Base.Name, Internal.Loc,
NFA_Simple, NFA_Type);
else
Create_Simple_Type
(Internal.Base.Local, NFA_Simple, NFA_Type);
end if;
if Internal.Base = No_Type_Member then
Base := Any_Simple_Type;
NFA_Type := Any_Simple_Type_Index;
elsif NFA_Simple = null
or else NFA_Simple.Simple_Content = No_Simple_Type_Index
then
Validation_Error
(Parser,
"base type specified in simpleContent definition must"
& " be a simple type",
Loc);
else
Base := Copy
(Get_Simple_Type (NFA, NFA_Simple.Simple_Content));
Override (Simple => Base,
Facets => Internal.Facets,
Symbols => Get_Symbol_Table (Parser.all),
As_Restriction => Internal.Kind =
Simple_Type_Restriction,
Error => Error,
Error_Loc => Loc);
if Error /= No_Symbol then
Validation_Error (Parser, Get (Error).all, Loc);
end if;
end if;
case Internal.Kind is
when Simple_Type_Restriction =>
Descr.Restriction_Of := NFA_Type;
when Simple_Type_Extension =>
Descr.Extension_Of := NFA_Type;
when others =>
null;
end case;
Result := Create_Simple_Type (NFA, Base);
Descr.Simple_Content := Result;
end;
end case;
Info.Simple.In_Process := False;
end Create_Simple_Type;
------------------------------
-- Create_Global_Attributes --
------------------------------
procedure Create_Global_Attributes (Attr : Internal_Attribute_Descr) is
Attr2 : Internal_Attribute_Descr;
begin
pragma Assert (Attr.Ref = No_Qualified_Name,
"A global attribute cannot define ref");
pragma Assert (Attr.Descr.Name /= No_Qualified_Name,
"A global attribute must have a name");
pragma Assert (Attr.Any = No_Internal_Any_Descr,
"A global attribute is not <anyAttribute>");
pragma Assert (Attr.Descr.Next = Empty_Named_Attribute_List,
"Global attributes cannot be in a list");
pragma Assert (Attr.Descr.Simple_Type = No_Simple_Type_Index,
"Type of global attributes should be undefined here");
Attr2 := Attr;
Resolve_Attribute_Type (Attr2, No_Location);
Create_Global_Attribute (Parser, Attr2.Descr, No_Location);
end Create_Global_Attributes;
------------------
-- Process_Type --
------------------
procedure Process_Type (Info : in out Internal_Type_Descr) is
S1 : State;
List : Attributes_List := No_Attributes;
Processed_Groups : AttrGroup_HTables.Instance;
-- ??? If this table is here, we can't have an <extension> with the
-- same attributeGroup as its base type. Maybe this should be local
-- to Recursive_Add_Attributes instead
procedure Recursive_Add_Attributes (Info : Internal_Type_Descr);
procedure Recursive_Add_Attributes (Info : Internal_Type_Descr) is
Ty : Global_Reference;
Index : Internal_Type_Index;
Had_Any : Boolean := False;
Base : Qualified_Name;
As_Restriction : Boolean;
begin
if Info.Is_Simple then
-- A simpleType has no attribute
return;
elsif Info.Details = null then
Add_Attributes (List, Info.Attributes, Processed_Groups,
As_Restriction => True, Had_Any => Had_Any);
Reset (Processed_Groups);
return;
end if;
if Info.Details.Kind = Type_Extension then
Base := Info.Details.Extension.Base;
As_Restriction := False;
elsif Info.Details.Kind = Type_Restriction then
Base := Info.Details.Restriction.Base;
As_Restriction := True;
else
Base := No_Qualified_Name;
end if;
if Base = No_Qualified_Name then
-- No character data is allowed, but we might have attributes
Add_Attributes (List, Info.Attributes, Processed_Groups,
As_Restriction => True, Had_Any => Had_Any);
elsif not As_Restriction then
Ty := Get (Ref.all, (Base, Ref_Type));
if Ty = No_Global_Reference then
Validation_Error
(Parser, "No type """ & To_QName (Base) & """", Info.Loc);
end if;
-- If the base type is in the current package, we might not
-- have computed all its attributes. Otherwise, get the list of
-- attributes already computed in the grammar, since it is
-- complete.
Index := Get (Types, Base);
if Index /= No_Internal_Type_Index then
Recursive_Add_Attributes (Shared.Types.Table (Index));
else
Add_Attributes
(Parser, List,
Get_Type_Descr (NFA, Ty.Typ).Attributes,
As_Restriction => False, Loc => Info.Loc);
end if;
Add_Attributes (List, Info.Attributes,
Processed_Groups, As_Restriction => False,
Had_Any => Had_Any);
else
Ty := Get (Ref.all, (Base, Ref_Type));
if Ty = No_Global_Reference then
Validation_Error
(Parser, "No type """ & To_QName (Base) & """", Info.Loc);
end if;
Index := Get (Types, Base);
if Index /= No_Internal_Type_Index then
Recursive_Add_Attributes (Shared.Types.Table (Index));
else
Add_Attributes
(Parser, List,
Get_Type_Descr (NFA, Ty.Typ).Attributes,
As_Restriction => True, Loc => Info.Loc);
end if;
Had_Any := False;
Add_Attributes (List, Info.Attributes,
Processed_Groups, As_Restriction => True,
Had_Any => Had_Any);
-- Always add <anyAttribute>, even if none was given in the
-- restriction (in which case none should exist for the type
-- either);
if not Had_Any then
List.Any := No_Any_Descr; -- Nothing matches
end if;
end if;
end Recursive_Add_Attributes;
begin
if Info.Is_Simple then
null; -- Already done in Process_Type
else
if Debug then
Debug_Output ("Process complexType "
& To_QName (Info.Properties.Name));
end if;
declare
Descr : constant access Type_Descr :=
Get_Type_Descr (NFA, Info.In_NFA);
Mask : Visited_All_Children;
Start : State := Descr.Complex_Content;
Is_All : constant Boolean :=
Info.Details /= null and then Info.Details.Kind = Type_All;
begin
pragma Assert (Descr.Complex_Content /= No_State);
if Is_All and then Info.Details.Min_Occurs.Value = 0 then
-- See comment in Process_Details as to why this is
-- handled here.
-- We should not make the transition directly from the
-- start node (Descr.Complex_Content), because it would
-- mean a user can start a <all minOccurs="0"> and stop
-- in the middle with no error
Start := NFA.Add_State;
NFA.Add_Empty_Transition (Descr.Complex_Content, Start);
end if;
Process_Details
(In_Type => Descr,
Details => Info.Details,
Start => Start, -- Descr.Complex_Content,
From => Start,
Nested_End => S1,
Mask => Mask);
-- Add the attributes only after we did the details, so that we
-- know there is no infinite recursion between the base types
-- of extensions and restrictions
if Debug then
Debug_Output ("Process attributes for complexType "
& To_QName (Info.Properties.Name) & " State="
& Descr.Complex_Content'Img
& " type_index=" & Info.In_NFA'Img);
end if;
Recursive_Add_Attributes (Info);
Descr.Attributes := List;
if Is_All then
NFA.Add_Transition
(S1, Final_State,
(Kind => Transition_Close_From_All,
Mask => Mask));
if Info.Details.Min_Occurs.Value = 0 then
NFA.Add_Transition
(Descr.Complex_Content, Final_State,
(Kind => Transition_Close));
end if;
else
NFA.Add_Transition
(S1, Final_State, (Kind => Transition_Close));
end if;
end;
end if;
Reset (Processed_Groups);
exception
when others =>
Reset (Processed_Groups);
raise;
end Process_Type;
Element_Info : Element_Descr;
Attr : Internal_Attribute_Descr;
S : State;
Ignored : Type_Descr_Access;
Ignored_Index : Type_Index;
pragma Unreferenced (Ignored, Ignored_Index);
begin
if Debug then
Debug_Output ("Create_NFA");
end if;
-- Prepare the entries for the types. These are empty to start with, but
-- they are needed to be able to create the more complex types, and the
-- global element.
for J in Type_Tables.First .. Last (Shared.Types) loop
-- Create the empty nested NFA if needed
S := No_State;
if not Shared.Types.Table (J).Is_Simple then
S := NFA.Add_State;
Shared.Types.Table (J).Properties.Complex_Content := S;
if Debug then
Debug_Output
("Created state for complexContent "
& To_QName (Shared.Types.Table (J).Properties.Name)
& " type=" & J'Img & " state=" & S'Img);
end if;
end if;
Shared.Types.Table (J).In_NFA :=
Create_Type (NFA, Shared.Types.Table (J).Properties);
if S /= No_State then
-- At least .Complex_Content has changed, so we need to reset data
NFA.Set_Data
(S,
State_Data'
(Simple => Shared.Types.Table (J).In_NFA,
Block => No_Block,
Nillable => False,
Default => No_Symbol,
Fixed => No_Symbol));
end if;
if Shared.Types.Table (J).Properties.Name /= No_Qualified_Name then
Set (Types, Shared.Types.Table (J).Properties.Name, J);
end if;
end loop;
-- Process the simple types (must be in a separate loop, since a
-- restriction or a union needs to know about its base type)
for J in Type_Tables.First .. Last (Shared.Types) loop
Create_Simple_Type (J, Ignored, Ignored_Index);
end loop;
-- Prepare the entries for the global attributes
Attr := Get_First (Shared.Global_Attributes);
while Attr /= No_Internal_Attribute loop
Create_Global_Attributes (Attr);
Attr := Get_Next (Shared.Global_Attributes);
end loop;
-- Prepare schema for global elements
if Debug then
Debug_Output ("Create_NFA: adding global elements");
end if;
Element_Info := Get_First (Shared.Global_Elements);
while Element_Info /= No_Element_Descr loop
Process_Global_Element (Element_Info, Start_State);
-- Save the state
Set (Shared.Global_Elements, Element_Info.Name, Element_Info);
Element_Info := Get_Next (Shared.Global_Elements);
end loop;
if Debug then
Debug_Output ("Create_NFA: complete type definition");
end if;
-- Finally, complete the definition of complexTypes
for J in Type_Tables.First .. Last (Shared.Types) loop
Process_Type (Shared.Types.Table (J));
end loop;
if Debug then
Output_Action ("NFA: " & Dump_Dot_NFA (Get_Grammar (Parser.all)));
end if;
Reset (Types);
exception
when others =>
Reset (Types);
raise;
end Create_NFA;
----------
-- Free --
----------
procedure Free (Shared : in out XSD_Data_Access) is
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(XSD_Data, XSD_Data_Access);
Attr : AttrGroup_Descr;
Gr : Group_Descr;
begin
if Shared /= null then
-- Free all data structures, no longer needed
Reset (Shared.Global_Elements);
Gr := Get_First (Shared.Global_Groups);
while Gr /= No_Group_Descr loop
Free (Gr.Details);
Gr := Get_Next (Shared.Global_Groups);
end loop;
Reset (Shared.Global_Groups);
Attr := Get_First (Shared.Global_AttrGroups);
while Attr /= No_AttrGroup_Descr loop
Unchecked_Free (Attr.Attributes);
Attr := Get_Next (Shared.Global_AttrGroups);
end loop;
Reset (Shared.Global_AttrGroups);
for T in Type_Tables.First .. Last (Shared.Types) loop
if Shared.Types.Table (T).Is_Simple then
null;
else
Unchecked_Free (Shared.Types.Table (T).Attributes);
Free (Shared.Types.Table (T).Details);
end if;
end loop;
Free (Shared.Types);
Reset (Shared.Global_Attributes);
Unchecked_Free (Shared);
end if;
end Free;
-----------------------------
-- Parse_Grammar_If_Needed --
-----------------------------
procedure Parse_Grammar_If_Needed
(Handler : not null access Validating_Reader'Class;
URI : Symbol;
Xsd_File : Symbol;
Do_Create_NFA : Boolean)
is
File : File_Input;
Schema : Schema_Reader;
S_File_Full : constant Symbol := To_Absolute_URI (Handler.all, Xsd_File);
Need_To_Initialize : Boolean := True;
begin
GNAT.Task_Lock.Lock;
Set_XML_Version (Schema, Get_XML_Version (Handler.all));
if URI_Was_Parsed (Get_Grammar (Handler.all), S_File_Full) then
if Debug then
Debug_Output ("Parse_Grammar " & Get (S_File_Full).all
& " already parsed");
end if;
GNAT.Task_Lock.Unlock;
return;
end if;
if Debug then
Debug_Output ("Parse_Grammar NS={" & Get (URI).all
& "} XSD={" & Get (Xsd_File).all & "} "
& Get (S_File_Full).all);
end if;
if Get_XSD_Version (Handler.Grammar) = XSD_1_0 then
-- Must check that no element of the same namespace was seen
-- already (as per 4.3.2 (4) in the XSD 1.0 norm, which was
-- changed in XSD 1.1).
declare
NS : XML_NS;
begin
Find_NS_From_URI
(Handler.all,
URI => URI,
NS => NS);
if NS /= No_XML_NS
and then Element_Count (NS) > 0
and then S_File_Full /= Get_System_Id (NS)
and then Get_Feature
(Handler.all, Sax.Readers.Schema_Validation_Feature)
then
Validation_Error
(Handler,
"schemaLocation for """
& Get (URI).all
& """ cannot occur after the first"
& " element of that namespace in XSD 1.0");
end if;
end;
end if;
if Debug then
Output_Seen ("Parsing grammar: " & Get (S_File_Full).all);
end if;
Open (Get (S_File_Full).all, File);
Set_Public_Id (File, Get (S_File_Full).all);
Set_System_Id (File, Get (S_File_Full).all);
-- Add_To will likely already contain the grammar for the
-- schema-for-schema, and we won't have to recreate it in most cases.
Set_Symbol_Table (Schema, Get_Symbol_Table (Handler.all));
Set_Grammar (Schema, Handler.Grammar);
Use_Basename_In_Error_Messages
(Schema, Use_Basename_In_Error_Messages (Handler.all));
Set_Feature
(Schema,
Sax.Readers.Schema_Validation_Feature,
Get_Feature (Handler.all, Sax.Readers.Schema_Validation_Feature));
if Handler.all in Schema_Reader'Class then
Schema.Shared := Schema_Reader (Handler.all).Shared;
Need_To_Initialize := False;
end if;
begin
Internal_Parse
(Schema, File,
Default_Namespace => URI,
Do_Initialize_Shared => Need_To_Initialize,
Do_Create_NFA => Need_To_Initialize and Do_Create_NFA);
exception
when XML_Not_Implemented | XML_Validation_Error =>
-- Copy the error message and location from Schema to Handler
Close (File);
Handler.Error_Msg := Schema.Error_Msg;
Handler.Error_Location := Schema.Error_Location;
raise;
end;
Free (Schema);
Close (File);
if Debug then
Output_Seen ("Done parsing new grammar: " & Get (Xsd_File).all);
end if;
GNAT.Task_Lock.Unlock;
exception
when Ada.IO_Exceptions.Name_Error =>
Free (Schema);
Close (File);
GNAT.Task_Lock.Unlock;
if Debug then
Debug_Output
(ASCII.LF
& "!!!! Could not open file " & Get (S_File_Full).all
& ASCII.LF);
end if;
-- According to XML Schema Primer 0, section 5.6, this is not an
-- error when we do not find the schema, since this attribute is only
-- a hint.
Warning
(Handler.all,
Create (Message => "Could not open file " & Get (S_File_Full).all,
Loc => Handler.Current_Location));
when others =>
GNAT.Task_Lock.Unlock;
Close (File);
raise;
end Parse_Grammar_If_Needed;
--------------------
-- Internal_Parse --
--------------------
procedure Internal_Parse
(Parser : in out Schema_Reader;
Input : in out Input_Sources.Input_Source'Class;
Default_Namespace : Symbol;
Do_Create_NFA : Boolean;
Do_Initialize_Shared : Boolean)
is
Grammar : constant XML_Grammar := Get_Grammar (Parser);
URI : Symbol;
begin
if Debug then
Output_Action
("Parsing schema " & Input_Sources.Get_System_Id (Input));
end if;
Initialize_Symbols (Parser);
URI := Find_Symbol (Parser, Input_Sources.Get_System_Id (Input));
if not URI_Was_Parsed (Grammar, URI) then
if Do_Initialize_Shared then
Parser.Shared := new XSD_Data;
Init (Parser.Shared.Types);
end if;
Initialize_Grammar (Parser);
Parser.Target_NS := Default_Namespace;
Set_Grammar (Parser, Grammar); -- In case it was not initialized yet
Set_Parsed_URI (Parser, URI);
Schema.Readers.Parse (Validating_Reader (Parser), Input);
if Do_Create_NFA then
Create_NFA (Parser'Access);
end if;
if Do_Initialize_Shared then
Free (Parser.Shared);
end if;
Unchecked_Free (Parser.Contexts);
end if;
exception
when others =>
Unchecked_Free (Parser.Contexts);
if Do_Initialize_Shared then
Free (Parser.Shared);
end if;
raise;
end Internal_Parse;
-----------
-- Parse --
-----------
procedure Parse
(Parser : in out Schema_Reader;
Input : in out Input_Sources.Input_Source'Class) is
begin
Internal_Parse
(Parser,
Input,
Default_Namespace => Empty_String,
Do_Create_NFA => True,
Do_Initialize_Shared => True);
end Parse;
-------------------
-- Resolve_QName --
-------------------
function Resolve_QName
(Handler : access Schema_Reader'Class;
QName : Sax.Symbols.Symbol;
NS_If_Empty : Sax.Symbols.Symbol := Empty_String;
Loc : Location) return Qualified_Name
is
Val : Cst_Byte_Sequence_Access;
Separator : Integer;
NS : XML_NS;
Prefix : Symbol;
begin
if QName = No_Symbol then
return No_Qualified_Name;
else
Val := Get (QName);
Separator := Split_Qname (Val.all);
Prefix :=
Find_Symbol (Handler.all, Val (Val'First .. Separator - 1));
Get_Namespace_From_Prefix
(Handler => Handler.all,
Prefix => Prefix,
NS => NS);
if NS = No_XML_NS then
if Prefix /= Empty_String then
Validation_Error
(Handler,
"Cannot resolve namespace prefix "
& Val (Val'First .. Separator - 1),
Loc);
return No_Qualified_Name;
else
return
(NS => NS_If_Empty,
Local =>
Find_Symbol (Handler.all, Val (Separator + 1 .. Val'Last)));
end if;
else
return
(NS => Get_URI (NS),
Local =>
Find_Symbol (Handler.all, Val (Separator + 1 .. Val'Last)));
end if;
end if;
end Resolve_QName;
----------------
-- Get_Occurs --
----------------
procedure Get_Occurs
(Handler : access Schema_Reader'Class;
Atts : Sax_Attribute_List;
Min_Occurs, Max_Occurs : out Occurrences)
is
Min_Occurs_Index : constant Integer :=
Get_Index (Atts, URI => Empty_String, Local_Name => Handler.MinOccurs);
Max_Occurs_Index : constant Integer :=
Get_Index (Atts, URI => Empty_String, Local_Name => Handler.MaxOccurs);
function Occurs_From_Value (Index : Integer) return Occurrences;
-- Return the value of maxOccurs from the attributes'value. This
-- properly takes into account the "unbounded" case
function Occurs_From_Value (Index : Integer) return Occurrences is
Value : constant Symbol := Get_Value (Atts, Index);
begin
if Value = Handler.Unbounded then
return (Unbounded => True);
else
declare
Val : constant Cst_Byte_Sequence_Access := Get (Value);
Pos : Integer;
C : Unicode_Char;
begin
return (Unbounded => False, Value => Natural'Value (Val.all));
exception
when Constraint_Error =>
-- Either we have an integer too big to fit in Integer, or
-- we do not have an integer at all
Pos := Val'First;
while Pos <= Val'Last loop
Encoding.Read (Val.all, Pos, C);
if not Is_Digit (C) then
Validation_Error
(Handler, "Value for ""maxOccurs"" must"
& " be an integer or ""unbounded""");
end if;
end loop;
return (Unbounded => False, Value => Natural'Last);
end;
end if;
end Occurs_From_Value;
begin
Min_Occurs := (False, 1);
Max_Occurs := (False, 1);
if Min_Occurs_Index /= -1 then
Min_Occurs := Occurs_From_Value (Min_Occurs_Index);
if Min_Occurs.Unbounded then
Validation_Error
(Handler, "minOccurs cannot be ""unbounded""");
end if;
end if;
if Max_Occurs_Index /= -1 then
Max_Occurs := Occurs_From_Value (Max_Occurs_Index);
end if;
if not Max_Occurs.Unbounded then
if Max_Occurs.Value > Max_Max_Occurs then
Validation_Error
(Handler,
"maxOccurs is too big (XML/Ada supports up to"
& Max_Max_Occurs'Img & "), consider using ""unbounded""",
Except => XML_Limitation'Identity);
elsif Max_Occurs.Value > Max_Occurs_Warn then
Handler.Warning
(Create
(Message =>
"maxOccurs is big and could result in a very large state"
& " machine. Consider using ""unbounded"" instead",
Loc => Handler.Current_Location));
end if;
end if;
end Get_Occurs;
------------------
-- Push_Context --
------------------
procedure Push_Context
(Handler : access Schema_Reader'Class; Ctx : Context)
is
Tmp : Context_Array_Access;
begin
if Handler.Contexts_Last = 0 then
Handler.Contexts := new Context_Array (1 .. Default_Contexts);
elsif Handler.Contexts_Last = Handler.Contexts'Last then
Tmp := new Context_Array (1 .. Handler.Contexts'Last + 30);
Tmp (Handler.Contexts'Range) := Handler.Contexts.all;
Unchecked_Free (Handler.Contexts);
Handler.Contexts := Tmp;
end if;
Handler.Contexts_Last := Handler.Contexts_Last + 1;
Handler.Contexts (Handler.Contexts_Last) := Ctx;
end Push_Context;
------------------
-- Create_Group --
------------------
procedure Create_Group
(Handler : access Schema_Reader'Class;
Atts : Sax_Attribute_List)
is
Min_Occurs, Max_Occurs : Occurrences := (False, 1);
Group : Group_Descr;
Name : Qualified_Name;
Details : Type_Details_Access;
begin
Group.Loc := Handler.Current_Location;
for J in 1 .. Get_Length (Atts) loop
Name := Get_Name (Atts, J);
if Name.NS = Empty_String then
if Name.Local = Handler.Name then
Group.Name := (NS => Handler.Target_NS,
Local => Get_Value (Atts, J));
elsif Name.Local = Handler.Ref then
Group.Ref := Resolve_QName
(Handler, Get_Value (Atts, J),
Loc => Get_Location (Atts, J));
end if;
end if;
end loop;
case Handler.Contexts (Handler.Contexts_Last).Typ is
when Context_Schema | Context_Redefine =>
null;
when Context_Sequence | Context_Choice | Context_Extension
| Context_Restriction =>
Get_Occurs (Handler, Atts, Min_Occurs, Max_Occurs);
Details := new Type_Details'
(Kind => Type_Group,
Min_Occurs => Min_Occurs,
Max_Occurs => Max_Occurs,
Loc => Handler.Current_Location,
In_Process => False,
Next => null,
Group => Group);
Insert_In_Type (Handler, Details);
when others =>
Validation_Error
(Handler,
"Unsupported ""group"" in this context",
Except => XML_Not_Implemented'Identity);
end case;
Push_Context (Handler,
(Typ => Context_Group,
Group => Group));
end Create_Group;
------------------
-- Finish_Group --
------------------
procedure Finish_Group (Handler : access Schema_Reader'Class) is
Ctx : constant Context_Access :=
Handler.Contexts (Handler.Contexts_Last)'Access;
Next : constant Context_Access :=
Handler.Contexts (Handler.Contexts_Last - 1)'Access;
begin
case Next.Typ is
when Context_Schema | Context_Redefine =>
Set (Handler.Shared.Global_Groups, Ctx.Group.Name, Ctx.Group);
when others =>
null;
end case;
end Finish_Group;
----------------------------
-- Create_Attribute_Group --
----------------------------
procedure Create_Attribute_Group
(Handler : access Schema_Reader'Class;
Atts : Sax_Attribute_List)
is
Group : AttrGroup_Descr;
Name : Qualified_Name;
begin
for J in 1 .. Get_Length (Atts) loop
Name := Get_Name (Atts, J);
if Name.NS = Empty_String then
if Name.Local = Handler.Name then
Group.Name := (NS => Handler.Target_NS,
Local => Get_Value (Atts, J));
elsif Name.Local = Handler.Ref then
Group.Ref := Resolve_QName
(Handler, Get_Value (Atts, J),
Loc => Get_Location (Atts, J));
end if;
end if;
end loop;
Push_Context
(Handler, (Typ => Context_Attribute_Group,
Attr_Group => Group));
end Create_Attribute_Group;
----------------------------
-- Finish_Attribute_Group --
----------------------------
procedure Finish_Attribute_Group (Handler : access Schema_Reader'Class) is
Ctx : constant Context_Access :=
Handler.Contexts (Handler.Contexts_Last)'Access;
Next : constant Context_Access :=
Handler.Contexts (Handler.Contexts_Last - 1)'Access;
Ctx2 : Context_Access;
Index : Natural;
begin
case Next.Typ is
when Context_Schema | Context_Redefine =>
Set
(Handler.Shared.Global_AttrGroups,
Ctx.Attr_Group.Name, Ctx.Attr_Group);
when Context_Type_Def =>
pragma Assert (Ctx.Attr_Group.Attributes = null);
Append
(Handler.Shared.Types.Table (Next.Type_Info).Attributes,
(Kind => Kind_Group,
Loc => Handler.Current_Location,
Group_Ref => Ctx.Attr_Group.Ref));
when Context_Extension | Context_Simple_Extension =>
pragma Assert (Ctx.Attr_Group.Attributes = null);
Index := Handler.Contexts_Last - 1;
while Index >= Handler.Contexts'First loop
Ctx2 := Handler.Contexts (Index)'Access;
if Ctx2.Typ = Context_Type_Def then
Append
(Handler.Shared.Types.Table (Ctx2.Type_Info).Attributes,
(Kind => Kind_Group,
Loc => Handler.Current_Location,
Group_Ref => Ctx.Attr_Group.Ref));
exit;
end if;
Index := Index - 1;
end loop;
when Context_Attribute_Group =>
pragma Assert (Ctx.Attr_Group.Attributes = null);
Append
(Next.Attr_Group.Attributes,
(Kind => Kind_Group,
Loc => Handler.Current_Location,
Group_Ref => Ctx.Attr_Group.Ref));
when others =>
Unchecked_Free (Ctx.Attr_Group.Attributes);
Validation_Error
(Handler,
"Invalid context for attributeGroup: " & Next.Typ'Img,
Except => XML_Not_Implemented'Identity);
end case;
end Finish_Attribute_Group;
------------
-- Append --
------------
procedure Append (List : in out Attr_Array_Access; Attr : Attr_Descr) is
Tmp : Attr_Array_Access;
begin
if List = null then
List := new Attr_Array'(1 => Attr,
2 .. 10 => (Kind => Kind_Unset,
Loc => No_Location));
elsif List (List'Last).Kind /= Kind_Unset then
Tmp := new Attr_Array (1 .. List'Last + 10);
Tmp (List'Range) := List.all;
Tmp (List'Last + 1) := Attr;
Tmp (List'Last + 2 .. Tmp'Last) :=
(others => Attr_Descr'(Kind => Kind_Unset, Loc => No_Location));
Unchecked_Free (List);
List := Tmp;
else
for L in List'Range loop
if List (L).Kind = Kind_Unset then
List (L) := Attr;
return;
end if;
end loop;
end if;
end Append;
--------------------
-- Create_Include --
--------------------
procedure Create_Include
(Handler : access Schema_Reader'Class;
Atts : Sax_Attribute_List)
is
Schema_Location_Index : constant Integer :=
Get_Index (Atts, Empty_String, Handler.Schema_Location);
begin
Parse_Grammar
(Handler,
URI => Handler.Target_NS,
Xsd_File => Get_Value (Atts, Schema_Location_Index),
Do_Create_NFA => False); -- Will be performed later
end Create_Include;
---------------------
-- Create_Redefine --
---------------------
procedure Create_Redefine
(Handler : access Schema_Reader'Class;
Atts : Sax_Attribute_List)
is
Location_Index : constant Integer :=
Get_Index (Atts, Empty_String, Handler.Schema_Location);
begin
-- Disable for now.
-- On the test./testschema -xsd boeingData/ipo4/ipo.xsd
-- -xsd boeingData/ipo4/address.xsd
-- -xsd boeingData/ipo4/itematt.xsd
-- boeingData/ipo4/ipo_1.xml
-- we redefine an extension whose base type comes from the redefined
-- grammar, and whose name is the same. As a result, the extension and
-- its base type end up being the same XML_Type, and thus we get
-- infinite loops. We should really merge the models when the grammar is
-- parsed.
Validation_Error
(Handler,
"<redefine> not supported",
Except => XML_Not_Implemented'Identity);
Parse_Grammar
(Handler,
URI => Handler.Target_NS,
Do_Create_NFA => True,
Xsd_File => Get_Value (Atts, Location_Index));
Push_Context (Handler, (Typ => Context_Redefine));
end Create_Redefine;
-------------------
-- Create_Import --
-------------------
procedure Create_Import
(Handler : access Schema_Reader'Class;
Atts : Sax_Attribute_List)
is
Location_Index : constant Integer :=
Get_Index (Atts, Empty_String, Handler.Schema_Location);
-- Namespace_Index : constant Integer :=
-- Get_Index (Atts, Empty_String, Handler.Namespace);
begin
if Location_Index = -1 then
-- if Namespace_Index = -1 then
-- -- See 4.2.6.1: If that attribute is absent, then the import
-- -- allows unqualified reference to components with no target
-- -- namespace
-- null;
-- end if;
Validation_Error
(Handler,
"Import with no schemaLocation is unsupported",
Except => XML_Not_Implemented'Identity);
else
declare
Location : constant Symbol := Get_Value (Atts, Location_Index);
begin
if Debug then
Debug_Output ("Import: " & Get (Location).all);
Debug_Output ("Adding new grammar to Handler.Created_Grammar");
end if;
-- The namespace attribute indicates that the XSD may contain
-- qualified references to schema components in that namespace.
-- (4.2.6.1). It does not give the default targetNamespace
Parse_Grammar
(Handler,
URI => Empty_String,
Do_Create_NFA => True,
Xsd_File => Location);
end;
end if;
end Create_Import;
--------------------------
-- Create_Any_Attribute --
--------------------------
procedure Create_Any_Attribute
(Handler : access Schema_Reader'Class;
Atts : Sax_Attribute_List)
is
Name : Qualified_Name;
Att : Attr_Descr (Kind => Kind_Attribute);
begin
Att.Loc := Handler.Current_Location;
Att.Attr.Any := (Namespaces => Handler.Any_Namespace,
Target_NS => Handler.Target_NS,
Process_Contents => Process_Strict);
for J in 1 .. Get_Length (Atts) loop
Name := Get_Name (Atts, J);
if Name.NS = Empty_String then
if Name.Local = Handler.Namespace then
Att.Attr.Any.Namespaces := Get_Value (Atts, J);
elsif Name.Local = Handler.Process_Contents then
Att.Attr.Any.Process_Contents :=
Process_Contents_From_Atts (Handler, Atts, J);
end if;
end if;
end loop;
Insert_Attribute (Handler, Handler.Contexts_Last, Att);
end Create_Any_Attribute;
---------------------
-- Create_Notation --
---------------------
procedure Create_Notation
(Handler : access Schema_Reader'Class; Atts : Sax_Attribute_List)
is
type Notation_Descr is record
Name : Symbol;
System_Id : Symbol := Empty_String;
Public_Id : Symbol := Empty_String;
end record;
Name : Qualified_Name;
Notation : Notation_Descr;
begin
for J in 1 .. Get_Length (Atts) loop
Name := Get_Name (Atts, J);
if Name.NS = Empty_String then
if Name.Local = Handler.Name then
Notation.Name := Get_Value (Atts, J);
elsif Name.Local = Handler.Public then
Notation.Public_Id := Get_Value (Atts, J);
elsif Name.Local = Handler.System then
Notation.System_Id := Get_Value (Atts, J);
end if;
end if;
end loop;
Add_Notation (Get_NFA (Handler.Grammar), Notation.Name);
Notation_Decl
(Sax_Reader'Class (Handler.all),
Name => Get (Notation.Name).all,
System_Id => Get (Notation.System_Id).all,
Public_Id => Get (Notation.Public_Id).all);
end Create_Notation;
--------------------
-- Create_Element --
--------------------
procedure Create_Element
(Handler : access Schema_Reader'Class;
Atts : Sax_Attribute_List)
is
Min_Occurs, Max_Occurs : Occurrences := (False, 1);
Info : Element_Descr;
Name : Qualified_Name;
Details : Type_Details_Access;
begin
Info.Loc := Handler.Current_Location;
Info.Form := Handler.Element_Form_Default;
Info.Block := Handler.Target_Block_Default;
for J in 1 .. Get_Length (Atts) loop
Name := Get_Name (Atts, J);
if Name.NS = Empty_String then
if Name.Local = Handler.Typ then
Info.Typ := Resolve_QName
(Handler, Get_Value (Atts, J),
NS_If_Empty => Handler.Target_NS,
Loc => Get_Location (Atts, J));
elsif Name.Local = Handler.Name then
Info.Name := (NS => Handler.Target_NS,
Local => Get_Value (Atts, J));
elsif Name.Local = Handler.Ref then
Info.Ref := Resolve_QName
(Handler, Get_Value (Atts, J),
Loc => Get_Location (Atts, J));
elsif Name.Local = Handler.Substitution_Group then
Info.Substitution_Group :=
Resolve_QName
(Handler, Get_Value (Atts, J),
Loc => Get_Location (Atts, J));
elsif Name.Local = Handler.Default then
Info.Default := Get_Value (Atts, J);
elsif Name.Local = Handler.Fixed then
Info.Fixed := Get_Value (Atts, J);
elsif Name.Local = Handler.S_Abstract then
Info.Is_Abstract := Get_Value_As_Boolean (Atts, J, False);
elsif Name.Local = Handler.Nillable then
Info.Nillable := Get_Value_As_Boolean (Atts, J, False);
elsif Name.Local = Handler.Form then
Info.Form := Compute_Form (Atts, Handler, J);
elsif Name.Local = Handler.Final then
Info.Final := Compute_Final (Atts, Handler, J);
elsif Name.Local = Handler.Block then
Compute_Blocks (Atts, Handler, Info.Block, Info.Has_Block, J);
end if;
end if;
end loop;
if Info.Name /= No_Qualified_Name then
if Info.Ref /= No_Qualified_Name
and then Info.Ref.NS = No_Symbol
and then Info.Name = Info.Ref
and then not In_Redefine_Context (Handler.all)
then
Validation_Error
(Handler, """ref"" attribute cannot be self-referencing");
elsif Info.Ref /= No_Qualified_Name then
Validation_Error
(Handler, "Name and Ref cannot be both specified");
end if;
elsif Info.Ref = No_Qualified_Name then
Validation_Error
(Handler, "Either ""name"" or ""ref"" attribute must be present");
else
-- Section 3.3.2, validity constraints 3.3.3
if Info.Typ /= No_Qualified_Name then
Validation_Error
(Handler,
"""type"" attribute cannot be specified along with ""ref""");
end if;
end if;
if Info.Default /= No_Symbol and then Info.Fixed /= No_Symbol then
Validation_Error
(Handler, "Default and Fixed cannot be both specified");
end if;
if Info.Ref /= No_Qualified_Name then
Info.Form := Qualified;
end if;
if Handler.Contexts (Handler.Contexts_Last).Typ /= Context_Schema then
Get_Occurs (Handler, Atts, Min_Occurs, Max_Occurs);
Details := new Type_Details'
(Kind => Type_Element,
Min_Occurs => Min_Occurs,
Max_Occurs => Max_Occurs,
Loc => Handler.Current_Location,
In_Process => False,
Next => null,
Element => Info);
Insert_In_Type (Handler, Details);
end if;
Push_Context
(Handler,
(Typ => Context_Element,
Elem_Details => Details,
Element => Info));
end Create_Element;
--------------------
-- Finish_Element --
--------------------
procedure Finish_Element (Handler : access Schema_Reader'Class) is
Ctx : constant Context_Access :=
Handler.Contexts (Handler.Contexts_Last)'Access;
Next : constant Context_Access :=
Handler.Contexts (Handler.Contexts_Last - 1)'Access;
Info : constant Element_Descr := Ctx.Element;
begin
case Next.Typ is
when Context_Schema | Context_Redefine =>
Set (Handler.Shared.Global_Elements, Info.Name, Info);
when others =>
-- We might have added the type definition
Ctx.Elem_Details.Element := Ctx.Element;
end case;
end Finish_Element;
------------------------
-- Create_Simple_Type --
------------------------
procedure Create_Simple_Type
(Handler : access Schema_Reader'Class;
Atts : Sax_Attribute_List)
is
Ctx : constant Context_Access :=
Handler.Contexts (Handler.Contexts_Last)'Access;
begin
Prepare_Type (Handler, Atts, Is_Simple => True);
if Ctx.Typ = Context_Simple_Restriction then
Ctx.Simple.Base :=
(Name => No_Qualified_Name,
Local => Handler.Contexts (Handler.Contexts_Last).Type_Info);
end if;
end Create_Simple_Type;
---------------------
-- Add_Type_Member --
---------------------
procedure Add_Type_Member
(Handler : access Schema_Reader'Class;
List : in out Type_Member_Array;
Member : Type_Member;
Loc : Location)
is
begin
for A in List'Range loop
if List (A) = No_Type_Member then
List (A) := Member;
return;
end if;
end loop;
Validation_Error
(Handler,
"Too many types in the union", Loc,
XML_Not_Implemented'Identity);
end Add_Type_Member;
------------------------
-- Finish_Simple_Type --
------------------------
procedure Finish_Simple_Type (Handler : access Schema_Reader'Class) is
Ctx : constant Context_Access :=
Handler.Contexts (Handler.Contexts_Last)'Access;
Next : constant Context_Access :=
Handler.Contexts (Handler.Contexts_Last - 1)'Access;
begin
case Next.Typ is
when Context_Schema | Context_Redefine => null;
when Context_Element => Next.Element.Local_Type := Ctx.Type_Info;
when Context_Attribute =>
Next.Attribute.Attr.Local_Type := Ctx.Type_Info;
when Context_List =>
Add_Type_Member (Handler, Next.List.List_Items,
(Name => No_Qualified_Name,
Local => Ctx.Type_Info),
No_Location);
when Context_Union =>
Add_Type_Member (Handler, Next.Union.Union_Items,
(Name => No_Qualified_Name,
Local => Ctx.Type_Info),
No_Location);
when Context_Restriction =>
Next.Restriction.Restriction.Details :=
Handler.Shared.Types.Table (Ctx.Type_Info).Details;
when Context_Simple_Restriction =>
-- The simpleType is in fact the base type of the restriction. The
-- following was already done in Create_Simple_Type:
-- Next.Simple.Base.Local := Ctx.Type_Info;
null;
when others =>
Validation_Error
(Handler,
"Unsupported: ""simpleType"" in this context",
Except => XML_Not_Implemented'Identity);
end case;
end Finish_Simple_Type;
--------------------
-- Compute_Blocks --
--------------------
procedure Compute_Blocks
(Atts : Sax_Attribute_List;
Handler : access Schema_Reader'Class;
Blocks : out Block_Status;
Is_Set : out Boolean;
Index : Integer)
is
procedure On_Item (Str : Byte_Sequence);
procedure On_Item (Str : Byte_Sequence) is
begin
if Str = "restriction" then
Blocks (Block_Restriction) := True;
elsif Str = "extension" then
Blocks (Block_Extension) := True;
elsif Str = "substitution" then
Blocks (Block_Substitution) := True;
elsif Str = "#all" then
Blocks := (others => True);
else
Validation_Error
(Handler, "Invalid value for block: """ & Str & """");
end if;
end On_Item;
procedure For_Each is new For_Each_Item (On_Item);
begin
Is_Set := Index /= -1;
Blocks := No_Block;
if Index /= -1 then
For_Each (Get (Get_Value (Atts, Index)).all);
if Debug then
Output_Action ("Set_Block (" & To_String (Blocks) & ")");
end if;
end if;
end Compute_Blocks;
------------------
-- Compute_Form --
------------------
function Compute_Form
(Atts : Sax_Attribute_List;
Handler : access Schema_Reader'Class;
Index : Integer) return Form_Type is
begin
if Get_Value (Atts, Index) = Handler.Qualified then
return Qualified;
else
return Unqualified;
end if;
end Compute_Form;
-------------------
-- Compute_Final --
-------------------
function Compute_Final
(Atts : Sax_Attribute_List;
Handler : access Schema_Reader'Class;
Index : Integer) return Final_Status
is
Final : Final_Status;
procedure On_Item (Str : Byte_Sequence);
procedure On_Item (Str : Byte_Sequence) is
begin
if Str = "restriction" then
Final (Final_Restriction) := True;
elsif Str = "extension" then
Final (Final_Extension) := True;
elsif Str = "#all" then
Final := (others => True);
elsif Str = "union" then
Final (Final_Union) := True;
elsif Str = "list" then
Final (Final_List) := True;
else
Validation_Error
(Handler, "Invalid value for final: """ & Str & """");
end if;
end On_Item;
procedure For_Each is new For_Each_Item (On_Item);
begin
Final := (others => False);
if Index /= -1 then
For_Each (Get (Get_Value (Atts, Index)).all);
if Debug then
Output_Action ("Set_Final (" & To_String (Final) & ")");
end if;
end if;
return Final;
end Compute_Final;
------------------
-- Prepare_Type --
------------------
procedure Prepare_Type
(Handler : access Schema_Reader'Class;
Atts : Sax_Attribute_List;
Is_Simple : Boolean)
is
Info : Internal_Type_Descr (Is_Simple => Is_Simple);
Is_Set : Boolean;
Name : Qualified_Name;
Props : Type_Descr;
begin
Info.Loc := Handler.Current_Location;
Props.Block := Handler.Target_Block_Default;
for J in 1 .. Get_Length (Atts) loop
Name := Get_Name (Atts, J);
if Name.NS = Empty_String then
if Name.Local = Handler.Mixed then
Props.Mixed := Get_Value_As_Boolean (Atts, J, False);
elsif Name.Local = Handler.Name then
Props.Name :=
(NS => Handler.Target_NS,
Local => Get_Value (Atts, J));
elsif Name.Local = Handler.Block then
Compute_Blocks (Atts, Handler, Props.Block, Is_Set, J);
elsif Name.Local = Handler.Final then
Props.Final := Compute_Final (Atts, Handler, J);
elsif Name.Local = Handler.S_Abstract then
Props.Is_Abstract := Get_Value_As_Boolean (Atts, J, False);
end if;
end if;
end loop;
-- block="substitution" does not apply to types, only to elements
Props.Block (Block_Substitution) := False;
Info.Properties := Props;
Append (Handler.Shared.Types, Info);
Push_Context
(Handler,
(Typ => Context_Type_Def,
Type_Info => Last (Handler.Shared.Types)));
end Prepare_Type;
-------------------------
-- Create_Complex_Type --
-------------------------
procedure Create_Complex_Type
(Handler : access Schema_Reader'Class;
Atts : Sax_Attribute_List) is
begin
Prepare_Type (Handler, Atts, Is_Simple => False);
end Create_Complex_Type;
-------------------------
-- Finish_Complex_Type --
-------------------------
procedure Finish_Complex_Type (Handler : access Schema_Reader'Class) is
Ctx : constant Context_Access :=
Handler.Contexts (Handler.Contexts_Last)'Access;
Next : constant Context_Access :=
Handler.Contexts (Handler.Contexts_Last - 1)'Access;
begin
case Next.Typ is
when Context_Element => Next.Element.Local_Type := Ctx.Type_Info;
when others => null;
end case;
end Finish_Complex_Type;
------------------------
-- Create_Restriction --
------------------------
procedure Create_Restriction
(Handler : access Schema_Reader'Class;
Atts : Sax_Attribute_List)
is
Ctx : constant Context_Access :=
Handler.Contexts (Handler.Contexts_Last)'Access;
Restr : Restriction_Descr;
Details : Type_Details_Access;
Name : Qualified_Name;
In_Type : constant Internal_Type_Index := Ctx.Type_Info;
begin
Restr.Loc := Handler.Current_Location;
Restr.Base := (NS => Handler.XML_Schema_URI,
Local => Handler.Any_Simple_Type);
for J in 1 .. Get_Length (Atts) loop
Name := Get_Name (Atts, J);
if Name.NS = Empty_String then
if Name.Local = Handler.Base then
Restr.Base := Resolve_QName
(Handler, Get_Value (Atts, J), Handler.Target_NS,
Get_Location (Atts, J));
end if;
end if;
end loop;
if Handler.Shared.Types.Table (In_Type).Is_Simple
or else Handler.Shared.Types.Table (In_Type).Simple.Kind /=
Simple_Type_None
then
if Restr.Base = (NS => Handler.XML_Schema_URI, Local => Handler.IDREF)
or else Restr.Base =
(NS => Handler.XML_Schema_URI, Local => Handler.IDREFS)
then
Validation_Error
(Handler,
"Unsupported type IDREF and IDREFS",
Except => XML_Not_Implemented'Identity);
end if;
if not Handler.Shared.Types.Table (In_Type).Is_Simple then
Details := new Type_Details'
(Kind => Type_Restriction,
Min_Occurs => (False, 1),
Max_Occurs => (False, 1),
Loc => Handler.Current_Location,
In_Process => False,
Next => null,
Simple_Content_Restriction => True,
Restriction => Restr);
Insert_In_Type (Handler, Details);
end if;
Push_Context
(Handler,
(Typ => Context_Simple_Restriction,
Simple => (Kind => Simple_Type_Restriction,
In_Process => False,
Facets => No_Facets,
Base =>
(Name => Restr.Base,
Local => No_Internal_Type_Index),
Loc => Handler.Current_Location)));
else
Details := new Type_Details'
(Kind => Type_Restriction,
Min_Occurs => (False, 1),
Max_Occurs => (False, 1),
Loc => Handler.Current_Location,
In_Process => False,
Next => null,
Simple_Content_Restriction => False,
Restriction => Restr);
Insert_In_Type (Handler, Details);
Push_Context
(Handler,
(Typ => Context_Restriction,
Restriction => Details));
end if;
end Create_Restriction;
------------------------
-- Finish_Restriction --
------------------------
procedure Finish_Restriction (Handler : access Schema_Reader'Class) is
Ctx : constant Context_Access :=
Handler.Contexts (Handler.Contexts_Last)'Access;
Next : constant Context_Access :=
Handler.Contexts (Handler.Contexts_Last - 1)'Access;
begin
if Ctx.Typ = Context_Simple_Restriction then
pragma Assert (Next.Typ = Context_Type_Def);
Handler.Shared.Types.Table (Next.Type_Info).Simple := Ctx.Simple;
end if;
end Finish_Restriction;
------------------
-- Create_Union --
------------------
procedure Create_Union
(Handler : access Schema_Reader'Class;
Atts : Sax_Attribute_List)
is
Name : Qualified_Name;
procedure Add_Union (Str : Byte_Sequence);
-- Add a unioned type to [Simple]
procedure Add_Union (Str : Byte_Sequence) is
Sym : constant Symbol := Find_Symbol (Handler.all, Str);
Ctx : constant Context_Access :=
Handler.Contexts (Handler.Contexts_Last)'Access;
Name : constant Qualified_Name :=
Resolve_QName (Handler, Sym, Handler.Target_NS,
Loc => Ctx.Union.Loc);
begin
Add_Type_Member
(Handler,
Ctx.Union.Union_Items,
(Name => Name, Local => No_Internal_Type_Index),
Ctx.Union.Loc);
end Add_Union;
procedure For_Each_Union is new For_Each_Item (Add_Union);
begin
Push_Context
(Handler,
(Typ => Context_Union,
Union => (Kind => Simple_Type_Union,
In_Process => False,
Loc => Handler.Current_Location,
Union_Items => (others => No_Type_Member))));
for J in 1 .. Get_Length (Atts) loop
Name := Get_Name (Atts, J);
if Name.NS = Empty_String then
if Name.Local = Handler.Member_Types then
For_Each_Union (Get (Get_Value (Atts, J)).all);
end if;
end if;
end loop;
end Create_Union;
------------------
-- Finish_Union --
------------------
procedure Finish_Union (Handler : access Schema_Reader'Class) is
Ctx : constant Context_Access :=
Handler.Contexts (Handler.Contexts_Last)'Access;
Next : constant Context_Access :=
Handler.Contexts (Handler.Contexts_Last - 1)'Access;
begin
case Next.Typ is
when Context_Type_Def =>
Handler.Shared.Types.Table (Next.Type_Info).Simple := Ctx.Union;
when others =>
Validation_Error
(Handler,
"Unsupported: ""union"" in this context",
Except => XML_Not_Implemented'Identity);
end case;
end Finish_Union;
----------------------
-- Create_Extension --
----------------------
procedure Create_Extension
(Handler : access Schema_Reader'Class;
Atts : Sax_Attribute_List)
is
Ctx : constant Context_Access :=
Handler.Contexts (Handler.Contexts_Last)'Access;
Ext : Extension_Descr;
Name : Qualified_Name;
Details : Type_Details_Access;
In_Type : constant Internal_Type_Index := Ctx.Type_Info;
begin
Ext.Loc := Handler.Current_Location;
for J in 1 .. Get_Length (Atts) loop
Name := Get_Name (Atts, J);
if Name.NS = Empty_String then
if Name.Local = Handler.Base then
Ext.Base := Resolve_QName
(Handler, Get_Value (Atts, J), Handler.Target_NS,
Loc => Get_Location (Atts, J));
end if;
end if;
end loop;
if Ext.Base = No_Qualified_Name then
Validation_Error
(Handler, "Attribute ""base"" required for <extensionType>");
end if;
if Handler.Shared.Types.Table (In_Type).Is_Simple
or else Handler.Shared.Types.Table (In_Type).Simple.Kind /=
Simple_Type_None
then
if Debug then
Debug_Output ("Create extension: in simpleContent or simpleType");
end if;
if not Handler.Shared.Types.Table (In_Type).Is_Simple then
Details := new Type_Details'
(Kind => Type_Extension,
Min_Occurs => (False, 1),
Max_Occurs => (False, 1),
Loc => Handler.Current_Location,
In_Process => False,
Next => null,
Simple_Content => True,
Extension => Ext);
Insert_In_Type (Handler, Details);
end if;
Push_Context
(Handler,
(Typ => Context_Simple_Extension,
Simple => (Kind => Simple_Type_Extension,
In_Process => False,
Base => (Name => Ext.Base,
Local => No_Internal_Type_Index),
Facets => No_Facets,
Loc => Handler.Current_Location)));
else
Details := new Type_Details'
(Kind => Type_Extension,
Min_Occurs => (False, 1),
Max_Occurs => (False, 1),
Loc => Handler.Current_Location,
In_Process => False,
Next => null,
Simple_Content => False,
Extension => Ext);
Insert_In_Type (Handler, Details);
Push_Context
(Handler,
(Typ => Context_Extension,
Extension => Details));
end if;
end Create_Extension;
----------------------
-- Finish_Extension --
----------------------
procedure Finish_Extension (Handler : access Schema_Reader'Class) is
Ctx : constant Context_Access :=
Handler.Contexts (Handler.Contexts_Last)'Access;
Next : constant Context_Access :=
Handler.Contexts (Handler.Contexts_Last - 1)'Access;
begin
if Ctx.Typ = Context_Simple_Extension then
pragma Assert (Next.Typ = Context_Type_Def); -- a simple type
Handler.Shared.Types.Table (Next.Type_Info).Simple := Ctx.Simple;
end if;
end Finish_Extension;
-----------------
-- Create_List --
-----------------
procedure Create_List
(Handler : access Schema_Reader'Class;
Atts : Sax_Attribute_List)
is
Name : Qualified_Name;
begin
Push_Context
(Handler,
(Typ => Context_List,
List => (Kind => Simple_Type_List,
In_Process => False,
Loc => Handler.Current_Location,
List_Items => (others => No_Type_Member))));
for J in 1 .. Get_Length (Atts) loop
Name := Get_Name (Atts, J);
if Name.NS = Empty_String then
if Name.Local = Handler.Item_Type then
Name := Resolve_QName
(Handler, Get_Value (Atts, J), Handler.Target_NS,
Loc => Get_Location (Atts, J));
Add_Type_Member
(Handler,
Handler.Contexts (Handler.Contexts_Last).List.List_Items,
(Name => Name, Local => No_Internal_Type_Index),
Handler.Current_Location);
end if;
end if;
end loop;
end Create_List;
-----------------
-- Finish_List --
-----------------
procedure Finish_List (Handler : access Schema_Reader'Class) is
Ctx : constant Context_Access :=
Handler.Contexts (Handler.Contexts_Last)'Access;
Next : constant Context_Access :=
Handler.Contexts (Handler.Contexts_Last - 1)'Access;
Next_Next : constant Context_Access :=
Handler.Contexts (Handler.Contexts_Last - 2)'Access;
begin
case Next.Typ is
when Context_Type_Def =>
if Next.Type_Info = No_Internal_Type_Index then
-- within a <simpleType><restriction><simpleType><list>
pragma Assert (Next_Next.Typ = Context_Simple_Restriction);
Next_Next.Simple := Ctx.List;
else
-- within a <simpleType><list>
pragma Assert (Next.Type_Info /= No_Internal_Type_Index);
Handler.Shared.Types.Table (Next.Type_Info).Simple := Ctx.List;
end if;
when others =>
Validation_Error
(Handler,
"Unsupported: ""list"" in this context",
Except => XML_Not_Implemented'Identity);
end case;
end Finish_List;
--------------------
-- Insert_In_Type --
--------------------
procedure Insert_In_Type
(Handler : access Schema_Reader'Class;
Element : in out Type_Details_Access)
is
procedure Append (List : in out Type_Details_Access;
Elem : Type_Details_Access);
procedure Append (List : in out Type_Details_Access;
Elem : Type_Details_Access)
is
Tmp : Type_Details_Access;
begin
if List = null then
List := Elem;
else
Tmp := List;
while Tmp.Next /= null loop
Tmp := Tmp.Next;
end loop;
Tmp.Next := Elem;
end if;
end Append;
Ctx : constant Context_Access :=
Handler.Contexts (Handler.Contexts_Last)'Access;
begin
case Ctx.Typ is
when Context_Type_Def =>
if Handler.Shared.Types.Table (Ctx.Type_Info).Is_Simple then
Free (Element);
Validation_Error
(Handler, "Invalid element in simple type");
end if;
if Debug and then
Handler.Shared.Types.Table (Ctx.Type_Info).Details /= null
then
Debug_Output ("Insert_In_Type, type already has details "
& " when inserting " & Element.Kind'Img);
end if;
pragma Assert
(Handler.Shared.Types.Table (Ctx.Type_Info).Details = null);
Handler.Shared.Types.Table (Ctx.Type_Info).Details := Element;
when Context_Sequence =>
Append (Ctx.Seq.First_In_Seq, Element);
when Context_Choice =>
Append (Ctx.Choice.First_In_Choice, Element);
when Context_All =>
Append (Ctx.All_Detail.First_In_All, Element);
when Context_Group =>
if Ctx.Group.Details /= null then
Free (Element);
Validation_Error
(Handler, "Invalid element in non group");
end if;
Ctx.Group.Details := Element;
when Context_Extension =>
if Ctx.Extension.Extension.Details /= null then
Free (Element);
Validation_Error
(Handler, "Invalid element in non-empty extension");
end if;
Ctx.Extension.Extension.Details := Element;
when Context_Restriction =>
if Ctx.Restriction.Restriction.Details /= null then
Free (Element);
Validation_Error
(Handler, "Invalid element in non-empty restriction");
end if;
Ctx.Restriction.Restriction.Details := Element;
when Context_Simple_Restriction | Context_Simple_Extension =>
Free (Element);
when Context_Schema | Context_Attribute | Context_Element
| Context_Union
| Context_List | Context_Redefine | Context_Attribute_Group =>
Free (Element);
Validation_Error
(Handler,
"Unsupported: """ & Element.Kind'Img & """ in context "
& Ctx.Typ'Img,
Except => XML_Not_Implemented'Identity);
end case;
end Insert_In_Type;
-------------------
-- Create_Choice --
-------------------
procedure Create_Choice
(Handler : access Schema_Reader'Class;
Atts : Sax_Attribute_List)
is
Min_Occurs, Max_Occurs : Occurrences := (False, 1);
Choice : Type_Details_Access;
begin
Get_Occurs (Handler, Atts, Min_Occurs, Max_Occurs);
Choice := new Type_Details'
(Kind => Type_Choice,
Min_Occurs => Min_Occurs,
Max_Occurs => Max_Occurs,
Loc => Handler.Current_Location,
In_Process => False,
Next => null,
First_In_Choice => null);
Insert_In_Type (Handler, Choice);
Push_Context
(Handler,
(Typ => Context_Choice,
Choice => Choice));
end Create_Choice;
---------------------
-- Create_Sequence --
---------------------
procedure Create_Sequence
(Handler : access Schema_Reader'Class;
Atts : Sax_Attribute_List)
is
Min_Occurs, Max_Occurs : Occurrences := (False, 1);
Seq : Type_Details_Access;
begin
Get_Occurs (Handler, Atts, Min_Occurs, Max_Occurs);
Seq := new Type_Details'
(Kind => Type_Sequence,
Min_Occurs => Min_Occurs,
Max_Occurs => Max_Occurs,
Loc => Handler.Current_Location,
In_Process => False,
Next => null,
First_In_Seq => null);
Insert_In_Type (Handler, Seq);
Push_Context
(Handler,
(Typ => Context_Sequence,
Seq => Seq));
end Create_Sequence;
----------------------
-- Create_Attribute --
----------------------
procedure Create_Attribute
(Handler : access Schema_Reader'Class;
Atts : Sax_Attribute_List)
is
Name : Qualified_Name;
Att : Attr_Descr (Kind => Kind_Attribute);
Ctx : constant Context_Access :=
Handler.Contexts (Handler.Contexts_Last)'Access;
Has_Form : Boolean := False;
begin
Att.Attr.Descr.Form := Handler.Attribute_Form_Default;
Att.Loc := Handler.Current_Location;
for J in 1 .. Get_Length (Atts) loop
Name := Get_Name (Atts, J);
if Name.NS = Empty_String then
if Name.Local = Handler.Name then
Att.Attr.Descr.Name := (NS => Handler.Target_NS,
Local => Get_Value (Atts, J));
elsif Name.Local = Handler.Typ then
Att.Attr.Typ := Resolve_QName
(Handler, Get_Value (Atts, J),
Loc => Get_Location (Atts, J));
if Att.Attr.Typ =
(NS => Handler.XML_Schema_URI, Local => Handler.IDREF)
or else Att.Attr.Typ =
(NS => Handler.XML_Schema_URI, Local => Handler.IDREFS)
then
Validation_Error
(Handler,
"Unsupported type IDREF and IDREFS",
Get_Location (Atts, J),
Except => XML_Not_Implemented'Identity);
end if;
elsif Name.Local = Handler.S_Use then
if Get_Value (Atts, J) = Handler.Required then
Att.Attr.Descr.Use_Type := Required;
elsif Get_Value (Atts, J) = Handler.Prohibited then
Att.Attr.Descr.Use_Type := Prohibited;
else
Att.Attr.Descr.Use_Type := Optional;
end if;
elsif Name.Local = Handler.Fixed then
Att.Attr.Descr.Fixed := Get_Value (Atts, J);
elsif Name.Local = Handler.Ref then
Att.Attr.Ref := Resolve_QName
(Handler, Get_Value (Atts, J), Handler.Target_NS,
Loc => Get_Location (Atts, J));
elsif Name.Local = Handler.Form then
Att.Attr.Descr.Form :=
Form_Type'Value (Get (Get_Value (Atts, J)).all);
Has_Form := True;
elsif Name.Local = Handler.Default then
Att.Attr.Descr.Default := Get_Value (Atts, J);
elsif Name.Local = Handler.Namespace_Target then
Att.Attr.Descr.Target_NS := Get_Value (Atts, J);
end if;
end if;
end loop;
-- See section 3.2.3 for valid attributes combination
if Att.Attr.Descr.Target_NS /= No_Symbol then
if Att.Attr.Descr.Name /= No_Qualified_Name then
Validation_Error
(Handler,
"name must be specified when targetNamespace is specified");
end if;
if Has_Form then
Validation_Error
(Handler,
"Cannot specify ""form"" when targetNamespace is given");
end if;
Validation_Error
(Handler,
"targetNamespace not supported in attribute declaration",
Except => XML_Not_Implemented'Identity);
end if;
if Has_Form and then Att.Attr.Ref /= No_Qualified_Name then
Validation_Error
(Handler,
"Attributes ""form"" and ""ref"" cannot be both specified");
end if;
if Att.Attr.Typ /= No_Qualified_Name then
if Att.Attr.Ref /= No_Qualified_Name then
Validation_Error
(Handler,
"Attributes ""type"" and ""ref"" cannot be both specified");
end if;
end if;
if Att.Attr.Descr.Fixed /= No_Symbol
and then Att.Attr.Descr.Default /= No_Symbol
then
Validation_Error
(Handler,
"Attributes ""fixed"" and ""default"" cannot be both specified");
end if;
if Att.Attr.Descr.Default /= No_Symbol
and then Att.Attr.Descr.Use_Type /= Optional
then
Validation_Error
(Handler,
"Use must be ""optional"" when a default value is specified");
end if;
if Get_XSD_Version (Handler.Grammar) = XSD_1_1
and then Att.Attr.Descr.Fixed /= No_Symbol
and then Att.Attr.Descr.Use_Type = Prohibited
then
Validation_Error
(Handler,
"""prohibited"" is forbidden when"
& " a fixed value is specified");
end if;
if Att.Attr.Descr.Name /= No_Qualified_Name then
case Ctx.Typ is
when Context_Attribute_Group | Context_Type_Def =>
null;
when others =>
if Handler.Target_NS = Handler.XML_Instance_URI then
Validation_Error
(Handler,
"Invalid target namespace for attribute declaration: """
& Get (Handler.Target_NS).all & """");
end if;
end case;
end if;
Att.Attr.Descr.Is_Local := Att.Attr.Ref = No_Qualified_Name;
Push_Context
(Handler,
(Typ => Context_Attribute,
Attribute => Att));
end Create_Attribute;
----------------------
-- Insert_Attribute --
----------------------
procedure Insert_Attribute
(Handler : access Schema_Reader'Class;
In_Context : Natural;
Attribute : Attr_Descr)
is
Ctx : Context renames Handler.Contexts (In_Context);
Index : Natural;
Ctx2 : Context_Access;
begin
case Ctx.Typ is
when Context_Type_Def =>
Append
(Handler.Shared.Types.Table (Ctx.Type_Info).Attributes,
Attribute);
when Context_Schema | Context_Redefine =>
Set
(Handler.Shared.Global_Attributes,
Attribute.Attr.Descr.Name, Attribute.Attr);
when Context_Extension | Context_Restriction =>
Index := Handler.Contexts_Last;
while Index >= Handler.Contexts'First loop
Ctx2 := Handler.Contexts (Index)'Access;
if Ctx2.Typ = Context_Type_Def then
Append
(Handler.Shared.Types.Table (Ctx2.Type_Info).Attributes,
Attribute);
exit;
end if;
Index := Index - 1;
end loop;
when Context_Simple_Extension | Context_Simple_Restriction =>
pragma Assert
(Handler.Contexts (In_Context - 1).Typ = Context_Type_Def);
pragma Assert -- a <simpleType><extension> cannot have attributes
(not Handler.Shared.Types.Table
(Handler.Contexts (In_Context - 1).Type_Info).Is_Simple);
Append
(Handler.Shared.Types.Table
(Handler.Contexts (In_Context - 1).Type_Info).Attributes,
Attribute);
when Context_Attribute_Group =>
Append (Ctx.Attr_Group.Attributes, Attribute);
when Context_Element | Context_Sequence | Context_Choice
| Context_Attribute | Context_All
| Context_Union | Context_List | Context_Group =>
Validation_Error
(Handler,
"Unsupported: ""attribute"" in this context",
Except => XML_Not_Implemented'Identity);
end case;
end Insert_Attribute;
----------------------
-- Finish_Attribute --
----------------------
procedure Finish_Attribute (Handler : access Schema_Reader'Class) is
Ctx : constant Context_Access :=
Handler.Contexts (Handler.Contexts_Last)'Access;
begin
Insert_Attribute (Handler, Handler.Contexts_Last - 1, Ctx.Attribute);
end Finish_Attribute;
-------------------
-- Create_Schema --
-------------------
procedure Create_Schema
(Handler : access Schema_Reader'Class;
Atts : Sax_Attribute_List)
is
Info : Schema_Descr;
Is_Set : Boolean := False;
Name : Qualified_Name;
begin
Info.Element_Form_Default := Unqualified;
Info.Attribute_Form_Default := Unqualified;
for J in 1 .. Get_Length (Atts) loop
Name := Get_Name (Atts, J);
if Name.NS = Empty_String then
if Name.Local = Handler.S_Element_Form_Default then
Info.Element_Form_Default := Compute_Form (Atts, Handler, J);
elsif Name.Local = Handler.S_Attribute_Form_Default then
Info.Attribute_Form_Default := Compute_Form (Atts, Handler, J);
elsif Name.Local = Handler.Block_Default then
Compute_Blocks (Atts, Handler, Info.Block, Is_Set, J);
elsif Name.Local = Handler.Namespace_Target then
Info.Target_NS := Get_Value (Atts, J);
end if;
elsif Name.NS = Handler.XML_Instance_URI then
if Name.Local = Handler.No_Namespace_Schema_Location then
-- Already handled through Hook_Start_Element when validating
-- the grammar itself, but needed if we do not validate the
-- grammar
Parse_Grammar
(Handler,
URI => Empty_String,
Xsd_File => Get_Value (Atts, J),
Do_Create_NFA => False);
elsif Name.Local = Handler.Schema_Location then
-- Already handled through Hook_Start_Element when validating
-- the grammar itself
Parse_Grammars
(Handler, Get_Value (Atts, J), Do_Create_NFA => False);
end if;
end if;
end loop;
if Info.Target_NS /= No_Symbol then
if Debug then
Output_Action ("Get_NS (Handler.Created_Grammar, """
& Get (Info.Target_NS).all & """, Handler.Target_NS)");
end if;
Handler.Target_NS := Info.Target_NS;
end if;
Handler.Element_Form_Default := Info.Element_Form_Default;
Handler.Attribute_Form_Default := Info.Attribute_Form_Default;
if Is_Set then
Handler.Target_Block_Default := Info.Block;
end if;
Push_Context (Handler, (Typ => Context_Schema));
end Create_Schema;
--------------------------------
-- Process_Contents_From_Atts --
--------------------------------
function Process_Contents_From_Atts
(Handler : access Schema_Reader'Class;
Atts : Sax_Attribute_List;
Index : Integer) return Process_Contents_Type is
begin
if Get_Value (Atts, Index) = Handler.Lax then
return Process_Lax;
elsif Get_Value (Atts, Index) = Handler.Strict then
return Process_Strict;
else
return Process_Skip;
end if;
end Process_Contents_From_Atts;
----------------
-- Create_Any --
----------------
procedure Create_Any
(Handler : access Schema_Reader'Class;
Atts : Sax_Attribute_List)
is
Details : Type_Details_Access;
Any : Internal_Any_Descr;
Name : Qualified_Name;
Min_Occurs, Max_Occurs : Occurrences := (False, 1);
begin
Any.Target_NS := Handler.Target_NS;
Any.Namespaces := Handler.Any_Namespace;
for J in 1 .. Get_Length (Atts) loop
Name := Get_Name (Atts, J);
if Name.NS = Empty_String then
if Name.Local = Handler.Namespace then
Any.Namespaces := Get_Value (Atts, J);
elsif Name.Local = Handler.Process_Contents then
Any.Process_Contents :=
Process_Contents_From_Atts (Handler, Atts, J);
end if;
end if;
end loop;
Get_Occurs (Handler, Atts, Min_Occurs, Max_Occurs);
Details := new Type_Details'
(Kind => Type_Any,
Min_Occurs => Min_Occurs,
Max_Occurs => Max_Occurs,
Loc => Handler.Current_Location,
In_Process => False,
Next => null,
Any => Any);
Insert_In_Type (Handler, Details);
end Create_Any;
----------------
-- Create_All --
----------------
procedure Create_All
(Handler : access Schema_Reader'Class;
Atts : Sax_Attribute_List)
is
Min_Occurs, Max_Occurs : Occurrences := (False, 1);
Details : Type_Details_Access;
begin
Get_Occurs (Handler, Atts, Min_Occurs, Max_Occurs);
Details := new Type_Details'
(Kind => Type_All,
Min_Occurs => Min_Occurs,
Max_Occurs => Max_Occurs,
Loc => Handler.Current_Location,
In_Process => False,
Next => null,
First_In_All => null);
Insert_In_Type (Handler, Details);
Push_Context
(Handler,
(Typ => Context_All,
All_Detail => Details));
end Create_All;
-------------------
-- Start_Element --
-------------------
overriding procedure Start_Element
(Handler : in out Schema_Reader;
NS : Sax.Utils.XML_NS;
Local_Name : Sax.Symbols.Symbol;
Atts : Sax.Readers.Sax_Attribute_List)
is
H : constant Schema_Reader_Access := Handler'Unchecked_Access;
Ctx : Context_Access;
begin
if Debug then
Output_Seen ("Start " & Get (Local_Name).all
& " at " & To_String (Handler.Current_Location));
end if;
-- Check the grammar
Start_Element (Validating_Reader (Handler), NS, Local_Name, Atts);
-- Process the element
if Handler.Contexts = null then
if Local_Name /= Handler.S_Schema then
Validation_Error (H, "Root element must be <schema>");
end if;
Create_Schema (H, Atts);
elsif Local_Name = Handler.Annotation then
Handler.In_Annotation := True;
elsif Local_Name = Handler.Notation then
Create_Notation (H, Atts);
elsif Local_Name = Handler.Element then
Create_Element (H, Atts);
elsif Local_Name = Handler.Complex_Type then
Create_Complex_Type (H, Atts);
elsif Local_Name = Handler.Simple_Type then
Create_Simple_Type (H, Atts);
elsif Local_Name = Handler.Restriction then
Create_Restriction (H, Atts);
elsif Local_Name = Handler.Extension then
Create_Extension (H, Atts);
elsif Local_Name = Handler.Any_Attribute then
Create_Any_Attribute (H, Atts);
elsif Local_Name = Handler.Pattern then
Ctx := Handler.Contexts (Handler.Contexts_Last)'Access;
pragma Assert (Ctx.Typ = Context_Simple_Restriction);
pragma Assert (Ctx.Simple.Kind = Simple_Type_Restriction);
-- Use the non-normalized value for <pattern>
Add_Facet
(Grammar => Handler.Grammar,
Facets => Ctx.Simple.Facets,
Facet_Name => Local_Name,
Value => Get_Non_Normalized_Value
(Atts, Get_Index (Atts, Empty_String, Handler.Value)),
Loc => Handler.Current_Location);
elsif Local_Name = Handler.Maxlength
or else Local_Name = Handler.Minlength
or else Local_Name = Handler.Length
or else Local_Name = Handler.Enumeration
or else Local_Name = Handler.Whitespace
or else Local_Name = Handler.Total_Digits
or else Local_Name = Handler.Fraction_Digits
or else Local_Name = Handler.MaxInclusive
or else Local_Name = Handler.MaxExclusive
or else Local_Name = Handler.MinInclusive
or else Local_Name = Handler.MinExclusive
then
Ctx := Handler.Contexts (Handler.Contexts_Last)'Access;
pragma Assert (Ctx.Typ = Context_Simple_Restriction);
pragma Assert (Ctx.Simple.Kind = Simple_Type_Restriction);
Add_Facet
(Grammar => Handler.Grammar,
Facets => Ctx.Simple.Facets,
Facet_Name => Local_Name,
Value => Get_Value
(Atts, Get_Index (Atts, Empty_String, Handler.Value)),
Loc => Handler.Current_Location);
elsif Local_Name = Handler.S_All then
Create_All (H, Atts);
elsif Local_Name = Handler.Sequence then
Create_Sequence (H, Atts);
elsif Local_Name = Handler.Choice then
Create_Choice (H, Atts);
elsif Local_Name = Handler.List then
Create_List (H, Atts);
elsif Local_Name = Handler.Union then
Create_Union (H, Atts);
elsif Local_Name = Handler.Attribute then
Create_Attribute (H, Atts);
elsif Local_Name = Handler.Group then
Create_Group (H, Atts);
elsif Local_Name = Handler.Simple_Content then
Ctx := Handler.Contexts (Handler.Contexts_Last)'Access;
pragma Assert (Ctx.Typ = Context_Type_Def);
Handler.Shared.Types.Table (Ctx.Type_Info).Simple :=
(Kind => Simple_Type,
In_Process => False,
Loc => Handler.Current_Location);
Handler.Shared.Types.Table (Ctx.Type_Info).Properties.Mixed := True;
elsif Local_Name = Handler.Complex_Content then
Ctx := Handler.Contexts (Handler.Contexts_Last)'Access;
pragma Assert (Ctx.Typ = Context_Type_Def);
-- Do not reset Properties.Mixed here, since it might have been set
-- to "true" on the parent <complexType> node.
elsif Local_Name = Handler.Attribute_Group then
Create_Attribute_Group (H, Atts);
elsif Local_Name = Handler.Any then
Create_Any (H, Atts);
elsif Local_Name = Handler.Redefine then
Validation_Error
(Handler'Access,
"Unsupported <redefined>",
Except => XML_Not_Implemented'Identity);
Create_Redefine (H, Atts);
elsif Local_Name = Handler.Include then
Create_Include (H, Atts);
elsif Local_Name = Handler.Import then
Create_Import (H, Atts);
elsif Handler.In_Annotation then
null; -- ignore all tags
elsif Handler.Feature_Ignore_Unsupported_XSD_Elements
and then
(Local_Name = Handler.Keyref
or else Local_Name = Handler.Key
or else Local_Name = Handler.Selector
or else Local_Name = Handler.Unique
or else Local_Name = Handler.Field)
then
Warning
(Handler,
Create (Message => "Unsupported element in the schema: "
& Get (Local_Name).all,
Loc => Handler.Current_Location));
else
Validation_Error
(Handler'Access,
"Unsupported element in the schema: " & Get (Local_Name).all,
Except => XML_Not_Implemented'Identity);
end if;
end Start_Element;
-----------------
-- End_Element --
-----------------
overriding procedure End_Element
(Handler : in out Schema_Reader;
NS : Sax.Utils.XML_NS;
Local_Name : Sax.Symbols.Symbol)
is
H : constant Schema_Reader_Access := Handler'Unchecked_Access;
Handled : Boolean := True;
begin
-- Check the grammar
End_Element (Validating_Reader (Handler), NS, Local_Name);
-- Process the tag
if Local_Name = Handler.Element then
Finish_Element (H);
elsif Local_Name = Handler.S_Schema then
null;
elsif Local_Name = Handler.Complex_Type then
Finish_Complex_Type (H);
elsif Local_Name = Handler.Simple_Type then
Finish_Simple_Type (H);
elsif Local_Name = Handler.S_All then
null;
elsif Local_Name = Handler.Sequence then
null;
elsif Local_Name = Handler.Any_Attribute then
Handled := False;
elsif Local_Name = Handler.Choice then
null;
elsif Local_Name = Handler.Restriction then
Finish_Restriction (H);
elsif Local_Name = Handler.Extension then
Finish_Extension (H);
elsif Local_Name = Handler.Attribute then
Finish_Attribute (H);
elsif Local_Name = Handler.Union then
Finish_Union (H);
elsif Local_Name = Handler.List then
Finish_List (H);
elsif Local_Name = Handler.Maxlength
or else Local_Name = Handler.Pattern
or else Local_Name = Handler.Minlength
or else Local_Name = Handler.Enumeration
or else Local_Name = Handler.Whitespace
or else Local_Name = Handler.Total_Digits
or else Local_Name = Handler.Fraction_Digits
or else Local_Name = Handler.MaxInclusive
or else Local_Name = Handler.MaxExclusive
or else Local_Name = Handler.MinInclusive
or else Local_Name = Handler.MinExclusive
then
Handled := False;
elsif Local_Name = Handler.Attribute_Group then
Finish_Attribute_Group (H);
elsif Local_Name = Handler.Redefine then
null;
elsif Local_Name = Handler.Group then
Finish_Group (H);
elsif Local_Name = Handler.Any
or else Local_Name = Handler.Include
or else Local_Name = Handler.Import
or else Local_Name = Handler.Simple_Content
or else Local_Name = Handler.Complex_Content
then
Handled := False;
elsif Local_Name = Handler.Annotation then
Handler.In_Annotation := False;
Handled := False;
else
if Debug then
Output_Action
("Close tag not handled yet: " & Get (Local_Name).all);
end if;
Handled := False;
end if;
-- Release the context
if Handled then
Handler.Contexts_Last := Handler.Contexts_Last - 1;
end if;
end End_Element;
----------------
-- Characters --
----------------
procedure Characters
(Handler : in out Schema_Reader; Ch : Unicode.CES.Byte_Sequence)
is
begin
Characters (Validating_Reader (Handler), Ch);
end Characters;
----------
-- Free --
----------
procedure Free (Self : in out Type_Details_Access) is
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(Type_Details, Type_Details_Access);
Next : Type_Details_Access;
begin
while Self /= null loop
Next := Self.Next;
case Self.Kind is
when Type_Empty | Type_Element | Type_Any => null;
when Type_Sequence => Free (Self.First_In_Seq);
when Type_Choice => Free (Self.First_In_Choice);
when Type_All => Free (Self.First_In_All);
when Type_Group => Free (Self.Group.Details);
when Type_Extension =>
Free (Self.Extension.Details);
when Type_Restriction =>
Free (Self.Restriction.Details);
end case;
Unchecked_Free (Self);
Self := Next;
end loop;
end Free;
-----------------
-- Set_Feature --
-----------------
overriding procedure Set_Feature
(Parser : in out Schema_Reader; Name : String; Value : Boolean) is
begin
if Name = Feature_Ignore_Unsupported_XSD_Elements then
Parser.Feature_Ignore_Unsupported_XSD_Elements := Value;
else
Set_Feature (Validating_Reader (Parser), Name, Value);
end if;
end Set_Feature;
-----------------
-- Get_Feature --
-----------------
overriding function Get_Feature
(Parser : Schema_Reader; Name : String) return Boolean is
begin
if Name = Feature_Ignore_Unsupported_XSD_Elements then
return Parser.Feature_Ignore_Unsupported_XSD_Elements;
else
return Get_Feature (Validating_Reader (Parser), Name);
end if;
end Get_Feature;
end Schema.Schema_Readers;
Reference in New Issue View Git Blame Copy Permalink