Fix error in generating supplier index;

OPT flattening was causing recursive building of the list when it should only include
C_ARCHETYPE_ROOT objects defined in the source archetype.

components/adl_compiler/src/comparator/template_flattener.e

@@ -44,77 +44,82 @@ feature {NONE} -- Implementation
 		require
 			a_flat_arch.is_flat
 		local
-			supp_flat_arch, matched_arch: ARCHETYPE
-			supp_arch_root_cco: C_COMPLEX_OBJECT
-			supp_arch_id: STRING
-			bindings: HASH_TABLE [URI, STRING]
+			supp_expanded_arch, matched_arch: ARCHETYPE
+			supp_expanded_arch_root_cco: C_COMPLEX_OBJECT
+			supp_expanded_arch_id: STRING
+			bindings_for_terminology: HASH_TABLE [URI, STRING]
 			found: BOOLEAN
 		do
 debug ("overlay")
 	io.put_string ("&&&&&& flattening template root nodes &&&&&&%N")
 end
 			fillers_on_current_path.extend (a_flat_arch.archetype_id.physical_id)
 
+			-- iterate across a HASH_TABLE [ARRAYED_LIST [C_ARCHETYPE_ROOT], STRING] structure
+			-- where the keys are archetype refs (usually archetype id to major version)
 			across a_flat_arch.suppliers_index as xrefs_csr loop
 				-- get the definition structure of the flat archetype corresponding to the archetype id in the suppliers list
 				check attached current_library.archetype_matching_ref (xrefs_csr.key) as att_ala then
 					matched_arch := att_ala.flat_archetype_processed (include_rm)
 				end
 
-				-- make a copy of the supplier archetype (or template)
-				create supp_flat_arch.make_from_other (matched_arch)
-				supp_arch_id := supp_flat_arch.archetype_id.physical_id
-				supp_arch_root_cco := supp_flat_arch.definition
+				-- make a copy of the supplier archetype (or template), to be fully expanded
+				create supp_expanded_arch.make_from_other (matched_arch)
+				supp_expanded_arch_id := supp_expanded_arch.archetype_id.physical_id
+				supp_expanded_arch_root_cco := supp_expanded_arch.definition
 
 				-- add the terminology of this archetype to the OPT component_terminologies
-				if not opt.has_component_terminology (supp_arch_id) then
-					opt.add_component_terminology (supp_flat_arch.terminology, supp_arch_id)
+				if not opt.has_component_terminology (supp_expanded_arch_id) then
+					opt.add_component_terminology (supp_expanded_arch.terminology, supp_expanded_arch_id)
 				end
 
 				-- get list of C_ARCHETYPE_ROOT nodes in this archetype or template corresponding to the supplier
-				-- archetype id xrefs_csr.key into each one of these C_ARCHETYPE_ROOT nodes, clone the
-				-- flat definition structure from the supplier archetype
+				-- archetype id xrefs_csr.key;
+				-- into each one of these C_ARCHETYPE_ROOT nodes, clone the flat definition structure from the supplier
+				-- archetype (iterating on ARRAYED_LIST [C_ARCHETYPE_ROOT] all for same archetype)
 				across xrefs_csr.item as c_arch_roots_csr loop
 
-					-- first, copy any bindings to the root point of the used archetype/overlay into the bindings of the owning template, under the
-					-- id-code of the use_archetype reference
-					across supp_flat_arch.terminology.term_bindings as bindings_for_terminology_csr loop
-						bindings := bindings_for_terminology_csr.item
+					-- first, copy any bindings to the root id node of the used archetype/overlay into the bindings of the owning template,
+					-- under the id-code of the use_archetype reference
+					across supp_expanded_arch.terminology.term_bindings as bindings_for_terminology_csr loop
+						bindings_for_terminology := bindings_for_terminology_csr.item
 
 						-- see if there is a binding for the supplier archetype concept id (some id1....1 code) or any parent of that
 						found := False
-						from bindings.start until bindings.off or found loop
-							if supp_flat_arch.concept_id.starts_with (bindings.key_for_iteration) then
+						from bindings_for_terminology.start until bindings_for_terminology.off or found loop
+							if is_valid_root_id_code(bindings_for_terminology.key_for_iteration) and
+								supp_expanded_arch.specialisation_depth >= specialisation_depth_from_code(bindings_for_terminology.key_for_iteration)
+							then
 								found := True
-								if attached bindings.item_for_iteration as uri and
+								if attached bindings_for_terminology.item_for_iteration as uri and
 									not a_flat_arch.terminology.has_term_binding (bindings_for_terminology_csr.key, c_arch_roots_csr.item.node_id)
 								then
 									a_flat_arch.terminology.put_term_binding (uri, bindings_for_terminology_csr.key, c_arch_roots_csr.item.node_id)
 								end
 							end
-							bindings.forth
+							bindings_for_terminology.forth
 						end
 					end
 
 					-- always convert, to ensure archetype id replaces archetype ref in C_ARCHETYPE_ROOT
 					-- even if no overlaying takes place
-					c_arch_roots_csr.item.convert_to_flat (supp_flat_arch.archetype_id)
+					c_arch_roots_csr.item.convert_to_flat (supp_expanded_arch.archetype_id)
 
 					-- Now we decide if we are going to overlay the referenced supplier archetype...
 					-- limit depth in case of recursive inclusion and don't repeat descent into same archetype
 					-- on any given descent path (we could be more sophisticated and allow N uses of same
 					-- archetype on same path, if it were needed)
