SCHEMA express2cheddar_facade;
	USE FROM Package;
	USE FROM record_and_class;
	USE FROM discriminated_type;
	USE FROM platypus_dictionary_schema;
	USE FROM express_toolsbox_functions;
	USE FROM express_dictionary_queries;
	USE FROM cheddar_domains;
	USE FROM cheddar_dtd;

	CONSTANT 
		source_licence : STRING := '' + '------------------------------------------------------------------------------\n' 
		+ '------------------------------------------------------------------------------\n' 
		+ '--  This source file was automatically generated by Platypus\n' 
		+ '--  see http://dossen.univ-brest.fr/apl\n' 
		+ '-- \n' 
		+ '--  Any modification of this file will be lost. \n' 
		+ '--  Please see the "platypus" directory instead : it contains the Cheddar''s\n' 
		+ '--  model and its meta-model. \n' 
		+ '------------------------------------------------------------------------------\n \n' 
		+ '------------------------------------------------------------------------------\n' 
		+ '-- Cheddar is a free real time scheduling tool.\n' 
		+ '-- This program provides services to automatically check temporal constraints\n' 
		+ '-- of real time tasks.\n' 
		+ '--\n' 
		+ '-- Copyright (C) 2002-2014   Frank Singhoff\n' 
		+ '-- Cheddar is developed by the LAB-STICC Team, University of Brest\n' 
		+ '--\n' 
		+ '-- This program is free software; you can redistribute it and/or modify\n' 
		+ '-- it under the terms of the GNU General Public License as published by\n' 
		+ '-- the Free Software Foundation; either version 2 of the License, or\n' 
		+ '-- (at your option) any later version.\n' 
		+ '--\n' 
		+ '-- This program is distributed in the hope that it will be useful,\n' 
		+ '-- but WITHOUT ANY WARRANTY; without even the implied warranty of\n' 
		+ '-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the\n' 
		+ '-- GNU General Public License for more details.\n' 
		+ '--\n' 
		+ '-- You should have received a copy of the GNU General Public License\n' 
		+ '-- along with this program; if not, write to the Free Software\n' 
		+ '-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA\n' 
		+ '--\n' 
		+ '--\n' 
		+ '-- Contact : cheddar@listes.univ-brest.fr\n' 
		+ '-- 	To post to this mailing list, you must be subscribed\n' 
		+ '-- 	(see http//beru.univ-brest.fr/~singhoff/cheddar for details)\n' 
		+ '--\n' 
		+ '------------------------------------------------------------------------------\n' 
		+ '------------------------------------------------------------------------------\n';
		xml_id_name : STRING := 'cheddar_private_id';
	END_CONSTANT;

	FUNCTION is_of_generated_concept_kind ( c : dictionary_instance ) : BOOLEAN;
		RETURN ( ( 'CHEDDAR_DOMAINS.ADA_TYPE' IN TYPEOF ( c ) ) OR
			 ( 'RECORD_AND_CLASS.ADA_ENTITY' IN TYPEOF ( c ) ) OR
			 ( 'PACKAGE.PACKAGE_ALIAS' IN TYPEOF ( c ) ) OR
			 ( 'RECORD_AND_CLASS.CHEDDAR_FUNCTION_PTR' IN TYPEOF ( c ) ) );
	END_FUNCTION;

	FUNCTION all_ada_packages : SET OF ADA_Package;
		LOCAL 
			insts : SET OF GENERIC := allModelInstances;
		END_LOCAL;
		RETURN ( QUERY ( i <* insts | 'PACKAGE.ADA_PACKAGE' IN TYPEOF ( i ) ) );
	END_FUNCTION;

	FUNCTION ada_package_named ( name : STRING ) : ada_package;
		LOCAL 
			packages : SET OF ADA_Package := all_ada_packages;
			key : STRING := Lowerize ( name );
		END_LOCAL;

		REPEAT no := LOINDEX ( packages ) TO HIINDEX ( packages );
			ALIAS curr FOR packages [ no];
				IF ( Lowerize ( curr.name ) = key ) THEN
					RETURN ( curr );
				END_IF;
			END_ALIAS;
		END_REPEAT;
		RETURN ( ? );
	END_FUNCTION;

	FUNCTION package_ada_classes ( pkg : ada_package ) : LIST OF ada_class;
		LOCAL 
			cls_list : LIST OF ada_class := [ ];
		END_LOCAL;

		ALIAS entities FOR pkg.entities;
			REPEAT noi := LOINDEX ( entities ) TO HIINDEX ( entities );
				IF ( 'RECORD_AND_CLASS.ADA_CLASS' IN TYPEOF ( entities [ noi] ) ) THEN
					cls_list := cls_list + entities [ noi];
				END_IF;
			END_REPEAT;
		END_ALIAS;
		RETURN ( cls_list );
	END_FUNCTION;

	FUNCTION all_ada_classes : LIST OF ada_entity;
		LOCAL 
			cls_list : LIST OF ada_class := [ ];
			all_pkgs : LIST OF ada_package := SetToList ( all_ada_packages );
		END_LOCAL;

		REPEAT no := LOINDEX ( all_pkgs ) TO HIINDEX ( all_pkgs );
			cls_list := cls_list + package_ada_classes ( all_pkgs [ no] );
		END_REPEAT;
		RETURN ( cls_list );
	END_FUNCTION;

	PROCEDURE prepare_root_ada_classes;
		LOCAL 
			clslist : LIST OF ada_class := all_ada_classes;
		END_LOCAL;

		REPEAT no := LOINDEX ( clslist ) TO HIINDEX ( clslist );
			ALIAS curr FOR clslist [ no];
				IF SIZEOF ( curr.supertypes ) = 0 THEN
					IF ( NOT has_attribute_named ( curr, xml_id_name ) ) THEN
						add_xml_id_to_ada_class ( curr );
					END_IF;
				END_IF;
			END_ALIAS;
		END_REPEAT;
	END_PROCEDURE;

	FUNCTION all_ada_records : LIST OF ada_entity;
		LOCAL 
			cls_list : LIST OF ada_class := [ ];
			all_pkgs : LIST OF ada_package := SetToList ( all_ada_packages );
		END_LOCAL;

		REPEAT no := LOINDEX ( all_pkgs ) TO HIINDEX ( all_pkgs );
			ALIAS entities FOR all_pkgs [ no].entities;
				REPEAT noi := LOINDEX ( entities ) TO HIINDEX ( entities );
					IF ( 'RECORD_AND_CLASS.RECORD' IN TYPEOF ( entities [ noi] ) ) THEN
						cls_list := cls_list + entities [ noi];
					END_IF;
				END_REPEAT;
			END_ALIAS;
		END_REPEAT;
		RETURN ( cls_list );
	END_FUNCTION;

	PROCEDURE generate_all_into ( dir : STRING );
		(*# MultiByteFileStream defaultToLF #*)
		prepare_root_ada_classes;
		all_packages_code_into ( true, dir, 'Platypus2Cheddar' );
		all_packages_code_into ( false, dir, 'Platypus2Cheddar' );
		dtds_into ( dir );
	END_PROCEDURE;

	PROCEDURE generate_all;
		generate_all_into ( '' );
	END_PROCEDURE;

	FUNCTION all_ada_discriminated_types : LIST OF ada_entity;
		LOCAL 
			dt_list : LIST OF discriminated_type := [ ];
			all_pkgs : LIST OF ada_package := SetToList ( all_ada_packages );
		END_LOCAL;

		REPEAT no := LOINDEX ( all_pkgs ) TO HIINDEX ( all_pkgs );
			ALIAS entities FOR all_pkgs [ no].entities;
				REPEAT noi := LOINDEX ( entities ) TO HIINDEX ( entities );
					IF ( 'DISCRIMINATED_TYPE.DISCRIMINATED_TYPE' IN TYPEOF ( entities [ noi] ) ) THEN
						dt_list := dt_list + entities [ noi];
					END_IF;
				END_REPEAT;
			END_ALIAS;
		END_REPEAT;
		RETURN ( dt_list );
	END_FUNCTION;

	PROCEDURE add_xml_id_to_ada_class ( VAR cls : ada_class );
		LOCAL 
			idtype : cheddar_xml_id_type :=
			 entity_instance ( ? ) ||
			 sdai_instance ( ) ||
			 dictionary_instance ( ) ||
			 simple_type ( ) ||
			 string_type ( ?,
				 false ) ||
			 cheddar_xml_id_type ( );
			idattr : explicit_attribute :=
			 entity_instance ( cls ) ||
			 sdai_instance ( ) ||
			 dictionary_instance ( ) ||
			 attribute ( xml_id_name,
				 cls,
				 idtype,
				 ? ) ||
			 explicit_attribute ( false );
		END_LOCAL;
		idtype.owner := idattr;
		INSERT ( cls.attributes, idattr, 0 );
	END_PROCEDURE;

	FUNCTION package_records ( pkg : ada_package ) : LIST OF record;
		LOCAL 
			rec_list : LIST OF record := [ ];
		END_LOCAL;

		ALIAS entities FOR pkg.entities;
			REPEAT noi := LOINDEX ( entities ) TO HIINDEX ( entities );
				IF ( 'RECORD_AND_CLASS.RECORD' IN TYPEOF ( entities [ noi] ) ) THEN
					rec_list := rec_list + entities [ noi];
				END_IF;
			END_REPEAT;
		END_ALIAS;
		RETURN ( rec_list );
	END_FUNCTION;

	FUNCTION package_discriminated_types ( pkg : ada_package ) : LIST OF discriminated_type;
		LOCAL 
			dt_list : LIST OF discriminated_type := [ ];
		END_LOCAL;

		ALIAS entities FOR pkg.entities;
			REPEAT noi := LOINDEX ( entities ) TO HIINDEX ( entities );
				IF ( 'DISCRIMINATED_TYPE.DISCRIMINATED_TYPE' IN TYPEOF ( entities [ noi] ) ) THEN
					dt_list := dt_list + entities [ noi];
				END_IF;
			END_REPEAT;
		END_ALIAS;
		RETURN ( dt_list );
	END_FUNCTION;

	FUNCTION ada_entity_named ( name : STRING ) : ada_entity;
		LOCAL 
			entities : LIST OF ADA_Entity := all_ada_entities;
			key : STRING := Lowerize ( name );
		END_LOCAL;

		REPEAT no := LOINDEX ( entities ) TO HIINDEX ( entities );
			ALIAS curr FOR entities [ no];
				IF ( Lowerize ( curr.name ) = key ) THEN
					RETURN ( curr );
				END_IF;
			END_ALIAS;
		END_REPEAT;
		RETURN ( ? );
	END_FUNCTION;

	FUNCTION all_ada_entities : LIST OF ada_entity;
		LOCAL 
			ent_list : LIST OF ada_entity := [ ];
			all_pkgs : LIST OF ada_package := SetToList ( all_ada_packages );
		END_LOCAL;

		REPEAT no := LOINDEX ( all_pkgs ) TO HIINDEX ( all_pkgs );
			ALIAS entities FOR all_pkgs [ no].entities;
				REPEAT noi := LOINDEX ( entities ) TO HIINDEX ( entities );
					IF ( 'RECORD_AND_CLASS.RECORD' IN TYPEOF ( entities [ noi] ) ) THEN
						ent_list := ent_list + entities [ noi];
					END_IF;
					IF ( 'RECORD_AND_CLASS.ADA_CLASS' IN TYPEOF ( entities [ noi] ) ) THEN
						ent_list := ent_list + entities [ noi];
					END_IF;
					IF ( 'DISCRIMINATED_TYPE.DISCRIMINATED_TYPE' IN TYPEOF ( entities [ noi] ) ) THEN
						ent_list := ent_list + entities [ noi];
					END_IF;
				END_REPEAT;
			END_ALIAS;
		END_REPEAT;
		RETURN ( ent_list );
	END_FUNCTION;

	PROCEDURE dtds_Into ( dir : STRING );
		LOCAL 
			roots : LIST OF root_dtd_element := root_dtds;
			path : STRING;
		END_LOCAL;
		(*# MultiByteFileStream defaultToLF #*)
		prepare_root_ada_classes;

		IF ( EXISTS ( dir ) ) THEN
			path := dir;
		ELSE
			path := '.';
		END_IF;

		REPEAT no := LOINDEX ( roots ) TO HIINDEX ( roots );
			ALIAS curr FOR roots [ no];
				WriteFile ( path + '/' + curr.tag + '.dtd', curr.dtd_code );
			END_ALIAS;
		END_REPEAT;
	END_PROCEDURE;
END_SCHEMA;

SCHEMA cheddar_dtd;
	USE FROM express2cheddar_facade;
	USE FROM platypus_dictionary_schema;
	USE FROM express_toolsbox_functions;
	USE FROM express_dictionary_queries;
	USE FROM record_and_class;
	USE FROM cheddar_domains;
	USE FROM package;
	USE FROM discriminated_type;

	ENTITY dtd_element 
		ABSTRACT SUPERTYPE;
		owner : OPTIONAL dtd_element;
		tag : STRING;
	DERIVE
		dtd_code : STRING := '';
	END_ENTITY;

	ENTITY composite_dtd_element 
		ABSTRACT SUPERTYPE 
		SUBTYPE OF ( dtd_element );
	DERIVE
		subs : LIST OF dtd_element := [ ];
	END_ENTITY;

	ENTITY root_dtd_element 
		SUBTYPE OF ( composite_dtd_element );
	DERIVE
		packages : LIST OF ada_package := xml_packages_with_tag ( SELF.tag );
		SELF\composite_dtd_element.subs : LIST OF package_dtd_element := compute_root_sub_elements ( SELF );
		SELF\dtd_element.dtd_code : STRING := compute_root_dtd_code ( SELF );
		declared_domains : LIST OF dtd_element := get_declared_entity_domains ( subs );
		referenced_entities : LIST OF dtd_element := get_referenced_entity_domains ( subs );
		implicit_domains : LIST OF entity_ref_dtd_element := compute_implicit_domains ( SELF );
	END_ENTITY;

	ENTITY package_dtd_element 
		SUBTYPE OF ( composite_dtd_element );
		package : ada_package;
	DERIVE
		SELF\dtd_element.tag : STRING := lowerize ( package.name );
		SELF\composite_dtd_element.subs : LIST OF dtd_element := compute_package_sub_elements ( SELF );
		SELF\dtd_element.dtd_code : STRING := compute_package_dtd_code ( SELF );
		attributes : LIST OF attribute_dtd_element := compute_package_attribute_dtd_elements ( SELF );
	END_ENTITY;

	ENTITY entity_dtd_element 
		SUBTYPE OF ( composite_dtd_element );
		domain : ada_entity;
	DERIVE
		SELF\dtd_element.tag : STRING := lowerize ( domain.name );
		SELF\composite_dtd_element.subs : LIST OF dtd_element := compute_entity_sub_elements ( SELF );
		SELF\dtd_element.dtd_code : STRING := compute_entity_dtd_code ( SELF );
	END_ENTITY;

	ENTITY ada_class_dtd_element 
		SUBTYPE OF ( entity_dtd_element );
	END_ENTITY;

	ENTITY record_dtd_element 
		SUBTYPE OF ( entity_dtd_element );
	END_ENTITY;

	ENTITY discriminated_type_dtd_element 
		SUBTYPE OF ( entity_dtd_element );
	DERIVE
		SELF\entity_dtd_element.subs : LIST OF dtd_element := compute_discriminated_type_sub_elements ( SELF );
		SELF\entity_dtd_element.dtd_code : STRING := compute_discriminated_type_code ( SELF );
	END_ENTITY;

	ENTITY attribute_dtd_element 
		SUBTYPE OF ( dtd_element );
		attribute : attribute;
		domain : domain_dtd_element;
	DERIVE
		SELF\dtd_element.tag : STRING := lowerize ( attribute.name );
		SELF\dtd_element.dtd_code : STRING := domain.dtd_code;
	END_ENTITY;

	ENTITY domain_dtd_element 
		SUBTYPE OF ( dtd_element );
		domain : entity_instance;
	DERIVE
		as_collection_element_dtd_code_tail : STRING := '';
	END_ENTITY;

	ENTITY simple_domain_dtd_element 
		SUBTYPE OF ( domain_dtd_element );
	DERIVE
		SELF\dtd_element.dtd_code : STRING := '<!ELEMENT ' + SELF.owner.tag + ' (#PCDATA)>\n';
		SELF\domain_dtd_element.as_collection_element_dtd_code_tail : STRING := '(#PCDATA)>\n';
	END_ENTITY;

	ENTITY collection_dtd_element 
		SUBTYPE OF ( domain_dtd_element );
		element_domain : domain_dtd_element;
	DERIVE
		SELF\dtd_element.dtd_code : STRING := '<!ELEMENT ' + owner.tag + ' ' + element_domain.as_collection_element_dtd_code_tail;
	END_ENTITY;

	ENTITY entity_ref_dtd_element 
		SUBTYPE OF ( domain_dtd_element );
	DERIVE
		infered_element : entity_dtd_element := ?;
		SELF\dtd_element.dtd_code : STRING := '<!ELEMENT ' + owner.tag + ' (' + lowerize ( domain.name ) + ')>\n';
	END_ENTITY;

	ENTITY record_ref_dtd_element 
		SUBTYPE OF ( entity_ref_dtd_element );
	DERIVE
		SELF\entity_ref_dtd_element.infered_element : entity_dtd_element :=
		 dtd_element ( ?,
			 ? ) ||
		 composite_dtd_element ||
		 entity_dtd_element ( domain ) ||
		 record_dtd_element;
		SELF\domain_dtd_element.as_collection_element_dtd_code_tail : STRING := '(' + lowerize ( domain.handled.name ) + ')*>\n';
	END_ENTITY;

	ENTITY ada_class_ref_dtd_element 
		SUBTYPE OF ( entity_ref_dtd_element );
	DERIVE
		SELF\entity_ref_dtd_element.infered_element : entity_dtd_element :=
		 dtd_element ( ?,
			 ? ) ||
		 composite_dtd_element ||
		 entity_dtd_element ( domain ) ||
		 ada_class_dtd_element;
		SELF\entity_ref_dtd_element.dtd_code : STRING := '<!ELEMENT ' + owner.tag + ' EMPTY>\n' 
		+ '<!ATTLIST ' + owner.tag + ' ref IDREF #REQUIRED>\n';
		SELF\entity_ref_dtd_element.as_collection_element_dtd_code_tail : STRING := ' EMPTY>\n' 
		+ '<!ATTLIST ' + owner.owner.tag + ' refs IDREFS #REQUIRED>\n';
	END_ENTITY;

	ENTITY discriminated_type_ref_dtd_element 
		SUBTYPE OF ( entity_ref_dtd_element );
	DERIVE
		SELF\entity_ref_dtd_element.infered_element : entity_dtd_element :=
		 dtd_element ( ?,
			 ? ) ||
		 composite_dtd_element ||
		 entity_dtd_element ( domain ) ||
		 discriminated_type_dtd_element;
		SELF\domain_dtd_element.as_collection_element_dtd_code_tail : STRING := '(' + lowerize ( domain.handled.name ) + ')*>\n';
	END_ENTITY;

	FUNCTION compute_root_dtd_code ( r : root_dtd_element ) : STRING;
		LOCAL 
			s : STRING := '';
			code : STRING;
			lines : LIST OF STRING := [ ];
			licence : STRING := string_replace ( source_licence, '--', '  ' );
			pkgs : LIST OF package_dtd_element := r.subs;
			attributes : LIST OF attribute_dtd_element := [ ];
			acode : STRING;
			previous : LIST OF STRING := [ ];
			implicits : LIST OF dtd_element := r.implicit_domains;
			infered : LIST OF entity_dtd_element := [ ];
			el : entity_dtd_element;
			infered_attributes : LIST OF attribute_dtd_element := [ ];
		END_LOCAL;

		REPEAT no := LOINDEX ( implicits ) TO HIINDEX ( implicits );
			el := implicits [ no].infered_element;
			infered := infered + el;
			infered_attributes := infered_attributes + el.subs;
		END_REPEAT;
		s := s + '<!--' + licence + '-->\n\n' 

		+ '<!ELEMENT ' + r.tag + ' (';

		REPEAT no := LOINDEX ( pkgs ) TO HIINDEX ( pkgs );
			s := s + pkgs [ no].tag + '?';
			IF ( no < HIINDEX ( pkgs ) ) THEN
				s := s + ' | ';
			END_IF;
		END_REPEAT;
		s := s + ')*>\n\n';

		REPEAT no := LOINDEX ( pkgs ) TO HIINDEX ( pkgs );
			code := pkgs [ no].dtd_code;
			previous := previous + LinesFromString ( code );
			s := s + code;
		END_REPEAT;
		s := s + '\n';

		REPEAT no := LOINDEX ( infered ) TO HIINDEX ( infered );
			acode := infered [ no].dtd_code;
			IF ( NOT ( acode IN previous ) ) THEN
				s := s + acode;
				previous := previous + acode;
			END_IF;
		END_REPEAT;

		REPEAT no := LOINDEX ( pkgs ) TO HIINDEX ( pkgs );
			attributes := attributes + compute_package_attribute_dtd_elements ( pkgs [ no] );
		END_REPEAT;

		REPEAT no := LOINDEX ( attributes ) TO HIINDEX ( attributes );
			acode := attributes [ no].dtd_code;
			IF ( NOT ( acode IN previous ) ) THEN
				s := s + attributes [ no].dtd_code;
				previous := previous + acode;
			END_IF;
		END_REPEAT;

		REPEAT no := LOINDEX ( infered_attributes ) TO HIINDEX ( infered_attributes );
			acode := infered_attributes [ no].dtd_code;
			IF ( NOT ( acode IN previous ) ) THEN
				s := s + acode;
				previous := previous + acode;
			END_IF;
		END_REPEAT;
		RETURN ( s );
	END_FUNCTION;

	FUNCTION root_dtds : LIST OF root_dtd_element;
		LOCAL 
			xml_pkgs : LIST OF ada_package := xml_packages;
			root_names : LIST OF STRING := [ ];
			result : LIST OF root_dtd_element := [ ];
		END_LOCAL;

		REPEAT no := LOINDEX ( xml_pkgs ) TO HIINDEX ( xml_pkgs );
			ALIAS curr_pkg FOR xml_pkgs [ no];
				root_names := root_names + curr_pkg.xml_root_tags;
			END_ALIAS;
		END_REPEAT;
		root_names := SetToList ( ListToSet ( root_names ) );

		REPEAT no := LOINDEX ( root_names ) TO HIINDEX ( root_names );
			result := result + composite_dtd_element ( ) || root_dtd_element ( ) || dtd_element ( ?, root_names [ no] );
		END_REPEAT;
		RETURN ( result );
	END_FUNCTION;

	FUNCTION compute_root_sub_elements ( e : root_dtd_element ) : LIST OF package_dtd_element;
		LOCAL 
			result : LIST OF package_dtd_element := [ ];
		END_LOCAL;

		ALIAS packages FOR e.packages;
			REPEAT no := LOINDEX ( packages ) TO HIINDEX ( packages );
				result := result + ( dtd_element ( e, ? ) || composite_dtd_element || package_dtd_element ( packages [ no] ) );
			END_REPEAT;
		END_ALIAS;
		RETURN ( result );
	END_FUNCTION;

	FUNCTION compute_package_attribute_dtd_elements ( p : package_dtd_element ) : LIST OF attribute_dtd_element;
		LOCAL 
			subs : LIST OF dtd_element := p.subs;
			r : LIST OF attribute_dtd_element := [ ];
		END_LOCAL;

		REPEAT no := LOINDEX ( subs ) TO HIINDEX ( subs );
			r := r + subs [ no].subs;
		END_REPEAT;
		RETURN ( r );
	END_FUNCTION;

	FUNCTION compute_package_dtd_code ( p : package_dtd_element ) : STRING;
		LOCAL 
			subs : LIST OF dtd_element := p.subs;
			s : STRING := '';
		END_LOCAL;

		IF ( SIZEOF ( subs ) > 0 ) THEN
			s := s + '<!ELEMENT ' + p.tag + ' (';
			REPEAT no := LOINDEX ( subs ) TO HIINDEX ( subs );
				s := s + subs [ no].tag;
				IF ( no < HIINDEX ( subs ) ) THEN
					s := s + ' | ';
				END_IF;
			END_REPEAT;
			s := s + ')+>\n';
			REPEAT no := LOINDEX ( subs ) TO HIINDEX ( subs );
				s := s + subs [ no].dtd_code;
			END_REPEAT;
			s := s + '\n';
		END_IF;
		RETURN ( s );
	END_FUNCTION;

	FUNCTION compute_package_sub_elements ( e : package_dtd_element ) : LIST OF dtd_element;
		LOCAL 
			result : LIST OF dtd_element := [ ];
			classes : LIST OF ada_entity := package_ada_classes ( e.package );
			records : LIST OF ada_entity := package_records ( e.package );
			discrims : LIST OF discriminated_type := package_discriminated_types ( e.package );
		END_LOCAL;

		REPEAT no := LOINDEX ( classes ) TO HIINDEX ( classes );
			ALIAS curr FOR classes [ no];
				result :=
				 result + ( dtd_element ( e,
						 ? ) ||
					 composite_dtd_element ||
					 entity_dtd_element ( curr ) ||
					 ada_class_dtd_element );
			END_ALIAS;
		END_REPEAT;

		REPEAT no := LOINDEX ( records ) TO HIINDEX ( records );
			ALIAS curr FOR records [ no];
				result :=
				 result + ( dtd_element ( e,
						 ? ) ||
					 composite_dtd_element ||
					 entity_dtd_element ( curr ) ||
					 record_dtd_element );
			END_ALIAS;
		END_REPEAT;

		REPEAT no := LOINDEX ( discrims ) TO HIINDEX ( discrims );
			ALIAS curr FOR discrims [ no];
				result :=
				 result + ( dtd_element ( e,
						 ? ) ||
					 composite_dtd_element ||
					 entity_dtd_element ( curr ) ||
					 discriminated_type_dtd_element );
			END_ALIAS;
		END_REPEAT;
		RETURN ( result );
	END_FUNCTION;

	FUNCTION compute_entity_dtd_code ( ent : entity_dtd_element ) : STRING;
		LOCAL 
			s : STRING := '';
			l : LIST OF STRING := [ ];
			subs : LIST OF dtd_element := ent.subs;
		END_LOCAL;

		REPEAT no := LOINDEX ( subs ) TO HIINDEX ( subs );
			ALIAS curr FOR subs [ no];
				l := l + curr.tag;
			END_ALIAS;
		END_REPEAT;
		s := '<!ELEMENT ' + ent.tag + ' (' + StringAggregateConcatSeparatedBy ( l, ' | ' ) + ')*>\n';

		IF ( 'RECORD_AND_CLASS.ADA_CLASS' IN TYPEOF ( ent.domain ) ) THEN
			s := s + '<!ATTLIST ' + ent.tag + ' id ID #REQUIRED>\n';
		END_IF;
		RETURN ( s );
	END_FUNCTION;

	FUNCTION compute_attribute_dtd_list_from_attribute_list ( owner : dtd_element; attrs : LIST OF explicit_attribute ) : LIST OF dtd_element;
		LOCAL 
			result : LIST OF dtd_element := [ ];
		END_LOCAL;

		REPEAT no := LOINDEX ( attrs ) TO HIINDEX ( attrs );
			ALIAS curr FOR attrs [ no];
				IF ( lowerize ( curr.name ) <> lowerize ( xml_id_name ) ) THEN
					result := result + compute_attribute_dtd_element ( owner, curr );
				END_IF;
			END_ALIAS;
		END_REPEAT;
		RETURN ( result );
	END_FUNCTION;

	FUNCTION compute_entity_sub_elements ( e : entity_dtd_element ) : LIST OF dtd_element;
		LOCAL 
			attrs : LIST OF explicit_attribute := inherited_explicit_attributes ( e.domain );
			result : LIST OF dtd_element := compute_attribute_dtd_list_from_attribute_list ( e, attrs );
		END_LOCAL;
		RETURN ( result );
	END_FUNCTION;

	FUNCTION compute_discriminated_type_code ( ent : discriminated_type_dtd_element ) : STRING;
		LOCAL 
			s : STRING := '';
			l : LIST OF STRING := [ ];
			subs : LIST OF dtd_element := ent.subs;
		END_LOCAL;

		REPEAT no := LOINDEX ( subs ) TO HIINDEX ( subs );
			ALIAS curr FOR subs [ no];
				l := l + curr.tag;
			END_ALIAS;
		END_REPEAT;
		s := '<!ELEMENT ' + ent.tag + ' (' + StringAggregateConcatSeparatedBy ( l, ' | ' ) + ')*>\n';
		RETURN ( s );
	END_FUNCTION;

	FUNCTION compute_discriminated_type_sub_elements ( e : discriminated_type_dtd_element ) : LIST OF dtd_element;
		LOCAL 
			attrs : LIST OF explicit_attribute := discriminated_type_attributes ( e.domain );
			result : LIST OF dtd_element := compute_attribute_dtd_list_from_attribute_list ( e, attrs );
		END_LOCAL;
		RETURN ( result );
	END_FUNCTION;

	FUNCTION compute_attribute_dtd_element ( owner : dtd_element; a : attribute ) : attribute_dtd_element;
		LOCAL 
			domain : entity_instance := ( basic_ada_domain ( a.domain ) ).handled;
			result : attribute_dtd_element;
		END_LOCAL;
		result := ( dtd_element ( owner, ? ) || attribute_dtd_element ( a, ? ) );
		result.domain := compute_domain_dtd_element ( result, domain );
		RETURN ( result );
	END_FUNCTION;

	FUNCTION compute_domain_dtd_element ( owner : dtd_element; domain : entity_instance ) : domain_dtd_element;
		LOCAL 
			sub_domain : entity_instance;
			element_domain : entity_instance;
			result : domain_dtd_element;
		END_LOCAL;

		IF ( 'PLATYPUS_DICTIONARY_SCHEMA.DICTIONARY_INSTANCE_REFERENCE' IN TYPEOF ( domain ) ) THEN
			RETURN ( compute_domain_dtd_element ( owner, domain.ref ) );
		ELSE
			IF ( 'CHEDDAR_DOMAINS.ADA_PRIMITIVE_TYPE' IN TYPEOF ( domain ) ) THEN
				RETURN ( simple_domain_dtd_element ( ) || dtd_element ( owner, ? ) || domain_dtd_element ( domain ) );
			ELSE
				IF ( 'CHEDDAR_DOMAINS.ADA_ENUMERATION' IN TYPEOF ( domain ) ) THEN
					RETURN ( simple_domain_dtd_element ( ) || dtd_element ( owner, ? ) || domain_dtd_element ( domain ) );
				ELSE
					IF ( 'CHEDDAR_DOMAINS.CHEDDAR_PRIORITY_RANGE' IN TYPEOF ( domain ) ) THEN
						RETURN ( simple_domain_dtd_element ( ) ||
							 dtd_element ( owner,
								 ? ) ||
							 domain_dtd_element ( domain ) );
					ELSE
						IF ( 'RECORD_AND_CLASS.RECORD' IN TYPEOF ( domain ) ) THEN
							RETURN ( record_ref_dtd_element ( ) ||
								 entity_ref_dtd_element ( ) ||
								 dtd_element ( owner,
									 ? ) ||
								 domain_dtd_element ( domain ) );
						ELSE
							IF ( 'DISCRIMINATED_TYPE.DISCRIMINATED_TYPE' IN TYPEOF ( domain ) ) THEN
								RETURN ( discriminated_type_ref_dtd_element ( ) ||
									 entity_ref_dtd_element ( ) ||
									 dtd_element ( owner,
										 ? ) ||
									 domain_dtd_element ( domain ) );
							ELSE
								IF ( 'RECORD_AND_CLASS.ADA_CLASS' IN TYPEOF ( domain ) ) THEN
									RETURN ( ada_class_ref_dtd_element ( ) ||
										 entity_ref_dtd_element ( ) ||
										 dtd_element ( owner,
											 ? ) ||
										 domain_dtd_element ( domain ) );
								ELSE
									IF ( 'PLATYPUS_DICTIONARY_SCHEMA.DEFINED_TYPE' IN
											 TYPEOF ( domain ) ) THEN
										sub_domain := basic_ada_domain ( domain.domain );
										IF ( 'PLATYPUS_DICTIONARY_SCHEMA.AGGREGATION_TYPE' IN
												 TYPEOF ( sub_domain ) ) THEN
											element_domain :=
											 basic_ada_domain ( sub_domain.element_type );
											result :=
											 collection_dtd_element ( ? ) ||
											 dtd_element ( owner,
												 ? ) ||
											 domain_dtd_element ( domain );
											result.element_domain :=
											 compute_domain_dtd_element ( result,
												 element_domain );
											RETURN ( result );
										END_IF;
									END_IF;
								END_IF;
							END_IF;
						END_IF;
					END_IF;
				END_IF;
			END_IF;
		END_IF;
		println ( domain );
		RETURN ( unknown_domain_dtd_element ( ) || dtd_element ( owner, ? ) || domain_dtd_element ( domain ) );
	END_FUNCTION;

	FUNCTION xml_packages : LIST OF ada_package;
		RETURN ( QUERY ( p <* SetToList ( all_ada_packages ) | SIZEOF ( p.xml_root_tags ) > 0 ) );
	END_FUNCTION;

	FUNCTION get_referenced_entity_domains ( pkgs : LIST OF package_dtd_element ) : LIST OF entity_ref_dtd_element;
		LOCAL 
			attributes : LIST OF attribute_dtd_element := [ ];
			domains : LIST OF entity_ref_dtd_element := [ ];
			names : LIST OF STRING := [ ];
			curr : domain_dtd_element;
		END_LOCAL;

		REPEAT no := LOINDEX ( pkgs ) TO HIINDEX ( pkgs );
			attributes := attributes + compute_package_attribute_dtd_elements ( pkgs [ no] );
		END_REPEAT;

		REPEAT noi := LOINDEX ( attributes ) TO HIINDEX ( attributes );
			curr := ?;
			ALIAS dom FOR attributes [ noi].domain;
				IF ( 'CHEDDAR_DTD.ENTITY_REF_DTD_ELEMENT' IN TYPEOF ( dom ) ) THEN
					curr := dom;
				END_IF;
				IF ( ( 'CHEDDAR_DTD.COLLECTION_DTD_ELEMENT' IN TYPEOF ( dom ) ) AND
						 ( 'CHEDDAR_DTD.ENTITY_REF_DTD_ELEMENT' IN TYPEOF ( dom.element_domain ) ) ) THEN
					curr := dom.element_domain;
				END_IF;
				IF ( EXISTS ( curr ) ) THEN
					IF ( NOT ( lowerize ( curr.domain.name ) IN names ) ) THEN
						domains := domains + curr;
						names := names + lowerize ( curr.domain.name );
					END_IF;
				END_IF;
			END_ALIAS;
		END_REPEAT;
		RETURN ( domains );
	END_FUNCTION;

	FUNCTION get_declared_entity_domains ( pkgs : LIST OF package_dtd_element ) : LIST OF dtd_element;
		LOCAL 
			result : LIST OF dtd_element := [ ];
		END_LOCAL;

		REPEAT no := LOINDEX ( pkgs ) TO HIINDEX ( pkgs );
			result := result + pkgs [ no].subs;
		END_REPEAT;
		RETURN ( result );
	END_FUNCTION;

	FUNCTION compute_implicit_domains ( r : root_dtd_element ) : LIST OF entity_ref_dtd_element;
		LOCAL 
			refed : LIST OF entity_ref_dtd_element := r.referenced_entities;
			decl : LIST OF dtd_element := r.declared_domains;
			decl_domain : LIST OF entity_instance := [ ];
			not_declared : LIST OF entity_ref_dtd_element := [ ];
		END_LOCAL;

		REPEAT no := LOINDEX ( decl ) TO HIINDEX ( decl );
			ALIAS curr FOR decl [ no];
				decl_domain := decl_domain + curr.domain;
			END_ALIAS;
		END_REPEAT;

		REPEAT no := LOINDEX ( refed ) TO HIINDEX ( refed );
			ALIAS curr FOR refed [ no];
				IF ( NOT ( curr.domain IN decl_domain ) ) AND ( NOT ( curr IN not_declared ) ) THEN
					not_declared := not_declared + curr;
				END_IF;
			END_ALIAS;
		END_REPEAT;
		RETURN ( not_declared );
	END_FUNCTION;

	ENTITY unknown_domain_dtd_element 
		SUBTYPE OF ( domain_dtd_element );
	DERIVE
		SELF\dtd_element.dtd_code : STRING := '<!ELEMENT ' + SELF.owner.tag + ' ANY>\n';
		SELF\domain_dtd_element.as_collection_element_dtd_code_tail : STRING := 'ANY>\n';
	END_ENTITY;

	FUNCTION xml_packages_with_tag ( tag : STRING ) : LIST OF ada_package;
		RETURN ( QUERY ( p <* xml_packages | tag IN p.xml_root_tags ) );
	END_FUNCTION;
END_SCHEMA;

SCHEMA ada_interface;
	USE FROM platypus_dictionary_schema;
	USE FROM express_toolsbox_functions;
	USE FROM package;

	ENTITY ada_interface;
		prefix : STRING;
		suffix : OPTIONAL STRING;
		with_it : BOOLEAN;
		use_it : BOOLEAN;
	DERIVE
		full_name : STRING := ada_interface_path ( SELF );
		declaration : STRING := ada_interface_declaration ( SELF );
	END_ENTITY;

	FUNCTION ada_interface_path ( i : ada_interface ) : STRING;
		LOCAL 
			name : STRING := i.prefix;
		END_LOCAL;

		IF EXISTS ( i.suffix ) THEN
			name := name + '.' + i.suffix;
		END_IF;
		RETURN ( name );
	END_FUNCTION;

	FUNCTION ada_interface_declaration ( int : ada_interface ) : STRING;
		LOCAL 
			s : STRING := '';
			name : STRING := ada_interface_path ( int );
		END_LOCAL;

		IF ( int.with_it ) THEN
			s := s + 'with ' + name + ';\n';
		END_IF;

		IF ( int.use_it ) THEN
			s := s + 'use ' + name + ';\n';
		END_IF;
		RETURN ( s );
	END_FUNCTION;

	FUNCTION ada_interfaces_code ( from_pkg : ada_package; l : LIST OF ada_interface ) : STRING;
		LOCAL 
			found : SET OF STRING := [ ];
			with_suffix : LIST OF ada_interface := [ ];
			with_prefix_only : LIST OF ada_interface := [ ];
			cleaned : LIST OF ada_interface := [ ];
			inserted : BOOLEAN;
			s : STRING := '';
		END_LOCAL;

		REPEAT no := LOINDEX ( l ) TO HIINDEX ( l );
			ALIAS curr FOR l [ no];
				IF ( NOT EXISTS ( from_pkg ) ) OR ( upperize ( from_pkg.name ) <> upperize ( curr.prefix ) ) THEN
					IF NOT ( upperize ( curr.full_name ) IN found ) THEN
						found := found + upperize ( curr.full_name );
						cleaned := cleaned + curr;
					END_IF;
				END_IF;
			END_ALIAS;
		END_REPEAT;

		REPEAT no := LOINDEX ( cleaned ) TO HIINDEX ( cleaned );
			ALIAS curr FOR cleaned [ no];
				IF ( EXISTS ( curr.suffix ) ) THEN
					with_suffix := with_suffix + curr;
				ELSE
					with_prefix_only := with_prefix_only + curr;
				END_IF;
			END_ALIAS;
		END_REPEAT;
		cleaned := [ ];

		REPEAT no := LOINDEX ( with_prefix_only ) TO HIINDEX ( with_prefix_only );
			cleaned := cleaned + with_prefix_only [ no];
		END_REPEAT;

		REPEAT no := LOINDEX ( with_suffix ) TO HIINDEX ( with_suffix );
			ALIAS curr FOR with_suffix [ no];
				inserted := false;
				REPEAT noi := LOINDEX ( cleaned ) TO HIINDEX ( cleaned );
					ALIAS curri FOR cleaned [ noi];
						IF ( upperize ( curr.prefix ) = upperize ( curri.prefix ) ) THEN
							INSERT ( cleaned, curr, noi );
							inserted := true;
							ESCAPE;
						END_IF;
					END_ALIAS;
				END_REPEAT;
				IF ( inserted = false ) THEN
					cleaned := cleaned + curr;
				END_IF;
			END_ALIAS;
		END_REPEAT;

		REPEAT no := LOINDEX ( cleaned ) TO HIINDEX ( cleaned );
			ALIAS curr FOR cleaned [ no];
				s := s + curr.declaration + '\n';
			END_ALIAS;
		END_REPEAT;
		RETURN ( s );
	END_FUNCTION;
END_SCHEMA;

SCHEMA xml_io;
	USE FROM platypus_dictionary_schema;
	USE FROM express_toolsbox_functions;
	USE FROM express2cheddar_facade;
	USE FROM record_and_class;
	USE FROM discriminated_type;
	USE FROM ada_interface;
	USE FROM package;

	FUNCTION xml_architecture_io_ads_package_code : STRING;
		LOCAL 
			test : STRING := '';
			code : STRING := '';
			pkgs : LIST OF ada_package := SetToList ( all_ada_packages );
			allcls : LIST OF ada_class := all_ada_classes;
			allrecs : LIST OF ada_class := all_ada_records;
			alldts : LIST OF discriminated_type := all_ada_discriminated_types;
			interfaces : LIST OF ada_interface :=
			 [ ada_interface ( 'Sax',
					 'Readers',
					 true,
					 true ),
				 ada_interface ( 'Networks',
					 ?,
					 true,
					 true ),
				 ada_interface ( 'Sax',
					 'Exceptions',
					 true,
					 true ),
				 ada_interface ( 'Sax',
					 'Locators',
					 true,
					 true ),
				 ada_interface ( 'Sax',
					 'Attributes',
					 true,
					 true ),
				 ada_interface ( 'Unicode',
					 'CES',
					 true,
					 true ),
				 ada_interface ( 'Unicode',
					 ?,
					 true,
					 true ),
				 ada_interface ( 'xml_generic_parsers',
					 ?,
					 true,
					 true ),
				 ada_interface ( 'Ada',
					 'Text_IO',
					 true,
					 true ),
				 ada_interface ( 'Ada',
					 'Strings.Unbounded',
					 true,
					 true ),
				 ada_interface ( 'Strings',
					 ?,
					 true,
					 true ),
				 ada_interface ( 'Unbounded_Strings',
					 ?,
					 true,
					 true ),
				 ada_interface ( 'Ada',
					 'Numerics.Aux',
					 true,
					 true ),
				 ada_interface ( 'call_framework_interface',
					 ?,
					 true,
					 true ),
				 ada_interface ( 'Debug',
					 ?,
					 true,
					 true ) ];
		END_LOCAL;
		code := source_licence + '\n';

		REPEAT no := LOINDEX ( pkgs ) TO HIINDEX ( pkgs );
			interfaces := interfaces + ada_interface ( pkgs [ no].name, ?, true, true );
			interfaces := interfaces + ada_package_interface ( pkgs [ no], true );
		END_REPEAT;
		code := source_licence + ada_interfaces_code ( ?, interfaces );
		code := code + 'package xml_architecture_io is\n\n' 

		+ '-- Attributes of the discriminated types\n\n';

		REPEAT no := LOINDEX ( alldts ) TO HIINDEX ( alldts );
			code := code + alldts [ no].xml_io_record_code + '\n';
		END_REPEAT;
		code :=
		 code +
		 '\nprocedure Start_Element(' +
		 '\n	Handler: in out Xml_Generic_Parser;' +
		 '\n	ref : in out unbounded_string;' +
		 '\n	id : in out unbounded_string;' +
		 '\n	Namespace_Uri : Unicode.CES.Byte_Sequence := "";' +
		 '\n	Local_Name : Unicode.CES.Byte_Sequence := "";' +
		 '\n	Qname : Unicode.CES.Byte_Sequence := "";' +
		 '\n	Atts : Sax.Attributes.Attributes''Class);\n';

		REPEAT no := LOINDEX ( alldts ) TO HIINDEX ( alldts );
			test := discriminated_type_xml_start_element_code ( alldts [ no] );
			IF ( test > '' ) THEN
				code := code + '\nprocedure Start_Element(\n' 
				+ '\tHandler : in out Xml_generic_parser;\n' 
				+ '\tobj : in out ' + alldts [ no].name + '_io;\n' 
				+ '\tNamespace_Uri : Unicode.CES.Byte_Sequence := "";\n' 
				+ '\tLocal_Name : Unicode.CES.Byte_Sequence := "";\n' 
				+ '\tQname : Unicode.CES.Byte_Sequence := "";\n' 
				+ '\tAtts : Sax.Attributes.Attributes''Class);\n';
			END_IF;
			code := code + '\nprocedure End_Element(\n' 
			+ '\tHandler : in out Xml_generic_parser;\n' 
			+ '\tobj : in out ' + alldts [ no].name + '_io;\n' 
			+ '\tNamespace_Uri : Unicode.CES.Byte_Sequence := "";\n' 
			+ '\tLocal_Name : Unicode.CES.Byte_Sequence := "";\n' 
			+ '\tQname : Unicode.CES.Byte_Sequence := "");\n';
		END_REPEAT;

		REPEAT no := LOINDEX ( alldts ) TO HIINDEX ( alldts );
			code := code + '\nprocedure Initialize(obj : out ' + alldts [ no].name + '_io);';
		END_REPEAT;
		code := code + '\n\n' 

		+ '-- Attributes of the parsed entities\n\n';

		REPEAT no := LOINDEX ( allrecs ) TO HIINDEX ( allrecs );
			code := code + allrecs [ no].xml_io_record_code + '\n';
		END_REPEAT;
		code := code + '\n';

		REPEAT no := LOINDEX ( allrecs ) TO HIINDEX ( allrecs );
			code := code + '\nprocedure Initialize(obj : out ' + allrecs [ no].name + '_io);';
		END_REPEAT;
		code := code + '\n';

		REPEAT no := LOINDEX ( allrecs ) TO HIINDEX ( allrecs );
			test := ada_entity_xml_start_element_code ( allrecs [ no] );
			IF ( test > '' ) THEN
				code := code + '\nprocedure Start_Element(\n' 
				+ '\tHandler : in out Xml_generic_parser;\n' 
				+ '\tobj : in out ' + allrecs [ no].name + '_io;\n' 
				+ '\tNamespace_Uri : Unicode.CES.Byte_Sequence := "";\n' 
				+ '\tLocal_Name : Unicode.CES.Byte_Sequence := "";\n' 
				+ '\tQname : Unicode.CES.Byte_Sequence := "";\n' 
				+ '\tAtts : Sax.Attributes.Attributes''Class);\n';
			END_IF;
			code := code + '\nprocedure End_Element(\n' 
			+ '\tHandler : in out Xml_generic_parser;\n' 
			+ '\tobj : in out ' + allrecs [ no].name + '_io;\n' 
			+ '\tNamespace_Uri : Unicode.CES.Byte_Sequence := "";\n' 
			+ '\tLocal_Name : Unicode.CES.Byte_Sequence := "";\n' 
			+ '\tQname : Unicode.CES.Byte_Sequence := "");\n';
		END_REPEAT;

		REPEAT no := LOINDEX ( allcls ) TO HIINDEX ( allcls );
			code := code + allcls [ no].xml_io_record_code + '\n';
		END_REPEAT;
		code := code + '\n';

		REPEAT no := LOINDEX ( allcls ) TO HIINDEX ( allcls );
			code := code + '\nprocedure Initialize(obj : out ' + allcls [ no].name + '_io);';
		END_REPEAT;
		code := code + '\n';

		REPEAT no := LOINDEX ( allcls ) TO HIINDEX ( allcls );
			test := ada_entity_xml_start_element_code ( allcls [ no] );
			IF ( test > '' ) THEN
				code := code + '\nprocedure Start_Element(\n' 
				+ '\tHandler : in out Xml_generic_parser;\n' 
				+ '\tobj : in out ' + allcls [ no].name + '_io;\n' 
				+ '\tNamespace_Uri : Unicode.CES.Byte_Sequence := "";\n' 
				+ '\tLocal_Name : Unicode.CES.Byte_Sequence := "";\n' 
				+ '\tQname : Unicode.CES.Byte_Sequence := "";\n' 
				+ '\tAtts : Sax.Attributes.Attributes''Class);\n';
			END_IF;
			code := code + '\nprocedure End_Element(\n' 
			+ '\tHandler : in out Xml_generic_parser;\n' 
			+ '\tobj : in out ' + allcls [ no].name + '_io;\n' 
			+ '\tNamespace_Uri : Unicode.CES.Byte_Sequence := "";\n' 
			+ '\tLocal_Name : Unicode.CES.Byte_Sequence := "";\n' 
			+ '\tQname : Unicode.CES.Byte_Sequence := "");\n';
		END_REPEAT;
		code := code + '\n\nend xml_architecture_io;\n';
		RETURN ( code );
	END_FUNCTION;

	FUNCTION xml_architecture_io_adb_package_code : STRING;
		LOCAL 
			code : STRING := '';
			allcls : LIST OF ada_class := all_ada_classes;
			allrecs : LIST OF record := all_ada_records;
			allents : LIST OF ada_entity := allcls + allrecs;
			strtab : LIST OF STRING := [ ];
			alldts : LIST OF discriminated_type := all_ada_discriminated_types;
		END_LOCAL;
		code := source_licence + '\n';
		code := code + 'package body xml_architecture_io is\n\n';
		code := code + '\n';
		code :=
		 code +
		 '\nprocedure Start_Element(' +
		 '\n	Handler: in out Xml_Generic_Parser;' +
		 '\n	ref : in out unbounded_string;' +
		 '\n	id : in out unbounded_string;' +
		 '\n	Namespace_Uri : Unicode.CES.Byte_Sequence := "";' +
		 '\n	Local_Name : Unicode.CES.Byte_Sequence := "";' +
		 '\n	Qname : Unicode.CES.Byte_Sequence := "";' +
		 '\n	Atts : Sax.Attributes.Attributes''Class) is' +
		 '\nbegin' +
		 '\n	if Get_Length (Atts) > 0 then' +
		 '\n		if (To_String (To_Lower (Qname)) = "' +
		 Lowerize ( allents [ LOINDEX ( allents ) ].name ) +
		 '")';

		REPEAT no := LOINDEX ( allents ) + 1 TO HIINDEX ( allents );
			code := code + '\n\t\t\t OR (To_String (To_Lower (Qname)) = "' + Lowerize ( allents [ no].name ) + '")';
		END_REPEAT;
		code :=
		 code +
		 ' then' +
		 '\n			for J in 0 .. Get_Length (Atts) - 1 loop' +
		 '\n				if To_String (To_Lower (Get_Qname (Atts, J))) = "id" then' +
		 '\n					id := To_Unbounded_String (Get_Value (Atts, J));' +
		 '\n				end if;' +
		 '\n				if To_String (To_Lower (Get_Qname (Atts, J))) = "ref" then' +
		 '\n					ref := To_Unbounded_String (Get_Value (Atts, J));' +
		 '\n				end if;' +
		 '\n			end loop;' +
		 '\n		end if;' +
		 '\n	end if;' +
		 '\nend Start_Element;\n\n';

		REPEAT no := LOINDEX ( alldts ) TO HIINDEX ( alldts );
			code := code + discriminated_type_xml_io_record_initialize_code ( alldts [ no] );
			code := code + discriminated_type_xml_start_element_code ( alldts [ no] );
			code := code + discriminated_type_xml_end_element_code ( alldts [ no] );
		END_REPEAT;

		REPEAT no := LOINDEX ( allrecs ) TO HIINDEX ( allrecs );
			code := code + ada_entity_xml_io_record_initialize_code ( allrecs [ no] );
			code := code + ada_entity_xml_start_element_code ( allrecs [ no] );
			code := code + ada_entity_xml_end_element_code ( allrecs [ no] );
		END_REPEAT;

		REPEAT no := LOINDEX ( allcls ) TO HIINDEX ( allcls );
			code := code + ada_entity_xml_io_record_initialize_code ( allcls [ no] );
			code := code + ada_entity_xml_start_element_code ( allcls [ no] );
			code := code + ada_entity_xml_end_element_code ( allcls [ no] );
		END_REPEAT;
		code := code + 'end xml_architecture_io;\n';
		RETURN ( code );
	END_FUNCTION;
END_SCHEMA;

SCHEMA cheddar_domains;
	USE FROM express2cheddar_facade;
	USE FROM ada_interface;
	USE FROM platypus_dictionary_schema;
	USE FROM platypus_expressions_schema;
	USE FROM express_toolsbox_functions;
	USE FROM express_dictionary_queries;

	CONSTANT 
		std_io_interfaces : LIST OF ada_interface := [ ada_interface ( 'standards_io', ?, true, true ) ];
	END_CONSTANT;

	ENTITY pragma_convention;
		convention : STRING;
	END_ENTITY;

	ENTITY ada_type 
		SUBTYPE OF ( defined_type );
	DERIVE
		ada_ident : STRING := name;
		ada_ref_ident : STRING := name;
		init_value : STRING := ?;
		dependencies : LIST OF dictionary_instance := dependencies_of ( SELF.owner, SELF.domain.handled );
		refed_by_pointer : BOOLEAN := false;
	END_ENTITY;

	FUNCTION dependencies_of ( o : context_definition; t : dictionary_instance ) : LIST OF dictionary_instance;
		LOCAL 
			r : LIST OF dictionary_instance := [ ];
		END_LOCAL;

		IF ( 'PLATYPUS_DICTIONARY_SCHEMA.AGGREGATION_TYPE' IN TYPEOF ( t ) ) THEN
			r := r + dependencies_of ( o, t.element_type.handled );
		ELSE
			IF ( is_of_generated_concept_kind ( t ) ) THEN
				IF ( t.owner = o ) THEN
					r := r + t.dependencies + t;
				END_IF;
			END_IF;
		END_IF;
		RETURN ( r );
	END_FUNCTION;

	ENTITY cheddar_defined_type 
		SUBTYPE OF ( ada_type );
	DERIVE
		ads_interface_list : LIST OF ada_interface := cheddar_defined_type_interfaces_list ( SELF, true );
		adb_interface_list : LIST OF ada_interface := cheddar_defined_type_interfaces_list ( SELF, false );
		SELF\defined_type.accepted : entity_instance := SELF.accept_cheddar_defined_type;
		ads_pre_def : STRING := '';
	END_ENTITY;

	ENTITY constrained_array_type 
		SUBTYPE OF ( cheddar_defined_type );
		min_idx : STRING;
		max_idx : OPTIONAL STRING;
		interfaces : LIST OF ada_interface;
	DERIVE
		adb_interfaces_list : LIST OF ada_interface := [ ];
		ads_interfaces_list : LIST OF ada_interface := interfaces;
		adb_code : STRING := '';
		ads_code : STRING := constrained_array_type_ads_code ( SELF );
	END_ENTITY;

	FUNCTION constrained_array_type_ads_code ( a : constrained_array_type ) : STRING;
		LOCAL 
			code : STRING := '';
		END_LOCAL;
		code := 'type ' + a.ada_ident + ' is Array ( ';

		IF ( EXISTS ( a.max_idx ) ) THEN
			code := code + a.min_idx + ' .. ' + a.max_idx;
		ELSE
			code := code + a.min_idx;
		END_IF;

		ALIAS etype FOR a.domain.element_type.handled;
			IF ( 'RECORD_AND_CLASS.ADA_CLASS' IN TYPEOF ( etype ) ) THEN
				code := code + ' ) of ' + etype.ptr_type + ';\n';
			ELSE
				code := code + ' ) of ' + etype.ada_ident + ';\n';
			END_IF;
		END_ALIAS;
		RETURN ( code );
	END_FUNCTION;

	FUNCTION cheddar_defined_type_interfaces_list ( r : cheddar_defined_type; ads : BOOLEAN ) : LIST OF ada_interface;
		LOCAL 
			result : LIST OF ada_interface := [ ];
		END_LOCAL;

		IF ( ads ) THEN
			result := result + ada_interface ( r.owner.name, ?, true, true );
		END_IF;
		RETURN ( result );
	END_FUNCTION;

	ENTITY cheddar_entity_definition 
		SUBTYPE OF ( entity_definition );
	DERIVE
		ads_interfaces_list : LIST OF ada_interface := [ ];
		adb_interfaces_list : LIST OF ada_interface := [ ];
		ada_ident : STRING := SELF.name;
		ada_ref_ident : STRING := SELF.name;
		init_value : STRING := ?;
		ads_code : STRING := '';
		adb_code : STRING := '';
	END_ENTITY;

	ENTITY unmapped_type_reference;
		ref : entity_instance;
	DERIVE
		ads_interfaces_list : LIST OF ada_interface := ( basic_ada_domain ( SELF.ref ) ).ads_interfaces_list;
		adb_interfaces_list : LIST OF ada_interface := ( basic_ada_domain ( SELF.ref ) ).adb_interfaces_list;
		ada_ident : STRING := SELF.name;
		ada_ref_ident : STRING := SELF.name;
		init_value : STRING := ( basic_ada_domain ( SELF.ref ) ).init_value;
		ads_code : STRING := '';
		adb_code : STRING := '';
		refed_by_pointer : BOOLEAN := false;
	END_ENTITY;

	ENTITY unmapped_entity_definition;
	DERIVE
		ads_interfaces_list : LIST OF ada_interface := [ ];
		adb_interfaces_list : LIST OF ada_interface := [ ];
		ada_ident : STRING := SELF.name;
		ada_ref_ident : STRING := SELF.name;
		init_value : STRING := ?;
		ads_code : STRING := '';
		adb_code : STRING := '';
	END_ENTITY;

	ENTITY basic_ada_type_getter;
	DERIVE
		accept_string_type : dictionary_instance := ( ada_unbounded_string_type ( ) || ada_primitive_type ( ) || dictionary_instance ( ) );
		accept_integer_type : dictionary_instance := ( ada_natural_type ( ) || ada_primitive_type ( ) || dictionary_instance ( ) );
		accept_real_type : dictionary_instance := ( ada_double_type ( ) || ada_primitive_type ( ) || dictionary_instance ( ) );
		accept_boolean_type : dictionary_instance := ( ada_boolean_type ( ) || ada_primitive_type ( ) || dictionary_instance ( ) );
		accept_enumeration_type : dictionary_instance := SELF\enumeration_type;
		accept_ada_enumeration : dictionary_instance := SELF;
		accept_attribute_reference : dictionary_instance :=
		 ( ada_attribute_reference ( ) ||
			 ada_named_type_reference ( ) ||
			 SELF\attribute_reference );
		accept_defined_type_reference : dictionary_instance := basic_ada_domain ( SELF\defined_type_reference.ref );
		accept_defined_type : dictionary_instance := unmapped_type_reference ( SELF.domain ) || SELF;
		accept_ada_range : dictionary_instance := SELF;
		accept_ada_class_reference : dictionary_instance := SELF;
		accept_ada_record_reference : dictionary_instance := SELF;
		accept_entity_definition_reference : dictionary_instance :=
		 ( unmapped_type_reference ( SELF.ref ) ||
			 SELF\entity_definition_reference );
		accept_entity_definition : dictionary_instance := ( unmapped_entity_definition ( ) || SELF\entity_definition );
		accept_cheddar_defined_type : dictionary_instance := ( SELF );
		accept_list_type : dictionary_instance := ( ada_list_type ( ) || SELF\list_type );
		accept_array_type : dictionary_instance := ( ada_array_type ( ) || SELF\array_type );
		accept_set_type : dictionary_instance := ( ada_set_type ( ) || SELF\set_type );
		accept_bag_type : dictionary_instance := ( ada_bag_type ( ) || SELF\bag_type );
		accept_explicit_type_reference : dictionary_instance := SELF;
	END_ENTITY;

	FUNCTION basic_ada_domain ( d : dictionary_instance ) : entity_instance;
		RETURN ( ( d || basic_ada_type_getter ( ) ).accepted );
	END_FUNCTION;

	ENTITY ada_primitive_type 
		SUBTYPE OF ( entity_definition );
	DERIVE
		ads_interfaces_list : LIST OF ada_interface := [ ];
		adb_interfaces_list : LIST OF ada_interface := [ ];
		ads_code : STRING := '';
		adb_code : STRING := '';
		put_prefix : STRING := '';
		refed_by_pointer : BOOLEAN := false;
	END_ENTITY;

	ENTITY cheddar_primitive_type 
		SUBTYPE OF ( ada_primitive_type );
	END_ENTITY;

	(* ? cheddar_law_type ? *)
	ENTITY cheddar_law_type 
		SUBTYPE OF ( cheddar_primitive_type );
	DERIVE
		SELF\ada_primitive_type.ads_interfaces_list : LIST OF ada_interface :=
		 [ ada_interface ( 'Expression',
				 ?,
				 true,
				 true ),
			 ada_interface ( 'Expression',
				 ?,
				 false,
				 true ) ];
		SELF\ada_primitive_type.adb_interfaces_list : LIST OF ada_interface := [ ];
		ada_ident : STRING := 'law_type';
		ada_ref_ident : STRING := SELF.ada_ident;
		init_value : STRING := ?;
	END_ENTITY;

	ENTITY cheddar_priority_range 
		SUBTYPE OF ( cheddar_defined_type );
	DERIVE
		ads_code : STRING :=
		 '
-- Definition of priority range. We choose the most current value :
-- 256 priority levels (from 0 to 255)
-- Zero is the lowest priority level
Type Priority_Range is new Natural range 0 .. 255;
package Priority_Io is new Text_IO.Integer_IO (Priority_Range);
use Priority_Io;
';
		adb_code : STRING := '';
		ads_interfaces_list : LIST OF ada_interface :=
		 [ ada_interface ( 'Framework_Config',
				 ?,
				 true,
				 true ),
			 ada_interface ( 'Framework_Config',
				 'Priority_Io',
				 false,
				 true ) ];
		adb_interfaces_list : LIST OF ada_interface := [ ];
		SELF\ada_type.ada_ident : STRING := 'Priority_Range';
		SELF\ada_type.ada_ref_ident : STRING := SELF.ada_ident;
		SELF\ada_type.init_value : STRING := '0';
	END_ENTITY;

	ENTITY ada_natural_type 
		SUBTYPE OF ( ada_primitive_type );
	DERIVE
		SELF\ada_primitive_type.ads_interfaces_list : LIST OF ada_interface :=
		 std_io_interfaces + [ ada_interface ( 'standards_io',
				 'natural_io',
				 false,
				 true ) ];
		SELF\ada_primitive_type.adb_interfaces_list : LIST OF ada_interface := [ ada_interface ( 'primitive_xml_strings', ?, true, true ) ];
		ada_ident : STRING := 'Natural';
		ada_ref_ident : STRING := SELF.ada_ident;
		init_value : STRING := '0';
		SELF\ada_primitive_type.put_prefix : STRING := 'standards_io.natural_io.';
	END_ENTITY;

	ENTITY ada_unbounded_string_type 
		SUBTYPE OF ( ada_primitive_type );
	DERIVE
		SELF\ada_primitive_type.ads_interfaces_list : LIST OF ada_interface :=
		 [ ada_interface ( 'ada.strings',
				 'unbounded.text_io',
				 true,
				 true ),
			 ada_interface ( 'Text_io',
				 ?,
				 true,
				 true ),
			 ada_interface ( 'Unbounded_Strings',
				 ?,
				 true,
				 true ),
			 ada_interface ( 'Convert_Strings',
				 ?,
				 true,
				 false ),
			 ada_interface ( 'Convert_Unbounded_Strings',
				 ?,
				 true,
				 false ) ];
		SELF\ada_primitive_type.adb_interfaces_list : LIST OF ada_interface :=
		 [ ada_interface ( 'Text_io',
				 ?,
				 true,
				 true ),
			 ada_interface ( 'primitive_xml_strings',
				 ?,
				 true,
				 true ) ];
		ada_ident : STRING := 'Unbounded_String';
		ada_ref_ident : STRING := SELF.ada_ident;
		init_value : STRING := 'empty_string';
	END_ENTITY;

	ENTITY cheddar_xml_id_type 
		SUBTYPE OF ( string_type );
	DERIVE
		SELF\ada_unbounded_string_type.ads_interfaces_list : LIST OF ada_interface :=
		 [ ada_interface ( 'ada.strings',
				 'unbounded.text_io',
				 true,
				 true ),
			 ada_interface ( 'Text_io',
				 ?,
				 true,
				 true ),
			 ada_interface ( 'Unbounded_Strings',
				 ?,
				 true,
				 true ),
			 ada_interface ( 'Convert_Strings',
				 ?,
				 true,
				 false ),
			 ada_interface ( 'Convert_Unbounded_Strings',
				 ?,
				 true,
				 false ),
			 ada_interface ( 'id_generators',
				 ?,
				 true,
				 true ) ];
		adb_interfaces_list : LIST OF ada_interface :=
		 [ ada_interface ( 'call_framework',
				 ?,
				 true,
				 true ),
			 ada_interface ( 'id_generators',
				 ?,
				 true,
				 true ) ];
		ads_code : STRING := '';
		adb_code : STRING := '';
		put_prefix : STRING := '';
		refed_by_pointer : BOOLEAN := false;
		SELF\ada_unbounded_string_type.init_value : STRING := 'generate_id';
	END_ENTITY;

	ENTITY ada_boolean_type 
		SUBTYPE OF ( ada_primitive_type );
	DERIVE
		SELF\ada_primitive_type.ads_interfaces_list : LIST OF ada_interface :=
		 std_io_interfaces + [ ada_interface ( 'standards_io',
				 'boolean_io',
				 false,
				 true ) ];
		SELF\ada_primitive_type.adb_interfaces_list : LIST OF ada_interface := [ ada_interface ( 'primitive_xml_strings', ?, true, true ) ];
		ada_ident : STRING := 'Boolean';
		ada_ref_ident : STRING := SELF.ada_ident;
		init_value : STRING := 'false';
		SELF\ada_primitive_type.put_prefix : STRING := 'standards_io.boolean_io.';
	END_ENTITY;

	ENTITY ada_real_type 
		SUBTYPE OF ( ada_primitive_type );
	DERIVE
		SELF\ada_primitive_type.ads_interfaces_list : LIST OF ada_interface :=
		 std_io_interfaces + [ ada_interface ( 'Ada',
				 'Numerics.Aux',
				 true,
				 true ),
			 ada_interface ( 'standards_io',
				 'float_io',
				 false,
				 true ) ];
		SELF\ada_primitive_type.adb_interfaces_list : LIST OF ada_interface := [ ada_interface ( 'primitive_xml_strings', ?, true, true ) ];
		ada_ident : STRING := 'Float';
		ada_ref_ident : STRING := SELF.ada_ident;
		init_value : STRING := '0.0';
		SELF\ada_primitive_type.put_prefix : STRING := 'standards_io.float_io.';
	END_ENTITY;

	ENTITY ada_double_type 
		SUBTYPE OF ( ada_primitive_type );
	DERIVE
		SELF\ada_primitive_type.ads_interfaces_list : LIST OF ada_interface :=
		 std_io_interfaces + [ ada_interface ( 'Ada',
				 'Numerics.Aux',
				 true,
				 true ),
			 ada_interface ( 'standards_io',
				 'double_io',
				 false,
				 true ) ];
		SELF\ada_primitive_type.adb_interfaces_list : LIST OF ada_interface := [ ada_interface ( 'primitive_xml_strings', ?, true, true ) ];
		ada_ident : STRING := 'Double';
		ada_ref_ident : STRING := SELF.ada_ident;
		init_value : STRING := '0.0';
		SELF\ada_primitive_type.put_prefix : STRING := 'standards_io.double_io.';
	END_ENTITY;

	ENTITY ada_integer_type 
		SUBTYPE OF ( ada_primitive_type );
	DERIVE
		SELF\ada_primitive_type.ads_interfaces_list : LIST OF ada_interface :=
		 std_io_interfaces + [ ada_interface ( 'standards_io',
				 'integer_io',
				 false,
				 true ) ];
		SELF\ada_primitive_type.adb_interfaces_list : LIST OF ada_interface := [ ada_interface ( 'primitive_xml_strings', ?, true, true ) ];
		ada_ident : STRING := 'Integer';
		ada_ref_ident : STRING := SELF.ada_ident;
		init_value : STRING := '0';
		SELF\ada_primitive_type.put_prefix : STRING := 'standards_io.integer_io.';
	END_ENTITY;

	ENTITY ada_named_type_reference 
		SUBTYPE OF ( entity_instance );
	DERIVE
		ads_interfaces_list : LIST OF ada_interface := [ ];
		adb_interfaces_list : LIST OF ada_interface := [ ];
		ada_ident : STRING := SELF.ref.name;
		ada_ref_ident : STRING := SELF.ada_ident;
	END_ENTITY;

	ENTITY ada_record_reference 
		SUBTYPE OF ( ada_named_type_reference );
	DERIVE
		SELF\entity_definition_reference.accepted : entity_instance := SELF.accept_ada_record_reference;
	END_ENTITY;

	ENTITY ada_class_reference 
		SUBTYPE OF ( ada_named_type_reference );
	DERIVE
		SELF\entity_definition_reference.accepted : entity_instance := SELF.accept_ada_class_reference;
		SELF\ada_named_type_reference.ads_interfaces_list : LIST OF ada_interface :=
		 [ ada_interface ( SELF.ref.owner.name,
				 ?,
				 true,
				 true ) ];
		SELF\ada_named_type_reference.ada_ident : STRING := SELF.ref.name + '_Ptr';
		init_value : STRING := 'initialize';
	END_ENTITY;

	ENTITY ada_primitive_class_reference 
		SUBTYPE OF ( ada_class_reference );
		pointed_type_name : STRING;
		package_name : STRING;
	DERIVE
		SELF\ada_class_reference.ads_interfaces_list : LIST OF ada_interface := [ ada_interface ( package_name, ?, true, true ) ];
		SELF\ada_class_reference.ada_ident : STRING := pointed_type_name + '_Ptr';
	END_ENTITY;

	ENTITY ada_attribute_reference 
		SUBTYPE OF ( ada_named_type_reference );
	END_ENTITY;

	ENTITY ada_array_type 
		SUBTYPE OF ( array_type );
	DERIVE
		ads_interfaces_list : LIST OF ada_interface := std_io_interfaces;
		adb_interfaces_list : LIST OF ada_interface := [ ];
		ada_ident : STRING := ?;
		ada_ref_ident : STRING := SELF.ada_ident;
		init_value : STRING := ?;
	END_ENTITY;

	ENTITY ada_list_type 
		SUBTYPE OF ( list_type );
	DERIVE
		ads_interfaces_list : LIST OF ada_interface := std_io_interfaces;
		adb_interfaces_list : LIST OF ada_interface := [ ];
		ada_ident : STRING := 'list';
		ada_ref_ident : STRING := SELF.ada_ident;
		init_value : STRING := ?;
	END_ENTITY;

	ENTITY ada_set_type 
		SUBTYPE OF ( set_type );
	DERIVE
		ads_interfaces_list : LIST OF ada_interface := std_io_interfaces;
		adb_interfaces_list : LIST OF ada_interface := [ ];
		ada_ident : STRING := 'set';
		ada_ref_ident : STRING := SELF.ada_ident;
	END_ENTITY;

	ENTITY ada_bag_type 
		SUBTYPE OF ( bag_type );
	DERIVE
		ads_interfaces_list : LIST OF ada_interface := std_io_interfaces;
		adb_interfaces_list : LIST OF ada_interface := [ ];
		ada_ident : STRING := 'bag';
		ada_ref_ident : STRING := SELF.ada_ident;
	END_ENTITY;

	ENTITY ada_enumeration 
		SUBTYPE OF ( ada_type );
		convertion : OPTIONAL STRING;
	DERIVE
		ads_interfaces_list : LIST OF ada_interface :=
		 [ ada_interface ( 'Convert_Strings',
				 ?,
				 true,
				 false ),
			 ada_interface ( 'Convert_Unbounded_Strings',
				 ?,
				 true,
				 false ),
			 ada_interface ( 'text_io',
				 ?,
				 true,
				 true ),
			 ada_interface ( 'ada.strings',
				 'unbounded',
				 true,
				 true ) ];
		adb_interfaces_list : LIST OF ada_interface := [ ada_interface ( 'primitive_xml_strings', ?, true, true ) ];
		ads_code : STRING := enumeration_ads_code ( SELF );
		adb_code : STRING := enumeration_adb_code ( SELF );
		SELF\ada_type.ada_ident : STRING := name;
		SELF\ada_type.ada_ref_ident : STRING := SELF.ada_ident;
		SELF\ada_type.init_value : STRING := NVL ( convertion, domain.elements [ 1 ] );
		io_type_name : STRING := SELF.ada_ident + '_io';
		full_io_type_name : STRING := SELF.owner.name + '.' + SELF.io_type_name;
		SELF\defined_type.accepted : entity_instance := SELF.accept_ada_enumeration;
		ads_pre_def : STRING := '';
	END_ENTITY;

	FUNCTION enumeration_ads_code ( e : ada_enumeration ) : STRING;
		LOCAL 
			code : STRING;
			convert_type : STRING := NVL ( e.convertion, e.domain.elements [ LOINDEX ( e.domain.elements ) ] );
		END_LOCAL;
		code := 'type ' + e.name + ' is (\n\t' + StringAggregateConcatSeparatedBy ( e.domain.elements, ',\n\t' ) + ');\n';

		IF ( 'CHEDDAR_DOMAINS.PRAGMA_CONVENTION' IN TYPEOF ( e ) ) THEN
			code := code + 'pragma convention (' + e.convention + ', ' + e.name + ');\n';
		END_IF;
		code := code + '\n' 
		+ 'procedure To_' + e.name + ' is\n' 
		+ 'new Convert_Strings(' + e.name + ', ' + convert_type + ');\n' 
		+ 'procedure To_' + e.name + ' is\n' 
		+ 'new Convert_Unbounded_Strings(' + e.name + ', ' + convert_type + ');\n' 
		+ 'function XML_String (obj : in ' + e.name + ') return Unbounded_String;\n' 
		+ 'function XML_Ref_String (obj : in ' + e.name + ') return Unbounded_String;\n' 
		+ 'package ' + e.name + '_io is new text_io.enumeration_io(' + e.name + ');\n' 
		+ 'use ' + e.name + '_io;\n\n';
		RETURN ( code );
	END_FUNCTION;

	ENTITY basic_ada_type_value_format 
		SUBTYPE OF ( dictionary_instance );
		val : expression;
		basic_ada_type : OPTIONAL dictionary_instance;
	DERIVE
		formated : STRING := basic_ada_expression_value_string ( SELF.val );
	END_ENTITY;

	FUNCTION basic_ada_expression_value_string ( e : expression ) : STRING;
		LOCAL 
			code : STRING := '';
		END_LOCAL;

		IF ( 'PLATYPUS_EXPRESSIONS_SCHEMA.IDENTIFIER' IN TYPEOF ( e ) ) THEN
			RETURN ( e.name );
		END_IF;

		IF ( 'PLATYPUS_EXPRESSIONS_SCHEMA.INTEGER_LITERAL' IN TYPEOF ( e ) ) THEN
			RETURN ( FORMAT ( e.val, 'I' ) );
		END_IF;

		IF ( 'PLATYPUS_EXPRESSIONS_SCHEMA.TRUE_CONSTANT' IN TYPEOF ( e ) ) THEN
			RETURN ( 'True' );
		END_IF;

		IF ( 'PLATYPUS_EXPRESSIONS_SCHEMA.FALSE_CONSTANT' IN TYPEOF ( e ) ) THEN
			RETURN ( 'False' );
		END_IF;

		IF ( 'PLATYPUS_EXPRESSIONS_SCHEMA.BINARY_EXPRESSION' IN TYPEOF ( e ) ) THEN
			RETURN ( '(' +
				 basic_ada_expression_value_string ( e.left_expr ) +
				 ' ' +
				 e.op_string +
				 ' ' +
				 basic_ada_expression_value_string ( e.right_expr ) +
				 ')' );
		END_IF;
		RETURN ( 'null' );
	END_FUNCTION;

	FUNCTION enumeration_adb_code ( e : ada_enumeration ) : STRING;
		LOCAL 
			code : STRING;
		END_LOCAL;
		code := 'function XML_String(obj : in ' + e.name + ') return Unbounded_String is\n' 
		+ 'begin\n' 
		+ '	return to_unbounded_string(' + e.name + '''image (obj) );\n' 
		+ 'end XML_String;\n\n' 

		+ 'function XML_Ref_String (obj : in ' + e.name + ') return Unbounded_String is\n' 
		+ 'begin\n' 
		+ '\traise xml_ref_string_error;\n' 
		+ '\treturn to_unbounded_string("");\n' 
		+ 'end XML_Ref_String;\n\n';
		RETURN ( code );
	END_FUNCTION;

	ENTITY range_type 
		SUBTYPE OF ( defined_type );
		lower : STRING;
		upper : STRING;
		lower_constant : OPTIONAL STRING;
		upper_constant : OPTIONAL STRING;
	DERIVE
		ads_interfaces_list : LIST OF ada_interface := [ ];
		adb_interfaces_list : LIST OF ada_interface := [ ];
		ada_ident : STRING := name;
		ada_ref_ident : STRING := SELF.ada_ident;
		ads_code : STRING := range_type_ads_code ( SELF );
		adb_code : STRING := '';
	END_ENTITY;

	FUNCTION range_type_ads_code ( rt : range_type ) : STRING;
		LOCAL 
			r : STRING := 'type ' + rt.ada_ident + ' is Range ' + rt.lower + ' .. ' + rt.upper + ';\n';
		END_LOCAL;

		IF ( EXISTS ( rt.lower_constant ) ) THEN
			r := r + rt.lower_constant + ' : constant ' + rt.ada_ident + ' := ' + rt.ada_ident + '''First;\n';
		END_IF;

		IF ( EXISTS ( rt.upper_constant ) ) THEN
			r := r + rt.upper_constant + ' : constant ' + rt.ada_ident + ' := ' + rt.ada_ident + '''Last;\n';
		END_IF;
		RETURN ( r );
	END_FUNCTION;

	ENTITY explicit_type_reference 
		SUBTYPE OF ( defined_type );
		used_name : OPTIONAL STRING;
		interfaces : LIST OF ada_interface;
	DERIVE
		SELF\defined_type.accepted : entity_instance := SELF.accept_explicit_type_reference;
		ads_interfaces_list : LIST OF ada_interface := SELF.interfaces;
		adb_interfaces_list : LIST OF ada_interface := [ ada_interface ( SELF.owner.name, ?, true, true ) ] + interfaces;
		ada_ident : STRING := SELF.name;
		ptr_type : STRING := SELF.ada_ident + '_Ptr';
		ada_ref_ident : STRING := NVL ( SELF.used_name, SELF.name );
		init_value : STRING := ?;
		ads_code : STRING := '';
		adb_code : STRING := '';
		refed_by_pointer : BOOLEAN := string_ends_with ( SELF.ada_ref_ident, '_Ptr' );
	END_ENTITY;

	ENTITY in_scope_attribute;
	DERIVE
		init_code : STRING := in_scope_attribute_init_code ( SELF );
	END_ENTITY;

	FUNCTION in_scope_attribute_init_code ( a : in_scope_attribute ) : STRING;
		LOCAL 
			code : STRING := '';
		END_LOCAL;

		ALIAS domain FOR a.domain.handled;
			IF ( domain.refed_by_pointer ) THEN
				code := code + '\n\tif obj.' + a.name + ' /= null then\n' 
				+ '\t\tFree (obj.' + a.name + ' );\n' 
				+ '\tend if;\n' 
				+ '\tobj.' + a.name + ' := new ' + domain.name + ';\n' 
				+ '\tInitialize(obj.' + a.name + '.all);\n';
			END_IF;
		END_ALIAS;
		RETURN ( code );
	END_FUNCTION;

	FUNCTION domain_interfaces_list ( ada_domain : entity_instance; ads : BOOLEAN; pkg : schema_definition ) : LIST OF ada_interface;
		LOCAL 
			result : LIST OF ada_interface := [ ];
		END_LOCAL;

		ALIAS h FOR ada_domain.handled;
			IF ads THEN
				result := result + ada_domain.ads_interfaces_list;
			ELSE
				result := result + ada_domain.adb_interfaces_list;
				IF ( 'CHEDDAR_DOMAINS.ADA_ENUMERATION' IN TYPEOF ( h ) ) THEN
					IF ( h.owner.name <> pkg.name ) THEN
						result := result + ada_interface ( h.owner.name, ?, true, false );
						result := result + ada_interface ( h.full_io_type_name, ?, false, true );
					END_IF;
				END_IF;
			END_IF;
			IF ( 'CHEDDAR_DOMAINS.ADA_PRIMITIVE_TYPE' IN TYPEOF ( h ) ) OR
				 ( 'DISCRIMINATED_TYPE.DISCRIMINATED_TYPE' IN TYPEOF ( h ) ) THEN
				IF ads THEN
					result := result + h.ads_interfaces_list;
				ELSE
					result := result + h.adb_interfaces_list;
				END_IF;
			END_IF;
		END_ALIAS;
		RETURN ( result );
	END_FUNCTION;
END_SCHEMA;

SCHEMA cheddar_constants;
	USE FROM express2cheddar_facade;
	USE FROM platypus_dictionary_schema;
	USE FROM cheddar_domains;
	USE FROM ada_interface;
	USE FROM express_dictionary_queries;
	USE FROM express_toolsbox_functions;

	ENTITY ada_constant 
		SUBTYPE OF ( constant_definition );
		final : BOOLEAN;
		other_initializer : OPTIONAL STRING;
	DERIVE
		ads_code : STRING := ada_constant_ads_code ( SELF );
		adb_code : STRING := '';
		ads_interfaces_list : LIST OF ada_interface := ada_constant_interfaces_list ( SELF, true );
		adb_interfaces_list : LIST OF ada_interface := [ ];
	END_ENTITY;

	FUNCTION do_comments_with ( src : STRING ) : STRING;
		(*# " comments " 
		| r s |
		r := ''.
		s :=  self src val.
		s linesDo: [:l | r := r , '--', l, String cr]. 
		self return: (PltStringLiteral val: r)
     		#*)
		(*#<pharo> " comments " 
		| r s |
		r := ''.
		s :=  self src.
		s linesDo: [:l | r := r , '--', l, String cr]. 
		^ self return: r #*)
	END_FUNCTION;

	FUNCTION ada_constant_ads_code ( c : ada_constant ) : STRING;
		LOCAL 
			code : STRING := '';
			remarks : LIST OF remark := remarks_for ( c );
			rem : STRING;
			domain : dictionary_instance := basic_ada_domain ( c.domain );
		END_LOCAL;

		IF ( SIZEOF ( remarks ) > 0 ) THEN
			REPEAT no := LOINDEX ( remarks ) TO HIINDEX ( remarks );
				rem := clean_remark_text_of ( remarks [ no] );
				rem := do_comments_with ( rem );
				code := code + rem;
			END_REPEAT;
		END_IF;
		code := code + c.name + ' : ';

		IF c.final THEN
			code := code + 'constant ';
		END_IF;
		code := code + domain.ada_ref_ident;

		IF NOT EXISTS ( c.other_initializer ) THEN
			code := code + ' := ' + basic_ada_type_value_format ( c.initializer, ? ).formated + ';';
		ELSE
			IF c.other_initializer > '' THEN
				code := code + ' := ' + c.other_initializer;
			END_IF;
			code := code + ';';
		END_IF;
		code := code + '\n';
		RETURN ( code );
	END_FUNCTION;

	FUNCTION ada_constant_interfaces_list ( r : ada_constant; ads : BOOLEAN ) : LIST OF ada_interface;
		LOCAL 
			result : LIST OF ada_interface := [ ];
			ada_domain : entity_instance;
		END_LOCAL;
		ada_domain := basic_ada_domain ( r.domain );
		result := domain_interfaces_list ( ada_domain, ads, r.owner );
		RETURN ( result );
	END_FUNCTION;
END_SCHEMA;

SCHEMA record_and_class;
	USE FROM platypus_dictionary_schema;
	USE FROM platypus_environment_schema;
	USE FROM platypus_expressions_schema;
	USE FROM express_toolsbox_functions;
	USE FROM express_dictionary_queries;
	USE FROM express2cheddar_facade;
	USE FROM cheddar_domains;
	USE FROM discriminated_type;
	USE FROM ada_interface;

	FUNCTION is_generic_object ( e : entity_instance ) : BOOLEAN;

		IF ( 'RECORD_AND_CLASS.ADA_CLASS' IN TYPEOF ( e ) ) THEN
			RETURN ( inherits_from_entity_named ( e, 'generic_object' ) );
		END_IF;
		RETURN ( false );
	END_FUNCTION;

	FUNCTION is_named_object ( e : entity_instance ) : BOOLEAN;

		IF ( 'RECORD_AND_CLASS.ADA_CLASS' IN TYPEOF ( e ) ) THEN
			RETURN ( inherits_from_entity_named ( e, 'named_object' ) );
		END_IF;
		RETURN ( false );
	END_FUNCTION;

	ENTITY ada_entity 
		ABSTRACT SUPERTYPE 
		SUBTYPE OF ( entity_definition );
	DERIVE
		refed_by_pointer : BOOLEAN := false;
		ada_ident : STRING := name;
		ada_ref_ident : STRING := SELF.ada_ident;
		ptr_type : STRING := name + '_Ptr';
		explicit_attributes : LIST OF explicit_attribute :=
		 QUERY ( a <* attributes |
			 'PLATYPUS_DICTIONARY_SCHEMA.EXPLICIT_ATTRIBUTE' IN TYPEOF ( a ) );
		derived_attributes : LIST OF explicit_attribute :=
		 QUERY ( a <* attributes |
			 'PLATYPUS_DICTIONARY_SCHEMA.DERIVED_ATTRIBUTE' IN TYPEOF ( a ) );
		put_prefix : STRING := '';
		dependencies : LIST OF dictionary_instance := dependencies_of_ada_entity ( SELF.owner, SELF );
		xml_writer_code : STRING := ?;
		xml_io_record_code : STRING := ?;
		html_tag : STRING := Lowerize ( SELF.name );
	END_ENTITY;

	FUNCTION dependencies_of_ada_entity ( o : context_definition; t : ada_entity ) : LIST OF dictionary_instance;
		LOCAL 
			r : LIST OF dictionary_instance := [ ];
			attrs : LIST OF attribute := inherited_explicit_attributes ( t );
		END_LOCAL;

		REPEAT no := LOINDEX ( attrs ) TO HIINDEX ( attrs );
			r := r + dependencies_of ( o, attrs [ no].domain.handled );
		END_REPEAT;
		r := r + t;
		RETURN ( r );
	END_FUNCTION;

	ENTITY ada_class 
		SUBTYPE OF ( ada_entity );
		is_private : BOOLEAN;
	DERIVE
		SELF\ada_entity.refed_by_pointer : BOOLEAN := true;
		ads_pre_def : STRING := 'type ' + SELF.name + '; type ' + SELF.ptr_type + ' is access all ' + SELF.name + '''Class;';
		ads_code : STRING := ada_class_ads_code ( SELF, is_private );
		adb_code : STRING := ada_class_adb_code ( SELF );
		init_value : STRING := ?;
		ads_interfaces_list : LIST OF ada_interface := ada_entity_interfaces_list ( SELF, true );
		adb_interfaces_list : LIST OF ada_interface := ada_entity_interfaces_list ( SELF, false );
		SELF\ada_entity.ada_ref_ident : STRING := SELF.ptr_type;
		SELF\ada_entity.xml_writer_code : STRING := ada_class_xml_writer_code ( SELF );
		SELF\ada_entity.xml_io_record_code : STRING := ada_class_xml_io_record_code ( SELF );
	END_ENTITY;

	ENTITY record 
		SUBTYPE OF ( ada_entity );
	DERIVE
		ads_code : STRING := record_ads_code ( SELF );
		adb_code : STRING := record_adb_code ( SELF );
		ads_pre_def : STRING := 'type ' + SELF.name + '; type ' + SELF.ptr_type + ' is access all ' + SELF.name + ';';
		ads_interfaces_list : LIST OF ada_interface := ada_entity_interfaces_list ( SELF, true );
		adb_interfaces_list : LIST OF ada_interface := ada_entity_interfaces_list ( SELF, false );
		SELF\ada_entity.xml_writer_code : STRING := record_xml_writer_code ( SELF );
		SELF\ada_entity.xml_io_record_code : STRING := record_xml_io_record_code ( SELF );
	END_ENTITY;

	FUNCTION ada_class_ads_code ( cip : ada_class; with_private : BOOLEAN ) : STRING;
		LOCAL 
			result : STRING;
			abstr : STRING := '';
			local_sup : entity_definition := local_root_supertype_of ( cip );
		END_LOCAL;
		result := '\n' 
		+ '-- --------= ' + cip.name + ' =--------\n\n';

		IF SIZEOF ( cip.supertypes ) > 0 THEN
			ALIAS supref FOR cip.supertypes [ 1 ].ref;
				result := result + 'type ' + cip.name + ' is ' + abstr + 'new ' + supref.ada_ident + ' with ';
			END_ALIAS;
		ELSE
			result := result + 'type ' + cip.name + ' is ' + abstr + 'new Ada.Finalization.Controlled with ';
		END_IF;

		IF ( with_private ) THEN
			result := result + 'private;\n';
		ELSE
			result := result + ada_class_attributes_ads_code ( cip );
		END_IF;
		result := result + '\nprocedure Initialize(obj : in out ' + cip.name + ');\n' 
		+ 'procedure Put(obj : in ' + cip.name + ');\n' 
		+ 'procedure Put(obj : in ' + cip.ptr_type + ');\n';
		result := result + 'procedure Put_Name(obj : in ' + cip.ptr_type + ');\n';
		result := result + 'procedure Build_Attributes_XML_String(obj : in ' + cip.name + '; result : in out Unbounded_String);\n' 
		+ 'function XML_String(obj : in ' + cip.name + ') return Unbounded_String;\n' 
		+ 'function XML_String(obj : in ' + cip.ptr_type + ') return Unbounded_String;\n' 
		+ 'function XML_Ref_String(obj : in ' + cip.name + ') return Unbounded_String;\n' 
		+ 'function XML_Ref_String(obj : in ' + cip.ptr_type + ') return Unbounded_String;\n';

		IF ( is_named_object ( cip ) ) THEN
			result := result + 'function Get_Name (obj : in ' + cip.name + ') return Unbounded_String;\n' 
			+ 'function Get_Name (obj : in ' + cip.ptr_type + ') return Unbounded_String;\n';
		END_IF;
		result := result + 'function Copy(obj : in ' + cip.ptr_type + ') return ' + local_sup.ptr_type + ';\n' 
		+ 'function Copy(obj : in ' + cip.name + ') return ' + local_sup.ptr_type + ';\n' 
		+ 'function type_of(obj : in ' + cip.name + ') return unbounded_string_list;\n' 
		+ 'function type_of(obj : in ' + cip.ptr_type + ') return unbounded_string_list;\n' 
		+ 'procedure Free  is new Unchecked_Deallocation (' + cip.name + '''Class, ' + cip.ptr_type + ');\n';
		RETURN ( result );
	END_FUNCTION;

	FUNCTION ada_class_adb_code ( cip : ada_class ) : STRING;
		LOCAL 
			code : STRING;
		END_LOCAL;
		code := '\n' 
		+ '-- --------= ' + cip.name + ' =--------\n' 
		+ ada_class_initialize_code ( cip ) + '\n' 
		+ ada_class_copy_code ( cip ) + '\n' 
		+ ada_class_put_code ( cip ) + '\n';

		IF ( is_named_object ( cip ) ) THEN
			code := code + ada_class_get_name_code ( cip ) + '\n';
		END_IF;
		code := code + ada_class_typeof_code ( cip ) + '\n' 
		+ ada_class_xml_writer_code ( cip ) + '\n';
		RETURN ( code );
	END_FUNCTION;

	FUNCTION ada_class_xml_writer_code ( cip : ada_class ) : STRING;
		LOCAL 
			code : STRING;
			contents : STRING := '';
			sub : STRING;
		END_LOCAL;
		code := '\nprocedure Build_Attributes_XML_String(obj : in ' + cip.name + '; result : in out Unbounded_String) is \nbegin\n';

		IF SIZEOF ( cip.supertypes ) > 0 THEN
			ALIAS sup FOR cip.supertypes [ LOINDEX ( cip.supertypes ) ].handled;
				contents := contents + '\tBuild_Attributes_XML_String(' + sup.name + '(obj), result);\n';
			END_ALIAS;
		END_IF;

		REPEAT no := LOINDEX ( cip.explicit_attributes ) TO HIINDEX ( cip.explicit_attributes );
			ALIAS attr FOR cip.explicit_attributes [ no];
				sub := explicit_attribute_xml_writer_code ( 'obj', attr );
				IF sub > '' THEN
					contents := contents + sub + '\n';
				END_IF;
			END_ALIAS;
		END_REPEAT;

		IF contents = '' THEN
			contents := '\tnull;\n';
		END_IF;
		code := code + contents + 'end Build_Attributes_XML_String;\n\n' 

		+ 'function XML_String(obj : in ' + cip.name + ') return Unbounded_String is\n' 
		+ '\tresult : Unbounded_String;\n' 
		+ 'begin\n' 
		+ '\tresult := to_unbounded_string("<' + cip.html_tag + ' id=""") & obj.' + xml_id_name + ' & to_unbounded_string(""" >");\n' 
		+ '\tBuild_Attributes_XML_String(obj, result);\n' 
		+ '\tresult := result & to_unbounded_string("</' + cip.html_tag + '>");\n' 
		+ '\treturn (result);\n' 
		+ 'end XML_String;\n\n' 

		+ 'function XML_String(obj : in ' + cip.ptr_type + ') return Unbounded_String is\n' 
		+ 'begin\n' 
		+ '	if obj /= null then\n' 
		+ '		return XML_String(obj.all);\n' 
		+ '	else\n' 
		+ '		return Empty_String;\n' 
		+ '	end if;\n' 
		+ 'end XML_String;\n\n' 

		+ 'function XML_Ref_String(obj : in ' + cip.name + ') return Unbounded_String is\n' 
		+ '\tresult : Unbounded_String;\n' 
		+ 'begin\n' 
		+ '\tresult := to_unbounded_string("<' + cip.html_tag + ' ref=""") & obj.' + xml_id_name + ' & to_unbounded_string(""" />");\n' 
		+ '\treturn (result);\n' 
		+ 'end XML_Ref_String;\n\n' 

		+ 'function XML_Ref_String(obj : in ' + cip.ptr_type + ') return Unbounded_String is\n' 
		+ 'begin\n' 
		+ '\treturn XML_Ref_String(obj.all);\n' 
		+ 'end XML_Ref_String;\n\n';
		RETURN ( code );
	END_FUNCTION;

	FUNCTION record_xml_writer_code ( cip : record ) : STRING;
		LOCAL 
			code : STRING;
			acode : STRING;
		END_LOCAL;
		code := '\nprocedure Build_Attributes_XML_String(obj : in ' + cip.name + '; result : in out Unbounded_String) is \nbegin\n';

		REPEAT no := LOINDEX ( cip.explicit_attributes ) TO HIINDEX ( cip.explicit_attributes );
			ALIAS attr FOR cip.explicit_attributes [ no];
				acode := explicit_attribute_xml_writer_code ( 'obj', attr );
				IF ( acode > '' ) THEN
					code := code + acode + '\n';
				END_IF;
			END_ALIAS;
		END_REPEAT;
		code := code + 'end Build_Attributes_XML_String;\n\n' 

		+ 'function XML_String(obj : in ' + cip.name + ') return Unbounded_String is\n' 
		+ '\tresult : Unbounded_String;\n' 
		+ 'begin\n' 
		+ '\tresult := to_unbounded_string("<' + cip.html_tag + '>");\n' 
		+ '\tBuild_Attributes_XML_String(obj, result);\n' 
		+ '\tresult := result & to_unbounded_string("</' + cip.html_tag + '>");\n' 
		+ '\treturn (result);\n' 
		+ 'end XML_String;\n\n' 

		+ 'function XML_String(obj : in ' + cip.ptr_type + ') return Unbounded_String is\n' 
		+ 'begin\n' 
		+ '	if obj /= null then\n' 
		+ '		return XML_String(obj.all);\n' 
		+ '	else\n' 
		+ '		return Empty_String;\n' 
		+ '	end if;\n' 
		+ 'end XML_String;\n\n' 

		+ 'function XML_Ref_String(obj : in ' + cip.name + ') return Unbounded_String is\n' 
		+ '\tresult : Unbounded_String;\n' 
		+ 'begin\n' 
		+ '	raise xml_ref_string_error;\n' 
		+ '	return to_unbounded_string("");\n' 
		+ 'end XML_Ref_String;\n';
		RETURN ( code );
	END_FUNCTION;

	FUNCTION ada_class_initialize_code ( cip : ada_class ) : STRING;
		LOCAL 
			code : STRING;
			innerCode : STRING := '';
			attrs : LIST OF attribute;
			init : STRING;
		END_LOCAL;
		code := '\nprocedure Initialize(obj : in out ' + cip.name + ') is \nbegin\n';

		IF SIZEOF ( cip.supertypes ) > 0 THEN
			ALIAS sup FOR cip.supertypes [ LOINDEX ( cip.supertypes ) ].handled;
				innerCode := innerCode + '\tinitialize(' + sup.name + '(obj));\n';
			END_ALIAS;
		END_IF;

		REPEAT no := LOINDEX ( cip.explicit_attributes ) TO HIINDEX ( cip.explicit_attributes );
			ALIAS attr FOR cip.explicit_attributes [ no];
				init := explicit_attribute_initialize ( attr );
				IF ( EXISTS ( init ) AND ( init > '' ) ) THEN
					innerCode := innerCode + '\t' + init + '\n';
				END_IF;
			END_ALIAS;
		END_REPEAT;

		REPEAT no := LOINDEX ( cip.derived_attributes ) TO HIINDEX ( cip.derived_attributes );
			ALIAS attr FOR cip.derived_attributes [ no];
				init := derived_attribute_initialize ( attr );
				IF ( EXISTS ( init ) AND ( init > '' ) ) THEN
					innerCode := innerCode + '\t' + init + '\n';
				END_IF;
			END_ALIAS;
		END_REPEAT;

		IF innerCode = '' THEN
			innerCode := '\tnull;\n';
		END_IF;
		code := code + innerCode + 'end Initialize;\n';
		RETURN ( code );
	END_FUNCTION;

	FUNCTION explicit_attribute_initialize ( attr : explicit_attribute ) : STRING;
		LOCAL 
			domain : dictionary_instance := basic_ada_domain ( attr.domain );
			init : STRING := domain.init_value;
		END_LOCAL;

		IF ( attr.name = xml_id_name ) THEN
			RETURN ( 'generate_id( framework_id, obj.' + attr.name + ' );' );
		END_IF;

		IF ( 'CHEDDAR_DOMAINS.IN_SCOPE_ATTRIBUTE' IN TYPEOF ( attr ) ) THEN
			RETURN ( attr.init_code );
		END_IF;

		IF ( 'CHEDDAR_DOMAINS.CHEDDAR_PRIMITIVE_TYPE' IN TYPEOF ( domain.handled ) ) THEN
			init := domain.handled.init_value;
		END_IF;

		IF NOT ( EXISTS ( init ) ) THEN
			RETURN ( ? );
		ELSE
			IF init <> 'initialize' THEN
				RETURN ( 'obj.' + attr.name + ' := ' + init + ';' );
			ELSE
				IF ( domain.handled.refed_by_pointer ) THEN
					RETURN ( 'initialize( obj.' + attr.name + '.all);' );
				ELSE
					RETURN ( 'initialize( obj.' + attr.name + ');' );
				END_IF;
			END_IF;
		END_IF;
	END_FUNCTION;

	FUNCTION derived_attribute_initialize ( attr : explicit_attribute ) : STRING;
		LOCAL 
			code : STRING;
			val : STRING;
			key : STRING := upperize ( attr.name );
		END_LOCAL;

		IF ( EXISTS ( attr.redeclaring ) ) THEN
			IF SIZEOF ( QUERY ( a <* inherited_explicit_attributes ( attr.owner ) | upperize ( a.name ) = key ) ) > 0 THEN
				val := basic_ada_type_value_format ( attr.assign, ? ).formated;
				code := 'obj.' + attr.name + ' := ' + val + ';';
			END_IF;
		END_IF;
		RETURN ( code );
	END_FUNCTION;

	FUNCTION ada_class_typeof_code ( cip : ada_class ) : STRING;
		LOCAL 
			code : STRING;
			sups : LIST OF entity_definition := all_supertypes_of ( cip );
		END_LOCAL;
		code := 'function type_of ( obj : in ' + cip.name + ' ) return unbounded_string_list is\n' 
		+ '\tlist : unbounded_string_list;\n' 
		+ '\ts : unbounded_string_ptr;\n' 
		+ 'begin\n' 
		+ '\t' + 'Initialize(list);\n' 
		+ '\n';

		REPEAT no := LOINDEX ( sups ) TO HIINDEX ( sups );
			ALIAS curr FOR sups [ no];
				code := code + '\t' + 's := new unbounded_string;\n' 
				+ '\t' + 's.all := to_unbounded_string("' + upperize ( curr.owner.name ) + '.' + upperize ( curr.name ) + '");\n' 
				+ '\t' + 'Add (list, s);\n' 
				+ '\n';
			END_ALIAS;
		END_REPEAT;
		code := code + '\treturn list;\nend type_of;\n\n' 

		+ 'function type_of ( obj : in ' + cip.ptr_type + ' ) return unbounded_string_list is\n' 
		+ 'begin\n' 
		+ '\treturn type_of(obj.all);\n' 
		+ 'end type_of;\n';
		RETURN ( code );
	END_FUNCTION;

	FUNCTION ada_class_copy_code ( cip : ada_class ) : STRING;
		LOCAL 
			code : STRING;
			v : STRING := 'New_' + cip.name;
			local_sup : entity_definition := local_root_supertype_of ( cip );
		END_LOCAL;
		code := 'function Copy ( obj : in ' + cip.name + ' ) return ' + local_sup.ptr_type + ' is\n' 
		+ '\t' + v + ' : ' + cip.ptr_type + ';\n' 
		+ 'begin\n' 
		+ '\t' + v + ' := new ' + cip.name + '''(obj);\n';

		IF local_sup.ptr_type <> cip.ptr_type THEN
			code := code + '\treturn ' + local_sup.ptr_type + '(' + v + ');\n';
		ELSE
			code := code + '\treturn (' + v + ');\n';
		END_IF;
		code := code + 'end Copy;\n\n' 

		+ 'function Copy ( obj : in ' + cip.ptr_type + ' ) return ' + local_sup.ptr_type + ' is\n' 
		+ 'begin\n' 
		+ '\treturn copy(obj.all);\n' 
		+ 'end Copy;\n';
		RETURN ( code );
	END_FUNCTION;

	FUNCTION ada_class_put_code ( cip : ada_class ) : STRING;
		LOCAL 
			code : STRING;
			acode : STRING;
		END_LOCAL;
		code := 'procedure Put(obj : in ' + cip.name + ') is \nbegin\n';

		IF SIZEOF ( cip.supertypes ) > 0 THEN
			ALIAS sup FOR cip.supertypes [ LOINDEX ( cip.supertypes ) ].handled;
				code := code + '\tput(' + sup.name + '(obj));\n';
			END_ALIAS;
		END_IF;

		REPEAT no := LOINDEX ( cip.explicit_attributes ) TO HIINDEX ( cip.explicit_attributes );
			ALIAS attr FOR cip.explicit_attributes [ no];
				acode := explicit_attribute_put ( attr );
				IF ( acode > '' ) THEN
					code := code + '\t' + acode + '\n';
				END_IF;
			END_ALIAS;
		END_REPEAT;
		code := code + 'end Put;\n \n' 
		+ 'procedure Put(obj : in ' + cip.ptr_type + ') is\n' 
		+ 'begin\n' 
		+ '\tPut(Obj.All);\n' 
		+ 'end Put;\n \n';
		code := code + 'procedure Put_Name ( obj : in ' + cip.ptr_type + ') is\n' 
		+ 'begin\n';

		IF ( has_inherited_attribute_named ( cip, 'name' ) ) THEN
			code := code + '\tPut ( To_String ( Obj.Name ) );\n';
		ELSE
			code := code + '\tPut ( To_String ( Obj.' + xml_id_name + ' ) );\n';
		END_IF;
		code := code + 'end Put_Name;\n';
		RETURN ( code );
	END_FUNCTION;

	FUNCTION ada_class_get_name_code ( cip : ada_class ) : STRING;
		LOCAL 
			code : STRING;
		END_LOCAL;
		code := 'function Get_Name (obj : in ' + cip.name + ') return Unbounded_String is\n' 
		+ 'begin\n';

		IF ( has_inherited_attribute_named ( cip, 'name' ) ) THEN
			code := code + '	return obj.name;\n';
		ELSE
			code := code + '	return obj.' + xml_id_name + ';\n';
		END_IF;
		code := code + 'end Get_Name;\n\n' 

		+ 'function Get_Name (obj : in ' + cip.name + '_ptr) return Unbounded_String is\n' 
		+ 'begin\n';

		IF ( has_inherited_attribute_named ( cip, 'name' ) ) THEN
			code := code + '	return obj.name;\n';
		ELSE
			code := code + '	return obj.' + xml_id_name + ';\n';
		END_IF;
		code := code + 'end Get_Name;\n';
		RETURN ( code );
	END_FUNCTION;

	FUNCTION ada_class_attributes_ads_code ( cip : ada_class ) : STRING;
		LOCAL 
			result : STRING;
			domain : entity_instance;
		END_LOCAL;

		IF SIZEOF ( cip.explicit_attributes ) = 0 THEN
			result := 'null record;\n';
		ELSE
			result := '\nrecord\n';
			REPEAT no := LOINDEX ( cip.explicit_attributes ) TO HIINDEX ( cip.explicit_attributes );
				ALIAS attr FOR cip.explicit_attributes [ no];
					domain := basic_ada_domain ( attr.domain );
					IF ( 'RECORD_AND_CLASS.ADA_CLASS' IN TYPEOF ( domain.handled ) ) OR
						 ( 'DISCRIMINATED_TYPE.DISCRIMINATED_TYPE' IN TYPEOF ( domain.handled ) ) THEN
						result := result + ' ' + attr.name + ' : ' + domain.handled.ptr_type + ';\n';
					ELSE
						result := result + ' ' + attr.name + ' : ' + domain.ada_ref_ident + ';\n';
					END_IF;
				END_ALIAS;
			END_REPEAT;
			result := result + 'end record;\n';
		END_IF;
		RETURN ( result );
	END_FUNCTION;

	FUNCTION ada_entity_interfaces_list ( r : ada_entity; ads : BOOLEAN ) : LIST OF ada_interface;
		LOCAL 
			result : LIST OF ada_interface := entity_definition_interfaces_list ( r, ads );
		END_LOCAL;

		IF ads THEN
			IF 'PACKAGE.ADA_PACKAGE' IN TYPEOF ( r.owner ) THEN
				result := result + ada_interface ( r.owner.name, ?, true, true );
			END_IF;
			IF ( SIZEOF ( r.supertypes ) > 0 ) THEN
				ALIAS supref FOR r.supertypes [ 1 ].ref;
					IF 'PACKAGE.ADA_PACKAGE' IN TYPEOF ( supref.owner ) THEN
						result := result + ada_interface ( supref.owner.name, ?, true, true );
					END_IF;
				END_ALIAS;
			END_IF;
			result := result + ada_interface ( 'Ada.Finalization', ?, true, false );
			result := result + ada_interface ( 'unbounded_strings', ?, true, true );
			result := result + ada_interface ( 'ada.strings', 'unbounded', true, true );
			result := result + ada_interface ( 'unbounded_strings', 'Unbounded_String_List_Package', false, true );
			result := result + ada_interface ( 'Unchecked_Deallocation', ?, true, false );
			result := result + ada_interface ( 'Primitive_XML_Strings', ?, true, true );
		ELSE
			IF ( has_attribute_named ( r, xml_id_name ) ) THEN
				result := result + ada_interface ( 'framework', ?, true, true );
				result := result + ada_interface ( 'id_generators', ?, true, true );
			END_IF;
		END_IF;
		RETURN ( result );
	END_FUNCTION;

	FUNCTION entity_definition_interfaces_list ( r : entity_definition; ads : BOOLEAN ) : LIST OF ada_interface;
		LOCAL 
			result : LIST OF ada_interface := [ ];
			ada_domain : entity_instance;
		END_LOCAL;

		REPEAT no := LOINDEX ( r.explicit_attributes ) TO HIINDEX ( r.explicit_attributes );
			ALIAS curr FOR r.explicit_attributes [ no];
				ada_domain := basic_ada_domain ( curr.domain );
				result := result + domain_interfaces_list ( ada_domain, ads, r.owner );
			END_ALIAS;
		END_REPEAT;
		RETURN ( result );
	END_FUNCTION;

	FUNCTION record_ads_code ( rec : record ) : STRING;
		LOCAL 
			result : STRING;
			domain : entity_instance;
		END_LOCAL;
		result := '\n' 
		+ '-- --------= ' + rec.name + ' =--------\n\n' 

		+ 'type ' + rec.name + ' is\nrecord\n';

		REPEAT no := LOINDEX ( rec.attributes ) TO HIINDEX ( rec.attributes );
			result := result + ' ' + rec.attributes [ no].name + ' : ';
			domain := basic_ada_domain ( rec.attributes [ no].domain );
			IF ( domain.handled.refed_by_pointer ) THEN
				result := result + domain.handled.ptr_type + ';\n';
			ELSE
				result := result + domain.ada_ref_ident + ';\n';
			END_IF;
		END_REPEAT;
		result := result + 'end record;\n\n' 

		+ 'procedure Initialize(obj : out ' + rec.name + ');\n' 
		+ 'procedure Put(obj : in ' + rec.name + ');\n' 
		+ 'procedure Put(obj : in ' + rec.ptr_type + ');\n' 
		+ 'function Copy(obj : in ' + rec.ptr_type + ') return ' + rec.ptr_type + ';\n' 
		+ 'function Copy(obj : in ' + rec.name + ') return ' + rec.ptr_type + ';\n' 
		+ 'procedure Build_Attributes_XML_String(obj : in ' + rec.name + '; result : in out Unbounded_String);\n' 
		+ 'function XML_String(obj : in ' + rec.name + ') return Unbounded_String;\n' 
		+ 'function XML_String(obj : in ' + rec.ptr_type + ') return Unbounded_String;\n' 
		+ 'function XML_Ref_String(obj : in ' + rec.name + ') return Unbounded_String;\n' 
		+ 'procedure Free  is new Unchecked_Deallocation (' + rec.name + ', ' + rec.ptr_type + ');\n';
		RETURN ( result );
	END_FUNCTION;

	FUNCTION record_initialize_code ( rec : record ) : STRING;
		LOCAL 
			code : STRING;
			innerCode : STRING := '';
			attrs : LIST OF attribute;
			init : STRING;
		END_LOCAL;
		code := '\nprocedure Initialize(obj : out ' + rec.name + ') is \nbegin\n';

		REPEAT no := LOINDEX ( rec.explicit_attributes ) TO HIINDEX ( rec.explicit_attributes );
			ALIAS attr FOR rec.explicit_attributes [ no];
				init := explicit_attribute_initialize ( attr );
				IF ( EXISTS ( init ) AND ( init > '' ) ) THEN
					innerCode := innerCode + '\t' + init + '\n';
				END_IF;
			END_ALIAS;
		END_REPEAT;

		IF innerCode = '' THEN
			innerCode := '\tnull;\n';
		END_IF;
		code := code + innerCode + 'end Initialize;\n';
		RETURN ( code );
	END_FUNCTION;

	FUNCTION record_adb_code ( rec : record ) : STRING;
		LOCAL 
			code : STRING;
		END_LOCAL;
		code := '\n' 
		+ '-- --------= ' + rec.name + ' =--------\n' 
		+ record_initialize_code ( rec ) + '\n' 
		+ record_put_code ( rec ) + '\n' 
		+ record_xml_writer_code ( rec ) + '\n' 
		+ record_copy_code ( rec ) + '\n';
		RETURN ( code );
	END_FUNCTION;

	FUNCTION record_put_code ( rec : record ) : STRING;
		LOCAL 
			code : STRING;
			acode : STRING;
		END_LOCAL;
		code := 'procedure Put(obj : in ' + rec.name + ') is \nbegin\n';

		REPEAT no := LOINDEX ( rec.explicit_attributes ) TO HIINDEX ( rec.explicit_attributes );
			ALIAS attr FOR rec.explicit_attributes [ no];
				acode := explicit_attribute_put ( attr );
				IF ( acode > '' ) THEN
					code := code + '\t' + acode + '\n';
				END_IF;
			END_ALIAS;
		END_REPEAT;
		code := code + 'end Put;\n \n' 
		+ 'procedure Put(obj : in ' + rec.ptr_type + ') is\n' 
		+ 'begin\n' 
		+ '\tPut(Obj.All);\n' 
		+ 'end Put;\n';
		RETURN ( code );
	END_FUNCTION;

	FUNCTION explicit_attribute_put ( attr : explicit_attribute ) : STRING;
		LOCAL 
			code : STRING;
			prfx : STRING := '';
			domain : entity_instance := basic_ada_domain ( attr.domain );
		END_LOCAL;
		code := 'put("' + attr.name + ': "); ';

		IF ( 'RECORD_AND_CLASS.CHEDDAR_FUNCTION_PTR' IN TYPEOF ( domain.handled ) ) THEN
			RETURN ( '' );
		END_IF;

		IF ( 'CHEDDAR_DOMAINS.ADA_PRIMITIVE_TYPE' IN TYPEOF ( domain.handled ) ) THEN
			prfx := domain.handled.put_prefix;
		END_IF;

		IF ( domain.handled.refed_by_pointer ) THEN
			code := code + 'if obj.' + attr.name + ' /= null then ' + prfx + 'put(obj.' + attr.name + '.all' + '); else put("null"); end if;';
		ELSE
			code := code + prfx + 'put(obj.' + attr.name + '); ';
		END_IF;
		code := code + 'put ( "; " );';
		RETURN ( code );
	END_FUNCTION;

	FUNCTION explicit_attribute_xml_writer_code ( prefix : STRING; attr : explicit_attribute ) : STRING;
		LOCAL 
			code : STRING;
			domain : entity_instance := basic_ada_domain ( attr.domain );
			tag : STRING := Lowerize ( attr.name );
		END_LOCAL;

		IF ( 'RECORD_AND_CLASS.CHEDDAR_FUNCTION_PTR' IN TYPEOF ( domain.handled ) ) THEN
			RETURN ( '' );
		END_IF;

		IF ( attr.name = xml_id_name ) THEN
			RETURN ( '' );
		END_IF;

		IF ( is_generic_object ( domain.handled ) ) THEN
			(* code := '\tresult := result & XML_Ref_String (' + prefix + '.' + attr.name + ' );'; *)
			code :=
			 '\tresult := result & to_unbounded_string("<' +
			 attr.name +
			 ' ref=""") & ' +
			 prefix +
			 '.' +
			 attr.name +
			 '.' +
			 xml_id_name +
			 ' & to_unbounded_string(""" />");';
		ELSE
			code := '\tif (XML_String(' + prefix + '.' + attr.name + ') /= Empty_String) then\n' 
			+
			 '\t\tresult := result & to_unbounded_string("<' +
			 tag +
			 '>") & XML_String(' +
			 prefix +
			 '.' +
			 attr.name +
			 ') & to_unbounded_string("</' +
			 tag +
			 '>");\n\tend if;';
		END_IF;
		RETURN ( code );
	END_FUNCTION;

	ENTITY cheddar_function_ptr 
		SUBTYPE OF ( entity_definition );
		arguments : STRING;
		returns : STRING;
	DERIVE
		ads_interface_list : LIST OF ada_interface := [ ];
		adb_interface_list : LIST OF ada_interface := [ ];
		ads_code : STRING := 'Type ' + SELF.name + ' is access function (' + SELF.arguments + ') return ' + SELF.returns + ';';
		adb_code : STRING := '';
		dependencies : LIST OF dictionary_instance := [ SELF ];
		refed_by_pointer : BOOLEAN := false;
		ads_pre_def : STRING := '';
	END_ENTITY;

	FUNCTION record_copy_code ( cip : record ) : STRING;
		LOCAL 
			code : STRING;
			v : STRING := 'New_' + cip.name;
		END_LOCAL;
		code := 'function Copy ( obj : in ' + cip.name + ' ) return ' + cip.ptr_type + ' is\n' 
		+ '\t' + v + ' : ' + cip.ptr_type + ';\n' 
		+ 'begin\n' 
		+ '\t' + v + ' := new ' + cip.name + '''(obj);\n';
		code := code + '\treturn (' + v + ');\n';
		code := code + 'end Copy;\n\n' 

		+ 'function Copy ( obj : in ' + cip.ptr_type + ' ) return ' + cip.ptr_type + ' is\n' 
		+ 'begin\n' 
		+ '\treturn copy(obj.all);\n' 
		+ 'end Copy;\n';
		RETURN ( code );
	END_FUNCTION;

	FUNCTION ada_class_xml_io_record_code ( cip : ada_class ) : STRING;
		RETURN ( '\ntype ' + cip.name + '_io is record' + ada_entity_attributes_xml_io_record_code ( cip ) + '\nend record;' );
	END_FUNCTION;

	FUNCTION ada_entity_attributes_xml_io_record_code ( cip : ada_class ) : STRING;
		LOCAL 
			code : STRING := '';
			attrcode : STRING;
		END_LOCAL;

		IF SIZEOF ( cip.supertypes ) > 0 THEN
			ALIAS sup FOR cip.supertypes [ LOINDEX ( cip.supertypes ) ].handled;
				code := code + ada_entity_attributes_xml_io_record_code ( sup );
			END_ALIAS;
		END_IF;

		REPEAT no := LOINDEX ( cip.explicit_attributes ) TO HIINDEX ( cip.explicit_attributes );
			ALIAS attr FOR cip.explicit_attributes [ no];
				attrcode := explicit_attribute_xml_io_record_code ( attr );
				code := code + attrcode;
			END_ALIAS;
		END_REPEAT;

		IF ( code = '' ) THEN
			code := '\tnull;';
		END_IF;
		RETURN ( code );
	END_FUNCTION;

	FUNCTION explicit_attribute_xml_io_record_code ( attr : explicit_attribute ) : STRING;
		LOCAL 
			code : STRING := '';
			domain : entity_instance := basic_ada_domain ( attr.domain );
			init : STRING := domain.init_value;
		END_LOCAL;

		IF ( 'RECORD_AND_CLASS.RECORD' IN TYPEOF ( domain.handled ) ) THEN
			RETURN ( ada_entity_attributes_xml_io_record_code ( domain.handled ) );
		END_IF;

		IF ( NOT is_generic_object ( domain.handled ) ) THEN
			IF ( 'CHEDDAR_DOMAINS.ADA_ENUMERATION' IN TYPEOF ( domain.handled ) ) OR ( EXISTS ( init ) ) THEN
				IF ( 'CHEDDAR_DOMAINS.ADA_ENUMERATION' IN TYPEOF ( domain.handled ) ) THEN
					code := '\t' + attr.name + ' : ' + domain.ada_ref_ident + ';';
				ELSE
					IF ( init = 'empty_string' ) THEN
						code := '\t' + attr.name + ' : Unbounded_String;';
					ELSE
						IF ( lowerize ( init ) = 'false' ) THEN
							code := '\t' + attr.name + ' : Boolean;';
						ELSE
							IF ( init = '0' ) THEN
								code := '\t' + attr.name + ' : Integer;';
							ELSE
								code := '\t' + attr.name + ' : Double;';
							END_IF;
						END_IF;
					END_IF;
				END_IF;
			END_IF;
		ELSE
			code := '\t' + attr.name + ' : Unbounded_String;';
		END_IF;

		IF ( code > '' ) THEN
			code := '\n' 
			+ code;
		END_IF;
		RETURN ( code );
	END_FUNCTION;

	FUNCTION record_xml_io_record_code ( rec : record ) : STRING;
		RETURN ( '\ntype ' + rec.name + '_io is record' + ada_entity_attributes_xml_io_record_code ( rec ) + '\nend record;\n' );
	END_FUNCTION;

	FUNCTION ada_entity_xml_io_record_initialize_code ( cip : ada_class ) : STRING;
		LOCAL 
			code : STRING := ada_entity_attributes_xml_io_record_initialize_code ( cip );
		END_LOCAL;

		IF ( code = '' ) THEN
			code := '\tnull;';
		END_IF;
		RETURN ( '\nprocedure Initialize(obj : out ' + cip.name + '_io) is \nbegin ' + code + '\nend Initialize;\n' );
	END_FUNCTION;

	FUNCTION ada_entity_attributes_xml_io_record_initialize_code ( cip : ada_class ) : STRING;
		LOCAL 
			code : STRING := '';
			s : STRING;
		END_LOCAL;

		IF SIZEOF ( cip.supertypes ) > 0 THEN
			ALIAS sup FOR cip.supertypes [ LOINDEX ( cip.supertypes ) ].handled;
				code := code + ada_entity_attributes_xml_io_record_initialize_code ( sup );
			END_ALIAS;
		END_IF;

		REPEAT no := LOINDEX ( cip.explicit_attributes ) TO HIINDEX ( cip.explicit_attributes );
			ALIAS attr FOR cip.explicit_attributes [ no];
				s := explicit_attribute_xml_io_record_initialize_code ( attr );
				IF ( s > '' ) THEN
					code := code + '\n' 
					+ s;
				END_IF;
			END_ALIAS;
		END_REPEAT;
		RETURN ( code );
	END_FUNCTION;

	FUNCTION explicit_attribute_xml_io_record_initialize_code ( attr : explicit_attribute ) : STRING;
		LOCAL 
			code : STRING := '';
			domain : entity_instance := basic_ada_domain ( attr.domain );
			init : STRING := domain.init_value;
		END_LOCAL;

		IF ( NOT is_generic_object ( domain.handled ) ) THEN
			IF ( 'CHEDDAR_DOMAINS.ADA_ENUMERATION' IN TYPEOF ( domain.handled ) ) THEN
				code := '\tobj.' + attr.name + ' := ' + domain.ada_ref_ident + '''first;';
			ELSE
				IF ( EXISTS ( init ) ) THEN
					code := '\tobj.' + attr.name + ' := ' + init + ';';
				END_IF;
			END_IF;
		ELSE
			code := '\tobj.' + attr.name + ' := empty_string;';
		END_IF;
		RETURN ( code );
	END_FUNCTION;

	FUNCTION ada_entity_xml_start_element_code ( cip : ada_entity ) : STRING;
		LOCAL 
			code : STRING;
		END_LOCAL;

		IF ( 'RECORD_AND_CLASS.RECORD' IN TYPEOF ( cip ) ) THEN
			code := '\nprocedure Start_Element(\n' 
			+ '\tHandler: in out Xml_Generic_Parser;\n' 
			+ '\tobj : in out ' + cip.name + '_io;\n' 
			+ '\tNamespace_Uri : Unicode.CES.Byte_Sequence := "";\n' 
			+ '\tLocal_Name : Unicode.CES.Byte_Sequence := "";\n' 
			+ '\tQname : Unicode.CES.Byte_Sequence := "";\n' 
			+ '\tAtts : Sax.Attributes.Attributes''Class) is\n' 
			+ 'begin\n' 
			+ '\tif To_String (To_Lower (Qname)) = "' + cip.html_tag + '" then\n' 
			+ '\t\tinitialize(obj);\n' 
			+ '\tend if;\n' 
			+ 'end Start_Element;\n';
		ELSE
			code := ada_entity_attributes_xml_start_element_code ( cip );
			IF ( code > '' ) THEN
				code := '\nprocedure Start_Element(\n' 
				+ '\tHandler: in out Xml_Generic_Parser;\n' 
				+ '\tobj : in out ' + cip.name + '_io;\n' 
				+ '\tNamespace_Uri : Unicode.CES.Byte_Sequence := "";\n' 
				+ '\tLocal_Name : Unicode.CES.Byte_Sequence := "";\n' 
				+ '\tQname : Unicode.CES.Byte_Sequence := "";\n' 
				+ '\tAtts : Sax.Attributes.Attributes''Class) is \nbegin\n' 
				+ '\tif Get_Length (Atts) > 0 then' + code + '\n' 
				+ '\tend if;\n' 
				+ 'end Start_Element;\n';
			END_IF;
		END_IF;
		RETURN ( code );
	END_FUNCTION;

	FUNCTION ada_entity_attributes_xml_start_element_code ( cip : ada_class ) : STRING;
		LOCAL 
			code : STRING := '';
			s : STRING;
		END_LOCAL;

		IF SIZEOF ( cip.supertypes ) > 0 THEN
			ALIAS sup FOR cip.supertypes [ LOINDEX ( cip.supertypes ) ].handled;
				code := code + ada_entity_attributes_xml_start_element_code ( sup );
			END_ALIAS;
		END_IF;

		REPEAT no := LOINDEX ( cip.explicit_attributes ) TO HIINDEX ( cip.explicit_attributes );
			ALIAS attr FOR cip.explicit_attributes [ no];
				s := explicit_attribute_xml_start_element_code ( attr );
				IF ( s > '' ) THEN
					code := code + s;
				END_IF;
			END_ALIAS;
		END_REPEAT;
		RETURN ( code );
	END_FUNCTION;

	FUNCTION explicit_attribute_xml_end_element_code ( attr : explicit_attribute ) : STRING;
		LOCAL 
			code : STRING := '';
			domain : entity_instance := basic_ada_domain ( attr.domain );
			init : STRING := domain.init_value;
			io_domain : STRING;
		END_LOCAL;

		IF ( NOT is_generic_object ( domain.handled ) ) THEN
			IF ( 'CHEDDAR_DOMAINS.ADA_ENUMERATION' IN TYPEOF ( domain.handled ) ) OR ( EXISTS ( init ) ) THEN
				IF ( 'CHEDDAR_DOMAINS.ADA_ENUMERATION' IN TYPEOF ( domain.handled ) ) THEN
					io_domain := domain.ada_ident;
				ELSE
					IF ( init = 'empty_string' ) THEN
						io_domain := 'String';
					ELSE
						IF ( lowerize ( init ) = 'false' ) THEN
							io_domain := 'Boolean';
						ELSE
							IF ( init = '0' ) THEN
								io_domain := 'Integer';
							ELSE
								io_domain := 'Double';
							END_IF;
						END_IF;
					END_IF;
				END_IF;
				IF init = 'empty_string' THEN
					code := '\n\tif To_String (To_Lower (Qname)) = "' + lowerize ( attr.name ) + '" then\n' 
					+ '\t\tobj.' + attr.name + ' := handler.Parameter_List (1);\n' 
					+ '\tend if;';
				ELSE
					code := '\n\tif To_String (To_Lower (Qname)) = "' + lowerize ( attr.name ) + '" then\n' 
					+ '\t\tTo_' + io_domain + ' (handler.Parameter_List (1), obj.' + attr.name + ', Handler.Ok);\n' 
					+ '\t\tif not Handler.Ok then\n' 
					+ '\t\t\tPut_Line ("Warning : Error on data type From " & To_String (Handler.Locator));\n' 
					+ '\t\tend if;\n' 
					+ '\tend if;';
				END_IF;
			END_IF;
		END_IF;
		RETURN ( code );
	END_FUNCTION;

	FUNCTION explicit_attribute_xml_start_element_code ( attr : explicit_attribute ) : STRING;
		LOCAL 
			code : STRING := '';
			domain : entity_instance := basic_ada_domain ( attr.domain );
			sub_domain : entity_instance;
			element_domain : entity_instance;
		END_LOCAL;

		IF ( is_generic_object ( domain.handled ) ) THEN
			code := '\n\t\tif To_String (To_Lower (Qname)) = "' + lowerize ( attr.name ) + '" then\n' 
			+ '\t\t\tfor J in 0 .. Get_Length (Atts) - 1 loop\n' 
			+ '\t\t\t\tif To_String (To_Lower (Get_Qname (Atts, J))) = "ref" then\n' 
			+ '\t\t\t\t\tobj.' + attr.name + ' := To_Unbounded_String (Get_Value (Atts, J));\n' 
			+ '\t\t\t\tend if;\n' 
			+ '\t\t\tend loop;\n' 
			+ '\t\tend if;';
		ELSE
			(*
			IF ( 'PLATYPUS_DICTIONARY_SCHEMA.DEFINED_TYPE' IN TYPEOF ( domain.handled ) ) THEN
				sub_domain := basic_ada_domain ( domain.domain );
				IF ( 'PLATYPUS_DICTIONARY_SCHEMA.AGGREGATION_TYPE' IN TYPEOF ( sub_domain ) ) THEN
					element_domain := basic_ada_domain ( sub_domain.element_type );
					code := '\n\t\tif To_String (To_Lower (Qname)) = "' + Lowerize ( element_domain.name ) + '" then\n' 
					+ '\t\t\tfor J in 0 .. Get_Length (Atts) - 1 loop\n' 
					+ '\t\t\t\tif To_String (To_Lower (Get_Qname (Atts, J))) = "ref" then\n' 
					+ '\t\t\t\t\tobj.core := To_Unbounded_String (Get_Value (Atts, J));\n' 
					+ '\t\t\t\tend if;\n' 
					+ '\t\t\tend loop;\n' 
					+ '\t\tend if;';
				END_IF;
			END_IF;
			*)
		END_IF;
		RETURN ( code );
	END_FUNCTION;

	FUNCTION ada_entity_xml_end_element_code ( cip : ada_entity ) : STRING;
		RETURN ( '\nprocedure End_Element(\n' 
			+ '\tHandler : in out Xml_generic_parser;\n' 
			+ '\tobj : in out ' + cip.name + '_io;\n' 
			+ '\tNamespace_Uri : Unicode.CES.Byte_Sequence := "";\n' 
			+ '\tLocal_Name    : Unicode.CES.Byte_Sequence := "";\n' 
			+ '\tQname : Unicode.CES.Byte_Sequence := "") is \nbegin\n' 
			+ ada_entity_attributes_xml_end_element_code ( cip ) + '\nend End_Element;\n' );
	END_FUNCTION;

	FUNCTION ada_entity_attributes_xml_end_element_code ( cip : ada_class ) : STRING;
		LOCAL 
			code : STRING := '';
			s : STRING;
		END_LOCAL;

		IF SIZEOF ( cip.supertypes ) > 0 THEN
			ALIAS sup FOR cip.supertypes [ LOINDEX ( cip.supertypes ) ].handled;
				code := code + ada_entity_attributes_xml_end_element_code ( sup );
			END_ALIAS;
		END_IF;

		REPEAT no := LOINDEX ( cip.explicit_attributes ) TO HIINDEX ( cip.explicit_attributes );
			ALIAS attr FOR cip.explicit_attributes [ no];
				s := explicit_attribute_xml_end_element_code ( attr );
				IF ( s > '' ) THEN
					code := code + '\n' 
					+ s;
				END_IF;
			END_ALIAS;
		END_REPEAT;

		IF ( code = '' ) THEN
			code := '\tnull;\n';
		END_IF;
		RETURN ( code );
	END_FUNCTION;
END_SCHEMA;

SCHEMA package;
	USE FROM platypus_dictionary_schema;
	USE FROM express_toolsbox_functions;
	USE FROM express_dictionary_queries;
	USE FROM express2cheddar_facade;
	USE FROM record_and_class;
	USE FROM cheddar_domains;
	USE FROM ada_interface;
	USE FROM cheddar_constants;
	USE FROM xml_io;

	ENTITY ada_package 
		SUBTYPE OF ( schema_definition );
		ads_interface : LIST OF ada_interface;
		adb_interface : LIST OF ada_interface;
		xml_root_tags : LIST OF STRING;
	DERIVE
		infered_ads_interfaces : LIST OF ada_interface := ada_package_interface ( SELF, true );
		ads_head : STRING := source_licence + '\n' 
		+ ada_interfaces_code ( SELF, ada_package_interface ( SELF, true ) );
		adb_head : STRING := source_licence + '\n' 
		+ ada_interfaces_code ( SELF, ada_package_interface ( SELF, false ) );
		ads_code : STRING := ads_head + '\n\nPackage ' + name + ' is \n \n' 
		+ ada_package_ads_code ( SELF ) + '\nEnd ' + name + ';';
		adb_code : STRING := adb_head + '\n\nPackage Body ' + name + ' is \n \n' 
		+ ada_package_adb_code ( SELF ) + '\nEnd ' + name + ';';
	END_ENTITY;

	FUNCTION ada_package_adb_code ( pkg : ada_package ) : STRING;
		LOCAL 
			result : STRING;
		END_LOCAL;
		result := ada_package_concepts_list_code ( pkg, pkg.types, false ) + ada_package_concepts_list_code ( pkg, pkg.entities, false );
		RETURN ( result );
	END_FUNCTION;

	FUNCTION ada_package_ads_code ( pkg : ada_package ) : STRING;
		LOCAL 
			result : STRING;
			classes : LIST OF ada_class := QUERY ( e <* pkg.entities | 'RECORD_AND_CLASS.ADA_CLASS' IN TYPEOF ( e ) );
			const_list : LIST OF ada_constant := QUERY ( e <* pkg.constants | 'CHEDDAR_CONSTANTS.ADA_CONSTANT' IN TYPEOF ( e ) );
			private_classes : LIST OF ada_class := QUERY ( e <* classes | e.is_private );
			generic_packages : LIST OF generic_package_instanciation := QUERY ( e <* pkg.entities | 'PACKAGE.GENERIC_PACKAGE_INSTANCIATION' IN TYPEOF ( e ) );
			head_generic_packages :  LIST OF generic_package_instanciation := QUERY ( e <* generic_packages | e.before_entities = true);
			tail_generic_packages :  LIST OF generic_package_instanciation := QUERY ( e <* generic_packages | e.before_entities = false);
			constrained_arrays : LIST OF defined_type;
			entities : LIST OF dictionary_instance := pkg.entities - generic_packages;
		END_LOCAL;
		constrained_arrays := QUERY ( t <* pkg.types | 'CHEDDAR_DOMAINS.CONSTRAINED_ARRAY_TYPE' IN TYPEOF ( t ) );
		result := ada_package_concepts_list_code ( pkg, ( ( pkg.types - constrained_arrays ) + head_generic_packages + entities ) + constrained_arrays +  tail_generic_packages , true );

		REPEAT no := LOINDEX ( const_list ) TO HIINDEX ( const_list );
			result := result + const_list [ no].ads_code + '\n';
		END_REPEAT;

		IF SIZEOF ( private_classes ) > 0 THEN
			result := result + '\n\nprivate\n \n';
			REPEAT no := LOINDEX ( private_classes ) TO HIINDEX ( private_classes );
				ALIAS supref FOR private_classes [ no].supertypes [ 1 ].ref;
					result := result + '\ntype ' + private_classes [ no].name + ' is new ' + supref.ada_ident + ' with\n' 
					+ ada_class_attributes_ads_code ( private_classes [ no] );
				END_ALIAS;
			END_REPEAT;
		END_IF;
		RETURN ( result );
	END_FUNCTION;

	FUNCTION ada_package_interface ( pkg : ada_package; ads : BOOLEAN ) : LIST OF ada_interface;
		LOCAL 
			ads_list : LIST OF ada_interface :=
			 [ ada_interface ( 'Ada.Strings.Unbounded',
					 ?,
					 true,
					 true ),
				 ada_interface ( 'Framework_Config',
					 ?,
					 true,
					 true ),
				 ada_interface ( 'id_generators',
					 ?,
					 true,
					 true ) ];
			adb_list : LIST OF ada_interface :=
			 [ ada_interface ( 'Text_io',
					 ?,
					 true,
					 true ),
				 ada_interface ( 'unbounded_strings',
					 ?,
					 true,
					 true ) ];
			wul : LIST OF ada_interface;
			result : LIST OF ada_interface := [ ];
			defs : LIST OF dictionary_instance := pkg.entities + pkg.types + pkg.constants;
			pkgKey : STRING := upperize ( pkg.name );
		END_LOCAL;

		REPEAT no := LOINDEX ( pkg.interface ) TO HIINDEX ( pkg.interface );
			ALIAS curr FOR pkg.interface [ no];
				IF ( 'PACKAGE.ADA_PACKAGE' IN TYPEOF ( curr.native_schema ) ) THEN
					ads_list := ads_list + ADA_INTERFACE ( curr.native_schema.name, ?, true, true );
				END_IF;
			END_ALIAS;
		END_REPEAT;

		REPEAT no := LOINDEX ( defs ) TO HIINDEX ( defs );
			ALIAS e FOR defs [ no];
				IF ( 'CHEDDAR_DOMAINS.CHEDDAR_DEFINED_TYPE' IN TYPEOF ( e ) ) THEN
					ads_list := ads_list + e.ads_interfaces_list;
					adb_list := adb_list + e.adb_interfaces_list;
				END_IF;
				IF ( 'CHEDDAR_DOMAINS.EXPLICIT_TYPE_REFERENCE' IN TYPEOF ( e ) ) THEN
					ads_list := ads_list + e.ads_interfaces_list;
					adb_list := adb_list + e.adb_interfaces_list;
				END_IF;
				IF ( 'CHEDDAR_CONSTANTS.ADA_CONSTANT' IN TYPEOF ( e ) ) THEN
					ads_list := ads_list + e.ads_interfaces_list;
					adb_list := adb_list + e.adb_interfaces_list;
				END_IF;
				IF ( 'RECORD_AND_CLASS.ADA_ENTITY' IN TYPEOF ( e ) ) THEN
					ads_list := ads_list + e.ads_interfaces_list;
					adb_list := adb_list + e.adb_interfaces_list;
				END_IF;
				IF ( 'CHEDDAR_DOMAINS.ADA_ENUMERATION' IN TYPEOF ( e ) ) THEN
					ads_list := ads_list + e.ads_interfaces_list;
					adb_list := adb_list + e.adb_interfaces_list;
				END_IF;
				IF ( 'CHEDDAR_DOMAINS.CONSTRAINED_ARRAY_TYPE' IN TYPEOF ( e ) ) THEN
					ads_list := ads_list + e.ads_interfaces_list;
					adb_list := adb_list + e.adb_interfaces_list;
				END_IF;
				IF ( 'PACKAGE.GENERIC_PACKAGE_INSTANCIATION' IN TYPEOF ( e ) ) THEN
					ads_list := ads_list + e.ads_interfaces_list;
					adb_list := adb_list + e.adb_interfaces_list;
				END_IF;
			END_ALIAS;
		END_REPEAT;

		IF ads THEN
			wul := ads_list + pkg.ads_interface;
		ELSE
			wul := adb_list + pkg.adb_interface;
		END_IF;

		REPEAT no := LOINDEX ( wul ) TO HIINDEX ( wul );
			ALIAS curr FOR wul [ no];
				IF ( upperize ( curr.prefix ) <> pkgKey ) THEN
					result := result + curr;
				END_IF;
			END_ALIAS;
		END_REPEAT;
		RETURN ( result );
	END_FUNCTION;

	FUNCTION all_packages_code ( ads : BOOLEAN ) : STRING;
		RETURN ( all_packages_code_into ( ads, ?, ? ) );
	END_FUNCTION;

	FUNCTION concept_in_list ( c : dictionary_instance; l : LIST OF dictionary_instance ) : BOOLEAN;
		LOCAL 
			key : STRING := upperize ( c.name );
		END_LOCAL;

		REPEAT no := LOINDEX ( l ) TO HIINDEX ( l );
			IF ( upperize ( l [ no].name ) = key ) THEN
				RETURN ( true );
			END_IF;
		END_REPEAT;
		RETURN ( false );
	END_FUNCTION;

	FUNCTION concept_list_local_dependencies ( sch : schema_definition; l : LIST OF dictionary_instance ) : LIST OF dictionary_instance;
		LOCAL 
			wl : LIST OF dictionary_instance := [ ];
			r : LIST OF dictionary_instance := [ ];
		END_LOCAL;

		REPEAT no := LOINDEX ( l ) TO HIINDEX ( l );
			ALIAS c FOR l [ no];
				IF ( is_of_generated_concept_kind ( c ) ) THEN
					wl := c.dependencies;
					REPEAT noi := LOINDEX ( wl ) TO HIINDEX ( wl );
						IF ( NOT ( concept_in_list ( wl [ noi], r ) ) ) THEN
							r := r + wl [ noi];
						END_IF;
					END_REPEAT;
				END_IF;
			END_ALIAS;
		END_REPEAT;
		RETURN ( r );
	END_FUNCTION;

	FUNCTION ada_package_concepts_list_code ( p : ada_package; concepts : LIST OF dictionary_instance; ads : BOOLEAN ) : STRING;
		LOCAL 
			result : STRING := '';
			code : STRING := '';
			tmp : STRING;
		END_LOCAL;

		IF ads THEN
			REPEAT no := LOINDEX ( concepts ) TO HIINDEX ( concepts );
				ALIAS c FOR concepts [ no];
					IF ( is_of_generated_concept_kind ( c ) ) THEN
						tmp := c.ads_pre_def;
						IF ( tmp > '' ) THEN
							code := code + tmp + '\n';
						END_IF;
					END_IF;
				END_ALIAS;
			END_REPEAT;
		END_IF;

		IF ( code > '' ) THEN
			result := code + '\n\n';
		END_IF;

		REPEAT no := LOINDEX ( concepts ) TO HIINDEX ( concepts );
			ALIAS c FOR concepts [ no];
				IF ( is_of_generated_concept_kind ( c ) ) THEN
					IF ads THEN
						code := c.ads_code;
					ELSE
						code := c.adb_code;
					END_IF;
					result := result + code;
					IF ( code > '' ) THEN
						result := result + '\n';
					END_IF;
				END_IF;
			END_ALIAS;
		END_REPEAT;
		RETURN ( result );
	END_FUNCTION;

	FUNCTION ada_package_class_typeof_list ( pkg : ada_package ) : STRING;
		LOCAL 
			result : STRING := '';
			classes : LIST OF ada_class := QUERY ( e <* pkg.entities | 'RECORD_AND_CLASS.ADA_CLASS' IN TYPEOF ( e ) );
		END_LOCAL;

		REPEAT no := LOINDEX ( classes ) TO HIINDEX ( classes );
			ALIAS curr FOR classes [ no];
				result := result + curr.name + '(';
				result := result + StringAggregateConcatSeparatedBy ( TYPEOF ( curr ), ',' );
				result := result + ')\n';
			END_ALIAS;
		END_REPEAT;
		RETURN ( result );
	END_FUNCTION;

	ENTITY package_alias;
		package_name : STRING;
		attribute_name : STRING;
	DERIVE
		ptr_type : STRING := SELF.name + '_Ptr';
		ads_interfaces_list : LIST OF ada_interface := [ ];
		adb_interfaces_list : LIST OF ada_interface := [ ada_interface ( SELF.owner.name, ?, true, true ) ];
		ads_code : STRING := 'subtype ' + SELF.name + ' is ' + package_name + '.' + attribute_name + ';\n' 
		+ 'subtype ' + SELF.ptr_type + ' is  ' + package_name + '.' + attribute_name + '_Ptr;\n';
		adb_code : STRING := '';
		init_value : STRING := ?;
		dependencies : LIST OF dictionary_instance := [ SELF ];
		ada_ref_ident : STRING := SELF.ptr_type;
		refed_by_pointer : BOOLEAN := true;
		ads_pre_def : STRING := '';
	END_ENTITY;

	ENTITY generic_package_instanciation 
		SUBTYPE OF ( ada_entity );
		generic_package_name : STRING;
		parameters : LIST OF STRING;
		interfaces : LIST OF ada_interface;
		before_entities : BOOLEAN;
	DERIVE
		aliases : LIST OF cheddar_defined_type := generic_package_aliases ( SELF );
		ads_interfaces_list : LIST OF ada_interface :=
		 [ ada_interface ( SELF.generic_package_name,
				 ?,
				 true,
				 false ),
			 ada_interface ( SELF.owner.name,
				 SELF.name,
				 false,
				 true ),
			 ada_interface ( 'Unchecked_Deallocation',
				 ?,
				 true,
				 false ) ] + interfaces;
		adb_interfaces_list : LIST OF ada_interface := [ ];
		ads_code : STRING :=
		 'package ' + ada_ident + ' is new ' + generic_package_name + '(' + StringAggregateConcatSeparatedBy ( parameters,
			 ', ' ) + ');\n' 
		+ 'use ' + ada_ident + ';\n' 
		+ generic_package_instanciation_attributes_ads_code ( SELF );
		adb_code : STRING := '';
		ads_pre_def : STRING := '';
	END_ENTITY;
	

	FUNCTION generic_package_aliases ( e : generic_package_instanciation ) : LIST OF cheddar_defined_type;
		LOCAL 
			aliases : LIST OF entity_instance := [ ];
			attrname : STRING;
		END_LOCAL;

		REPEAT no := LOINDEX ( e.attributes ) TO HIINDEX ( e.attributes );
			ALIAS attr FOR e.attributes [ no];
				ALIAS an FOR attr.name;
					IF ( an [ LENGTH ( an ) ] = '_' ) THEN
						attrname := an [ 1 : LENGTH ( an ) - 1 ];
					ELSE
						attrname := an;
					END_IF;
				END_ALIAS;
				aliases := aliases + ( ada_type ( ) || attr.domain || package_alias ( e.name, attrname ) );
			END_ALIAS;
		END_REPEAT;
		RETURN ( aliases );
	END_FUNCTION;

	FUNCTION generic_package_instanciation_attributes_ads_code ( e : generic_package_instanciation ) : STRING;
		LOCAL 
			result : STRING := '';
			aliases : LIST OF cheddar_defined_type := e.aliases;
		END_LOCAL;

		REPEAT no := LOINDEX ( aliases ) TO HIINDEX ( aliases );
			ALIAS attr FOR e.aliases [ no];
				result := result + attr.ads_code;
			END_ALIAS;
		END_REPEAT;
		RETURN ( result );
	END_FUNCTION;

	FUNCTION all_packages_code_into ( ads : BOOLEAN; dir : STRING; targetName : STRING ) : STRING;
		LOCAL 
			code : STRING := '';
			body : STRING;
			pkgs : LIST OF ADA_Package := SetToList ( all_ada_packages );
			targetPath : STRING;
		END_LOCAL;

		REPEAT no := LOINDEX ( pkgs ) TO HIINDEX ( pkgs );
			IF ads THEN
				body := pkgs [ no].ads_code;
			ELSE
				body := pkgs [ no].adb_code;
			END_IF;
			IF ( body > '' ) THEN
				code := code + body + '\n\n';
			END_IF;
		END_REPEAT;

		IF ads THEN
			code := code + xml_architecture_io_ads_package_code;
		ELSE
			code := code + xml_architecture_io_adb_package_code;
		END_IF;

		IF ( EXISTS ( dir ) ) THEN
			targetPath := dir;
		ELSE
			targetPath := '.';
		END_IF;

		IF ( EXISTS ( targetName ) ) THEN
			targetPath := targetPath + '/' + targetName;
		ELSE
			targetPath := targetPath + '/' + 'Platypus2Cheddar';
		END_IF;

		IF ads THEN
			WriteFile ( targetPath + '.ads', code );
		ELSE
			WriteFile ( targetPath + '.adb', code );
		END_IF;
		RETURN ( code );
	END_FUNCTION;
END_SCHEMA;

SCHEMA discriminated_type;
	USE FROM platypus_dictionary_schema;
	USE FROM express_toolsbox_functions;
	USE FROM express_dictionary_queries;
	USE FROM express2cheddar_facade;
	USE FROM record_and_class;
	USE FROM cheddar_domains;
	USE FROM ada_interface;

	ENTITY discriminated_type 
		SUBTYPE OF ( ada_entity );
	DERIVE
		SELF\ada_entity.refed_by_pointer : BOOLEAN := false;
		discriminant : attribute :=
		 ( QUERY ( attr <* attributes |
				 'DISCRIMINATED_TYPE.DISCRIMINATED_TYPE_DISCRIMINANT' IN TYPEOF ( attr ) ) ) [ 1 ];
		union_attr : attribute := ( QUERY ( attr <* attributes | 'DISCRIMINATED_TYPE.DISCRIMINATED_TYPE_UNION' IN TYPEOF ( attr ) ) ) [ 1 ];
		ads_interfaces_list : LIST OF ada_interface := discriminated_Type_interfaces_list ( SELF, true );
		adb_interfaces_list : LIST OF ada_interface := discriminated_Type_interfaces_list ( SELF, false );
		translated_attributes : LIST OF explicit_attribute := explicit_attributes - discriminant - union_attr;
		SELF\ada_entity.ada_ident : STRING := name;
		SELF\ada_entity.ada_ref_ident : STRING := SELF.ada_ident + '_Ptr';
		SELF\ada_entity.xml_io_record_code : STRING := discriminated_type_xml_io_record_code ( SELF );
		tail_attributes : LIST OF attribute := discriminated_type_tails_attributes ( SELF );
		ads_code : STRING := discriminated_type_ads_code ( SELF );
		adb_code : STRING := discriminated_type_adb_code ( SELF );
		ads_pre_def : STRING := '';
	END_ENTITY;

	FUNCTION discriminated_type_attributes ( d : discriminated_type ) : LIST OF attribute;
		LOCAL 
			other_attrs : LIST OF attribute := [ d.discriminant] + d.translated_attributes;
			tail_attrs : LIST OF explicit_attribute := discriminated_type_tails_attributes ( d );
			attrs : LIST OF attribute := other_attrs + tail_attrs;
		END_LOCAL;
		RETURN ( attrs );
	END_FUNCTION;

	FUNCTION discriminated_type_interfaces_list ( r : discriminated_type; ads : BOOLEAN ) : LIST OF ada_interface;
		RETURN ( ada_entity_interfaces_list ( r, ads ) );
	END_FUNCTION;

	ENTITY discriminated_type_discriminant 
		SUBTYPE OF ( explicit_attribute );
	END_ENTITY;

	ENTITY discriminated_type_union 
		SUBTYPE OF ( explicit_attribute );
	END_ENTITY;

	ENTITY discriminated_type_union_element_type 
		SUBTYPE OF ( ada_entity );
	DERIVE
		ads_interfaces_list : LIST OF ada_interface := [ ];
		adb_interfaces_list : LIST OF ada_interface := [ ];
		ads_code : STRING := '';
		adb_code : STRING := '';
		union_ads_code : STRING := discriminated_type_union_element_case_code ( SELF );
		ads_pre_def : STRING := '';
	END_ENTITY;

	ENTITY discriminated_type_union_type 
		SUBTYPE OF ( ada_entity );
	DERIVE
		ads_interfaces_list : LIST OF ada_interface := discriminated_type_union_type_interfaces_list ( SELF, true );
		adb_interfaces_list : LIST OF ada_interface := discriminated_type_union_type_interfaces_list ( SELF, false );
		ads_code : STRING := '';
		adb_code : STRING := '';
		union_ads_code : STRING := discriminated_type_union_case_code ( SELF );
		all_attributes : LIST OF attribute := inherited_explicit_attributes ( SELF );
		ads_pre_def : STRING := '';
	END_ENTITY;

	FUNCTION discriminated_type_union_type_interfaces_list ( d : discriminated_type_union_type; isAds : BOOLEAN ) : LIST OF ada_interface;
		LOCAL 
			l : LIST OF ada_interface := [ ];
		END_LOCAL;

		REPEAT no := LOINDEX ( d.attributes ) TO HIINDEX ( d.attributes );
			ALIAS curr FOR d.attributes [ no];
				l := l + entity_definition_interfaces_list ( curr.domain.handled, isAds );
			END_ALIAS;
		END_REPEAT;
		RETURN ( l );
	END_FUNCTION;

	FUNCTION discriminated_type_adb_code ( typ : discriminated_type ) : STRING;
		LOCAL 
			code : STRING;
			acode : STRING;
			discrim_attr : attribute := typ.discriminant;
			union_attr : attribute := typ.union_attr;
			union_type : defined_type := union_attr.domain.handled;
			union_attributes : LIST OF attribute := inherited_explicit_attributes ( union_type );
			transl_attrs : LIST OF attribute := typ.translated_attributes;
			v : STRING := 'New_' + typ.name;
		END_LOCAL;
		code := 'procedure Initialize (obj : out ' + typ.name + '_Ptr) is\n' 
		+ 'begin\n' 
		+ '\tobj := NULL;\n' 
		+ 'end Initialize;\n \n' 
		+ 'procedure Put(obj : in ' + typ.name + '_Ptr) is\n' 
		+ 'begin\n' 
		+ '\tif (obj /= NULL) then\n';

		REPEAT no := LOINDEX ( transl_attrs ) TO HIINDEX ( transl_attrs );
			ALIAS attr FOR transl_attrs [ no];
				acode := explicit_attribute_put ( attr );
				IF ( acode > '' ) THEN
					code := code + '\t\t' + acode + '\n';
				END_IF;
			END_ALIAS;
		END_REPEAT;
		code := code + '\t\t' + explicit_attribute_put ( discrim_attr ) + '\n' 
		+ '\t\tput ( "value: " );\n' 
		+ '\t\tcase obj.' + discrim_attr.name + ' is \n';

		REPEAT no := LOINDEX ( union_attributes ) TO HIINDEX ( union_attributes );
			ALIAS union_attr FOR union_attributes [ no];
				ALIAS ada_domain FOR basic_ada_domain ( union_attr.domain ).handled;
					ALIAS element_attributes FOR inherited_explicit_attributes ( ada_domain );
						code := code + '\t\t\twhen ' + union_attr.name + ' => \n';
						REPEAT noi := LOINDEX ( element_attributes ) TO HIINDEX ( element_attributes );
							ALIAS element_attr FOR element_attributes [ noi];
								acode := explicit_attribute_put ( element_attr );
								IF ( acode > '' ) THEN
									code := code + '\t\t\t\t' + acode + '\n';
								END_IF;
							END_ALIAS;
						END_REPEAT;
					END_ALIAS;
				END_ALIAS;
			END_ALIAS;
			code := code + '\n';
		END_REPEAT;
		(*APL*)
		code := code + '\t\tend case;\n\tend if;\n\tNew_Line;\nend Put;\n\n' 

		+ 'function Copy ( obj : in ' + typ.name + ' ) return ' + typ.ptr_type + ' is\n' 
		+ '\t' + v + ' : ' + typ.ptr_type + ';\n' 
		+ 'begin\n' 
		+ '\t' + v + ' := new ' + typ.name + '''(obj);\n' 
		+ '\treturn (' + v + ');\n' 
		+ 'end Copy;\n\n' 

		+ 'function Copy ( obj : in ' + typ.ptr_type + ' ) return ' + typ.ptr_type + ' is\n' 
		+ 'begin\n' 
		+ '\treturn copy(obj.all);\n' 
		+ 'end Copy;\n\n' 

		+ 'function XML_String(obj : in ' + typ.name + ') return Unbounded_String is\n' 
		+ '\tresult : Unbounded_String;\n' 
		+ 'begin\n' 
		+ '	result := to_unbounded_string("<' + typ.html_tag + '>");\n';

		REPEAT no := LOINDEX ( transl_attrs ) TO HIINDEX ( transl_attrs );
			ALIAS attr FOR transl_attrs [ no];
				acode := explicit_attribute_xml_writer_code ( 'obj', attr );
				IF ( acode > '' ) THEN
					code := code + '\t\t' + acode + '\n';
				END_IF;
			END_ALIAS;
		END_REPEAT;
		code := code + explicit_attribute_xml_writer_code ( 'obj', discrim_attr ) + '\n\n' 

		+ '\tcase obj.' + discrim_attr.name + ' is \n';

		REPEAT no := LOINDEX ( union_attributes ) TO HIINDEX ( union_attributes );
			ALIAS union_attr FOR union_attributes [ no];
				ALIAS ada_domain FOR basic_ada_domain ( union_attr.domain ).handled;
					ALIAS element_attributes FOR inherited_explicit_attributes ( ada_domain );
						code := code + '\t\twhen ' + union_attr.name + ' => \n';
						REPEAT noi := LOINDEX ( element_attributes ) TO HIINDEX ( element_attributes );
							ALIAS element_attr FOR element_attributes [ noi];
								acode := explicit_attribute_xml_writer_code ( 'obj', element_attr );
								IF ( acode > '' ) THEN
									code := code + '\t\t' + acode + '\n';
								END_IF;
							END_ALIAS;
						END_REPEAT;
					END_ALIAS;
				END_ALIAS;
			END_ALIAS;
			code := code + '\n';
		END_REPEAT;
		(*APL*)
		code := code + '\tend case;\n' 
		+ '\tresult := result & to_unbounded_string("</' + typ.html_tag + '>");\n' 
		+ '\treturn (result);\n' 
		+ 'end XML_String;\n\n' 

		+ 'function XML_String(obj : in ' + typ.name + '_Ptr) return Unbounded_String is\n' 
		+ 'begin\n' 
		+ '	return XML_String(obj.all);\n' 
		+ 'end XML_String;\n\n' 

		+ 'function XML_Ref_String(obj : in ' + typ.name + ') return Unbounded_String is\n' 
		+ '\tresult : Unbounded_String;\n' 
		+ 'begin\n' 
		+ '	raise xml_ref_string_error;\n' 
		+ '	return to_unbounded_string("");\n' 
		+ 'end XML_Ref_String;\n' 
		+ 'function XML_Ref_String(obj : in ' + typ.name + '_Ptr) return Unbounded_String is\n' 
		+ 'begin\n' 
		+ '	return XML_Ref_String(obj.all);\n' 
		+ 'end XML_Ref_String;\n\n';
		RETURN ( code );
	END_FUNCTION;

	FUNCTION discriminated_type_ads_code ( typ : discriminated_type ) : STRING;
		LOCAL 
			result : STRING;
			discrim_attr : attribute := typ.discriminant;
			discrim_type : entity_instance := discrim_attr.domain.handled;
			union_attr : attribute := typ.union_attr;
			union_type : defined_type := union_attr.domain.handled;
			union_selections : LIST OF attribute := inherited_explicit_attributes ( union_type );
			domain : entity_instance;
			transl_attrs : LIST OF attribute := typ.translated_attributes;
		END_LOCAL;
		result := 'type ' + typ.name + ' (' + discrim_attr.name + ' : ' + discrim_type.name + ' ) is record\n';

		REPEAT no := LOINDEX ( transl_attrs ) TO HIINDEX ( transl_attrs );
			ALIAS attr FOR transl_attrs [ no];
				domain := basic_ada_domain ( attr.domain );
				IF ( 'RECORD_AND_CLASS.ADA_CLASS' IN TYPEOF ( domain.handled ) ) THEN
					result := result + '\t' + attr.name + ' : ' + domain.handled.ptr_type + ';\n';
				ELSE
					result := result + '\t' + attr.name + ' : ' + domain.ada_ref_ident + ';\n';
				END_IF;
			END_ALIAS;
		END_REPEAT;
		result := result + '\tcase ' + discrim_attr.name + ' is \n' 
		+ union_type.union_ads_code + '\tend case;\nend record;\n\n' 

		+ 'type ' + typ.ptr_type + ' is access all ' + typ.name + ';\n' 
		+ '\nprocedure Initialize(obj : out ' + typ.ptr_type + ');\n' 
		+ '\nprocedure Put(obj : in ' + typ.ptr_type + ');\n' 
		+ 'function Copy(obj : in ' + typ.ptr_type + ') return ' + typ.ptr_type + ';\n' 
		+ 'function Copy(obj : in ' + typ.name + ') return ' + typ.ptr_type + ';\n' 
		+ 'function XML_String(obj : in ' + typ.name + ') return Unbounded_String;\n' 
		+ '\nfunction XML_String(obj : in ' + typ.ptr_type + ') return Unbounded_String;\n' 
		+ 'procedure Free  is new Unchecked_Deallocation (' + typ.name + ', ' + typ.ptr_type + ');\n' 
		+ 'function XML_Ref_String(obj : in ' + typ.name + ') return Unbounded_String;\n' 
		+ '\nfunction XML_Ref_String(obj : in ' + typ.ptr_type + ') return Unbounded_String;\n';
		RETURN ( result );
	END_FUNCTION;

	FUNCTION discriminated_type_union_case_code ( u : discriminated_type_union_type ) : STRING;
		LOCAL 
			code : STRING := '';
			all_attributes : LIST OF attribute := inherited_explicit_attributes ( u );
		END_LOCAL;

		REPEAT no := LOINDEX ( all_attributes ) TO HIINDEX ( all_attributes );
			ALIAS attr FOR all_attributes [ no];
				ALIAS ada_domain FOR basic_ada_domain ( attr.domain ).handled;
					code := code + '\t\twhen ' + attr.name + ' => \n ' + ada_domain.union_ads_code;
				END_ALIAS;
			END_ALIAS;
			code := code + '\n';
		END_REPEAT;
		RETURN ( code );
	END_FUNCTION;

	FUNCTION discriminated_type_union_element_case_code ( u : discriminated_type_union_element_type ) : STRING;
		LOCAL 
			code : STRING := '';
			all_attributes : LIST OF attribute := inherited_explicit_attributes ( u );
			domain : entity_instance;
		END_LOCAL;

		REPEAT no := LOINDEX ( all_attributes ) TO HIINDEX ( all_attributes );
			ALIAS attr FOR all_attributes [ no];
				domain := basic_ada_domain ( attr.domain );
				IF ( 'RECORD_AND_CLASS.ADA_CLASS' IN TYPEOF ( domain.handled ) ) THEN
					code := code + '\t\t\t' + attr.name + ' : ' + domain.handled.ptr_type + ';\n';
				ELSE
					code := code + '\t\t\t' + attr.name + ' : ' + domain.ada_ref_ident + ';\n';
				END_IF;
			END_ALIAS;
		END_REPEAT;
		RETURN ( code );
	END_FUNCTION;

	FUNCTION discriminated_type_xml_io_record_code ( typ : discriminated_type ) : STRING;
		LOCAL 
			code : STRING := '';
			discrim_attr : attribute := typ.discriminant;
			discrim_type : entity_instance := discrim_attr.domain.handled;
			union_attr : attribute := typ.union_attr;
			union_type : defined_type := union_attr.domain.handled;
			union_attributes : LIST OF attribute := inherited_explicit_attributes ( union_type );
			tails_attrs : LIST OF attribute := typ.tail_attributes;
			transl_attrs : LIST OF attribute := typ.translated_attributes;
		END_LOCAL;
		code := '\ntype ' + typ.name + '_io is record' + '\n\t' + discrim_attr.name + ' : ' + discrim_type.name + ';';

		REPEAT no := LOINDEX ( transl_attrs ) TO HIINDEX ( transl_attrs );
			ALIAS attr FOR transl_attrs [ no];
				code := code + explicit_attribute_xml_io_record_code ( attr );
			END_ALIAS;
		END_REPEAT;

		REPEAT no := LOINDEX ( tails_attrs ) TO HIINDEX ( tails_attrs );
			ALIAS attr FOR tails_attrs [ no];
				code := code + explicit_attribute_xml_io_record_code ( attr );
			END_ALIAS;
		END_REPEAT;
		code := code + '\nend record;\n';
		RETURN ( code );
	END_FUNCTION;

	FUNCTION discriminated_type_tails_attributes ( typ : discriminated_type ) : LIST OF attribute;
		LOCAL 
			union_attr : attribute := typ.union_attr;
			union_type : defined_type := union_attr.domain.handled;
			union_attributes : LIST OF attribute := inherited_explicit_attributes ( union_type );
			found : LIST OF attribute := [ ];
		END_LOCAL;

		REPEAT no := LOINDEX ( union_attributes ) TO HIINDEX ( union_attributes );
			ALIAS curr FOR union_attributes [ no];
				ALIAS handled FOR curr.domain.handled;
					found := found + inherited_explicit_attributes ( handled );
				END_ALIAS;
			END_ALIAS;
		END_REPEAT;
		RETURN ( found );
	END_FUNCTION;

	FUNCTION discriminated_type_xml_end_element_code ( typ : discriminated_type ) : STRING;
		RETURN ( '\nprocedure End_Element(\n' 
			+ '\tHandler : in out Xml_generic_parser;\n' 
			+ '\tobj : in out ' + typ.name + '_io;\n' 
			+ '\tNamespace_Uri : Unicode.CES.Byte_Sequence := "";\n' 
			+ '\tLocal_Name    : Unicode.CES.Byte_Sequence := "";\n' 
			+ '\tQname : Unicode.CES.Byte_Sequence := "") is \nbegin\n' 
			+ discriminated_type_attributes_xml_end_element_code ( typ ) + '\nend End_Element;\n' );
	END_FUNCTION;

	FUNCTION discriminated_type_xml_start_element_code ( typ : discriminated_type ) : STRING;
		LOCAL 
			code : STRING := discriminated_type_attributes_xml_start_element_code ( typ );
		END_LOCAL;

		IF ( code > '' ) THEN
			code := '\nprocedure Start_Element(\n' 
			+ '\tHandler: in out Xml_Generic_Parser;\n' 
			+ '\tobj : in out ' + typ.name + '_io;\n' 
			+ '\tNamespace_Uri : Unicode.CES.Byte_Sequence := "";\n' 
			+ '\tLocal_Name : Unicode.CES.Byte_Sequence := "";\n' 
			+ '\tQname : Unicode.CES.Byte_Sequence := "";\n' 
			+ '\tAtts : Sax.Attributes.Attributes''Class) is \nbegin\n' 
			+ '\tif Get_Length (Atts) > 0 then' + code + '\n' 
			+ '\tend if;\n' 
			+ 'end Start_Element;\n';
		END_IF;
		RETURN ( code );
	END_FUNCTION;

	FUNCTION discriminated_type_attributes_xml_end_element_code ( typ : discriminated_type ) : STRING;
		LOCAL 
			code : STRING := '';
			s : STRING;
			discrim_attr : attribute := typ.discriminant;
			attrs : LIST OF Attribute := typ.tail_attributes + typ.translated_attributes;
		END_LOCAL;
		code := code + explicit_attribute_xml_end_element_code ( discrim_attr ) + '\n';

		REPEAT no := LOINDEX ( attrs ) TO HIINDEX ( attrs );
			ALIAS attr FOR attrs [ no];
				s := explicit_attribute_xml_end_element_code ( attr );
				IF ( s > '' ) THEN
					code := code + '\n' 
					+ s;
				END_IF;
			END_ALIAS;
		END_REPEAT;

		IF ( code = '' ) THEN
			code := '\tnull;\n';
		END_IF;
		RETURN ( code );
	END_FUNCTION;

	FUNCTION discriminated_type_attributes_xml_start_element_code ( typ : discriminated_type ) : STRING;
		LOCAL 
			code : STRING := '';
			s : STRING;
			discrim_attr : attribute := typ.discriminant;
			attrs : LIST OF Attribute := typ.tail_attributes + typ.translated_attributes;
		END_LOCAL;
		code := explicit_attribute_xml_start_element_code ( discrim_attr );

		REPEAT no := LOINDEX ( attrs ) TO HIINDEX ( attrs );
			ALIAS attr FOR attrs [ no];
				s := explicit_attribute_xml_start_element_code ( attr );
				IF ( s > '' ) THEN
					code := code + '\n' 
					+ s;
				END_IF;
			END_ALIAS;
		END_REPEAT;
		RETURN ( code );
	END_FUNCTION;

	FUNCTION discriminated_type_attributes_xml_io_record_initialize_code ( typ : discriminated_type ) : STRING;
		LOCAL 
			code : STRING := '';
			s : STRING;
			discrim_attr : attribute := typ.discriminant;
			attrs : LIST OF Attribute := typ.tail_attributes + typ.translated_attributes;
		END_LOCAL;
		code := code + explicit_attribute_xml_io_record_initialize_code ( discrim_attr ) + '\n';

		REPEAT no := LOINDEX ( attrs ) TO HIINDEX ( attrs );
			ALIAS attr FOR attrs [ no];
				s := explicit_attribute_xml_io_record_initialize_code ( attr );
				IF ( s > '' ) THEN
					code := code + '\n' 
					+ s;
				END_IF;
			END_ALIAS;
		END_REPEAT;
		RETURN ( code );
	END_FUNCTION;

	FUNCTION discriminated_type_xml_io_record_initialize_code ( typ : discriminated_type ) : STRING;
		RETURN ( '\nprocedure Initialize(obj : out ' +
			 typ.name +
			 '_io) is \nbegin ' +
			 discriminated_type_attributes_xml_io_record_initialize_code ( typ ) +
			 '\nend Initialize;\n' );
	END_FUNCTION;
END_SCHEMA;