-					if depth <= Max_template_overlay_depth and not fillers_on_current_path.has (supp_arch_id) then
+					if depth <= Max_template_overlay_depth and not fillers_on_current_path.has (supp_expanded_arch_id) then
 
 						-- it is empty and needs to be replaced with the supplier structure
 						if not c_arch_roots_csr.item.has_attributes and not c_arch_roots_csr.item.is_prohibited then
 							-- perform overlays on supplier archetype first
-							overlay_filler_definitions (supp_flat_arch, include_rm, depth + 1)
+							overlay_filler_definitions (supp_expanded_arch, include_rm, depth + 1)
 debug ("overlay")
 	io.put_string ("%T node at " + c_arch_roots_csr.item.path +
 	" with " + xrefs_csr.key + "%N")
 end
-							across supp_arch_root_cco.attributes as attrs_csr loop
+							across supp_expanded_arch_root_cco.attributes as attrs_csr loop
 								c_arch_roots_csr.item.put_attribute (attrs_csr.item)
 debug ("overlay")
 	io.put_string ("%T%T cloning attribute " +

libraries/openehr/src/am/archetype/archetype.e

@@ -840,13 +840,14 @@ feature -- Validation
 
 	suppliers_index: HASH_TABLE [ARRAYED_LIST [C_ARCHETYPE_ROOT], STRING]
 			-- table of {list<C_ARCHETYPE_ROOT>, archetype_ref}
-			-- i.e. table of <list of use_archetype nodes>, each keyed by archetype ref
+			-- i.e. table of <list of use_archetype nodes>, keyed by archetype ref
 		local
 			def_it: C_ITERATOR
 		do
 			create Result.make (0)
 			create def_it.make (definition)
-			def_it.do_all_on_entry (
+--			do_all_on_entry (
+			def_it.do_at_surface (
 				agent (a_c_node: ARCHETYPE_CONSTRAINT; depth: INTEGER; idx: HASH_TABLE [ARRAYED_LIST [C_ARCHETYPE_ROOT], STRING])
 					local
 						al_car: ARRAYED_LIST [C_ARCHETYPE_ROOT]
@@ -860,7 +861,13 @@ feature -- Validation
 							end
 							al_car.extend (car)
 						end
-					end (?, ?, Result))
+					end (?, ?, Result),
+
+				agent (a_c_node: ARCHETYPE_CONSTRAINT): BOOLEAN
+					do
+						Result := attached {C_ARCHETYPE_ROOT} a_c_node
+					end
+			)
 		end
 
 	rules_index: HASH_TABLE [ARRAYED_LIST [EXPR_ARCHETYPE_REF], STRING]

libraries/openehr/src/am/archetype/terminology/archetype_terminology.e

@@ -641,22 +641,22 @@ feature -- Modification
 			last_new_definition_code := new_term.code
 		end
 
-	put_term_binding (a_binding: URI; a_terminology_id, a_key: STRING)
+	put_term_binding (a_binding: URI; a_terminology_id, a_binding_key: STRING)
 			-- add a new term binding to local code a_code, in the terminology
 			-- group corresponding to the a_term_code.terminology
 		require
-			Key_valid: is_valid_code (a_key) implies has_code (a_key)
-			Not_already_added: not has_term_binding (a_terminology_id, a_key)
+			Key_valid: is_valid_code (a_binding_key) implies has_code (a_binding_key)
+			Not_already_added: not has_term_binding (a_terminology_id, a_binding_key)
 		do
 			if not has_term_bindings (a_terminology_id) then
 				term_bindings.put (create {HASH_TABLE [URI, STRING]}.make(0), a_terminology_id)
 			end
 			if attached term_bindings.item (a_terminology_id) as bindings then
-				bindings.put (a_binding, a_key)
+				bindings.put (a_binding, a_binding_key)
 			end
 			term_binding_map_cache := Void
 		ensure
-			Binding_added: has_term_binding (a_terminology_id, a_key)
+			Binding_added: has_term_binding (a_terminology_id, a_binding_key)
 		end
 
 	replace_term_definition_item (a_language: STRING; a_code, a_key, a_value: STRING)
@@ -672,16 +672,16 @@ feature -- Modification
 			end
 		end
 
-	replace_term_binding (a_binding: URI; a_terminology_id, a_key: STRING)
+	replace_term_binding (a_binding: URI; a_terminology_id, a_binding_key: STRING)
 			-- replaces existing a term binding to local code a_code, in group a_terminology
 		require
-			Key_valid: is_valid_code (a_key) implies has_code (a_key)
-			Already_added: has_term_binding (a_terminology_id, a_key)
+			Key_valid: is_valid_code (a_binding_key) implies has_code (a_binding_key)
+			Already_added: has_term_binding (a_terminology_id, a_binding_key)
 		do
-			term_bindings_for_terminology (a_terminology_id).replace (a_binding, a_key)
+			term_bindings_for_terminology (a_terminology_id).replace (a_binding, a_binding_key)
 			term_binding_map_cache := Void
 		ensure
-			Binding_added: has_term_binding (a_terminology_id, a_key)
+			Binding_added: has_term_binding (a_terminology_id, a_binding_key)
 		end
 
 	replicate_term_definition (an_old_code, a_new_code: STRING)