From c044d5fd86909037758a2b7a90416f35f4164282 Mon Sep 17 00:00:00 2001 From: "Achim D. Brucker" Date: Mon, 11 May 2020 12:26:48 +0100 Subject: [PATCH] Use symlinks for shared files. --- Core_DOM/Core_SC_DOM/common/Core_DOM.thy | 40 +- .../common/Core_DOM_Basic_Datatypes.thy | 67 +- .../Core_SC_DOM/common/Core_DOM_Functions.thy | 3726 +---------------- .../Core_SC_DOM/common/Core_DOM_Tests.thy | 41 +- .../Core_SC_DOM/common/classes/BaseClass.thy | 75 +- .../common/classes/CharacterDataClass.thy | 351 +- .../common/classes/DocumentClass.thy | 341 +- .../Core_SC_DOM/common/classes/NodeClass.thy | 205 +- .../common/classes/ObjectClass.thy | 218 +- .../Core_SC_DOM/common/monads/BaseMonad.thy | 377 +- .../common/monads/CharacterDataMonad.thy | 532 +-- .../common/monads/DocumentMonad.thy | 604 +-- .../common/monads/ElementMonad.thy | 446 +- .../Core_SC_DOM/common/monads/NodeMonad.thy | 219 +- .../Core_SC_DOM/common/monads/ObjectMonad.thy | 259 +- .../common/pointers/CharacterDataPointer.thy | 200 +- .../common/pointers/DocumentPointer.thy | 155 +- .../common/pointers/ElementPointer.thy | 179 +- .../common/pointers/NodePointer.thy | 112 +- .../common/pointers/ObjectPointer.thy | 52 +- Core_DOM/Core_SC_DOM/common/pointers/Ref.thy | 63 +- .../common/preliminaries/Heap_Error_Monad.thy | 931 +--- .../preliminaries/Hiding_Type_Variables.thy | 585 +-- .../common/preliminaries/Testing_Utils.thy | 93 +- .../common/tests/Core_DOM_BaseTest.thy | 274 +- .../common/tests/Document-adoptNode.html | 37 +- .../common/tests/Document-adoptNode.html.orig | 51 +- .../common/tests/Document-getElementById.html | 252 +- .../tests/Document-getElementById.html.orig | 351 +- .../common/tests/Document_adoptNode.thy | 114 +- .../common/tests/Document_getElementById.thy | 278 +- .../common/tests/Node-insertBefore.html | 289 +- .../common/tests/Node-insertBefore.html.orig | 307 +- .../common/tests/Node-removeChild.html | 67 +- .../common/tests/Node-removeChild.html.orig | 55 +- .../common/tests/Node_insertBefore.thy | 129 +- .../common/tests/Node_removeChild.thy | 160 +- 37 files changed, 37 insertions(+), 12198 deletions(-) mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/Core_DOM.thy mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/Core_DOM_Basic_Datatypes.thy mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/Core_DOM_Functions.thy mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/Core_DOM_Tests.thy mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/classes/BaseClass.thy mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/classes/CharacterDataClass.thy mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/classes/DocumentClass.thy mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/classes/NodeClass.thy mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/classes/ObjectClass.thy mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/monads/BaseMonad.thy mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/monads/CharacterDataMonad.thy mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/monads/DocumentMonad.thy mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/monads/ElementMonad.thy mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/monads/NodeMonad.thy mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/monads/ObjectMonad.thy mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/pointers/CharacterDataPointer.thy mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/pointers/DocumentPointer.thy mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/pointers/ElementPointer.thy mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/pointers/NodePointer.thy mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/pointers/ObjectPointer.thy mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/pointers/Ref.thy mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/preliminaries/Heap_Error_Monad.thy mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/preliminaries/Hiding_Type_Variables.thy mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/preliminaries/Testing_Utils.thy mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/tests/Core_DOM_BaseTest.thy mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/tests/Document-adoptNode.html mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/tests/Document-adoptNode.html.orig mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/tests/Document-getElementById.html mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/tests/Document-getElementById.html.orig mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/tests/Document_adoptNode.thy mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/tests/Document_getElementById.thy mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/tests/Node-insertBefore.html mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/tests/Node-insertBefore.html.orig mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/tests/Node-removeChild.html mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/tests/Node-removeChild.html.orig mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/tests/Node_insertBefore.thy mode change 100644 => 120000 Core_DOM/Core_SC_DOM/common/tests/Node_removeChild.thy diff --git a/Core_DOM/Core_SC_DOM/common/Core_DOM.thy b/Core_DOM/Core_SC_DOM/common/Core_DOM.thy deleted file mode 100644 index 6b48724..0000000 --- a/Core_DOM/Core_SC_DOM/common/Core_DOM.thy +++ /dev/null @@ -1,39 +0,0 @@ -(*********************************************************************************** - * Copyright (c) 2016-2018 The University of Sheffield, UK - * - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * * Redistributions of source code must retain the above copyright notice, this - * list of conditions and the following disclaimer. - * - * * Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - * SPDX-License-Identifier: BSD-2-Clause - ***********************************************************************************) - -section\The Core DOM\ -text\This theory is the main entry point of our formalization of the core DOM.\ - -theory Core_DOM -imports - "Core_DOM_Heap_WF" -begin - - -end diff --git a/Core_DOM/Core_SC_DOM/common/Core_DOM.thy b/Core_DOM/Core_SC_DOM/common/Core_DOM.thy new file mode 120000 index 0000000..0a29882 --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/Core_DOM.thy @@ -0,0 +1 @@ +../../Core_DOM/common/Core_DOM.thy \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/Core_DOM_Basic_Datatypes.thy b/Core_DOM/Core_SC_DOM/common/Core_DOM_Basic_Datatypes.thy deleted file mode 100644 index fa409d9..0000000 --- a/Core_DOM/Core_SC_DOM/common/Core_DOM_Basic_Datatypes.thy +++ /dev/null @@ -1,66 +0,0 @@ -(*********************************************************************************** - * Copyright (c) 2016-2018 The University of Sheffield, UK - * - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * * Redistributions of source code must retain the above copyright notice, this - * list of conditions and the following disclaimer. - * - * * Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - * SPDX-License-Identifier: BSD-2-Clause - *******************************************************************************\***) - -section\Basic Data Types\ -text\ - \label{sec:Core_DOM_Basic_Datatypes} - This theory formalizes the primitive data types used by the DOM standard~\cite{dom-specification}. -\ -theory Core_DOM_Basic_Datatypes - imports - Main -begin - -type_synonym USVString = string -text\ - In the official standard, the type @{type "USVString"} corresponds to the set of all possible - sequences of Unicode scalar values. As we are not interested in analyzing the specifics of Unicode - strings, we just model @{type "USVString"} using the standard type @{type "string"} of Isabelle/HOL. -\ - -type_synonym DOMString = string -text\ - In the official standard, the type @{type "DOMString"} corresponds to the set of all possible - sequences of code units, commonly interpreted as UTF-16 encoded strings. Again, as we are not - interested in analyzing the specifics of Unicode strings, we just model @{type "DOMString"} using - the standard type @{type "string"} of Isabelle/HOL. -\ - -type_synonym doctype = DOMString - -paragraph\Examples\ -definition html :: doctype - where "html = ''''" - -hide_const id - -text \This dummy locale is used to create scoped definitions by using global interpretations - and defines.\ -locale l_dummy -end diff --git a/Core_DOM/Core_SC_DOM/common/Core_DOM_Basic_Datatypes.thy b/Core_DOM/Core_SC_DOM/common/Core_DOM_Basic_Datatypes.thy new file mode 120000 index 0000000..5cd0262 --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/Core_DOM_Basic_Datatypes.thy @@ -0,0 +1 @@ +../../Core_DOM/common/Core_DOM_Basic_Datatypes.thy \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/Core_DOM_Functions.thy b/Core_DOM/Core_SC_DOM/common/Core_DOM_Functions.thy deleted file mode 100644 index deae67a..0000000 --- a/Core_DOM/Core_SC_DOM/common/Core_DOM_Functions.thy +++ /dev/null @@ -1,3725 +0,0 @@ -(*********************************************************************************** - * Copyright (c) 2016-2018 The University of Sheffield, UK - * - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * * Redistributions of source code must retain the above copyright notice, this - * list of conditions and the following disclaimer. - * - * * Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - * SPDX-License-Identifier: BSD-2-Clause - ***********************************************************************************) - -section\Querying and Modifying the DOM\ -text\In this theory, we are formalizing the functions for querying and modifying -the DOM.\ - -theory Core_DOM_Functions -imports - "monads/DocumentMonad" -begin - -text \If we do not declare show\_variants, then all abbreviations that contain - constants that are overloaded by using adhoc\_overloading get immediately unfolded.\ -declare [[show_variants]] - -subsection \Various Functions\ - -lemma insort_split: "x \ set (insort y xs) \ (x = y \ x \ set xs)" - apply(induct xs) - by(auto) - -lemma concat_map_distinct: - "distinct (concat (map f xs)) \ y \ set (concat (map f xs)) \ \!x \ set xs. y \ set (f x)" - apply(induct xs) - by(auto) - -lemma concat_map_all_distinct: "distinct (concat (map f xs)) \ x \ set xs \ distinct (f x)" - apply(induct xs) - by(auto) - -lemma distinct_concat_map_I: - assumes "distinct xs" - and "\x. x \ set xs \ distinct (f x)" -and "\x y. x \ set xs \ y \ set xs \ x \ y \ (set (f x)) \ (set (f y)) = {}" -shows "distinct (concat ((map f xs)))" - using assms - apply(induct xs) - by(auto) - -lemma distinct_concat_map_E: - assumes "distinct (concat ((map f xs)))" - shows "\x y. x \ set xs \ y \ set xs \ x \ y \ (set (f x)) \ (set (f y)) = {}" - and "\x. x \ set xs \ distinct (f x)" - using assms - apply(induct xs) - by(auto) - -lemma bind_is_OK_E3 [elim]: - assumes "h \ ok (f \ g)" and "pure f h" - obtains x where "h \ f \\<^sub>r x" and "h \ ok (g x)" - using assms - by(auto simp add: bind_def returns_result_def returns_heap_def is_OK_def execute_def pure_def - split: sum.splits) - - -subsection \Basic Functions\ - -subsubsection \get\_child\_nodes\ - -locale l_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs -begin - -definition get_child_nodes\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) element_ptr \ unit \ (_, (_) node_ptr list) dom_prog" - where - "get_child_nodes\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r element_ptr _ = get_M element_ptr RElement.child_nodes" - -definition get_child_nodes\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) character_data_ptr \ unit \ (_, (_) node_ptr list) dom_prog" - where - "get_child_nodes\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r _ _ = return []" - -definition get_child_nodes\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) document_ptr \ unit \ (_, (_) node_ptr list) dom_prog" - where - "get_child_nodes\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr _ = do { - doc_elem \ get_M document_ptr document_element; - (case doc_elem of - Some element_ptr \ return [cast element_ptr] - | None \ return []) - }" - -definition a_get_child_nodes_tups :: "(((_) object_ptr \ bool) \ ((_) object_ptr \ unit - \ (_, (_) node_ptr list) dom_prog)) list" - where - "a_get_child_nodes_tups = [ - (is_element_ptr, get_child_nodes\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r \ the \ cast), - (is_character_data_ptr, get_child_nodes\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r \ the \ cast), - (is_document_ptr, get_child_nodes\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r \ the \ cast) - ]" - -definition a_get_child_nodes :: "(_) object_ptr \ (_, (_) node_ptr list) dom_prog" - where - "a_get_child_nodes ptr = invoke a_get_child_nodes_tups ptr ()" - -definition a_get_child_nodes_locs :: "(_) object_ptr \ ((_) heap \ (_) heap \ bool) set" - where - "a_get_child_nodes_locs ptr \ - (if is_element_ptr_kind ptr then {preserved (get_M (the (cast ptr)) RElement.child_nodes)} else {}) \ - (if is_document_ptr_kind ptr then {preserved (get_M (the (cast ptr)) RDocument.document_element)} else {}) \ - {preserved (get_M ptr RObject.nothing)}" - -definition first_child :: "(_) object_ptr \ (_, (_) node_ptr option) dom_prog" - where - "first_child ptr = do { - children \ a_get_child_nodes ptr; - return (case children of [] \ None | child#_ \ Some child)}" -end - -locale l_get_child_nodes_defs = - fixes get_child_nodes :: "(_) object_ptr \ (_, (_) node_ptr list) dom_prog" - fixes get_child_nodes_locs :: "(_) object_ptr \ ((_) heap \ (_) heap \ bool) set" - -locale l_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_type_wf type_wf + - l_known_ptr known_ptr + - l_get_child_nodes_defs get_child_nodes get_child_nodes_locs + - l_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs - for type_wf :: "(_) heap \ bool" - and known_ptr :: "(_) object_ptr \ bool" - and get_child_nodes :: "(_) object_ptr \ (_, (_) node_ptr list) dom_prog" - and get_child_nodes_locs :: "(_) object_ptr \ ((_) heap \ (_) heap \ bool) set" + - assumes known_ptr_impl: "known_ptr = DocumentClass.known_ptr" - assumes type_wf_impl: "type_wf = DocumentClass.type_wf" - assumes get_child_nodes_impl: "get_child_nodes = a_get_child_nodes" - assumes get_child_nodes_locs_impl: "get_child_nodes_locs = a_get_child_nodes_locs" -begin -lemmas get_child_nodes_def = get_child_nodes_impl[unfolded a_get_child_nodes_def] -lemmas get_child_nodes_locs_def = get_child_nodes_locs_impl[unfolded a_get_child_nodes_locs_def] - -lemma get_child_nodes_split: - "P (invoke (a_get_child_nodes_tups @ xs) ptr ()) = - ((known_ptr ptr \ P (get_child_nodes ptr)) - \ (\(known_ptr ptr) \ P (invoke xs ptr ())))" - by(auto simp add: known_ptr_impl get_child_nodes_impl a_get_child_nodes_def a_get_child_nodes_tups_def - known_ptr_defs CharacterDataClass.known_ptr_defs ElementClass.known_ptr_defs - NodeClass.known_ptr_defs - split: invoke_splits) - -lemma get_child_nodes_split_asm: - "P (invoke (a_get_child_nodes_tups @ xs) ptr ()) = - (\((known_ptr ptr \ \P (get_child_nodes ptr)) - \ (\(known_ptr ptr) \ \P (invoke xs ptr ()))))" - by(auto simp add: known_ptr_impl get_child_nodes_impl a_get_child_nodes_def - a_get_child_nodes_tups_def known_ptr_defs CharacterDataClass.known_ptr_defs - ElementClass.known_ptr_defs NodeClass.known_ptr_defs - split: invoke_splits) - -lemmas get_child_nodes_splits = get_child_nodes_split get_child_nodes_split_asm - -lemma get_child_nodes_ok [simp]: - assumes "known_ptr ptr" - assumes "type_wf h" - assumes "ptr |\| object_ptr_kinds h" - shows "h \ ok (get_child_nodes ptr)" - using assms(1) assms(2) assms(3) - apply(auto simp add: known_ptr_impl type_wf_impl get_child_nodes_def a_get_child_nodes_tups_def)[1] - apply(split invoke_splits, rule conjI)+ - apply((rule impI)+, drule(1) known_ptr_not_document_ptr, drule(1) known_ptr_not_character_data_ptr, - drule(1) known_ptr_not_element_ptr) - apply(auto simp add: NodeClass.known_ptr_defs)[1] - apply(auto simp add: get_child_nodes\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def dest: get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok - split: list.splits option.splits intro!: bind_is_OK_I2)[1] - apply(auto simp add: get_child_nodes\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def)[1] - apply (auto simp add: get_child_nodes\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def CharacterDataClass.type_wf_defs - DocumentClass.type_wf_defs intro!: bind_is_OK_I2 split: option.splits)[1] - using get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok \type_wf h\[unfolded type_wf_impl] by blast - -lemma get_child_nodes_ptr_in_heap [simp]: - assumes "h \ get_child_nodes ptr \\<^sub>r children" - shows "ptr |\| object_ptr_kinds h" - using assms - by(auto simp add: get_child_nodes_impl a_get_child_nodes_def invoke_ptr_in_heap - dest: is_OK_returns_result_I) - -lemma get_child_nodes_pure [simp]: - "pure (get_child_nodes ptr) h" - apply (auto simp add: get_child_nodes_impl a_get_child_nodes_def a_get_child_nodes_tups_def)[1] - apply(split invoke_splits, rule conjI)+ - by(auto simp add: get_child_nodes\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def get_child_nodes\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def - get_child_nodes\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def intro!: bind_pure_I split: option.splits) - -lemma get_child_nodes_reads: "reads (get_child_nodes_locs ptr) (get_child_nodes ptr) h h'" - apply(simp add: get_child_nodes_locs_impl get_child_nodes_impl a_get_child_nodes_def - a_get_child_nodes_tups_def a_get_child_nodes_locs_def) - apply(split invoke_splits, rule conjI)+ - apply(auto)[1] - apply(auto simp add: get_child_nodes\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def intro: reads_subset[OF reads_singleton] - reads_subset[OF check_in_heap_reads] - intro!: reads_bind_pure reads_subset[OF return_reads] split: option.splits)[1] (* slow: ca 1min *) - apply(auto simp add: get_child_nodes\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def intro: reads_subset[OF check_in_heap_reads] - intro!: reads_bind_pure reads_subset[OF return_reads] )[1] - apply(auto simp add: get_child_nodes\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def intro: reads_subset[OF reads_singleton] - reads_subset[OF check_in_heap_reads] intro!: reads_bind_pure reads_subset[OF return_reads] - split: option.splits) - done -end - -locale l_get_child_nodes = l_type_wf + l_known_ptr + l_get_child_nodes_defs + - assumes get_child_nodes_reads: "reads (get_child_nodes_locs ptr) (get_child_nodes ptr) h h'" - assumes get_child_nodes_ok: "type_wf h \ known_ptr ptr \ ptr |\| object_ptr_kinds h - \ h \ ok (get_child_nodes ptr)" - assumes get_child_nodes_ptr_in_heap: "h \ ok (get_child_nodes ptr) \ ptr |\| object_ptr_kinds h" - assumes get_child_nodes_pure [simp]: "pure (get_child_nodes ptr) h" - -global_interpretation l_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs defines - get_child_nodes = l_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_child_nodes and - get_child_nodes_locs = l_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_child_nodes_locs - . - -interpretation - i_get_child_nodes?: l_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr get_child_nodes get_child_nodes_locs - by(auto simp add: l_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def get_child_nodes_def get_child_nodes_locs_def) -declare l_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma get_child_nodes_is_l_get_child_nodes [instances]: - "l_get_child_nodes type_wf known_ptr get_child_nodes get_child_nodes_locs" - apply(unfold_locales) - using get_child_nodes_reads get_child_nodes_ok get_child_nodes_ptr_in_heap get_child_nodes_pure - by blast+ - - -paragraph \new\_element\ - -locale l_new_element_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr get_child_nodes get_child_nodes_locs - for type_wf :: "(_) heap \ bool" - and known_ptr :: "(_) object_ptr \ bool" - and get_child_nodes :: "(_) object_ptr \ ((_) heap, exception, (_) node_ptr list) prog" - and get_child_nodes_locs :: "(_) object_ptr \ ((_) heap \ (_) heap \ bool) set" -begin -lemma get_child_nodes_new_element: - "ptr' \ cast new_element_ptr \ h \ new_element \\<^sub>r new_element_ptr \ h \ new_element \\<^sub>h h' - \ r \ get_child_nodes_locs ptr' \ r h h'" - by (auto simp add: get_child_nodes_locs_def new_element_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t new_element_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t - new_element_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t split: prod.splits if_splits option.splits - elim!: bind_returns_result_E bind_returns_heap_E intro: is_element_ptr_kind_obtains) - -lemma new_element_no_child_nodes: - "h \ new_element \\<^sub>r new_element_ptr \ h \ new_element \\<^sub>h h' - \ h' \ get_child_nodes (cast new_element_ptr) \\<^sub>r []" - apply(auto simp add: get_child_nodes_def a_get_child_nodes_tups_def - split: prod.splits elim!: bind_returns_result_E bind_returns_heap_E)[1] - apply(split invoke_splits, rule conjI)+ - apply(auto intro: new_element_is_element_ptr)[1] - by(auto simp add: new_element_ptr_in_heap get_child_nodes\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def check_in_heap_def - new_element_child_nodes intro!: bind_pure_returns_result_I - intro: new_element_is_element_ptr elim!: new_element_ptr_in_heap) -end - -locale l_new_element_get_child_nodes = l_new_element + l_get_child_nodes + - assumes get_child_nodes_new_element: - "ptr' \ cast new_element_ptr \ h \ new_element \\<^sub>r new_element_ptr - \ h \ new_element \\<^sub>h h' \ r \ get_child_nodes_locs ptr' \ r h h'" - assumes new_element_no_child_nodes: - "h \ new_element \\<^sub>r new_element_ptr \ h \ new_element \\<^sub>h h' - \ h' \ get_child_nodes (cast new_element_ptr) \\<^sub>r []" - -interpretation i_new_element_get_child_nodes?: - l_new_element_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr get_child_nodes get_child_nodes_locs - by(unfold_locales) -declare l_new_element_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma new_element_get_child_nodes_is_l_new_element_get_child_nodes [instances]: - "l_new_element_get_child_nodes type_wf known_ptr get_child_nodes get_child_nodes_locs" - using new_element_is_l_new_element get_child_nodes_is_l_get_child_nodes - apply(auto simp add: l_new_element_get_child_nodes_def l_new_element_get_child_nodes_axioms_def)[1] - using get_child_nodes_new_element new_element_no_child_nodes - by fast+ - - -paragraph \new\_character\_data\ - -locale l_new_character_data_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr get_child_nodes get_child_nodes_locs - for type_wf :: "(_) heap \ bool" - and known_ptr :: "(_) object_ptr \ bool" - and get_child_nodes :: "(_) object_ptr \ ((_) heap, exception, (_) node_ptr list) prog" - and get_child_nodes_locs :: "(_) object_ptr \ ((_) heap \ (_) heap \ bool) set" -begin -lemma get_child_nodes_new_character_data: - "ptr' \ cast new_character_data_ptr \ h \ new_character_data \\<^sub>r new_character_data_ptr - \ h \ new_character_data \\<^sub>h h' \ r \ get_child_nodes_locs ptr' \ r h h'" - by (auto simp add: get_child_nodes_locs_def new_character_data_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t - new_character_data_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t new_character_data_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t - split: prod.splits if_splits option.splits - elim!: bind_returns_result_E bind_returns_heap_E - intro: is_character_data_ptr_kind_obtains) - -lemma new_character_data_no_child_nodes: - "h \ new_character_data \\<^sub>r new_character_data_ptr \ h \ new_character_data \\<^sub>h h' - \ h' \ get_child_nodes (cast new_character_data_ptr) \\<^sub>r []" - apply(auto simp add: get_child_nodes_def a_get_child_nodes_tups_def - split: prod.splits elim!: bind_returns_result_E bind_returns_heap_E)[1] - apply(split invoke_splits, rule conjI)+ - apply(auto intro: new_character_data_is_character_data_ptr)[1] - by(auto simp add: new_character_data_ptr_in_heap get_child_nodes\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def - check_in_heap_def new_character_data_child_nodes - intro!: bind_pure_returns_result_I - intro: new_character_data_is_character_data_ptr elim!: new_character_data_ptr_in_heap) -end - -locale l_new_character_data_get_child_nodes = l_new_character_data + l_get_child_nodes + - assumes get_child_nodes_new_character_data: - "ptr' \ cast new_character_data_ptr \ h \ new_character_data \\<^sub>r new_character_data_ptr - \ h \ new_character_data \\<^sub>h h' \ r \ get_child_nodes_locs ptr' \ r h h'" - assumes new_character_data_no_child_nodes: - "h \ new_character_data \\<^sub>r new_character_data_ptr \ h \ new_character_data \\<^sub>h h' - \ h' \ get_child_nodes (cast new_character_data_ptr) \\<^sub>r []" - -interpretation i_new_character_data_get_child_nodes?: - l_new_character_data_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr get_child_nodes get_child_nodes_locs - by(unfold_locales) -declare l_new_character_data_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma new_character_data_get_child_nodes_is_l_new_character_data_get_child_nodes [instances]: - "l_new_character_data_get_child_nodes type_wf known_ptr get_child_nodes get_child_nodes_locs" - using new_character_data_is_l_new_character_data get_child_nodes_is_l_get_child_nodes - apply(simp add: l_new_character_data_get_child_nodes_def l_new_character_data_get_child_nodes_axioms_def) - using get_child_nodes_new_character_data new_character_data_no_child_nodes - by fast - - - -paragraph \new\_document\ - -locale l_new_document_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr get_child_nodes get_child_nodes_locs - for type_wf :: "(_) heap \ bool" - and known_ptr :: "(_) object_ptr \ bool" - and get_child_nodes :: "(_) object_ptr \ ((_) heap, exception, (_) node_ptr list) prog" - and get_child_nodes_locs :: "(_) object_ptr \ ((_) heap \ (_) heap \ bool) set" -begin -lemma get_child_nodes_new_document: - "ptr' \ cast new_document_ptr \ h \ new_document \\<^sub>r new_document_ptr - \ h \ new_document \\<^sub>h h' \ r \ get_child_nodes_locs ptr' \ r h h'" - by (auto simp add: get_child_nodes_locs_def new_document_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t new_document_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t - new_document_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t split: prod.splits if_splits option.splits - elim!: bind_returns_result_E bind_returns_heap_E - intro: is_document_ptr_kind_obtains) - -lemma new_document_no_child_nodes: - "h \ new_document \\<^sub>r new_document_ptr \ h \ new_document \\<^sub>h h' - \ h' \ get_child_nodes (cast new_document_ptr) \\<^sub>r []" - apply(auto simp add: get_child_nodes_def a_get_child_nodes_tups_def - split: prod.splits - elim!: bind_returns_result_E bind_returns_heap_E)[1] - apply(split invoke_splits, rule conjI)+ - apply(auto intro: new_document_is_document_ptr)[1] - by(auto simp add: new_document_ptr_in_heap get_child_nodes\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def check_in_heap_def - new_document_document_element - intro!: bind_pure_returns_result_I - intro: new_document_is_document_ptr elim!: new_document_ptr_in_heap split: option.splits) -end - -locale l_new_document_get_child_nodes = l_new_document + l_get_child_nodes + - assumes get_child_nodes_new_document: - "ptr' \ cast new_document_ptr \ h \ new_document \\<^sub>r new_document_ptr - \ h \ new_document \\<^sub>h h' \ r \ get_child_nodes_locs ptr' \ r h h'" - assumes new_document_no_child_nodes: - "h \ new_document \\<^sub>r new_document_ptr \ h \ new_document \\<^sub>h h' - \ h' \ get_child_nodes (cast new_document_ptr) \\<^sub>r []" - -interpretation i_new_document_get_child_nodes?: - l_new_document_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr get_child_nodes get_child_nodes_locs - by(unfold_locales) -declare l_new_document_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma new_document_get_child_nodes_is_l_new_document_get_child_nodes [instances]: - "l_new_document_get_child_nodes type_wf known_ptr get_child_nodes get_child_nodes_locs" - using new_document_is_l_new_document get_child_nodes_is_l_get_child_nodes - apply(simp add: l_new_document_get_child_nodes_def l_new_document_get_child_nodes_axioms_def) - using get_child_nodes_new_document new_document_no_child_nodes - by fast - -subsubsection \set\_child\_nodes\ - -locale l_set_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs -begin -definition set_child_nodes\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: - "(_) element_ptr \ (_) node_ptr list \ (_, unit) dom_prog" - where - "set_child_nodes\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r element_ptr children = put_M element_ptr RElement.child_nodes_update children" - -definition set_child_nodes\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: - "(_) character_data_ptr \ (_) node_ptr list \ (_, unit) dom_prog" - where - "set_child_nodes\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r _ _ = error HierarchyRequestError" - -definition set_child_nodes\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) document_ptr \ (_) node_ptr list \ (_, unit) dom_prog" - where - "set_child_nodes\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr children = do { - (case children of - [] \ put_M document_ptr document_element_update None - | child # [] \ (case cast child of - Some element_ptr \ put_M document_ptr document_element_update (Some element_ptr) - | None \ error HierarchyRequestError) - | _ \ error HierarchyRequestError) - }" - -definition a_set_child_nodes_tups :: - "(((_) object_ptr \ bool) \ ((_) object_ptr \ (_) node_ptr list \ (_, unit) dom_prog)) list" - where - "a_set_child_nodes_tups \ [ - (is_element_ptr, set_child_nodes\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r \ the \ cast), - (is_character_data_ptr, set_child_nodes\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r \ the \ cast), - (is_document_ptr, set_child_nodes\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r \ the \ cast) - ]" - -definition a_set_child_nodes :: "(_) object_ptr \ (_) node_ptr list \ (_, unit) dom_prog" - where - "a_set_child_nodes ptr children = invoke a_set_child_nodes_tups ptr (children)" -lemmas set_child_nodes_defs = a_set_child_nodes_def - -definition a_set_child_nodes_locs :: "(_) object_ptr \ (_, unit) dom_prog set" - where - "a_set_child_nodes_locs ptr \ - (if is_element_ptr_kind ptr - then all_args (put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t (the (cast ptr)) RElement.child_nodes_update) else {}) \ - (if is_document_ptr_kind ptr - then all_args (put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t (the (cast ptr)) document_element_update) else {})" -end - -locale l_set_child_nodes_defs = - fixes set_child_nodes :: "(_) object_ptr \ (_) node_ptr list \ (_, unit) dom_prog" - fixes set_child_nodes_locs :: "(_) object_ptr \ (_, unit) dom_prog set" - -locale l_set_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_type_wf type_wf + - l_known_ptr known_ptr + - l_set_child_nodes_defs set_child_nodes set_child_nodes_locs + - l_set_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs - for type_wf :: "(_) heap \ bool" - and known_ptr :: "(_) object_ptr \ bool" - and set_child_nodes :: "(_) object_ptr \ (_) node_ptr list \ (_, unit) dom_prog" - and set_child_nodes_locs :: "(_) object_ptr \ (_, unit) dom_prog set" + - assumes known_ptr_impl: "known_ptr = DocumentClass.known_ptr" - assumes type_wf_impl: "type_wf = DocumentClass.type_wf" - assumes set_child_nodes_impl: "set_child_nodes = a_set_child_nodes" - assumes set_child_nodes_locs_impl: "set_child_nodes_locs = a_set_child_nodes_locs" -begin -lemmas set_child_nodes_def = set_child_nodes_impl[unfolded a_set_child_nodes_def] -lemmas set_child_nodes_locs_def = set_child_nodes_locs_impl[unfolded a_set_child_nodes_locs_def] - -lemma set_child_nodes_split: - "P (invoke (a_set_child_nodes_tups @ xs) ptr (children)) = - ((known_ptr ptr \ P (set_child_nodes ptr children)) - \ (\(known_ptr ptr) \ P (invoke xs ptr (children))))" - by(auto simp add: known_ptr_impl set_child_nodes_impl a_set_child_nodes_def - a_set_child_nodes_tups_def known_ptr_defs CharacterDataClass.known_ptr_defs - ElementClass.known_ptr_defs NodeClass.known_ptr_defs split: invoke_splits) - -lemma set_child_nodes_split_asm: - "P (invoke (a_set_child_nodes_tups @ xs) ptr (children)) = - (\((known_ptr ptr \ \P (set_child_nodes ptr children)) - \ (\(known_ptr ptr) \ \P (invoke xs ptr (children)))))" - by(auto simp add: known_ptr_impl set_child_nodes_impl a_set_child_nodes_def - a_set_child_nodes_tups_def known_ptr_defs CharacterDataClass.known_ptr_defs - ElementClass.known_ptr_defs NodeClass.known_ptr_defs split: invoke_splits)[1] -lemmas set_child_nodes_splits = set_child_nodes_split set_child_nodes_split_asm - -lemma set_child_nodes_writes: "writes (set_child_nodes_locs ptr) (set_child_nodes ptr children) h h'" - apply(simp add: set_child_nodes_locs_impl set_child_nodes_impl a_set_child_nodes_def - a_set_child_nodes_tups_def a_set_child_nodes_locs_def) - apply(split invoke_splits, rule conjI)+ - apply(auto)[1] - apply(auto simp add: set_child_nodes\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def intro!: writes_bind_pure - intro: writes_union_right_I split: list.splits)[1] - apply(auto intro: writes_union_right_I split: option.splits)[1] - apply(auto intro: writes_union_right_I split: option.splits)[1] - apply(auto intro: writes_union_right_I split: option.splits)[1] - apply(auto intro: writes_union_right_I split: option.splits)[1] - apply(auto intro: writes_union_right_I split: option.splits)[1] - apply(auto intro: writes_union_right_I split: option.splits)[1] (*slow: ca. 1min *) - apply(auto simp add: set_child_nodes\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def intro!: writes_bind_pure)[1] - apply(auto simp add: set_child_nodes\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def intro: writes_union_left_I - intro!: writes_bind_pure split: list.splits option.splits)[1] - done - -lemma set_child_nodes_pointers_preserved: - assumes "w \ set_child_nodes_locs object_ptr" - assumes "h \ w \\<^sub>h h'" - shows "object_ptr_kinds h = object_ptr_kinds h'" - using assms(1) object_ptr_kinds_preserved[OF writes_singleton2 assms(2)] - by(auto simp add: set_child_nodes_locs_impl all_args_def a_set_child_nodes_locs_def - split: if_splits) - -lemma set_child_nodes_typess_preserved: - assumes "w \ set_child_nodes_locs object_ptr" - assumes "h \ w \\<^sub>h h'" - shows "type_wf h = type_wf h'" - using assms(1) type_wf_preserved[OF writes_singleton2 assms(2)] - by(auto simp add: set_child_nodes_locs_impl type_wf_impl all_args_def a_set_child_nodes_locs_def - split: if_splits) -end - -locale l_set_child_nodes = l_type_wf + l_set_child_nodes_defs + - assumes set_child_nodes_writes: - "writes (set_child_nodes_locs ptr) (set_child_nodes ptr children) h h'" - assumes set_child_nodes_pointers_preserved: - "w \ set_child_nodes_locs object_ptr \ h \ w \\<^sub>h h' \ object_ptr_kinds h = object_ptr_kinds h'" - assumes set_child_nodes_types_preserved: - "w \ set_child_nodes_locs object_ptr \ h \ w \\<^sub>h h' \ type_wf h = type_wf h'" - -global_interpretation l_set_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs defines - set_child_nodes = l_set_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_set_child_nodes and - set_child_nodes_locs = l_set_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_set_child_nodes_locs . - -interpretation - i_set_child_nodes?: l_set_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr set_child_nodes set_child_nodes_locs - apply(unfold_locales) - by (auto simp add: set_child_nodes_def set_child_nodes_locs_def) -declare l_set_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - - -lemma set_child_nodes_is_l_set_child_nodes [instances]: - "l_set_child_nodes type_wf set_child_nodes set_child_nodes_locs" - apply(unfold_locales) - using set_child_nodes_pointers_preserved set_child_nodes_typess_preserved set_child_nodes_writes - by blast+ - - -paragraph \get\_child\_nodes\ - -locale l_set_child_nodes_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = l_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M + l_set_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M -begin - -lemma set_child_nodes_get_child_nodes: - assumes "known_ptr ptr" - assumes "type_wf h" - assumes "h \ set_child_nodes ptr children \\<^sub>h h'" - shows "h' \ get_child_nodes ptr \\<^sub>r children" -proof - - have "h \ check_in_heap ptr \\<^sub>r ()" - using assms set_child_nodes_impl[unfolded a_set_child_nodes_def] invoke_ptr_in_heap - by (metis (full_types) check_in_heap_ptr_in_heap is_OK_returns_heap_I is_OK_returns_result_E - old.unit.exhaust) - then have ptr_in_h: "ptr |\| object_ptr_kinds h" - by (simp add: check_in_heap_ptr_in_heap is_OK_returns_result_I) - - have "type_wf h'" - apply(unfold type_wf_impl) - apply(rule subst[where P=id, OF type_wf_preserved[OF set_child_nodes_writes assms(3), - unfolded all_args_def], simplified]) - by(auto simp add: all_args_def assms(2)[unfolded type_wf_impl] - set_child_nodes_locs_impl[unfolded a_set_child_nodes_locs_def] - split: if_splits) - have "h' \ check_in_heap ptr \\<^sub>r ()" - using check_in_heap_reads set_child_nodes_writes assms(3) \h \ check_in_heap ptr \\<^sub>r ()\ - apply(rule reads_writes_separate_forwards) - by(auto simp add: all_args_def set_child_nodes_locs_impl[unfolded a_set_child_nodes_locs_def]) - then have "ptr |\| object_ptr_kinds h'" - using check_in_heap_ptr_in_heap by blast - with assms ptr_in_h \type_wf h'\ show ?thesis - apply(auto simp add: get_child_nodes_impl set_child_nodes_impl type_wf_impl known_ptr_impl - a_get_child_nodes_def a_get_child_nodes_tups_def a_set_child_nodes_def - a_set_child_nodes_tups_def - del: bind_pure_returns_result_I2 - intro!: bind_pure_returns_result_I2)[1] - apply(split invoke_splits, rule conjI) - apply(split invoke_splits, rule conjI) - apply(split invoke_splits, rule conjI) - apply(auto simp add: NodeClass.known_ptr_defs - dest!: known_ptr_not_document_ptr known_ptr_not_character_data_ptr - known_ptr_not_element_ptr)[1] - apply(auto simp add: NodeClass.known_ptr_defs - dest!: known_ptr_not_document_ptr known_ptr_not_character_data_ptr - known_ptr_not_element_ptr)[1] - apply(auto simp add: get_child_nodes\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def set_child_nodes\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok - split: list.splits option.splits - intro!: bind_pure_returns_result_I2 - dest: get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok; auto dest: returns_result_eq - dest!: document_put_get[where getter = document_element])[1] (* slow, ca 1min *) - apply(auto simp add: get_child_nodes\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def set_child_nodes\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def)[1] - by(auto simp add: get_child_nodes\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def set_child_nodes\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def dest: element_put_get) -qed - -lemma set_child_nodes_get_child_nodes_different_pointers: - assumes "ptr \ ptr'" - assumes "w \ set_child_nodes_locs ptr" - assumes "h \ w \\<^sub>h h'" - assumes "r \ get_child_nodes_locs ptr'" - shows "r h h'" - using assms - apply(auto simp add: get_child_nodes_locs_impl set_child_nodes_locs_impl all_args_def - a_set_child_nodes_locs_def a_get_child_nodes_locs_def - split: if_splits option.splits )[1] - apply(rule is_document_ptr_kind_obtains) - apply(simp) - apply(rule is_document_ptr_kind_obtains) - apply(auto)[1] - apply(auto)[1] - apply(rule is_element_ptr_kind_obtains) - apply(auto)[1] - apply(auto)[1] - apply(rule is_element_ptr_kind_obtains) - apply(auto) - done - -lemma set_child_nodes_element_ok [simp]: - assumes "known_ptr ptr" - assumes "type_wf h" - assumes "ptr |\| object_ptr_kinds h" - assumes "is_element_ptr_kind ptr" - shows "h \ ok (set_child_nodes ptr children)" -proof - - have "is_element_ptr ptr" - using \known_ptr ptr\ assms(4) - by(auto simp add: known_ptr_impl known_ptr_defs CharacterDataClass.known_ptr_defs ElementClass.known_ptr_defs NodeClass.known_ptr_defs split: option.splits) - then show ?thesis - using assms - apply(auto simp add: set_child_nodes_def a_set_child_nodes_tups_def set_child_nodes\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def split: option.splits)[1] - by (simp add: DocumentMonad.put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok local.type_wf_impl) -qed - -lemma set_child_nodes_document1_ok [simp]: - assumes "known_ptr ptr" - assumes "type_wf h" - assumes "ptr |\| object_ptr_kinds h" - assumes "is_document_ptr_kind ptr" - assumes "children = []" - shows "h \ ok (set_child_nodes ptr children)" -proof - - have "is_document_ptr ptr" - using \known_ptr ptr\ assms(4) - by(auto simp add: known_ptr_impl known_ptr_defs CharacterDataClass.known_ptr_defs ElementClass.known_ptr_defs NodeClass.known_ptr_defs split: option.splits) - then show ?thesis - using assms - apply(auto simp add: set_child_nodes_def a_set_child_nodes_tups_def set_child_nodes\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def split: option.splits)[1] - by (simp add: DocumentMonad.put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok local.type_wf_impl) -qed - -lemma set_child_nodes_document2_ok [simp]: - assumes "known_ptr ptr" - assumes "type_wf h" - assumes "ptr |\| object_ptr_kinds h" - assumes "is_document_ptr_kind ptr" - assumes "children = [child]" - assumes "is_element_ptr_kind child" - shows "h \ ok (set_child_nodes ptr children)" -proof - - have "is_document_ptr ptr" - using \known_ptr ptr\ assms(4) - by(auto simp add: known_ptr_impl known_ptr_defs CharacterDataClass.known_ptr_defs ElementClass.known_ptr_defs NodeClass.known_ptr_defs split: option.splits) - then show ?thesis - using assms - apply(auto simp add: set_child_nodes_def a_set_child_nodes_tups_def set_child_nodes\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def) - apply(split invoke_splits, rule conjI)+ - apply(auto simp add: is_element_ptr_kind\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def set_child_nodes\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def split: option.splits)[1] - apply(auto simp add: is_element_ptr_kind\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def set_child_nodes\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def split: option.splits)[1] - apply (simp add: local.type_wf_impl put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok) - apply(auto simp add: is_element_ptr_kind\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def set_child_nodes\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def split: option.splits)[1] - by(auto simp add: is_element_ptr_kind\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def set_child_nodes\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def split: option.splits)[1] -qed -end - -locale l_set_child_nodes_get_child_nodes = l_get_child_nodes + l_set_child_nodes + - assumes set_child_nodes_get_child_nodes: - "type_wf h \ known_ptr ptr - \ h \ set_child_nodes ptr children \\<^sub>h h' \ h' \ get_child_nodes ptr \\<^sub>r children" - assumes set_child_nodes_get_child_nodes_different_pointers: - "ptr \ ptr' \ w \ set_child_nodes_locs ptr \ h \ w \\<^sub>h h' - \ r \ get_child_nodes_locs ptr' \ r h h'" - -interpretation - i_set_child_nodes_get_child_nodes?: l_set_child_nodes_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf - known_ptr get_child_nodes get_child_nodes_locs set_child_nodes set_child_nodes_locs - by unfold_locales -declare l_set_child_nodes_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma set_child_nodes_get_child_nodes_is_l_set_child_nodes_get_child_nodes [instances]: - "l_set_child_nodes_get_child_nodes type_wf known_ptr get_child_nodes get_child_nodes_locs - set_child_nodes set_child_nodes_locs" - using get_child_nodes_is_l_get_child_nodes set_child_nodes_is_l_set_child_nodes - apply(auto simp add: l_set_child_nodes_get_child_nodes_def l_set_child_nodes_get_child_nodes_axioms_def)[1] - using set_child_nodes_get_child_nodes apply blast - using set_child_nodes_get_child_nodes_different_pointers apply metis - done - - -subsubsection \get\_attribute\ - -locale l_get_attribute\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs -begin -definition a_get_attribute :: "(_) element_ptr \ attr_key \ (_, attr_value option) dom_prog" - where - "a_get_attribute ptr k = do {m \ get_M ptr attrs; return (fmlookup m k)}" -lemmas get_attribute_defs = a_get_attribute_def - -definition a_get_attribute_locs :: "(_) element_ptr \ ((_) heap \ (_) heap \ bool) set" - where - "a_get_attribute_locs element_ptr = {preserved (get_M element_ptr attrs)}" -end - -locale l_get_attribute_defs = - fixes get_attribute :: "(_) element_ptr \ attr_key \ (_, attr_value option) dom_prog" - fixes get_attribute_locs :: "(_) element_ptr \ ((_) heap \ (_) heap \ bool) set" - -locale l_get_attribute\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_type_wf type_wf + - l_get_attribute_defs get_attribute get_attribute_locs + - l_get_attribute\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs - for type_wf :: "(_) heap \ bool" - and get_attribute :: "(_) element_ptr \ attr_key \ (_, attr_value option) dom_prog" - and get_attribute_locs :: "(_) element_ptr \ ((_) heap \ (_) heap \ bool) set" + - assumes type_wf_impl: "type_wf = DocumentClass.type_wf" - assumes get_attribute_impl: "get_attribute = a_get_attribute" - assumes get_attribute_locs_impl: "get_attribute_locs = a_get_attribute_locs" -begin -lemma get_attribute_pure [simp]: "pure (get_attribute ptr k) h" - by (auto simp add: bind_pure_I get_attribute_impl[unfolded a_get_attribute_def]) - -lemma get_attribute_ok: - "type_wf h \ element_ptr |\| element_ptr_kinds h \ h \ ok (get_attribute element_ptr k)" - apply(unfold type_wf_impl) - unfolding get_attribute_impl[unfolded a_get_attribute_def] using get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok - by (metis bind_is_OK_pure_I return_ok ElementMonad.get_M_pure) - -lemma get_attribute_ptr_in_heap: - "h \ ok (get_attribute element_ptr k) \ element_ptr |\| element_ptr_kinds h" - unfolding get_attribute_impl[unfolded a_get_attribute_def] - by (meson DocumentMonad.get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ptr_in_heap bind_is_OK_E is_OK_returns_result_I) - -lemma get_attribute_reads: - "reads (get_attribute_locs element_ptr) (get_attribute element_ptr k) h h'" - by(auto simp add: get_attribute_impl[unfolded a_get_attribute_def] - get_attribute_locs_impl[unfolded a_get_attribute_locs_def] - reads_insert_writes_set_right - intro!: reads_bind_pure) -end - -locale l_get_attribute = l_type_wf + l_get_attribute_defs + -assumes get_attribute_reads: - "reads (get_attribute_locs element_ptr) (get_attribute element_ptr k) h h'" -assumes get_attribute_ok: - "type_wf h \ element_ptr |\| element_ptr_kinds h \ h \ ok (get_attribute element_ptr k)" -assumes get_attribute_ptr_in_heap: - "h \ ok (get_attribute element_ptr k) \ element_ptr |\| element_ptr_kinds h" -assumes get_attribute_pure [simp]: "pure (get_attribute element_ptr k) h" - -global_interpretation l_get_attribute\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs defines - get_attribute = l_get_attribute\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_attribute and - get_attribute_locs = l_get_attribute\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_attribute_locs . - -interpretation - i_get_attribute?: l_get_attribute\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_attribute get_attribute_locs - apply(unfold_locales) - by (auto simp add: get_attribute_def get_attribute_locs_def) -declare l_get_attribute\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma get_attribute_is_l_get_attribute [instances]: - "l_get_attribute type_wf get_attribute get_attribute_locs" - apply(unfold_locales) - using get_attribute_reads get_attribute_ok get_attribute_ptr_in_heap get_attribute_pure - by blast+ - - -subsubsection \set\_attribute\ - -locale l_set_attribute\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs -begin - -definition - a_set_attribute :: "(_) element_ptr \ attr_key \ attr_value option \ (_, unit) dom_prog" - where - "a_set_attribute ptr k v = do { - m \ get_M ptr attrs; - put_M ptr attrs_update (if v = None then fmdrop k m else fmupd k (the v) m) - }" - -definition a_set_attribute_locs :: "(_) element_ptr \ (_, unit) dom_prog set" - where - "a_set_attribute_locs element_ptr \ all_args (put_M element_ptr attrs_update)" -end - -locale l_set_attribute_defs = - fixes set_attribute :: "(_) element_ptr \ attr_key \ attr_value option \ (_, unit) dom_prog" - fixes set_attribute_locs :: "(_) element_ptr \ (_, unit) dom_prog set" - -locale l_set_attribute\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_type_wf type_wf + - l_set_attribute_defs set_attribute set_attribute_locs + - l_set_attribute\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs - for type_wf :: "(_) heap \ bool" - and set_attribute :: "(_) element_ptr \ attr_key \ attr_value option \ (_, unit) dom_prog" - and set_attribute_locs :: "(_) element_ptr \ (_, unit) dom_prog set" + - assumes type_wf_impl: "type_wf = DocumentClass.type_wf" - assumes set_attribute_impl: "set_attribute = a_set_attribute" - assumes set_attribute_locs_impl: "set_attribute_locs = a_set_attribute_locs" -begin -lemmas set_attribute_def = set_attribute_impl[folded a_set_attribute_def] -lemmas set_attribute_locs_def = set_attribute_locs_impl[unfolded a_set_attribute_locs_def] - -lemma set_attribute_ok: "type_wf h \ element_ptr |\| element_ptr_kinds h \ h \ ok (set_attribute element_ptr k v)" - apply(unfold type_wf_impl) - unfolding set_attribute_impl[unfolded a_set_attribute_def] using get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok - by(metis (no_types, lifting) DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t ElementMonad.get_M_pure bind_is_OK_E - bind_is_OK_pure_I is_OK_returns_result_I) - -lemma set_attribute_writes: - "writes (set_attribute_locs element_ptr) (set_attribute element_ptr k v) h h'" - by(auto simp add: set_attribute_impl[unfolded a_set_attribute_def] - set_attribute_locs_impl[unfolded a_set_attribute_locs_def] - intro: writes_bind_pure) -end - -locale l_set_attribute = l_type_wf + l_set_attribute_defs + - assumes set_attribute_writes: - "writes (set_attribute_locs element_ptr) (set_attribute element_ptr k v) h h'" - assumes set_attribute_ok: - "type_wf h \ element_ptr |\| element_ptr_kinds h \ h \ ok (set_attribute element_ptr k v)" - -global_interpretation l_set_attribute\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs defines - set_attribute = l_set_attribute\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_set_attribute and - set_attribute_locs = l_set_attribute\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_set_attribute_locs . -interpretation - i_set_attribute?: l_set_attribute\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf set_attribute set_attribute_locs - apply(unfold_locales) - by (auto simp add: set_attribute_def set_attribute_locs_def) -declare l_set_attribute\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma set_attribute_is_l_set_attribute [instances]: - "l_set_attribute type_wf set_attribute set_attribute_locs" - apply(unfold_locales) - using set_attribute_ok set_attribute_writes - by blast+ - - -paragraph \get\_attribute\ - -locale l_set_attribute_get_attribute\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_get_attribute\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M + - l_set_attribute\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M -begin - -lemma set_attribute_get_attribute: - "h \ set_attribute ptr k v \\<^sub>h h' \ h' \ get_attribute ptr k \\<^sub>r v" - by(auto simp add: set_attribute_impl[unfolded a_set_attribute_def] - get_attribute_impl[unfolded a_get_attribute_def] - elim!: bind_returns_heap_E2 - intro!: bind_pure_returns_result_I - elim: element_put_get) -end - -locale l_set_attribute_get_attribute = l_get_attribute + l_set_attribute + - assumes set_attribute_get_attribute: - "h \ set_attribute ptr k v \\<^sub>h h' \ h' \ get_attribute ptr k \\<^sub>r v" - -interpretation - i_set_attribute_get_attribute?: l_set_attribute_get_attribute\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf - get_attribute get_attribute_locs set_attribute set_attribute_locs - by(unfold_locales) -declare l_set_attribute_get_attribute\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma set_attribute_get_attribute_is_l_set_attribute_get_attribute [instances]: - "l_set_attribute_get_attribute type_wf get_attribute get_attribute_locs set_attribute set_attribute_locs" - using get_attribute_is_l_get_attribute set_attribute_is_l_set_attribute - apply(simp add: l_set_attribute_get_attribute_def l_set_attribute_get_attribute_axioms_def) - using set_attribute_get_attribute - by blast - -paragraph \get\_child\_nodes\ - -locale l_set_attribute_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_set_attribute\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M + - l_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M -begin -lemma set_attribute_get_child_nodes: - "\w \ set_attribute_locs ptr. (h \ w \\<^sub>h h' \ (\r \ get_child_nodes_locs ptr'. r h h'))" - by(auto simp add: set_attribute_locs_def get_child_nodes_locs_def all_args_def - intro: element_put_get_preserved[where setter=attrs_update]) -end - -locale l_set_attribute_get_child_nodes = - l_set_attribute + - l_get_child_nodes + - assumes set_attribute_get_child_nodes: - "\w \ set_attribute_locs ptr. (h \ w \\<^sub>h h' \ (\r \ get_child_nodes_locs ptr'. r h h'))" - -interpretation - i_set_attribute_get_child_nodes?: l_set_attribute_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf - set_attribute set_attribute_locs known_ptr get_child_nodes get_child_nodes_locs - by unfold_locales -declare l_set_attribute_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma set_attribute_get_child_nodes_is_l_set_attribute_get_child_nodes [instances]: - "l_set_attribute_get_child_nodes type_wf set_attribute set_attribute_locs known_ptr - get_child_nodes get_child_nodes_locs" - using set_attribute_is_l_set_attribute get_child_nodes_is_l_get_child_nodes - apply(simp add: l_set_attribute_get_child_nodes_def l_set_attribute_get_child_nodes_axioms_def) - using set_attribute_get_child_nodes - by blast - - -subsubsection \get\_disconnected\_nodes\ - -locale l_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs -begin -definition a_get_disconnected_nodes :: "(_) document_ptr - \ (_, (_) node_ptr list) dom_prog" - where - "a_get_disconnected_nodes document_ptr = get_M document_ptr disconnected_nodes" -lemmas get_disconnected_nodes_defs = a_get_disconnected_nodes_def - -definition a_get_disconnected_nodes_locs :: "(_) document_ptr \ ((_) heap \ (_) heap \ bool) set" - where - "a_get_disconnected_nodes_locs document_ptr = {preserved (get_M document_ptr disconnected_nodes)}" -end - -locale l_get_disconnected_nodes_defs = - fixes get_disconnected_nodes :: "(_) document_ptr \ (_, (_) node_ptr list) dom_prog" - fixes get_disconnected_nodes_locs :: "(_) document_ptr \ ((_) heap \ (_) heap \ bool) set" - -locale l_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_type_wf type_wf + - l_get_disconnected_nodes_defs get_disconnected_nodes get_disconnected_nodes_locs + - l_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs - for type_wf :: "(_) heap \ bool" - and get_disconnected_nodes :: "(_) document_ptr \ ((_) heap, exception, (_) node_ptr list) prog" - and get_disconnected_nodes_locs :: "(_) document_ptr \ ((_) heap \ (_) heap \ bool) set" + - assumes type_wf_impl: "type_wf = DocumentClass.type_wf" - assumes get_disconnected_nodes_impl: "get_disconnected_nodes = a_get_disconnected_nodes" - assumes get_disconnected_nodes_locs_impl: "get_disconnected_nodes_locs = a_get_disconnected_nodes_locs" -begin -lemmas - get_disconnected_nodes_def = get_disconnected_nodes_impl[unfolded a_get_disconnected_nodes_def] -lemmas - get_disconnected_nodes_locs_def = get_disconnected_nodes_locs_impl[unfolded a_get_disconnected_nodes_locs_def] - -lemma get_disconnected_nodes_ok: - "type_wf h \ document_ptr |\| document_ptr_kinds h \ h \ ok (get_disconnected_nodes document_ptr)" - apply(unfold type_wf_impl) - unfolding get_disconnected_nodes_impl[unfolded a_get_disconnected_nodes_def] using get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok - by fast - -lemma get_disconnected_nodes_ptr_in_heap: - "h \ ok (get_disconnected_nodes document_ptr) \ document_ptr |\| document_ptr_kinds h" - unfolding get_disconnected_nodes_impl[unfolded a_get_disconnected_nodes_def] - by (simp add: DocumentMonad.get_M_ptr_in_heap) - -lemma get_disconnected_nodes_pure [simp]: "pure (get_disconnected_nodes document_ptr) h" - unfolding get_disconnected_nodes_impl[unfolded a_get_disconnected_nodes_def] by simp - -lemma get_disconnected_nodes_reads: - "reads (get_disconnected_nodes_locs document_ptr) (get_disconnected_nodes document_ptr) h h'" - by(simp add: get_disconnected_nodes_impl[unfolded a_get_disconnected_nodes_def] - get_disconnected_nodes_locs_impl[unfolded a_get_disconnected_nodes_locs_def] - reads_bind_pure reads_insert_writes_set_right) -end - -locale l_get_disconnected_nodes = l_type_wf + l_get_disconnected_nodes_defs + - assumes get_disconnected_nodes_reads: - "reads (get_disconnected_nodes_locs document_ptr) (get_disconnected_nodes document_ptr) h h'" - assumes get_disconnected_nodes_ok: - "type_wf h \ document_ptr |\| document_ptr_kinds h \ h \ ok (get_disconnected_nodes document_ptr)" - assumes get_disconnected_nodes_ptr_in_heap: - "h \ ok (get_disconnected_nodes document_ptr) \ document_ptr |\| document_ptr_kinds h" - assumes get_disconnected_nodes_pure [simp]: - "pure (get_disconnected_nodes document_ptr) h" - -global_interpretation l_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs defines - get_disconnected_nodes = l_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_disconnected_nodes and - get_disconnected_nodes_locs = l_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_disconnected_nodes_locs . -interpretation - i_get_disconnected_nodes?: l_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_disconnected_nodes - get_disconnected_nodes_locs - apply(unfold_locales) - by (auto simp add: get_disconnected_nodes_def get_disconnected_nodes_locs_def) -declare l_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma get_disconnected_nodes_is_l_get_disconnected_nodes [instances]: - "l_get_disconnected_nodes type_wf get_disconnected_nodes get_disconnected_nodes_locs" - apply(simp add: l_get_disconnected_nodes_def) - using get_disconnected_nodes_reads get_disconnected_nodes_ok get_disconnected_nodes_ptr_in_heap - get_disconnected_nodes_pure - by blast+ - - -paragraph \set\_child\_nodes\ - -locale l_set_child_nodes_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_set_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M + - CD: l_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M -begin -lemma set_child_nodes_get_disconnected_nodes: - "\w \ a_set_child_nodes_locs ptr. (h \ w \\<^sub>h h' \ (\r \ a_get_disconnected_nodes_locs ptr'. r h h'))" - by(auto simp add: a_set_child_nodes_locs_def a_get_disconnected_nodes_locs_def all_args_def) -end - -locale l_set_child_nodes_get_disconnected_nodes = l_set_child_nodes + l_get_disconnected_nodes + - assumes set_child_nodes_get_disconnected_nodes: - "\w \ set_child_nodes_locs ptr. (h \ w \\<^sub>h h' \ (\r \ get_disconnected_nodes_locs ptr'. r h h'))" - -interpretation - i_set_child_nodes_get_disconnected_nodes?: l_set_child_nodes_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf - known_ptr set_child_nodes set_child_nodes_locs - get_disconnected_nodes get_disconnected_nodes_locs - by(unfold_locales) -declare l_set_child_nodes_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma set_child_nodes_get_disconnected_nodes_is_l_set_child_nodes_get_disconnected_nodes [instances]: - "l_set_child_nodes_get_disconnected_nodes type_wf set_child_nodes set_child_nodes_locs - get_disconnected_nodes get_disconnected_nodes_locs" - using set_child_nodes_is_l_set_child_nodes get_disconnected_nodes_is_l_get_disconnected_nodes - apply(simp add: l_set_child_nodes_get_disconnected_nodes_def - l_set_child_nodes_get_disconnected_nodes_axioms_def) - using set_child_nodes_get_disconnected_nodes - by fast - - -paragraph \set\_attribute\ - -locale l_set_attribute_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_set_attribute\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M + - l_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M -begin -lemma set_attribute_get_disconnected_nodes: - "\w \ a_set_attribute_locs ptr. (h \ w \\<^sub>h h' \ (\r \ a_get_disconnected_nodes_locs ptr'. r h h'))" - by(auto simp add: a_set_attribute_locs_def a_get_disconnected_nodes_locs_def all_args_def) -end - -locale l_set_attribute_get_disconnected_nodes = l_set_attribute + l_get_disconnected_nodes + - assumes set_attribute_get_disconnected_nodes: - "\w \ set_attribute_locs ptr. (h \ w \\<^sub>h h' \ (\r \ get_disconnected_nodes_locs ptr'. r h h'))" - -interpretation - i_set_attribute_get_disconnected_nodes?: l_set_attribute_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf - set_attribute set_attribute_locs get_disconnected_nodes get_disconnected_nodes_locs - by(unfold_locales) -declare l_set_attribute_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma set_attribute_get_disconnected_nodes_is_l_set_attribute_get_disconnected_nodes [instances]: - "l_set_attribute_get_disconnected_nodes type_wf set_attribute set_attribute_locs - get_disconnected_nodes get_disconnected_nodes_locs" - using set_attribute_is_l_set_attribute get_disconnected_nodes_is_l_get_disconnected_nodes - apply(simp add: l_set_attribute_get_disconnected_nodes_def - l_set_attribute_get_disconnected_nodes_axioms_def) - using set_attribute_get_disconnected_nodes - by fast - - -paragraph \new\_element\ - -locale l_new_element_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_disconnected_nodes get_disconnected_nodes_locs - for type_wf :: "(_) heap \ bool" - and get_disconnected_nodes :: "(_) document_ptr \ ((_) heap, exception, (_) node_ptr list) prog" - and get_disconnected_nodes_locs :: "(_) document_ptr \ ((_) heap \ (_) heap \ bool) set" -begin -lemma get_disconnected_nodes_new_element: - "h \ new_element \\<^sub>r new_element_ptr \ h \ new_element \\<^sub>h h' - \ r \ get_disconnected_nodes_locs ptr' \ r h h'" - by(auto simp add: get_disconnected_nodes_locs_def new_element_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t) -end - -locale l_new_element_get_disconnected_nodes = l_get_disconnected_nodes_defs + - assumes get_disconnected_nodes_new_element: - "h \ new_element \\<^sub>r new_element_ptr \ h \ new_element \\<^sub>h h' - \ r \ get_disconnected_nodes_locs ptr' \ r h h'" - -interpretation i_new_element_get_disconnected_nodes?: - l_new_element_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_disconnected_nodes - get_disconnected_nodes_locs - by unfold_locales -declare l_new_element_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma new_element_get_disconnected_nodes_is_l_new_element_get_disconnected_nodes [instances]: - "l_new_element_get_disconnected_nodes get_disconnected_nodes_locs" - by (simp add: get_disconnected_nodes_new_element l_new_element_get_disconnected_nodes_def) - - -paragraph \new\_character\_data\ - -locale l_new_character_data_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_disconnected_nodes get_disconnected_nodes_locs - for type_wf :: "(_) heap \ bool" - and get_disconnected_nodes :: "(_) document_ptr \ ((_) heap, exception, (_) node_ptr list) prog" - and get_disconnected_nodes_locs :: "(_) document_ptr \ ((_) heap \ (_) heap \ bool) set" -begin -lemma get_disconnected_nodes_new_character_data: - "h \ new_character_data \\<^sub>r new_character_data_ptr \ h \ new_character_data \\<^sub>h h' - \ r \ get_disconnected_nodes_locs ptr' \ r h h'" - by(auto simp add: get_disconnected_nodes_locs_def new_character_data_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t) -end - -locale l_new_character_data_get_disconnected_nodes = l_get_disconnected_nodes_defs + - assumes get_disconnected_nodes_new_character_data: - "h \ new_character_data \\<^sub>r new_character_data_ptr \ h \ new_character_data \\<^sub>h h' - \ r \ get_disconnected_nodes_locs ptr' \ r h h'" - -interpretation i_new_character_data_get_disconnected_nodes?: - l_new_character_data_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_disconnected_nodes - get_disconnected_nodes_locs - by unfold_locales -declare l_new_character_data_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma new_character_data_get_disconnected_nodes_is_l_new_character_data_get_disconnected_nodes [instances]: - "l_new_character_data_get_disconnected_nodes get_disconnected_nodes_locs" - by (simp add: get_disconnected_nodes_new_character_data l_new_character_data_get_disconnected_nodes_def) - - -paragraph \new\_document\ - -locale l_new_document_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_disconnected_nodes get_disconnected_nodes_locs - for type_wf :: "(_) heap \ bool" - and get_disconnected_nodes :: "(_) document_ptr \ ((_) heap, exception, (_) node_ptr list) prog" - and get_disconnected_nodes_locs :: "(_) document_ptr \ ((_) heap \ (_) heap \ bool) set" -begin -lemma get_disconnected_nodes_new_document_different_pointers: - "new_document_ptr \ ptr' \ h \ new_document \\<^sub>r new_document_ptr \ h \ new_document \\<^sub>h h' - \ r \ get_disconnected_nodes_locs ptr' \ r h h'" - by(auto simp add: get_disconnected_nodes_locs_def new_document_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t) - -lemma new_document_no_disconnected_nodes: - "h \ new_document \\<^sub>r new_document_ptr \ h \ new_document \\<^sub>h h' - \ h' \ get_disconnected_nodes new_document_ptr \\<^sub>r []" - by(simp add: get_disconnected_nodes_def new_document_disconnected_nodes) - -end - -interpretation i_new_document_get_disconnected_nodes?: - l_new_document_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_disconnected_nodes get_disconnected_nodes_locs - by unfold_locales -declare l_new_document_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -locale l_new_document_get_disconnected_nodes = l_get_disconnected_nodes_defs + - assumes get_disconnected_nodes_new_document_different_pointers: - "new_document_ptr \ ptr' \ h \ new_document \\<^sub>r new_document_ptr \ h \ new_document \\<^sub>h h' - \ r \ get_disconnected_nodes_locs ptr' \ r h h'" - assumes new_document_no_disconnected_nodes: - "h \ new_document \\<^sub>r new_document_ptr \ h \ new_document \\<^sub>h h' - \ h' \ get_disconnected_nodes new_document_ptr \\<^sub>r []" - -lemma new_document_get_disconnected_nodes_is_l_new_document_get_disconnected_nodes [instances]: - "l_new_document_get_disconnected_nodes get_disconnected_nodes get_disconnected_nodes_locs" - apply (auto simp add: l_new_document_get_disconnected_nodes_def)[1] - using get_disconnected_nodes_new_document_different_pointers apply fast - using new_document_no_disconnected_nodes apply blast - done - - - -subsubsection \set\_disconnected\_nodes\ - -locale l_set_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs -begin - -definition a_set_disconnected_nodes :: "(_) document_ptr \ (_) node_ptr list \ (_, unit) dom_prog" - where - "a_set_disconnected_nodes document_ptr disc_nodes = put_M document_ptr disconnected_nodes_update disc_nodes" -lemmas set_disconnected_nodes_defs = a_set_disconnected_nodes_def - -definition a_set_disconnected_nodes_locs :: "(_) document_ptr \ (_, unit) dom_prog set" - where - "a_set_disconnected_nodes_locs document_ptr \ all_args (put_M document_ptr disconnected_nodes_update)" -end - -locale l_set_disconnected_nodes_defs = - fixes set_disconnected_nodes :: "(_) document_ptr \ (_) node_ptr list \ (_, unit) dom_prog" - fixes set_disconnected_nodes_locs :: "(_) document_ptr \ (_, unit) dom_prog set" - -locale l_set_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_type_wf type_wf + - l_set_disconnected_nodes_defs set_disconnected_nodes set_disconnected_nodes_locs + - l_set_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs - for type_wf :: "(_) heap \ bool" - and set_disconnected_nodes :: "(_) document_ptr \ (_) node_ptr list \ (_, unit) dom_prog" - and set_disconnected_nodes_locs :: "(_) document_ptr \ (_, unit) dom_prog set" + - assumes type_wf_impl: "type_wf = DocumentClass.type_wf" - assumes set_disconnected_nodes_impl: "set_disconnected_nodes = a_set_disconnected_nodes" - assumes set_disconnected_nodes_locs_impl: "set_disconnected_nodes_locs = a_set_disconnected_nodes_locs" -begin -lemmas set_disconnected_nodes_def = set_disconnected_nodes_impl[unfolded a_set_disconnected_nodes_def] -lemmas set_disconnected_nodes_locs_def = set_disconnected_nodes_locs_impl[unfolded a_set_disconnected_nodes_locs_def] -lemma set_disconnected_nodes_ok: - "type_wf h \ document_ptr |\| document_ptr_kinds h \ h \ ok (set_disconnected_nodes document_ptr node_ptrs)" - by (simp add: type_wf_impl put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok set_disconnected_nodes_impl[unfolded a_set_disconnected_nodes_def]) - -lemma set_disconnected_nodes_ptr_in_heap: - "h \ ok (set_disconnected_nodes document_ptr disc_nodes) \ document_ptr |\| document_ptr_kinds h" - by (simp add: set_disconnected_nodes_impl[unfolded a_set_disconnected_nodes_def] - DocumentMonad.put_M_ptr_in_heap) - -lemma set_disconnected_nodes_writes: - "writes (set_disconnected_nodes_locs document_ptr) (set_disconnected_nodes document_ptr disc_nodes) h h'" - by(auto simp add: set_disconnected_nodes_impl[unfolded a_set_disconnected_nodes_def] - set_disconnected_nodes_locs_impl[unfolded a_set_disconnected_nodes_locs_def] - intro: writes_bind_pure) - -lemma set_disconnected_nodes_pointers_preserved: - assumes "w \ set_disconnected_nodes_locs object_ptr" - assumes "h \ w \\<^sub>h h'" - shows "object_ptr_kinds h = object_ptr_kinds h'" - using assms(1) object_ptr_kinds_preserved[OF writes_singleton2 assms(2)] - by(auto simp add: all_args_def set_disconnected_nodes_locs_impl[unfolded - a_set_disconnected_nodes_locs_def] - split: if_splits) - -lemma set_disconnected_nodes_typess_preserved: - assumes "w \ set_disconnected_nodes_locs object_ptr" - assumes "h \ w \\<^sub>h h'" - shows "type_wf h = type_wf h'" - using assms(1) type_wf_preserved[OF writes_singleton2 assms(2)] - apply(unfold type_wf_impl) - by(auto simp add: all_args_def - set_disconnected_nodes_locs_impl[unfolded a_set_disconnected_nodes_locs_def] - split: if_splits) -end - -locale l_set_disconnected_nodes = l_type_wf + l_set_disconnected_nodes_defs + - assumes set_disconnected_nodes_writes: - "writes (set_disconnected_nodes_locs document_ptr) (set_disconnected_nodes document_ptr disc_nodes) h h'" - assumes set_disconnected_nodes_ok: - "type_wf h \ document_ptr |\| document_ptr_kinds h \ h \ ok (set_disconnected_nodes document_ptr disc_noded)" - assumes set_disconnected_nodes_ptr_in_heap: - "h \ ok (set_disconnected_nodes document_ptr disc_noded) \ document_ptr |\| document_ptr_kinds h" - assumes set_disconnected_nodes_pointers_preserved: - "w \ set_disconnected_nodes_locs document_ptr \ h \ w \\<^sub>h h' \ object_ptr_kinds h = object_ptr_kinds h'" - assumes set_disconnected_nodes_types_preserved: - "w \ set_disconnected_nodes_locs document_ptr \ h \ w \\<^sub>h h' \ type_wf h = type_wf h'" - -global_interpretation l_set_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs defines - set_disconnected_nodes = l_set_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_set_disconnected_nodes and - set_disconnected_nodes_locs = l_set_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_set_disconnected_nodes_locs . -interpretation - i_set_disconnected_nodes?: l_set_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf set_disconnected_nodes - set_disconnected_nodes_locs - apply unfold_locales - by (auto simp add: set_disconnected_nodes_def set_disconnected_nodes_locs_def) -declare l_set_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma set_disconnected_nodes_is_l_set_disconnected_nodes [instances]: - "l_set_disconnected_nodes type_wf set_disconnected_nodes set_disconnected_nodes_locs" - apply(simp add: l_set_disconnected_nodes_def) - using set_disconnected_nodes_ok set_disconnected_nodes_writes set_disconnected_nodes_pointers_preserved - set_disconnected_nodes_ptr_in_heap set_disconnected_nodes_typess_preserved - by blast+ - - -paragraph \get\_disconnected\_nodes\ - -locale l_set_disconnected_nodes_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = l_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M - + l_set_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M -begin -lemma set_disconnected_nodes_get_disconnected_nodes: - assumes "h \ a_set_disconnected_nodes document_ptr disc_nodes \\<^sub>h h'" - shows "h' \ a_get_disconnected_nodes document_ptr \\<^sub>r disc_nodes" - using assms - by(auto simp add: a_get_disconnected_nodes_def a_set_disconnected_nodes_def) - -lemma set_disconnected_nodes_get_disconnected_nodes_different_pointers: - assumes "ptr \ ptr'" - assumes "w \ a_set_disconnected_nodes_locs ptr" - assumes "h \ w \\<^sub>h h'" - assumes "r \ a_get_disconnected_nodes_locs ptr'" - shows "r h h'" - using assms - by(auto simp add: all_args_def a_set_disconnected_nodes_locs_def a_get_disconnected_nodes_locs_def - split: if_splits option.splits ) -end - -locale l_set_disconnected_nodes_get_disconnected_nodes = l_get_disconnected_nodes - + l_set_disconnected_nodes + - assumes set_disconnected_nodes_get_disconnected_nodes: - "h \ set_disconnected_nodes document_ptr disc_nodes \\<^sub>h h' - \ h' \ get_disconnected_nodes document_ptr \\<^sub>r disc_nodes" - assumes set_disconnected_nodes_get_disconnected_nodes_different_pointers: - "ptr \ ptr' \ w \ set_disconnected_nodes_locs ptr \ h \ w \\<^sub>h h' - \ r \ get_disconnected_nodes_locs ptr' \ r h h'" - -interpretation i_set_disconnected_nodes_get_disconnected_nodes?: - l_set_disconnected_nodes_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_disconnected_nodes - get_disconnected_nodes_locs set_disconnected_nodes set_disconnected_nodes_locs - by unfold_locales -declare l_set_disconnected_nodes_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma set_disconnected_nodes_get_disconnected_nodes_is_l_set_disconnected_nodes_get_disconnected_nodes [instances]: - "l_set_disconnected_nodes_get_disconnected_nodes type_wf get_disconnected_nodes get_disconnected_nodes_locs - set_disconnected_nodes set_disconnected_nodes_locs" - using set_disconnected_nodes_is_l_set_disconnected_nodes get_disconnected_nodes_is_l_get_disconnected_nodes - apply(simp add: l_set_disconnected_nodes_get_disconnected_nodes_def - l_set_disconnected_nodes_get_disconnected_nodes_axioms_def) - using set_disconnected_nodes_get_disconnected_nodes - set_disconnected_nodes_get_disconnected_nodes_different_pointers - by fast+ - - -paragraph \get\_child\_nodes\ - -locale l_set_disconnected_nodes_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_set_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M + - l_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M -begin -lemma set_disconnected_nodes_get_child_nodes: - "\w \ set_disconnected_nodes_locs ptr. (h \ w \\<^sub>h h' \ (\r \ get_child_nodes_locs ptr'. r h h'))" - by(auto simp add: set_disconnected_nodes_locs_impl[unfolded a_set_disconnected_nodes_locs_def] - get_child_nodes_locs_impl[unfolded a_get_child_nodes_locs_def] all_args_def) -end - -locale l_set_disconnected_nodes_get_child_nodes = l_set_disconnected_nodes_defs + l_get_child_nodes_defs + - assumes set_disconnected_nodes_get_child_nodes [simp]: - "\w \ set_disconnected_nodes_locs ptr. (h \ w \\<^sub>h h' \ (\r \ get_child_nodes_locs ptr'. r h h'))" - -interpretation - i_set_disconnected_nodes_get_child_nodes?: l_set_disconnected_nodes_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M - type_wf - set_disconnected_nodes set_disconnected_nodes_locs - known_ptr get_child_nodes get_child_nodes_locs - by unfold_locales -declare l_set_disconnected_nodes_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma set_disconnected_nodes_get_child_nodes_is_l_set_disconnected_nodes_get_child_nodes [instances]: - "l_set_disconnected_nodes_get_child_nodes set_disconnected_nodes_locs get_child_nodes_locs" - using set_disconnected_nodes_is_l_set_disconnected_nodes get_child_nodes_is_l_get_child_nodes - apply(simp add: l_set_disconnected_nodes_get_child_nodes_def) - using set_disconnected_nodes_get_child_nodes - by fast - - -subsubsection \get\_tag\_name\ - -locale l_get_tag_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs -begin -definition a_get_tag_name :: "(_) element_ptr \ (_, tag_type) dom_prog" - where - "a_get_tag_name element_ptr = get_M element_ptr tag_type" - -definition a_get_tag_name_locs :: "(_) element_ptr \ ((_) heap \ (_) heap \ bool) set" - where - "a_get_tag_name_locs element_ptr \ {preserved (get_M element_ptr tag_type)}" -end - -locale l_get_tag_name_defs = - fixes get_tag_name :: "(_) element_ptr \ (_, tag_type) dom_prog" - fixes get_tag_name_locs :: "(_) element_ptr \ ((_) heap \ (_) heap \ bool) set" - -locale l_get_tag_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_type_wf type_wf + - l_get_tag_name_defs get_tag_name get_tag_name_locs + - l_get_tag_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs - for type_wf :: "(_) heap \ bool" - and get_tag_name :: "(_) element_ptr \ (_, tag_type) dom_prog" - and get_tag_name_locs :: "(_) element_ptr \ ((_) heap \ (_) heap \ bool) set" + - assumes type_wf_impl: "type_wf = DocumentClass.type_wf" - assumes get_tag_name_impl: "get_tag_name = a_get_tag_name" - assumes get_tag_name_locs_impl: "get_tag_name_locs = a_get_tag_name_locs" -begin -lemmas get_tag_name_def = get_tag_name_impl[unfolded a_get_tag_name_def] -lemmas get_tag_name_locs_def = get_tag_name_locs_impl[unfolded a_get_tag_name_locs_def] - - - -lemma get_tag_name_ok: - "type_wf h \ element_ptr |\| element_ptr_kinds h \ h \ ok (get_tag_name element_ptr)" - apply(unfold type_wf_impl get_tag_name_impl[unfolded a_get_tag_name_def]) - using get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok - by blast - -lemma get_tag_name_pure [simp]: "pure (get_tag_name element_ptr) h" - unfolding get_tag_name_impl[unfolded a_get_tag_name_def] - by simp - -lemma get_tag_name_ptr_in_heap [simp]: - assumes "h \ get_tag_name element_ptr \\<^sub>r children" - shows "element_ptr |\| element_ptr_kinds h" - using assms - by(auto simp add: get_tag_name_impl[unfolded a_get_tag_name_def] get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ptr_in_heap - dest: is_OK_returns_result_I) - -lemma get_tag_name_reads: "reads (get_tag_name_locs element_ptr) (get_tag_name element_ptr) h h'" - by(simp add: get_tag_name_impl[unfolded a_get_tag_name_def] - get_tag_name_locs_impl[unfolded a_get_tag_name_locs_def] reads_bind_pure - reads_insert_writes_set_right) -end - -locale l_get_tag_name = l_type_wf + l_get_tag_name_defs + - assumes get_tag_name_reads: - "reads (get_tag_name_locs element_ptr) (get_tag_name element_ptr) h h'" - assumes get_tag_name_ok: - "type_wf h \ element_ptr |\| element_ptr_kinds h \ h \ ok (get_tag_name element_ptr)" - assumes get_tag_name_ptr_in_heap: - "h \ ok (get_tag_name element_ptr) \ element_ptr |\| element_ptr_kinds h" - assumes get_tag_name_pure [simp]: - "pure (get_tag_name element_ptr) h" - - -global_interpretation l_get_tag_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs defines - get_tag_name = l_get_tag_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_tag_name and - get_tag_name_locs = l_get_tag_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_tag_name_locs . - -interpretation - i_get_tag_name?: l_get_tag_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_tag_name get_tag_name_locs - apply(unfold_locales) - by (auto simp add: get_tag_name_def get_tag_name_locs_def) -declare l_get_tag_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma get_tag_name_is_l_get_tag_name [instances]: - "l_get_tag_name type_wf get_tag_name get_tag_name_locs" - apply(unfold_locales) - using get_tag_name_reads get_tag_name_ok get_tag_name_ptr_in_heap get_tag_name_pure - by blast+ - - -paragraph \set\_disconnected\_nodes\ - -locale l_set_disconnected_nodes_get_tag_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_set_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M + - l_get_tag_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M -begin -lemma set_disconnected_nodes_get_tag_name: - "\w \ a_set_disconnected_nodes_locs ptr. (h \ w \\<^sub>h h' \ (\r \ a_get_tag_name_locs ptr'. r h h'))" - by(auto simp add: a_set_disconnected_nodes_locs_def a_get_tag_name_locs_def all_args_def) -end - -locale l_set_disconnected_nodes_get_tag_name = l_set_disconnected_nodes + l_get_tag_name + - assumes set_disconnected_nodes_get_tag_name: - "\w \ set_disconnected_nodes_locs ptr. (h \ w \\<^sub>h h' \ (\r \ get_tag_name_locs ptr'. r h h'))" - -interpretation - i_set_disconnected_nodes_get_tag_name?: l_set_disconnected_nodes_get_tag_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf - set_disconnected_nodes set_disconnected_nodes_locs - get_tag_name get_tag_name_locs - by unfold_locales -declare l_set_disconnected_nodes_get_tag_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma set_disconnected_nodes_get_tag_name_is_l_set_disconnected_nodes_get_tag_name [instances]: - "l_set_disconnected_nodes_get_tag_name type_wf set_disconnected_nodes set_disconnected_nodes_locs - get_tag_name get_tag_name_locs" - using set_disconnected_nodes_is_l_set_disconnected_nodes get_tag_name_is_l_get_tag_name - apply(simp add: l_set_disconnected_nodes_get_tag_name_def l_set_disconnected_nodes_get_tag_name_axioms_def) - using set_disconnected_nodes_get_tag_name - by fast - - -paragraph \set\_child\_nodes\ - -locale l_set_child_nodes_get_tag_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_set_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M + - l_get_tag_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M -begin -lemma set_child_nodes_get_tag_name: - "\w \ set_child_nodes_locs ptr. (h \ w \\<^sub>h h' \ (\r \ get_tag_name_locs ptr'. r h h'))" - by(auto simp add: set_child_nodes_locs_def get_tag_name_locs_def all_args_def - intro: element_put_get_preserved[where getter=tag_type and setter=child_nodes_update]) -end - -locale l_set_child_nodes_get_tag_name = l_set_child_nodes + l_get_tag_name + - assumes set_child_nodes_get_tag_name: - "\w \ set_child_nodes_locs ptr. (h \ w \\<^sub>h h' \ (\r \ get_tag_name_locs ptr'. r h h'))" - -interpretation - i_set_child_nodes_get_tag_name?: l_set_child_nodes_get_tag_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr - set_child_nodes set_child_nodes_locs get_tag_name get_tag_name_locs - by unfold_locales -declare l_set_child_nodes_get_tag_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma set_child_nodes_get_tag_name_is_l_set_child_nodes_get_tag_name [instances]: - "l_set_child_nodes_get_tag_name type_wf set_child_nodes set_child_nodes_locs get_tag_name get_tag_name_locs" - using set_child_nodes_is_l_set_child_nodes get_tag_name_is_l_get_tag_name - apply(simp add: l_set_child_nodes_get_tag_name_def l_set_child_nodes_get_tag_name_axioms_def) - using set_child_nodes_get_tag_name - by fast - - -subsubsection \set\_tag\_type\ - -locale l_set_tag_type\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs -begin - -definition a_set_tag_type :: "(_) element_ptr \ tag_type \ (_, unit) dom_prog" - where - "a_set_tag_type ptr tag = do { - m \ get_M ptr attrs; - put_M ptr tag_type_update tag - }" -lemmas set_tag_type_defs = a_set_tag_type_def - -definition a_set_tag_type_locs :: "(_) element_ptr \ (_, unit) dom_prog set" - where - "a_set_tag_type_locs element_ptr \ all_args (put_M element_ptr tag_type_update)" -end - -locale l_set_tag_type_defs = - fixes set_tag_type :: "(_) element_ptr \ tag_type \ (_, unit) dom_prog" - fixes set_tag_type_locs :: "(_) element_ptr \ (_, unit) dom_prog set" - -locale l_set_tag_type\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_type_wf type_wf + - l_set_tag_type_defs set_tag_type set_tag_type_locs + - l_set_tag_type\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs - for type_wf :: "(_) heap \ bool" - and set_tag_type :: "(_) element_ptr \ char list \ (_, unit) dom_prog" - and set_tag_type_locs :: "(_) element_ptr \ (_, unit) dom_prog set" + - assumes type_wf_impl: "type_wf = DocumentClass.type_wf" - assumes set_tag_type_impl: "set_tag_type = a_set_tag_type" - assumes set_tag_type_locs_impl: "set_tag_type_locs = a_set_tag_type_locs" -begin - -lemma set_tag_type_ok: - "type_wf h \ element_ptr |\| element_ptr_kinds h \ h \ ok (set_tag_type element_ptr tag)" - apply(unfold type_wf_impl) - unfolding set_tag_type_impl[unfolded a_set_tag_type_def] using get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok - by (metis (no_types, lifting) DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t ElementMonad.get_M_pure bind_is_OK_E - bind_is_OK_pure_I is_OK_returns_result_I) - -lemma set_tag_type_writes: - "writes (set_tag_type_locs element_ptr) (set_tag_type element_ptr tag) h h'" - by(auto simp add: set_tag_type_impl[unfolded a_set_tag_type_def] - set_tag_type_locs_impl[unfolded a_set_tag_type_locs_def] intro: writes_bind_pure) - -lemma set_tag_type_pointers_preserved: - assumes "w \ set_tag_type_locs element_ptr" - assumes "h \ w \\<^sub>h h'" - shows "object_ptr_kinds h = object_ptr_kinds h'" - using assms(1) object_ptr_kinds_preserved[OF writes_singleton2 assms(2)] - by(auto simp add: all_args_def set_tag_type_locs_impl[unfolded a_set_tag_type_locs_def] - split: if_splits) - -lemma set_tag_type_typess_preserved: - assumes "w \ set_tag_type_locs element_ptr" - assumes "h \ w \\<^sub>h h'" - shows "type_wf h = type_wf h'" - apply(unfold type_wf_impl) - using assms(1) type_wf_preserved[OF writes_singleton2 assms(2)] - by(auto simp add: all_args_def set_tag_type_locs_impl[unfolded a_set_tag_type_locs_def] - split: if_splits) -end - -locale l_set_tag_type = l_type_wf + l_set_tag_type_defs + - assumes set_tag_type_writes: - "writes (set_tag_type_locs element_ptr) (set_tag_type element_ptr tag) h h'" - assumes set_tag_type_ok: - "type_wf h \ element_ptr |\| element_ptr_kinds h \ h \ ok (set_tag_type element_ptr tag)" - assumes set_tag_type_pointers_preserved: - "w \ set_tag_type_locs element_ptr \ h \ w \\<^sub>h h' \ object_ptr_kinds h = object_ptr_kinds h'" - assumes set_tag_type_types_preserved: - "w \ set_tag_type_locs element_ptr \ h \ w \\<^sub>h h' \ type_wf h = type_wf h'" - - -global_interpretation l_set_tag_type\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs defines - set_tag_type = l_set_tag_type\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_set_tag_type and - set_tag_type_locs = l_set_tag_type\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_set_tag_type_locs . -interpretation - i_set_tag_type?: l_set_tag_type\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf set_tag_type set_tag_type_locs - apply(unfold_locales) - by (auto simp add: set_tag_type_def set_tag_type_locs_def) -declare l_set_tag_type\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma set_tag_type_is_l_set_tag_type [instances]: - "l_set_tag_type type_wf set_tag_type set_tag_type_locs" - apply(simp add: l_set_tag_type_def) - using set_tag_type_ok set_tag_type_writes set_tag_type_pointers_preserved - set_tag_type_typess_preserved - by blast - -paragraph \get\_child\_nodes\ - -locale l_set_tag_type_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_set_tag_type\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M + - l_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M -begin -lemma set_tag_type_get_child_nodes: - "\w \ set_tag_type_locs ptr. (h \ w \\<^sub>h h' \ (\r \ get_child_nodes_locs ptr'. r h h'))" - by(auto simp add: set_tag_type_locs_impl[unfolded a_set_tag_type_locs_def] - get_child_nodes_locs_impl[unfolded a_get_child_nodes_locs_def] all_args_def - intro: element_put_get_preserved[where setter=tag_type_update and getter=child_nodes]) -end - -locale l_set_tag_type_get_child_nodes = l_set_tag_type + l_get_child_nodes + - assumes set_tag_type_get_child_nodes: - "\w \ set_tag_type_locs ptr. (h \ w \\<^sub>h h' \ (\r \ get_child_nodes_locs ptr'. r h h'))" - -interpretation - i_set_tag_type_get_child_nodes?: l_set_tag_type_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf - set_tag_type set_tag_type_locs known_ptr - get_child_nodes get_child_nodes_locs - by unfold_locales -declare l_set_tag_type_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma set_tag_type_get_child_nodes_is_l_set_tag_type_get_child_nodes [instances]: - "l_set_tag_type_get_child_nodes type_wf set_tag_type set_tag_type_locs known_ptr get_child_nodes - get_child_nodes_locs" - using set_tag_type_is_l_set_tag_type get_child_nodes_is_l_get_child_nodes - apply(simp add: l_set_tag_type_get_child_nodes_def l_set_tag_type_get_child_nodes_axioms_def) - using set_tag_type_get_child_nodes - by fast - - -paragraph \get\_disconnected\_nodes\ - -locale l_set_tag_type_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_set_tag_type\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M + - l_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M -begin -lemma set_tag_type_get_disconnected_nodes: - "\w \ set_tag_type_locs ptr. (h \ w \\<^sub>h h' \ (\r \ get_disconnected_nodes_locs ptr'. r h h'))" - by(auto simp add: set_tag_type_locs_impl[unfolded a_set_tag_type_locs_def] - get_disconnected_nodes_locs_impl[unfolded a_get_disconnected_nodes_locs_def] - all_args_def) -end - -locale l_set_tag_type_get_disconnected_nodes = l_set_tag_type + l_get_disconnected_nodes + - assumes set_tag_type_get_disconnected_nodes: - "\w \ set_tag_type_locs ptr. (h \ w \\<^sub>h h' \ (\r \ get_disconnected_nodes_locs ptr'. r h h'))" - -interpretation - i_set_tag_type_get_disconnected_nodes?: l_set_tag_type_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf - set_tag_type set_tag_type_locs get_disconnected_nodes - get_disconnected_nodes_locs - by unfold_locales -declare l_set_tag_type_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma set_tag_type_get_disconnected_nodes_is_l_set_tag_type_get_disconnected_nodes [instances]: - "l_set_tag_type_get_disconnected_nodes type_wf set_tag_type set_tag_type_locs get_disconnected_nodes - get_disconnected_nodes_locs" - using set_tag_type_is_l_set_tag_type get_disconnected_nodes_is_l_get_disconnected_nodes - apply(simp add: l_set_tag_type_get_disconnected_nodes_def - l_set_tag_type_get_disconnected_nodes_axioms_def) - using set_tag_type_get_disconnected_nodes - by fast - - -subsubsection \set\_val\ - -locale l_set_val\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs -begin - -definition a_set_val :: "(_) character_data_ptr \ DOMString \ (_, unit) dom_prog" - where - "a_set_val ptr v = do { - m \ get_M ptr val; - put_M ptr val_update v - }" -lemmas set_val_defs = a_set_val_def - -definition a_set_val_locs :: "(_) character_data_ptr \ (_, unit) dom_prog set" - where - "a_set_val_locs character_data_ptr \ all_args (put_M character_data_ptr val_update)" -end - -locale l_set_val_defs = - fixes set_val :: "(_) character_data_ptr \ DOMString \ (_, unit) dom_prog" - fixes set_val_locs :: "(_) character_data_ptr \ (_, unit) dom_prog set" - -locale l_set_val\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_type_wf type_wf + - l_set_val_defs set_val set_val_locs + - l_set_val\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs - for type_wf :: "(_) heap \ bool" - and set_val :: "(_) character_data_ptr \ char list \ (_, unit) dom_prog" - and set_val_locs :: "(_) character_data_ptr \ (_, unit) dom_prog set" + - assumes type_wf_impl: "type_wf = DocumentClass.type_wf" - assumes set_val_impl: "set_val = a_set_val" - assumes set_val_locs_impl: "set_val_locs = a_set_val_locs" -begin - -lemma set_val_ok: - "type_wf h \ character_data_ptr |\| character_data_ptr_kinds h \ h \ ok (set_val character_data_ptr tag)" - apply(unfold type_wf_impl) - unfolding set_val_impl[unfolded a_set_val_def] using get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_ok put_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_ok - by (metis (no_types, lifting) DocumentClass.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a CharacterDataMonad.get_M_pure - bind_is_OK_E bind_is_OK_pure_I is_OK_returns_result_I) - -lemma set_val_writes: "writes (set_val_locs character_data_ptr) (set_val character_data_ptr tag) h h'" - by(auto simp add: set_val_impl[unfolded a_set_val_def] set_val_locs_impl[unfolded a_set_val_locs_def] - intro: writes_bind_pure) - -lemma set_val_pointers_preserved: - assumes "w \ set_val_locs character_data_ptr" - assumes "h \ w \\<^sub>h h'" - shows "object_ptr_kinds h = object_ptr_kinds h'" - using assms(1) object_ptr_kinds_preserved[OF writes_singleton2 assms(2)] - by(auto simp add: all_args_def set_val_locs_impl[unfolded a_set_val_locs_def] split: if_splits) - -lemma set_val_typess_preserved: - assumes "w \ set_val_locs character_data_ptr" - assumes "h \ w \\<^sub>h h'" - shows "type_wf h = type_wf h'" - apply(unfold type_wf_impl) - using assms(1) type_wf_preserved[OF writes_singleton2 assms(2)] - by(auto simp add: all_args_def set_val_locs_impl[unfolded a_set_val_locs_def] split: if_splits) -end - -locale l_set_val = l_type_wf + l_set_val_defs + - assumes set_val_writes: - "writes (set_val_locs character_data_ptr) (set_val character_data_ptr tag) h h'" - assumes set_val_ok: - "type_wf h \ character_data_ptr |\| character_data_ptr_kinds h \ h \ ok (set_val character_data_ptr tag)" - assumes set_val_pointers_preserved: - "w \ set_val_locs character_data_ptr \ h \ w \\<^sub>h h' \ object_ptr_kinds h = object_ptr_kinds h'" - assumes set_val_types_preserved: - "w \ set_val_locs character_data_ptr \ h \ w \\<^sub>h h' \ type_wf h = type_wf h'" - - -global_interpretation l_set_val\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs defines - set_val = l_set_val\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_set_val and - set_val_locs = l_set_val\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_set_val_locs . -interpretation - i_set_val?: l_set_val\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf set_val set_val_locs - apply(unfold_locales) - by (auto simp add: set_val_def set_val_locs_def) -declare l_set_val\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma set_val_is_l_set_val [instances]: "l_set_val type_wf set_val set_val_locs" - apply(simp add: l_set_val_def) - using set_val_ok set_val_writes set_val_pointers_preserved set_val_typess_preserved - by blast - -paragraph \get\_child\_nodes\ - -locale l_set_val_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_set_val\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M + - l_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M -begin -lemma set_val_get_child_nodes: - "\w \ set_val_locs ptr. (h \ w \\<^sub>h h' \ (\r \ get_child_nodes_locs ptr'. r h h'))" - by(auto simp add: set_val_locs_impl[unfolded a_set_val_locs_def] - get_child_nodes_locs_impl[unfolded a_get_child_nodes_locs_def] all_args_def) -end - -locale l_set_val_get_child_nodes = l_set_val + l_get_child_nodes + - assumes set_val_get_child_nodes: - "\w \ set_val_locs ptr. (h \ w \\<^sub>h h' \ (\r \ get_child_nodes_locs ptr'. r h h'))" - -interpretation - i_set_val_get_child_nodes?: l_set_val_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf set_val set_val_locs known_ptr - get_child_nodes get_child_nodes_locs - by unfold_locales -declare l_set_val_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma set_val_get_child_nodes_is_l_set_val_get_child_nodes [instances]: - "l_set_val_get_child_nodes type_wf set_val set_val_locs known_ptr get_child_nodes get_child_nodes_locs" - using set_val_is_l_set_val get_child_nodes_is_l_get_child_nodes - apply(simp add: l_set_val_get_child_nodes_def l_set_val_get_child_nodes_axioms_def) - using set_val_get_child_nodes - by fast - - -paragraph \get\_disconnected\_nodes\ - -locale l_set_val_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_set_val\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M + - l_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M -begin -lemma set_val_get_disconnected_nodes: - "\w \ set_val_locs ptr. (h \ w \\<^sub>h h' \ (\r \ get_disconnected_nodes_locs ptr'. r h h'))" - by(auto simp add: set_val_locs_impl[unfolded a_set_val_locs_def] - get_disconnected_nodes_locs_impl[unfolded a_get_disconnected_nodes_locs_def] - all_args_def) -end - -locale l_set_val_get_disconnected_nodes = l_set_val + l_get_disconnected_nodes + - assumes set_val_get_disconnected_nodes: - "\w \ set_val_locs ptr. (h \ w \\<^sub>h h' \ (\r \ get_disconnected_nodes_locs ptr'. r h h'))" - -interpretation - i_set_val_get_disconnected_nodes?: l_set_val_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf set_val - set_val_locs get_disconnected_nodes get_disconnected_nodes_locs - by unfold_locales -declare l_set_val_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma set_val_get_disconnected_nodes_is_l_set_val_get_disconnected_nodes [instances]: - "l_set_val_get_disconnected_nodes type_wf set_val set_val_locs get_disconnected_nodes get_disconnected_nodes_locs" - using set_val_is_l_set_val get_disconnected_nodes_is_l_get_disconnected_nodes - apply(simp add: l_set_val_get_disconnected_nodes_def l_set_val_get_disconnected_nodes_axioms_def) - using set_val_get_disconnected_nodes - by fast - - - -subsubsection \get\_parent\ - -locale l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs = - l_get_child_nodes_defs get_child_nodes get_child_nodes_locs - for get_child_nodes :: "(_::linorder) object_ptr \ (_, (_) node_ptr list) dom_prog" - and get_child_nodes_locs :: "(_) object_ptr \ ((_) heap \ (_) heap \ bool) set" -begin -definition a_get_parent :: "(_) node_ptr \ (_, (_::linorder) object_ptr option) dom_prog" - where - "a_get_parent node_ptr = do { - check_in_heap (cast node_ptr); - parent_ptrs \ object_ptr_kinds_M \ filter_M (\ptr. do { - children \ get_child_nodes ptr; - return (node_ptr \ set children) - }); - (if parent_ptrs = [] - then return None - else return (Some (hd parent_ptrs))) - }" - -definition - "a_get_parent_locs \ (\ptr. get_child_nodes_locs ptr \ {preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr RObject.nothing)})" -end - -locale l_get_parent_defs = - fixes get_parent :: "(_) node_ptr \ (_, (_::linorder) object_ptr option) dom_prog" - fixes get_parent_locs :: "((_) heap \ (_) heap \ bool) set" - -locale l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_get_child_nodes type_wf known_ptr get_child_nodes get_child_nodes_locs + - l_known_ptrs known_ptr known_ptrs + - l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_child_nodes get_child_nodes_locs + - l_get_parent_defs get_parent get_parent_locs - for known_ptr :: "(_::linorder) object_ptr \ bool" - and type_wf :: "(_) heap \ bool" - and get_child_nodes (* :: "(_) object_ptr \ (_, (_) node_ptr list) dom_prog" *) - and get_child_nodes_locs (* :: "(_) object_ptr \ ((_) heap \ (_) heap \ bool) set" *) - and known_ptrs :: "(_) heap \ bool" - and get_parent :: "(_) node_ptr \ ((_) heap, exception, (_) object_ptr option) prog" - and get_parent_locs (* :: "((_) heap \ (_) heap \ bool) set" *) + - assumes get_parent_impl: "get_parent = a_get_parent" - assumes get_parent_locs_impl: "get_parent_locs = a_get_parent_locs" -begin -lemmas get_parent_def = get_parent_impl[unfolded a_get_parent_def] -lemmas get_parent_locs_def = get_parent_locs_impl[unfolded a_get_parent_locs_def] - -lemma get_parent_pure [simp]: "pure (get_parent ptr) h" - using get_child_nodes_pure - by(auto simp add: get_parent_def intro!: bind_pure_I filter_M_pure_I) - -lemma get_parent_ok [simp]: - assumes "type_wf h" - assumes "known_ptrs h" - assumes "ptr |\| node_ptr_kinds h" - shows "h \ ok (get_parent ptr)" - using assms get_child_nodes_ok get_child_nodes_pure - by(auto simp add: get_parent_impl[unfolded a_get_parent_def] known_ptrs_known_ptr - intro!: bind_is_OK_pure_I filter_M_pure_I filter_M_is_OK_I bind_pure_I) - -lemma get_parent_ptr_in_heap [simp]: "h \ ok (get_parent node_ptr) \ node_ptr |\| node_ptr_kinds h" - using get_parent_def is_OK_returns_result_I check_in_heap_ptr_in_heap - by (metis (no_types, lifting) bind_returns_heap_E get_parent_pure node_ptr_kinds_commutes pure_pure) - -lemma get_parent_parent_in_heap: - assumes "h \ get_parent child_node \\<^sub>r Some parent" - shows "parent |\| object_ptr_kinds h" - using assms get_child_nodes_pure - by(auto simp add: get_parent_def elim!: bind_returns_result_E2 - dest!: filter_M_not_more_elements[where x=parent] - intro!: filter_M_pure_I bind_pure_I - split: if_splits) - -lemma get_parent_child_dual: - assumes "h \ get_parent child \\<^sub>r Some ptr" - obtains children where "h \ get_child_nodes ptr \\<^sub>r children" and "child \ set children" - using assms get_child_nodes_pure - by(auto simp add: get_parent_def bind_pure_I - dest!: filter_M_holds_for_result - elim!: bind_returns_result_E2 - intro!: filter_M_pure_I - split: if_splits) - -lemma get_parent_reads: "reads get_parent_locs (get_parent node_ptr) h h'" - using get_child_nodes_reads[unfolded reads_def] - by(auto simp add: get_parent_def get_parent_locs_def - intro!: reads_bind_pure reads_subset[OF check_in_heap_reads] - reads_subset[OF get_child_nodes_reads] reads_subset[OF return_reads] - reads_subset[OF object_ptr_kinds_M_reads] filter_M_reads filter_M_pure_I bind_pure_I) - -lemma get_parent_reads_pointers: "preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr RObject.nothing) \ get_parent_locs" - by(auto simp add: get_parent_locs_def) -end - -locale l_get_parent = l_type_wf + l_known_ptrs + l_get_parent_defs + l_get_child_nodes + - assumes get_parent_reads: - "reads get_parent_locs (get_parent node_ptr) h h'" - assumes get_parent_ok: - "type_wf h \ known_ptrs h \ node_ptr |\| node_ptr_kinds h \ h \ ok (get_parent node_ptr)" - assumes get_parent_ptr_in_heap: - "h \ ok (get_parent node_ptr) \ node_ptr |\| node_ptr_kinds h" - assumes get_parent_pure [simp]: - "pure (get_parent node_ptr) h" - assumes get_parent_parent_in_heap: - "h \ get_parent child_node \\<^sub>r Some parent \ parent |\| object_ptr_kinds h" - assumes get_parent_child_dual: - "h \ get_parent child \\<^sub>r Some ptr \ (\children. h \ get_child_nodes ptr \\<^sub>r children - \ child \ set children \ thesis) \ thesis" - assumes get_parent_reads_pointers: - "preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr RObject.nothing) \ get_parent_locs" - -global_interpretation l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_child_nodes get_child_nodes_locs defines - get_parent = "l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_parent get_child_nodes" and - get_parent_locs = "l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_parent_locs get_child_nodes_locs" . - -interpretation - i_get_parent?: l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf get_child_nodes get_child_nodes_locs known_ptrs - get_parent get_parent_locs - using instances - apply(simp add: l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def) - apply(simp add: get_parent_def get_parent_locs_def) - done -declare l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma get_parent_is_l_get_parent [instances]: - "l_get_parent type_wf known_ptr known_ptrs get_parent get_parent_locs get_child_nodes get_child_nodes_locs" - using instances - apply(auto simp add: l_get_parent_def l_get_parent_axioms_def)[1] - using get_parent_reads get_parent_ok get_parent_ptr_in_heap get_parent_pure - get_parent_parent_in_heap get_parent_child_dual - using get_parent_reads_pointers - by blast+ - - -paragraph \set\_disconnected\_nodes\ - -locale l_set_disconnected_nodes_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_set_disconnected_nodes_get_child_nodes - set_disconnected_nodes set_disconnected_nodes_locs get_child_nodes get_child_nodes_locs - + l_set_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M - type_wf set_disconnected_nodes set_disconnected_nodes_locs - + l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M - known_ptr type_wf get_child_nodes get_child_nodes_locs known_ptrs get_parent get_parent_locs - for known_ptr :: "(_::linorder) object_ptr \ bool" - and type_wf :: "(_) heap \ bool" - and set_disconnected_nodes :: "(_) document_ptr \ (_) node_ptr list \ ((_) heap, exception, unit) prog" - and set_disconnected_nodes_locs :: "(_) document_ptr \ ((_) heap, exception, unit) prog set" - and get_child_nodes :: "(_) object_ptr \ ((_) heap, exception, (_) node_ptr list) prog" - and get_child_nodes_locs :: "(_) object_ptr \ ((_) heap \ (_) heap \ bool) set" - and known_ptrs :: "(_) heap \ bool" - and get_parent :: "(_) node_ptr \ ((_) heap, exception, (_) object_ptr option) prog" - and get_parent_locs :: "((_) heap \ (_) heap \ bool) set" -begin -lemma set_disconnected_nodes_get_parent [simp]: - "\w \ set_disconnected_nodes_locs ptr. (h \ w \\<^sub>h h' \ (\r \ get_parent_locs. r h h'))" - by(auto simp add: get_parent_locs_def set_disconnected_nodes_locs_def all_args_def) -end - -locale l_set_disconnected_nodes_get_parent = l_set_disconnected_nodes_defs + l_get_parent_defs + - assumes set_disconnected_nodes_get_parent [simp]: - "\w \ set_disconnected_nodes_locs ptr. (h \ w \\<^sub>h h' \ (\r \ get_parent_locs. r h h'))" - -interpretation i_set_disconnected_nodes_get_parent?: - l_set_disconnected_nodes_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf set_disconnected_nodes - set_disconnected_nodes_locs get_child_nodes get_child_nodes_locs known_ptrs get_parent get_parent_locs - using instances - by (simp add: l_set_disconnected_nodes_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def) -declare l_set_disconnected_nodes_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma set_disconnected_nodes_get_parent_is_l_set_disconnected_nodes_get_parent [instances]: - "l_set_disconnected_nodes_get_parent set_disconnected_nodes_locs get_parent_locs" - by(simp add: l_set_disconnected_nodes_get_parent_def) - - - -subsubsection \get\_root\_node\ - -locale l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs = - l_get_parent_defs get_parent get_parent_locs - for get_parent :: "(_) node_ptr \ ((_) heap, exception, (_::linorder) object_ptr option) prog" - and get_parent_locs :: "((_) heap \ (_) heap \ bool) set" -begin -partial_function (dom_prog) - a_get_ancestors :: "(_::linorder) object_ptr \ (_, (_) object_ptr list) dom_prog" - where - "a_get_ancestors ptr = do { - check_in_heap ptr; - ancestors \ (case cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr of - Some node_ptr \ do { - parent_ptr_opt \ get_parent node_ptr; - (case parent_ptr_opt of - Some parent_ptr \ a_get_ancestors parent_ptr - | None \ return []) - } - | None \ return []); - return (ptr # ancestors) - }" - -definition "a_get_ancestors_locs = get_parent_locs" - -definition a_get_root_node :: "(_) object_ptr \ (_, (_) object_ptr) dom_prog" - where - "a_get_root_node ptr = do { - ancestors \ a_get_ancestors ptr; - return (last ancestors) - }" -definition "a_get_root_node_locs = a_get_ancestors_locs" -end - -locale l_get_ancestors_defs = - fixes get_ancestors :: "(_::linorder) object_ptr \ (_, (_) object_ptr list) dom_prog" - fixes get_ancestors_locs :: "((_) heap \ (_) heap \ bool) set" - -locale l_get_root_node_defs = - fixes get_root_node :: "(_) object_ptr \ (_, (_) object_ptr) dom_prog" - fixes get_root_node_locs :: "((_) heap \ (_) heap \ bool) set" - -locale l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_get_parent + - l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs + - l_get_ancestors_defs + - l_get_root_node_defs + - assumes get_ancestors_impl: "get_ancestors = a_get_ancestors" - assumes get_ancestors_locs_impl: "get_ancestors_locs = a_get_ancestors_locs" - assumes get_root_node_impl: "get_root_node = a_get_root_node" - assumes get_root_node_locs_impl: "get_root_node_locs = a_get_root_node_locs" -begin -lemmas get_ancestors_def = a_get_ancestors.simps[folded get_ancestors_impl] -lemmas get_ancestors_locs_def = a_get_ancestors_locs_def[folded get_ancestors_locs_impl] -lemmas get_root_node_def = a_get_root_node_def[folded get_root_node_impl get_ancestors_impl] -lemmas get_root_node_locs_def = a_get_root_node_locs_def[folded get_root_node_locs_impl - get_ancestors_locs_impl] - -lemma get_ancestors_pure [simp]: - "pure (get_ancestors ptr) h" -proof - - have "\ptr h h' x. h \ get_ancestors ptr \\<^sub>r x \ h \ get_ancestors ptr \\<^sub>h h' \ h = h'" - proof (induct rule: a_get_ancestors.fixp_induct[folded get_ancestors_impl]) - case 1 - then show ?case - by(rule admissible_dom_prog) - next - case 2 - then show ?case - by simp - next - case (3 f) - then show ?case - using get_parent_pure - apply(auto simp add: pure_returns_heap_eq pure_def - split: option.splits - elim!: bind_returns_heap_E bind_returns_result_E - dest!: pure_returns_heap_eq[rotated, OF check_in_heap_pure])[1] - apply (meson option.simps(3) returns_result_eq) - by (metis get_parent_pure pure_returns_heap_eq) - qed - then show ?thesis - by (meson pure_eq_iff) -qed - - -lemma get_root_node_pure [simp]: "pure (get_root_node ptr) h" - by(auto simp add: get_root_node_def bind_pure_I) - - -lemma get_ancestors_ptr_in_heap: - assumes "h \ ok (get_ancestors ptr)" - shows "ptr |\| object_ptr_kinds h" - using assms - by(auto simp add: get_ancestors_def check_in_heap_ptr_in_heap - elim!: bind_is_OK_E dest: is_OK_returns_result_I) - -lemma get_ancestors_ptr: - assumes "h \ get_ancestors ptr \\<^sub>r ancestors" - shows "ptr \ set ancestors" - using assms - apply(simp add: get_ancestors_def) - by(auto elim!: bind_returns_result_E2 split: option.splits intro!: bind_pure_I) - -lemma get_ancestors_not_node: - assumes "h \ get_ancestors ptr \\<^sub>r ancestors" - assumes "\is_node_ptr_kind ptr" - shows "ancestors = [ptr]" - using assms - apply(simp add: get_ancestors_def) - by(auto elim!: bind_returns_result_E2 split: option.splits) - -lemma get_root_node_no_parent: - "h \ get_parent node_ptr \\<^sub>r None \ h \ get_root_node (cast node_ptr) \\<^sub>r cast node_ptr" - apply(auto simp add: check_in_heap_def get_root_node_def get_ancestors_def - intro!: bind_pure_returns_result_I )[1] - using get_parent_ptr_in_heap by blast - -end - -locale l_get_ancestors = l_get_ancestors_defs + - assumes get_ancestors_pure [simp]: "pure (get_ancestors node_ptr) h" - assumes get_ancestors_ptr_in_heap: "h \ ok (get_ancestors ptr) \ ptr |\| object_ptr_kinds h" - assumes get_ancestors_ptr: "h \ get_ancestors ptr \\<^sub>r ancestors \ ptr \ set ancestors" - -locale l_get_root_node = l_get_root_node_defs + l_get_parent_defs + - assumes get_root_node_pure[simp]: - "pure (get_root_node ptr) h" - assumes get_root_node_no_parent: - "h \ get_parent node_ptr \\<^sub>r None \ h \ get_root_node (cast node_ptr) \\<^sub>r cast node_ptr" - -global_interpretation l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_parent get_parent_locs - defines get_root_node = "l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_root_node get_parent" - and get_root_node_locs = "l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_root_node_locs get_parent_locs" - and get_ancestors = "l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_ancestors get_parent" - and get_ancestors_locs = "l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_ancestors_locs get_parent_locs" - . -declare a_get_ancestors.simps [code] - -interpretation - i_get_root_node?: l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr known_ptrs get_parent get_parent_locs - get_child_nodes get_child_nodes_locs get_ancestors get_ancestors_locs - get_root_node get_root_node_locs - using instances - apply(simp add: l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def) - by(simp add: get_root_node_def get_root_node_locs_def get_ancestors_def get_ancestors_locs_def) -declare l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma get_ancestors_is_l_get_ancestors [instances]: "l_get_ancestors get_ancestors" - unfolding l_get_ancestors_def - using get_ancestors_pure get_ancestors_ptr get_ancestors_ptr_in_heap - by blast - -lemma get_root_node_is_l_get_root_node [instances]: "l_get_root_node get_root_node get_parent" - apply(simp add: l_get_root_node_def) - using get_root_node_no_parent - by fast - - -paragraph \set\_disconnected\_nodes\ - -locale l_set_disconnected_nodes_get_ancestors\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_set_disconnected_nodes_get_parent - set_disconnected_nodes set_disconnected_nodes_locs get_parent get_parent_locs - + l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M - type_wf known_ptr known_ptrs get_parent get_parent_locs get_child_nodes get_child_nodes_locs - get_ancestors get_ancestors_locs get_root_node get_root_node_locs - + l_set_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M - type_wf set_disconnected_nodes set_disconnected_nodes_locs - for known_ptr :: "(_::linorder) object_ptr \ bool" - and set_disconnected_nodes :: "(_) document_ptr \ (_) node_ptr list \ ((_) heap, exception, unit) prog" - and set_disconnected_nodes_locs :: "(_) document_ptr \ ((_) heap, exception, unit) prog set" - and get_child_nodes :: "(_) object_ptr \ ((_) heap, exception, (_) node_ptr list) prog" - and get_child_nodes_locs :: "(_) object_ptr \ ((_) heap \ (_) heap \ bool) set" - and get_parent :: "(_) node_ptr \ ((_) heap, exception, (_) object_ptr option) prog" - and get_parent_locs :: "((_) heap \ (_) heap \ bool) set" - and type_wf :: "(_) heap \ bool" - and known_ptrs :: "(_) heap \ bool" - and get_ancestors :: "(_) object_ptr \ ((_) heap, exception, (_) object_ptr list) prog" - and get_ancestors_locs :: "((_) heap \ (_) heap \ bool) set" - and get_root_node :: "(_) object_ptr \ ((_) heap, exception, (_) object_ptr) prog" - and get_root_node_locs :: "((_) heap \ (_) heap \ bool) set" -begin -lemma set_disconnected_nodes_get_ancestors: - "\w \ set_disconnected_nodes_locs ptr. (h \ w \\<^sub>h h' \ (\r \ get_ancestors_locs. r h h'))" - by(auto simp add: get_parent_locs_def set_disconnected_nodes_locs_def get_ancestors_locs_def - all_args_def) -end - -locale l_set_disconnected_nodes_get_ancestors = l_set_disconnected_nodes_defs + l_get_ancestors_defs + - assumes set_disconnected_nodes_get_ancestors: - "\w \ set_disconnected_nodes_locs ptr. (h \ w \\<^sub>h h' \ (\r \ get_ancestors_locs. r h h'))" - -interpretation - i_set_disconnected_nodes_get_ancestors?: l_set_disconnected_nodes_get_ancestors\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr - set_disconnected_nodes set_disconnected_nodes_locs - get_child_nodes get_child_nodes_locs get_parent - get_parent_locs type_wf known_ptrs get_ancestors - get_ancestors_locs get_root_node get_root_node_locs - using instances - by (simp add: l_set_disconnected_nodes_get_ancestors\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def) -declare l_set_disconnected_nodes_get_ancestors\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - - -lemma set_disconnected_nodes_get_ancestors_is_l_set_disconnected_nodes_get_ancestors [instances]: - "l_set_disconnected_nodes_get_ancestors set_disconnected_nodes_locs get_ancestors_locs" - using instances - apply(simp add: l_set_disconnected_nodes_get_ancestors_def) - using set_disconnected_nodes_get_ancestors - by fast - - - -subsubsection \get\_owner\_document\ - -locale l_get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs = - l_get_disconnected_nodes_defs get_disconnected_nodes get_disconnected_nodes_locs + - l_get_root_node_defs get_root_node get_root_node_locs - for get_root_node :: "(_::linorder) object_ptr \ ((_) heap, exception, (_) object_ptr) prog" - and get_root_node_locs :: "((_) heap \ (_) heap \ bool) set" - and get_disconnected_nodes :: "(_) document_ptr \ ((_) heap, exception, (_) node_ptr list) prog" - and get_disconnected_nodes_locs :: "(_) document_ptr \ ((_) heap \ (_) heap \ bool) set" -begin - -definition a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) node_ptr \ unit \ (_, (_) document_ptr) dom_prog" - where - "a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr _ = do { - root \ get_root_node (cast node_ptr); - (case cast root of - Some document_ptr \ return document_ptr - | None \ do { - ptrs \ document_ptr_kinds_M; - candidates \ filter_M (\document_ptr. do { - disconnected_nodes \ get_disconnected_nodes document_ptr; - return (root \ cast ` set disconnected_nodes) - }) ptrs; - return (hd candidates) - }) - }" - -definition - a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) document_ptr \ unit \ (_, (_) document_ptr) dom_prog" - where - "a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr _ = do { - document_ptrs \ document_ptr_kinds_M; - (if document_ptr \ set document_ptrs then return document_ptr else error SegmentationFault)}" - -definition - a_get_owner_document_tups :: "(((_) object_ptr \ bool) \ ((_) object_ptr \ unit - \ (_, (_) document_ptr) dom_prog)) list" - where - "a_get_owner_document_tups = [ - (is_element_ptr, a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r \ the \ cast), - (is_character_data_ptr, a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r \ the \ cast), - (is_document_ptr, a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r \ the \ cast) - ]" - -definition a_get_owner_document :: "(_) object_ptr \ (_, (_) document_ptr) dom_prog" - where - "a_get_owner_document ptr = invoke a_get_owner_document_tups ptr ()" -end - -locale l_get_owner_document_defs = - fixes get_owner_document :: "(_::linorder) object_ptr \ (_, (_) document_ptr) dom_prog" - -locale l_get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_known_ptr known_ptr + - l_get_disconnected_nodes type_wf get_disconnected_nodes get_disconnected_nodes_locs + - l_get_root_node get_root_node get_root_node_locs + - l_get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_root_node get_root_node_locs get_disconnected_nodes - get_disconnected_nodes_locs + - l_get_owner_document_defs get_owner_document - for known_ptr :: "(_::linorder) object_ptr \ bool" - and type_wf :: "(_) heap \ bool" - and get_disconnected_nodes :: "(_) document_ptr \ ((_) heap, exception, (_) node_ptr list) prog" - and get_disconnected_nodes_locs :: "(_) document_ptr \ ((_) heap \ (_) heap \ bool) set" - and get_root_node :: "(_) object_ptr \ ((_) heap, exception, (_) object_ptr) prog" - and get_root_node_locs :: "((_) heap \ (_) heap \ bool) set" - and get_owner_document :: "(_) object_ptr \ ((_) heap, exception, (_) document_ptr) prog" + - assumes known_ptr_impl: "known_ptr = a_known_ptr" - assumes get_owner_document_impl: "get_owner_document = a_get_owner_document" -begin -lemmas known_ptr_def = known_ptr_impl[unfolded a_known_ptr_def] -lemmas get_owner_document_def = a_get_owner_document_def[folded get_owner_document_impl] - -lemma get_owner_document_split: - "P (invoke (a_get_owner_document_tups @ xs) ptr ()) = - ((known_ptr ptr \ P (get_owner_document ptr)) - \ (\(known_ptr ptr) \ P (invoke xs ptr ())))" - by(auto simp add: get_owner_document_def a_get_owner_document_tups_def known_ptr_def - CharacterDataClass.known_ptr_defs ElementClass.known_ptr_defs - NodeClass.known_ptr_defs - split: invoke_splits option.splits) - -lemma get_owner_document_split_asm: - "P (invoke (a_get_owner_document_tups @ xs) ptr ()) = - (\((known_ptr ptr \ \P (get_owner_document ptr)) - \ (\(known_ptr ptr) \ \P (invoke xs ptr ()))))" - by(auto simp add: get_owner_document_def a_get_owner_document_tups_def known_ptr_def - CharacterDataClass.known_ptr_defs ElementClass.known_ptr_defs - NodeClass.known_ptr_defs - split: invoke_splits) -lemmas get_owner_document_splits = get_owner_document_split get_owner_document_split_asm - -lemma get_owner_document_pure [simp]: - "pure (get_owner_document ptr) h" -proof - - have "\node_ptr. pure (a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr ()) h" - by(auto simp add: a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def - intro!: bind_pure_I filter_M_pure_I - split: option.splits) - moreover have "\document_ptr. pure (a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr ()) h" - by(auto simp add: a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def bind_pure_I) - ultimately show ?thesis - by(auto simp add: get_owner_document_def a_get_owner_document_tups_def - intro!: bind_pure_I - split: invoke_splits) -qed - -lemma get_owner_document_ptr_in_heap: - assumes "h \ ok (get_owner_document ptr)" - shows "ptr |\| object_ptr_kinds h" - using assms - by(auto simp add: get_owner_document_def invoke_ptr_in_heap dest: is_OK_returns_heap_I) -end - -locale l_get_owner_document = l_get_owner_document_defs + - assumes get_owner_document_ptr_in_heap: - "h \ ok (get_owner_document ptr) \ ptr |\| object_ptr_kinds h" - assumes get_owner_document_pure [simp]: - "pure (get_owner_document ptr) h" - -global_interpretation l_get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_root_node get_root_node_locs - get_disconnected_nodes get_disconnected_nodes_locs - defines get_owner_document_tups = - "l_get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_owner_document_tups get_root_node get_disconnected_nodes" - and get_owner_document = - "l_get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_owner_document get_root_node get_disconnected_nodes" - and get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r = - "l_get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r get_root_node get_disconnected_nodes" - . -interpretation - i_get_owner_document?: l_get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_parent get_parent_locs known_ptr type_wf - get_disconnected_nodes get_disconnected_nodes_locs get_root_node - get_root_node_locs get_owner_document - using instances - apply(auto simp add: l_get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def)[1] - by(auto simp add: get_owner_document_tups_def get_owner_document_def get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def)[1] -declare l_get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma get_owner_document_is_l_get_owner_document [instances]: - "l_get_owner_document get_owner_document" - using get_owner_document_ptr_in_heap - by(auto simp add: l_get_owner_document_def) - -subsubsection \remove\_child\ - -locale l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs = - l_get_child_nodes_defs get_child_nodes get_child_nodes_locs + - l_set_child_nodes_defs set_child_nodes set_child_nodes_locs + - l_get_parent_defs get_parent get_parent_locs + - l_get_owner_document_defs get_owner_document + - l_get_disconnected_nodes_defs get_disconnected_nodes get_disconnected_nodes_locs + - l_set_disconnected_nodes_defs set_disconnected_nodes set_disconnected_nodes_locs - for get_child_nodes :: "(_::linorder) object_ptr \ ((_) heap, exception, (_) node_ptr list) prog" - and get_child_nodes_locs :: "(_) object_ptr \ ((_) heap \ (_) heap \ bool) set" - and set_child_nodes :: "(_) object_ptr \ (_) node_ptr list \ ((_) heap, exception, unit) prog" - and set_child_nodes_locs :: "(_) object_ptr \ ((_) heap, exception, unit) prog set" - and get_parent :: "(_) node_ptr \ ((_) heap, exception, (_) object_ptr option) prog" - and get_parent_locs :: "((_) heap \ (_) heap \ bool) set" - and get_owner_document :: "(_) object_ptr \ ((_) heap, exception, (_) document_ptr) prog" - and get_disconnected_nodes :: "(_) document_ptr \ ((_) heap, exception, (_) node_ptr list) prog" - and get_disconnected_nodes_locs :: "(_) document_ptr \ ((_) heap \ (_) heap \ bool) set" - and set_disconnected_nodes :: "(_) document_ptr \ (_) node_ptr list \ ((_) heap, exception, unit) prog" - and set_disconnected_nodes_locs :: "(_) document_ptr \ ((_) heap, exception, unit) prog set" -begin -definition a_remove_child :: "(_) object_ptr \ (_) node_ptr \ (_, unit) dom_prog" - where - "a_remove_child ptr child = do { - children \ get_child_nodes ptr; - if child \ set children then - error NotFoundError - else do { - owner_document \ get_owner_document (cast child); - disc_nodes \ get_disconnected_nodes owner_document; - set_disconnected_nodes owner_document (child # disc_nodes); - set_child_nodes ptr (remove1 child children) - } - }" - -definition a_remove_child_locs :: "(_) object_ptr \ (_) document_ptr \ (_, unit) dom_prog set" - where - "a_remove_child_locs ptr owner_document = set_child_nodes_locs ptr - \ set_disconnected_nodes_locs owner_document" - -definition a_remove :: "(_) node_ptr \ (_, unit) dom_prog" - where - "a_remove node_ptr = do { - parent_opt \ get_parent node_ptr; - (case parent_opt of - Some parent \ do { - a_remove_child parent node_ptr; - return () - } - | None \ return ()) - }" -end - -locale l_remove_child_defs = - fixes remove_child :: "(_::linorder) object_ptr \ (_) node_ptr \ (_, unit) dom_prog" - fixes remove_child_locs :: "(_) object_ptr \ (_) document_ptr \ (_, unit) dom_prog set" - -locale l_remove_defs = - fixes remove :: "(_) node_ptr \ (_, unit) dom_prog" - -locale l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs + - l_remove_child_defs + - l_remove_defs + - l_get_parent + - l_get_owner_document + - l_set_child_nodes_get_child_nodes + - l_set_child_nodes_get_disconnected_nodes + - l_set_disconnected_nodes_get_disconnected_nodes + - l_set_disconnected_nodes_get_child_nodes + - assumes remove_child_impl: "remove_child = a_remove_child" - assumes remove_child_locs_impl: "remove_child_locs = a_remove_child_locs" - assumes remove_impl: "remove = a_remove" -begin -lemmas remove_child_def = a_remove_child_def[folded remove_child_impl] -lemmas remove_child_locs_def = a_remove_child_locs_def[folded remove_child_locs_impl] -lemmas remove_def = a_remove_def[folded remove_child_impl remove_impl] - -lemma remove_child_ptr_in_heap: - assumes "h \ ok (remove_child ptr child)" - shows "ptr |\| object_ptr_kinds h" -proof - - obtain children where children: "h \ get_child_nodes ptr \\<^sub>r children" - using assms - by(auto simp add: remove_child_def) - moreover have "children \ []" - using assms calculation - by(auto simp add: remove_child_def elim!: bind_is_OK_E2) - ultimately show ?thesis - using assms(1) get_child_nodes_ptr_in_heap by blast -qed - - -lemma remove_child_child_in_heap: - assumes "h \ remove_child ptr' child \\<^sub>h h'" - shows "child |\| node_ptr_kinds h" - using assms - apply(auto simp add: remove_child_def elim!: bind_returns_heap_E bind_returns_heap_E2[rotated, OF get_child_nodes_pure, rotated] split: if_splits)[1] - by (meson is_OK_returns_result_I local.get_owner_document_ptr_in_heap node_ptr_kinds_commutes) - - -lemma remove_child_in_disconnected_nodes: - (* assumes "known_ptrs h" *) - assumes "h \ remove_child ptr child \\<^sub>h h'" - assumes "h \ get_owner_document (cast child) \\<^sub>r owner_document" - assumes "h' \ get_disconnected_nodes owner_document \\<^sub>r disc_nodes" - shows "child \ set disc_nodes" -proof - - obtain prev_disc_nodes h2 children where - disc_nodes: "h \ get_disconnected_nodes owner_document \\<^sub>r prev_disc_nodes" and - h2: "h \ set_disconnected_nodes owner_document (child # prev_disc_nodes) \\<^sub>h h2" and - h': "h2 \ set_child_nodes ptr (remove1 child children) \\<^sub>h h'" - using assms(1) - apply(auto simp add: remove_child_def - elim!: bind_returns_heap_E - dest!: returns_result_eq[OF assms(2)] pure_returns_heap_eq[rotated, OF get_owner_document_pure] - pure_returns_heap_eq[rotated, OF get_child_nodes_pure] - split: if_splits)[1] - by (metis get_disconnected_nodes_pure pure_returns_heap_eq) - have "h2 \ get_disconnected_nodes owner_document \\<^sub>r disc_nodes" - apply(rule reads_writes_separate_backwards[OF get_disconnected_nodes_reads - set_child_nodes_writes h' assms(3)]) - by (simp add: set_child_nodes_get_disconnected_nodes) - then show ?thesis - by (metis (no_types, lifting) h2 set_disconnected_nodes_get_disconnected_nodes - list.set_intros(1) select_result_I2) -qed - -lemma remove_child_writes [simp]: - "writes (remove_child_locs ptr |h \ get_owner_document (cast child)|\<^sub>r) (remove_child ptr child) h h'" - apply(auto simp add: remove_child_def intro!: writes_bind_pure[OF get_child_nodes_pure] - writes_bind_pure[OF get_owner_document_pure] - writes_bind_pure[OF get_disconnected_nodes_pure])[1] - by(auto simp add: remove_child_locs_def set_disconnected_nodes_writes writes_union_right_I - set_child_nodes_writes writes_union_left_I - intro!: writes_bind) - -lemma remove_writes: - "writes (remove_child_locs (the |h \ get_parent child|\<^sub>r) |h \ get_owner_document (cast child)|\<^sub>r) (remove child) h h'" - by(auto simp add: remove_def intro!: writes_bind_pure split: option.splits) - -lemma remove_child_children_subset: - assumes "h \ remove_child parent child \\<^sub>h h'" - and "h \ get_child_nodes ptr \\<^sub>r children" - and "h' \ get_child_nodes ptr \\<^sub>r children'" - and known_ptrs: "known_ptrs h" - and type_wf: "type_wf h" - shows "set children' \ set children" -proof - - obtain ptr_children owner_document h2 disc_nodes where - owner_document: "h \ get_owner_document (cast child) \\<^sub>r owner_document" and - ptr_children: "h \ get_child_nodes parent \\<^sub>r ptr_children" and - disc_nodes: "h \ get_disconnected_nodes owner_document \\<^sub>r disc_nodes" and - h2: "h \ set_disconnected_nodes owner_document (child # disc_nodes) \\<^sub>h h2" and - h': "h2 \ set_child_nodes parent (remove1 child ptr_children) \\<^sub>h h'" - using assms(1) - by(auto simp add: remove_child_def - elim!: bind_returns_heap_E - dest!: pure_returns_heap_eq[rotated, OF get_owner_document_pure] - pure_returns_heap_eq[rotated, OF get_disconnected_nodes_pure] - pure_returns_heap_eq[rotated, OF get_child_nodes_pure] - split: if_splits) - have "parent |\| object_ptr_kinds h" - using get_child_nodes_ptr_in_heap ptr_children by blast - have "object_ptr_kinds h = object_ptr_kinds h2" - apply(rule writes_small_big[where P="\h h'. object_ptr_kinds h = object_ptr_kinds h'", - OF set_disconnected_nodes_writes h2]) - using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved - by (auto simp add: reflp_def transp_def) - have "type_wf h2" - using type_wf writes_small_big[where P="\h h'. type_wf h \ type_wf h'", - OF set_disconnected_nodes_writes h2] - using set_disconnected_nodes_types_preserved - by(auto simp add: reflp_def transp_def) - have "h2 \ get_child_nodes ptr \\<^sub>r children" - using get_child_nodes_reads set_disconnected_nodes_writes h2 assms(2) - apply(rule reads_writes_separate_forwards) - by (simp add: set_disconnected_nodes_get_child_nodes) - moreover have "h2 \ get_child_nodes parent \\<^sub>r ptr_children" - using get_child_nodes_reads set_disconnected_nodes_writes h2 ptr_children - apply(rule reads_writes_separate_forwards) - by (simp add: set_disconnected_nodes_get_child_nodes) - moreover have - "ptr \ parent \ h2 \ get_child_nodes ptr \\<^sub>r children = h' \ get_child_nodes ptr \\<^sub>r children" - using get_child_nodes_reads set_child_nodes_writes h' - apply(rule reads_writes_preserved) - by (metis set_child_nodes_get_child_nodes_different_pointers) - moreover have "h' \ get_child_nodes parent \\<^sub>r remove1 child ptr_children" - using h' set_child_nodes_get_child_nodes known_ptrs type_wf known_ptrs_known_ptr - \parent |\| object_ptr_kinds h\ \object_ptr_kinds h = object_ptr_kinds h2\ \type_wf h2\ - by fast - moreover have "set ( remove1 child ptr_children) \ set ptr_children" - by (simp add: set_remove1_subset) - ultimately show ?thesis - by (metis assms(3) order_refl returns_result_eq) -qed - - -lemma remove_child_pointers_preserved: - assumes "w \ remove_child_locs ptr owner_document" - assumes "h \ w \\<^sub>h h'" - shows "object_ptr_kinds h = object_ptr_kinds h'" - using assms - using set_child_nodes_pointers_preserved - using set_disconnected_nodes_pointers_preserved - unfolding remove_child_locs_def - by auto - -lemma remove_child_types_preserved: - assumes "w \ remove_child_locs ptr owner_document" - assumes "h \ w \\<^sub>h h'" - shows "type_wf h = type_wf h'" - using assms - using set_child_nodes_types_preserved - using set_disconnected_nodes_types_preserved - unfolding remove_child_locs_def - by auto -end - -locale l_remove_child = l_type_wf + l_known_ptrs + l_remove_child_defs + l_get_owner_document_defs - + l_get_child_nodes_defs + l_get_disconnected_nodes_defs + - assumes remove_child_writes: - "writes (remove_child_locs object_ptr |h \ get_owner_document (cast child)|\<^sub>r) (remove_child object_ptr child) h h'" - assumes remove_child_pointers_preserved: - "w \ remove_child_locs ptr owner_document \ h \ w \\<^sub>h h' \ object_ptr_kinds h = object_ptr_kinds h'" - assumes remove_child_types_preserved: - "w \ remove_child_locs ptr owner_document \ h \ w \\<^sub>h h' \ type_wf h = type_wf h'" - assumes remove_child_in_disconnected_nodes: - "known_ptrs h \ h \ remove_child ptr child \\<^sub>h h' - \ h \ get_owner_document (cast child) \\<^sub>r owner_document - \ h' \ get_disconnected_nodes owner_document \\<^sub>r disc_nodes - \ child \ set disc_nodes" - assumes remove_child_ptr_in_heap: "h \ ok (remove_child ptr child) \ ptr |\| object_ptr_kinds h" - assumes remove_child_child_in_heap: "h \ remove_child ptr' child \\<^sub>h h' \ child |\| node_ptr_kinds h" - assumes remove_child_children_subset: - "known_ptrs h \ type_wf h \ h \ remove_child parent child \\<^sub>h h' - \ h \ get_child_nodes ptr \\<^sub>r children - \ h' \ get_child_nodes ptr \\<^sub>r children' - \ set children' \ set children" - -locale l_remove - - -global_interpretation l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_child_nodes get_child_nodes_locs set_child_nodes - set_child_nodes_locs get_parent get_parent_locs - get_owner_document get_disconnected_nodes - get_disconnected_nodes_locs set_disconnected_nodes - set_disconnected_nodes_locs - defines remove = - "l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_remove get_child_nodes set_child_nodes get_parent get_owner_document - get_disconnected_nodes set_disconnected_nodes" - and remove_child = - "l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_remove_child get_child_nodes set_child_nodes get_owner_document - get_disconnected_nodes set_disconnected_nodes" - and remove_child_locs = - "l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_remove_child_locs set_child_nodes_locs set_disconnected_nodes_locs" - . -interpretation - i_remove_child?: l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes get_child_nodes_locs set_child_nodes - set_child_nodes_locs get_parent get_parent_locs get_owner_document - get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes - set_disconnected_nodes_locs remove_child remove_child_locs remove type_wf - known_ptr known_ptrs - using instances - apply(simp add: l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def) - by(simp add: remove_child_def remove_child_locs_def remove_def) -declare l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma remove_child_is_l_remove_child [instances]: - "l_remove_child type_wf known_ptr known_ptrs remove_child remove_child_locs get_owner_document - get_child_nodes get_disconnected_nodes" - using instances - apply(auto simp add: l_remove_child_def l_remove_child_axioms_def)[1] (*slow, ca 1min *) - using remove_child_pointers_preserved apply(blast) - using remove_child_pointers_preserved apply(blast) - using remove_child_types_preserved apply(blast) - using remove_child_types_preserved apply(blast) - using remove_child_in_disconnected_nodes apply(blast) - using remove_child_ptr_in_heap apply(blast) - using remove_child_child_in_heap apply(blast) - using remove_child_children_subset apply(blast) - done - - - -subsubsection \adopt\_node\ - -locale l_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs = - l_get_owner_document_defs get_owner_document + - l_get_parent_defs get_parent get_parent_locs + - l_remove_child_defs remove_child remove_child_locs + - l_get_disconnected_nodes_defs get_disconnected_nodes get_disconnected_nodes_locs + - l_set_disconnected_nodes_defs set_disconnected_nodes set_disconnected_nodes_locs - for get_owner_document :: "(_::linorder) object_ptr \ ((_) heap, exception, (_) document_ptr) prog" - and get_parent :: "(_) node_ptr \ ((_) heap, exception, (_) object_ptr option) prog" - and get_parent_locs :: "((_) heap \ (_) heap \ bool) set" - and remove_child :: "(_) object_ptr \ (_) node_ptr \ ((_) heap, exception, unit) prog" - and remove_child_locs :: "(_) object_ptr \ (_) document_ptr \ ((_) heap, exception, unit) prog set" - and get_disconnected_nodes :: "(_) document_ptr \ ((_) heap, exception, (_) node_ptr list) prog" - and get_disconnected_nodes_locs :: "(_) document_ptr \ ((_) heap \ (_) heap \ bool) set" - and set_disconnected_nodes :: "(_) document_ptr \ (_) node_ptr list \ ((_) heap, exception, unit) prog" - and set_disconnected_nodes_locs :: "(_) document_ptr \ ((_) heap, exception, unit) prog set" -begin -definition a_adopt_node :: "(_) document_ptr \ (_) node_ptr \ (_, unit) dom_prog" - where - "a_adopt_node document node = do { - old_document \ get_owner_document (cast node); - parent_opt \ get_parent node; - (case parent_opt of - Some parent \ do { - remove_child parent node - } | None \ do { - return () - }); - (if document \ old_document then do { - old_disc_nodes \ get_disconnected_nodes old_document; - set_disconnected_nodes old_document (remove1 node old_disc_nodes); - disc_nodes \ get_disconnected_nodes document; - set_disconnected_nodes document (node # disc_nodes) - } else do { - return () - }) - }" - -definition - a_adopt_node_locs :: "(_) object_ptr option \ (_) document_ptr \ (_) document_ptr \ (_, unit) dom_prog set" - where - "a_adopt_node_locs parent owner_document document_ptr = - ((if parent = None - then {} - else remove_child_locs (the parent) owner_document) \ set_disconnected_nodes_locs document_ptr - \ set_disconnected_nodes_locs owner_document)" -end - -locale l_adopt_node_defs = - fixes - adopt_node :: "(_) document_ptr \ (_) node_ptr \ (_, unit) dom_prog" - fixes - adopt_node_locs :: "(_) object_ptr option \ (_) document_ptr \ (_) document_ptr \ (_, unit) dom_prog set" - -global_interpretation l_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_owner_document get_parent get_parent_locs remove_child - remove_child_locs get_disconnected_nodes - get_disconnected_nodes_locs set_disconnected_nodes - set_disconnected_nodes_locs - defines adopt_node = "l_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_adopt_node get_owner_document get_parent remove_child - get_disconnected_nodes set_disconnected_nodes" - and adopt_node_locs = "l_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_adopt_node_locs - remove_child_locs set_disconnected_nodes_locs" - . - -locale l_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs - get_owner_document get_parent get_parent_locs remove_child remove_child_locs get_disconnected_nodes - get_disconnected_nodes_locs set_disconnected_nodes set_disconnected_nodes_locs - + l_adopt_node_defs - adopt_node adopt_node_locs - + l_get_owner_document - get_owner_document - + l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M - known_ptr type_wf get_child_nodes get_child_nodes_locs known_ptrs get_parent get_parent_locs - + l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M - get_child_nodes get_child_nodes_locs set_child_nodes set_child_nodes_locs get_parent - get_parent_locs get_owner_document get_disconnected_nodes get_disconnected_nodes_locs - set_disconnected_nodes set_disconnected_nodes_locs remove_child remove_child_locs remove type_wf - known_ptr known_ptrs - + l_set_disconnected_nodes_get_disconnected_nodes - type_wf get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes - set_disconnected_nodes_locs - for get_owner_document :: "(_::linorder) object_ptr \ ((_) heap, exception, (_) document_ptr) prog" - and get_parent :: "(_) node_ptr \ ((_) heap, exception, (_) object_ptr option) prog" - and get_parent_locs :: "((_) heap \ (_) heap \ bool) set" - and remove_child :: "(_) object_ptr \ (_) node_ptr \ ((_) heap, exception, unit) prog" - and remove_child_locs :: "(_) object_ptr \ (_) document_ptr \ ((_) heap, exception, unit) prog set" - and get_disconnected_nodes :: "(_) document_ptr \ ((_) heap, exception, (_) node_ptr list) prog" - and get_disconnected_nodes_locs :: "(_) document_ptr \ ((_) heap \ (_) heap \ bool) set" - and set_disconnected_nodes :: "(_) document_ptr \ (_) node_ptr list \ ((_) heap, exception, unit) prog" - and set_disconnected_nodes_locs :: "(_) document_ptr \ ((_) heap, exception, unit) prog set" - and adopt_node :: "(_) document_ptr \ (_) node_ptr \ ((_) heap, exception, unit) prog" - and adopt_node_locs :: "(_) object_ptr option \ (_) document_ptr \ (_) document_ptr - \ ((_) heap, exception, unit) prog set" - and known_ptr :: "(_) object_ptr \ bool" - and type_wf :: "(_) heap \ bool" - and get_child_nodes :: "(_) object_ptr \ ((_) heap, exception, (_) node_ptr list) prog" - and get_child_nodes_locs :: "(_) object_ptr \ ((_) heap \ (_) heap \ bool) set" - and known_ptrs :: "(_) heap \ bool" - and set_child_nodes :: "(_) object_ptr \ (_) node_ptr list \ ((_) heap, exception, unit) prog" - and set_child_nodes_locs :: "(_) object_ptr \ ((_) heap, exception, unit) prog set" - and remove :: "(_) node_ptr \ ((_) heap, exception, unit) prog" + - assumes adopt_node_impl: "adopt_node = a_adopt_node" - assumes adopt_node_locs_impl: "adopt_node_locs = a_adopt_node_locs" -begin -lemmas adopt_node_def = a_adopt_node_def[folded adopt_node_impl] -lemmas adopt_node_locs_def = a_adopt_node_locs_def[folded adopt_node_locs_impl] - -lemma adopt_node_writes: - shows "writes (adopt_node_locs |h \ get_parent node|\<^sub>r |h - \ get_owner_document (cast node)|\<^sub>r document_ptr) (adopt_node document_ptr node) h h'" - apply(auto simp add: adopt_node_def adopt_node_locs_def - intro!: writes_bind_pure[OF get_owner_document_pure] writes_bind_pure[OF get_parent_pure] - writes_bind_pure[OF get_disconnected_nodes_pure] - split: option.splits)[1] - apply(auto intro!: writes_bind)[1] - apply (simp add: set_disconnected_nodes_writes writes_union_right_I) - apply (simp add: set_disconnected_nodes_writes writes_union_left_I writes_union_right_I) - apply(auto intro!: writes_bind)[1] - apply (metis (no_types, lifting) remove_child_writes select_result_I2 writes_union_left_I) - apply (simp add: set_disconnected_nodes_writes writes_union_right_I) - by(auto intro: writes_subset[OF set_disconnected_nodes_writes] writes_subset[OF remove_child_writes]) - -lemma adopt_node_children_subset: - assumes "h \ adopt_node owner_document node \\<^sub>h h'" - and "h \ get_child_nodes ptr \\<^sub>r children" - and "h' \ get_child_nodes ptr \\<^sub>r children'" - and known_ptrs: "known_ptrs h" - and type_wf: "type_wf h" - shows "set children' \ set children" -proof - - obtain old_document parent_opt h2 where - old_document: "h \ get_owner_document (cast node) \\<^sub>r old_document" and - parent_opt: "h \ get_parent node \\<^sub>r parent_opt" and - h2: "h \ (case parent_opt of Some parent \ do { remove_child parent node } | None \ do { return ()}) \\<^sub>h h2" - and - h': "h2 \ (if owner_document \ old_document then do { - old_disc_nodes \ get_disconnected_nodes old_document; - set_disconnected_nodes old_document (remove1 node old_disc_nodes); - disc_nodes \ get_disconnected_nodes owner_document; - set_disconnected_nodes owner_document (node # disc_nodes) - } else do { return () }) \\<^sub>h h'" - using assms(1) - by(auto simp add: adopt_node_def - elim!: bind_returns_heap_E - dest!: pure_returns_heap_eq[rotated, OF get_owner_document_pure] - pure_returns_heap_eq[rotated, OF get_parent_pure]) - - have "h2 \ get_child_nodes ptr \\<^sub>r children'" - proof (cases "owner_document \ old_document") - case True - then obtain h3 old_disc_nodes disc_nodes where - old_disc_nodes: "h2 \ get_disconnected_nodes old_document \\<^sub>r old_disc_nodes" and - h3: "h2 \ set_disconnected_nodes old_document (remove1 node old_disc_nodes) \\<^sub>h h3" and - old_disc_nodes: "h3 \ get_disconnected_nodes owner_document \\<^sub>r disc_nodes" and - h': "h3 \ set_disconnected_nodes owner_document (node # disc_nodes) \\<^sub>h h'" - using h' - by(auto elim!: bind_returns_heap_E - bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated] ) - have "h3 \ get_child_nodes ptr \\<^sub>r children'" - using get_child_nodes_reads set_disconnected_nodes_writes h' assms(3) - apply(rule reads_writes_separate_backwards) - by (simp add: set_disconnected_nodes_get_child_nodes) - show ?thesis - using get_child_nodes_reads set_disconnected_nodes_writes h3 \h3 \ get_child_nodes ptr \\<^sub>r children'\ - apply(rule reads_writes_separate_backwards) - by (simp add: set_disconnected_nodes_get_child_nodes) - next - case False - then show ?thesis - using h' assms(3) by(auto) - qed - - show ?thesis - proof (insert h2, induct parent_opt) - case None - then show ?case - using assms - by(auto dest!: returns_result_eq[OF \h2 \ get_child_nodes ptr \\<^sub>r children'\]) - next - case (Some option) - then show ?case - using assms(2) \h2 \ get_child_nodes ptr \\<^sub>r children'\ remove_child_children_subset known_ptrs type_wf - by simp - qed -qed - -lemma adopt_node_child_in_heap: - assumes "h \ ok (adopt_node document_ptr child)" - shows "child |\| node_ptr_kinds h" - using assms - apply(auto simp add: adopt_node_def elim!: bind_is_OK_E)[1] - using get_owner_document_pure get_parent_ptr_in_heap pure_returns_heap_eq - by fast - -lemma adopt_node_pointers_preserved: - assumes "w \ adopt_node_locs parent owner_document document_ptr" - assumes "h \ w \\<^sub>h h'" - shows "object_ptr_kinds h = object_ptr_kinds h'" - using assms - using set_disconnected_nodes_pointers_preserved - using remove_child_pointers_preserved - unfolding adopt_node_locs_def - by (auto split: if_splits) - -lemma adopt_node_types_preserved: - assumes "w \ adopt_node_locs parent owner_document document_ptr" - assumes "h \ w \\<^sub>h h'" - shows "type_wf h = type_wf h'" - using assms - using remove_child_types_preserved - using set_disconnected_nodes_types_preserved - unfolding adopt_node_locs_def - by (auto split: if_splits) -end - -locale l_adopt_node = l_type_wf + l_known_ptrs + l_get_parent_defs + l_adopt_node_defs + l_get_child_nodes_defs + l_get_owner_document_defs + - assumes adopt_node_writes: - "writes (adopt_node_locs |h \ get_parent node|\<^sub>r - |h \ get_owner_document (cast node)|\<^sub>r document_ptr) (adopt_node document_ptr node) h h'" - assumes adopt_node_pointers_preserved: - "w \ adopt_node_locs parent owner_document document_ptr - \ h \ w \\<^sub>h h' \ object_ptr_kinds h = object_ptr_kinds h'" - assumes adopt_node_types_preserved: - "w \ adopt_node_locs parent owner_document document_ptr - \ h \ w \\<^sub>h h' \ type_wf h = type_wf h'" - assumes adopt_node_child_in_heap: - "h \ ok (adopt_node document_ptr child) \ child |\| node_ptr_kinds h" - assumes adopt_node_children_subset: - "h \ adopt_node owner_document node \\<^sub>h h' \ h \ get_child_nodes ptr \\<^sub>r children - \ h' \ get_child_nodes ptr \\<^sub>r children' - \ known_ptrs h \ type_wf h \ set children' \ set children" - -interpretation - i_adopt_node?: l_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_owner_document get_parent get_parent_locs remove_child - remove_child_locs get_disconnected_nodes get_disconnected_nodes_locs - set_disconnected_nodes set_disconnected_nodes_locs adopt_node adopt_node_locs - known_ptr type_wf get_child_nodes get_child_nodes_locs known_ptrs set_child_nodes - set_child_nodes_locs remove - apply(unfold_locales) - by(auto simp add: adopt_node_def adopt_node_locs_def) -declare l_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - - -lemma adopt_node_is_l_adopt_node [instances]: - "l_adopt_node type_wf known_ptr known_ptrs get_parent adopt_node adopt_node_locs get_child_nodes - get_owner_document" - using instances - by (simp add: l_adopt_node_axioms_def adopt_node_child_in_heap adopt_node_children_subset - adopt_node_pointers_preserved adopt_node_types_preserved adopt_node_writes - l_adopt_node_def) - - - -subsubsection \insert\_before\ - -locale l_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs = - l_get_parent_defs get_parent get_parent_locs - + l_get_child_nodes_defs get_child_nodes get_child_nodes_locs - + l_set_child_nodes_defs set_child_nodes set_child_nodes_locs - + l_get_ancestors_defs get_ancestors get_ancestors_locs - + l_adopt_node_defs adopt_node adopt_node_locs - + l_set_disconnected_nodes_defs set_disconnected_nodes set_disconnected_nodes_locs - + l_get_disconnected_nodes_defs get_disconnected_nodes get_disconnected_nodes_locs - + l_get_owner_document_defs get_owner_document - for get_parent :: "(_) node_ptr \ ((_) heap, exception, (_::linorder) object_ptr option) prog" - and get_parent_locs :: "((_) heap \ (_) heap \ bool) set" - and get_child_nodes :: "(_) object_ptr \ ((_) heap, exception, (_) node_ptr list) prog" - and get_child_nodes_locs :: "(_) object_ptr \ ((_) heap \ (_) heap \ bool) set" - and set_child_nodes :: "(_) object_ptr \ (_) node_ptr list \ ((_) heap, exception, unit) prog" - and set_child_nodes_locs :: "(_) object_ptr \ ((_) heap, exception, unit) prog set" - and get_ancestors :: "(_) object_ptr \ ((_) heap, exception, (_) object_ptr list) prog" - and get_ancestors_locs :: "((_) heap \ (_) heap \ bool) set" - and adopt_node :: "(_) document_ptr \ (_) node_ptr \ ((_) heap, exception, unit) prog" - and adopt_node_locs :: "(_) object_ptr option \ (_) document_ptr \ (_) document_ptr - \ ((_) heap, exception, unit) prog set" - and set_disconnected_nodes :: "(_) document_ptr \ (_) node_ptr list \ ((_) heap, exception, unit) prog" - and set_disconnected_nodes_locs :: "(_) document_ptr \ ((_) heap, exception, unit) prog set" - and get_disconnected_nodes :: "(_) document_ptr \ ((_) heap, exception, (_) node_ptr list) prog" - and get_disconnected_nodes_locs :: "(_) document_ptr \ ((_) heap \ (_) heap \ bool) set" - and get_owner_document :: "(_) object_ptr \ ((_) heap, exception, (_) document_ptr) prog" -begin - -definition a_next_sibling :: "(_) node_ptr \ (_, (_) node_ptr option) dom_prog" - where - "a_next_sibling node_ptr = do { - parent_opt \ get_parent node_ptr; - (case parent_opt of - Some parent \ do { - children \ get_child_nodes parent; - (case (dropWhile (\ptr. ptr = node_ptr) (dropWhile (\ptr. ptr \ node_ptr) children)) of - x#_ \ return (Some x) - | [] \ return None)} - | None \ return None) - }" - -fun insert_before_list :: "'xyz \ 'xyz option \ 'xyz list \ 'xyz list" - where - "insert_before_list v (Some reference) (x#xs) = (if reference = x - then v#x#xs else x # insert_before_list v (Some reference) xs)" - | "insert_before_list v (Some _) [] = [v]" - | "insert_before_list v None xs = xs @ [v]" - -definition a_insert_node :: "(_) object_ptr \ (_) node_ptr \ (_) node_ptr option - \ (_, unit) dom_prog" - where - "a_insert_node ptr new_child reference_child_opt = do { - children \ get_child_nodes ptr; - set_child_nodes ptr (insert_before_list new_child reference_child_opt children) - }" - -definition a_ensure_pre_insertion_validity :: "(_) node_ptr \ (_) object_ptr - \ (_) node_ptr option \ (_, unit) dom_prog" - where - "a_ensure_pre_insertion_validity node parent child_opt = do { - (if is_character_data_ptr_kind parent - then error HierarchyRequestError else return ()); - ancestors \ get_ancestors parent; - (if cast node \ set ancestors then error HierarchyRequestError else return ()); - (case child_opt of - Some child \ do { - child_parent \ get_parent child; - (if child_parent \ Some parent then error NotFoundError else return ())} - | None \ return ()); - children \ get_child_nodes parent; - (if children \ [] \ is_document_ptr parent - then error HierarchyRequestError else return ()); - (if is_character_data_ptr node \ is_document_ptr parent - then error HierarchyRequestError else return ()) - }" - -definition a_insert_before :: "(_) object_ptr \ (_) node_ptr - \ (_) node_ptr option \ (_, unit) dom_prog" - where - "a_insert_before ptr node child = do { - a_ensure_pre_insertion_validity node ptr child; - reference_child \ (if Some node = child - then a_next_sibling node - else return child); - owner_document \ get_owner_document ptr; - adopt_node owner_document node; - disc_nodes \ get_disconnected_nodes owner_document; - set_disconnected_nodes owner_document (remove1 node disc_nodes); - a_insert_node ptr node reference_child - }" - -definition a_insert_before_locs :: "(_) object_ptr \ (_) object_ptr option \ (_) document_ptr - \ (_) document_ptr \ (_, unit) dom_prog set" - where - "a_insert_before_locs ptr old_parent child_owner_document ptr_owner_document = - adopt_node_locs old_parent child_owner_document ptr_owner_document \ - set_child_nodes_locs ptr \ - set_disconnected_nodes_locs ptr_owner_document" -end - -locale l_insert_before_defs = - fixes insert_before :: "(_) object_ptr \ (_) node_ptr \ (_) node_ptr option \ (_, unit) dom_prog" - fixes insert_before_locs :: "(_) object_ptr \ (_) object_ptr option \ (_) document_ptr - \ (_) document_ptr \ (_, unit) dom_prog set" - -locale l_append_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs = - l_insert_before_defs -begin -definition "a_append_child ptr child = insert_before ptr child None" -end - -locale l_append_child_defs = - fixes append_child :: "(_) object_ptr \ (_) node_ptr \ (_, unit) dom_prog" - -locale l_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs - get_parent get_parent_locs get_child_nodes get_child_nodes_locs set_child_nodes - set_child_nodes_locs get_ancestors get_ancestors_locs adopt_node adopt_node_locs - set_disconnected_nodes set_disconnected_nodes_locs get_disconnected_nodes - get_disconnected_nodes_locs get_owner_document - + l_insert_before_defs - insert_before insert_before_locs - + l_append_child_defs - append_child - + l_set_child_nodes_get_child_nodes - type_wf known_ptr get_child_nodes get_child_nodes_locs set_child_nodes set_child_nodes_locs - + l_get_ancestors - get_ancestors get_ancestors_locs - + l_adopt_node - type_wf known_ptr known_ptrs get_parent get_parent_locs adopt_node adopt_node_locs - get_child_nodes get_child_nodes_locs get_owner_document - + l_set_disconnected_nodes - type_wf set_disconnected_nodes set_disconnected_nodes_locs - + l_get_disconnected_nodes - type_wf get_disconnected_nodes get_disconnected_nodes_locs - + l_get_owner_document - get_owner_document - + l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M - known_ptr type_wf get_child_nodes get_child_nodes_locs known_ptrs get_parent get_parent_locs - + l_set_disconnected_nodes_get_child_nodes - set_disconnected_nodes set_disconnected_nodes_locs get_child_nodes get_child_nodes_locs - for get_parent :: "(_) node_ptr \ ((_) heap, exception, (_::linorder) object_ptr option) prog" - and get_parent_locs :: "((_) heap \ (_) heap \ bool) set" - and get_child_nodes :: "(_) object_ptr \ ((_) heap, exception, (_) node_ptr list) prog" - and get_child_nodes_locs :: "(_) object_ptr \ ((_) heap \ (_) heap \ bool) set" - and set_child_nodes :: "(_) object_ptr \ (_) node_ptr list \ ((_) heap, exception, unit) prog" - and set_child_nodes_locs :: "(_) object_ptr \ ((_) heap, exception, unit) prog set" - and get_ancestors :: "(_) object_ptr \ ((_) heap, exception, (_) object_ptr list) prog" - and get_ancestors_locs :: "((_) heap \ (_) heap \ bool) set" - and adopt_node :: "(_) document_ptr \ (_) node_ptr \ ((_) heap, exception, unit) prog" - and adopt_node_locs :: "(_) object_ptr option \ (_) document_ptr \ (_) document_ptr - \ ((_) heap, exception, unit) prog set" - and set_disconnected_nodes :: "(_) document_ptr \ (_) node_ptr list \ ((_) heap, exception, unit) prog" - and set_disconnected_nodes_locs :: "(_) document_ptr \ ((_) heap, exception, unit) prog set" - and get_disconnected_nodes :: "(_) document_ptr \ ((_) heap, exception, (_) node_ptr list) prog" - and get_disconnected_nodes_locs :: "(_) document_ptr \ ((_) heap \ (_) heap \ bool) set" - and get_owner_document :: "(_) object_ptr \ ((_) heap, exception, (_) document_ptr) prog" - and insert_before :: "(_) object_ptr \ (_) node_ptr \ (_) node_ptr option \ ((_) heap, exception, unit) prog" - and insert_before_locs :: "(_) object_ptr \ (_) object_ptr option \ (_) document_ptr - \ (_) document_ptr \ (_, unit) dom_prog set" - and append_child :: "(_) object_ptr \ (_) node_ptr \ ((_) heap, exception, unit) prog" - and type_wf :: "(_) heap \ bool" - and known_ptr :: "(_) object_ptr \ bool" - and known_ptrs :: "(_) heap \ bool" + - assumes insert_before_impl: "insert_before = a_insert_before" - assumes insert_before_locs_impl: "insert_before_locs = a_insert_before_locs" -begin -lemmas insert_before_def = a_insert_before_def[folded insert_before_impl] -lemmas insert_before_locs_def = a_insert_before_locs_def[folded insert_before_locs_impl] - -lemma next_sibling_pure [simp]: - "pure (a_next_sibling new_child) h" - by(auto simp add: a_next_sibling_def get_parent_pure intro!: bind_pure_I split: option.splits list.splits) - -lemma insert_before_list_in_set: "x \ set (insert_before_list v ref xs) \ x = v \ x \ set xs" - apply(induct v ref xs rule: insert_before_list.induct) - by(auto) - -lemma insert_before_list_distinct: "x \ set xs \ distinct xs \ distinct (insert_before_list x ref xs)" - apply(induct x ref xs rule: insert_before_list.induct) - by(auto simp add: insert_before_list_in_set) - -lemma insert_before_list_subset: "set xs \ set (insert_before_list x ref xs)" - apply(induct x ref xs rule: insert_before_list.induct) - by(auto) - -lemma insert_before_list_node_in_set: "x \ set (insert_before_list x ref xs)" - apply(induct x ref xs rule: insert_before_list.induct) - by(auto) - -lemma insert_node_writes: - "writes (set_child_nodes_locs ptr) (a_insert_node ptr new_child reference_child_opt) h h'" - by(auto simp add: a_insert_node_def set_child_nodes_writes - intro!: writes_bind_pure[OF get_child_nodes_pure]) - -lemma ensure_pre_insertion_validity_pure [simp]: - "pure (a_ensure_pre_insertion_validity node ptr child) h" - by(auto simp add: a_ensure_pre_insertion_validity_def - intro!: bind_pure_I - split: option.splits) - -lemma insert_before_reference_child_not_in_children: - assumes "h \ get_parent child \\<^sub>r Some parent" - and "ptr \ parent" - and "\is_character_data_ptr_kind ptr" - and "h \ get_ancestors ptr \\<^sub>r ancestors" - and "cast node \ set ancestors" - shows "h \ insert_before ptr node (Some child) \\<^sub>e NotFoundError" -proof - - have "h \ a_ensure_pre_insertion_validity node ptr (Some child) \\<^sub>e NotFoundError" - using assms unfolding insert_before_def a_ensure_pre_insertion_validity_def - by auto (simp | rule bind_returns_error_I2)+ - then show ?thesis - unfolding insert_before_def by auto -qed - -lemma insert_before_ptr_in_heap: - assumes "h \ ok (insert_before ptr node reference_child)" - shows "ptr |\| object_ptr_kinds h" - using assms - apply(auto simp add: insert_before_def elim!: bind_is_OK_E)[1] - by (metis (mono_tags, lifting) ensure_pre_insertion_validity_pure is_OK_returns_result_I local.get_owner_document_ptr_in_heap next_sibling_pure pure_returns_heap_eq return_returns_heap) - -lemma insert_before_child_in_heap: - assumes "h \ ok (insert_before ptr node reference_child)" - shows "node |\| node_ptr_kinds h" - using assms - apply(auto simp add: insert_before_def elim!: bind_is_OK_E)[1] - by (metis (mono_tags, lifting) ensure_pre_insertion_validity_pure is_OK_returns_heap_I - l_get_owner_document.get_owner_document_pure local.adopt_node_child_in_heap - local.l_get_owner_document_axioms next_sibling_pure pure_returns_heap_eq return_pure) - -lemma insert_node_children_remain_distinct: - assumes insert_node: "h \ a_insert_node ptr new_child reference_child_opt \\<^sub>h h2" - and "h \ get_child_nodes ptr \\<^sub>r children" - and "new_child \ set children" - and "\ptr children. h \ get_child_nodes ptr \\<^sub>r children \ distinct children" - and known_ptr: "known_ptr ptr" - and type_wf: "type_wf h" - shows "\ptr children. h2 \ get_child_nodes ptr \\<^sub>r children \ distinct children" -proof - - fix ptr' children' - assume a1: "h2 \ get_child_nodes ptr' \\<^sub>r children'" - then show "distinct children'" - proof (cases "ptr = ptr'") - case True - have "h2 \ get_child_nodes ptr \\<^sub>r (insert_before_list new_child reference_child_opt children)" - using assms(1) assms(2) apply(auto simp add: a_insert_node_def elim!: bind_returns_heap_E)[1] - using returns_result_eq set_child_nodes_get_child_nodes known_ptr type_wf - using pure_returns_heap_eq by fastforce - then show ?thesis - using True a1 assms(2) assms(3) assms(4) insert_before_list_distinct returns_result_eq - by fastforce - next - case False - have "h \ get_child_nodes ptr' \\<^sub>r children'" - using get_child_nodes_reads insert_node_writes insert_node a1 - apply(rule reads_writes_separate_backwards) - by (meson False set_child_nodes_get_child_nodes_different_pointers) - then show ?thesis - using assms(4) by blast - qed -qed - -lemma insert_before_writes: - "writes (insert_before_locs ptr |h \ get_parent child|\<^sub>r - |h \ get_owner_document (cast child)|\<^sub>r |h \ get_owner_document ptr|\<^sub>r) (insert_before ptr child ref) h h'" - apply(auto simp add: insert_before_def insert_before_locs_def a_insert_node_def - intro!: writes_bind)[1] - apply (metis (no_types, hide_lams) ensure_pre_insertion_validity_pure local.adopt_node_writes - local.get_owner_document_pure next_sibling_pure pure_returns_heap_eq - select_result_I2 sup_commute writes_union_right_I) - apply (metis (no_types, hide_lams) ensure_pre_insertion_validity_pure next_sibling_pure - pure_returns_heap_eq select_result_I2 set_disconnected_nodes_writes - writes_union_right_I) - apply (simp add: set_child_nodes_writes writes_union_left_I writes_union_right_I) - apply (metis (no_types, hide_lams) adopt_node_writes ensure_pre_insertion_validity_pure - get_owner_document_pure pure_returns_heap_eq select_result_I2 writes_union_left_I) - apply (metis (no_types, hide_lams) ensure_pre_insertion_validity_pure pure_returns_heap_eq - select_result_I2 set_disconnected_nodes_writes writes_union_right_I) - by (simp add: set_child_nodes_writes writes_union_left_I writes_union_right_I) -end - - -locale l_append_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_append_child_defs + - l_append_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs + - assumes append_child_impl: "append_child = a_append_child" -begin - -lemmas append_child_def = a_append_child_def[folded append_child_impl] -end - -locale l_insert_before = l_insert_before_defs - -locale l_append_child = l_append_child_defs - -global_interpretation l_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_parent get_parent_locs get_child_nodes - get_child_nodes_locs set_child_nodes set_child_nodes_locs get_ancestors get_ancestors_locs - adopt_node adopt_node_locs set_disconnected_nodes set_disconnected_nodes_locs - get_disconnected_nodes get_disconnected_nodes_locs get_owner_document - defines - next_sibling = "l_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_next_sibling get_parent get_child_nodes" and - insert_node = "l_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_insert_node get_child_nodes set_child_nodes" and - ensure_pre_insertion_validity = "l_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_ensure_pre_insertion_validity - get_parent get_child_nodes get_ancestors" and - insert_before = "l_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_insert_before get_parent get_child_nodes - set_child_nodes get_ancestors adopt_node set_disconnected_nodes - get_disconnected_nodes get_owner_document" and - insert_before_locs = "l_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_insert_before_locs set_child_nodes_locs - adopt_node_locs set_disconnected_nodes_locs" - . - -global_interpretation l_append_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs insert_before - defines append_child = "l_append_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_append_child insert_before" - . - -interpretation - i_insert_before?: l_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_parent get_parent_locs get_child_nodes - get_child_nodes_locs set_child_nodes set_child_nodes_locs get_ancestors get_ancestors_locs - adopt_node adopt_node_locs set_disconnected_nodes set_disconnected_nodes_locs get_disconnected_nodes - get_disconnected_nodes_locs get_owner_document insert_before insert_before_locs append_child - type_wf known_ptr known_ptrs - apply(simp add: l_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def instances) - by (simp add: insert_before_def insert_before_locs_def) -declare l_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -interpretation i_append_child?: l_append_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M append_child insert_before insert_before_locs - apply(simp add: l_append_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances append_child_def) - done -declare l_append_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - - - - -subsubsection \create\_element\ - -locale l_create_element\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs = - l_get_disconnected_nodes_defs get_disconnected_nodes get_disconnected_nodes_locs + - l_set_disconnected_nodes_defs set_disconnected_nodes set_disconnected_nodes_locs + - l_set_tag_type_defs set_tag_type set_tag_type_locs - for get_disconnected_nodes :: - "(_) document_ptr \ ((_) heap, exception, (_) node_ptr list) prog" - and get_disconnected_nodes_locs :: - "(_) document_ptr \ ((_) heap \ (_) heap \ bool) set" - and set_disconnected_nodes :: - "(_) document_ptr \ (_) node_ptr list \ ((_) heap, exception, unit) prog" - and set_disconnected_nodes_locs :: - "(_) document_ptr \ ((_) heap, exception, unit) prog set" - and set_tag_type :: - "(_) element_ptr \ char list \ ((_) heap, exception, unit) prog" - and set_tag_type_locs :: - "(_) element_ptr \ ((_) heap, exception, unit) prog set" -begin -definition a_create_element :: "(_) document_ptr \ tag_type \ (_, (_) element_ptr) dom_prog" - where - "a_create_element document_ptr tag = do { - new_element_ptr \ new_element; - set_tag_type new_element_ptr tag; - disc_nodes \ get_disconnected_nodes document_ptr; - set_disconnected_nodes document_ptr (cast new_element_ptr # disc_nodes); - return new_element_ptr - }" -end - -locale l_create_element_defs = - fixes create_element :: "(_) document_ptr \ tag_type \ (_, (_) element_ptr) dom_prog" - -global_interpretation l_create_element\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_disconnected_nodes get_disconnected_nodes_locs - set_disconnected_nodes set_disconnected_nodes_locs - set_tag_type set_tag_type_locs - defines - create_element = "l_create_element\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_create_element get_disconnected_nodes - set_disconnected_nodes set_tag_type" - . - -locale l_create_element\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_create_element\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes set_disconnected_nodes_locs set_tag_type set_tag_type_locs + - l_get_disconnected_nodes type_wf get_disconnected_nodes get_disconnected_nodes_locs + - l_set_tag_type type_wf set_tag_type set_tag_type_locs + - l_create_element_defs create_element + - l_known_ptr known_ptr - for get_disconnected_nodes :: "(_) document_ptr \ ((_) heap, exception, (_) node_ptr list) prog" - and get_disconnected_nodes_locs :: "(_) document_ptr \ ((_) heap \ (_) heap \ bool) set" - and set_disconnected_nodes :: "(_) document_ptr \ (_) node_ptr list \ ((_) heap, exception, unit) prog" - and set_disconnected_nodes_locs :: "(_) document_ptr \ ((_) heap, exception, unit) prog set" - and set_tag_type :: "(_) element_ptr \ char list \ ((_) heap, exception, unit) prog" - and set_tag_type_locs :: "(_) element_ptr \ ((_) heap, exception, unit) prog set" - and type_wf :: "(_) heap \ bool" - and create_element :: "(_) document_ptr \ char list \ ((_) heap, exception, (_) element_ptr) prog" - and known_ptr :: "(_) object_ptr \ bool" + - assumes known_ptr_impl: "known_ptr = a_known_ptr" - assumes create_element_impl: "create_element = a_create_element" -begin -lemmas create_element_def = a_create_element_def[folded create_element_impl] - -lemma create_element_document_in_heap: - assumes "h \ ok (create_element document_ptr tag)" - shows "document_ptr |\| document_ptr_kinds h" -proof - - obtain h' where "h \ create_element document_ptr tag \\<^sub>h h'" - using assms(1) - by auto - then - obtain new_element_ptr h2 h3 disc_nodes_h3 where - new_element_ptr: "h \ new_element \\<^sub>r new_element_ptr" and - h2: "h \ new_element \\<^sub>h h2" and - h3: "h2 \ set_tag_type new_element_ptr tag \\<^sub>h h3" and - disc_nodes_h3: "h3 \ get_disconnected_nodes document_ptr \\<^sub>r disc_nodes_h3" and - h': "h3 \ set_disconnected_nodes document_ptr (cast new_element_ptr # disc_nodes_h3) \\<^sub>h h'" - by(auto simp add: create_element_def - elim!: bind_returns_heap_E - bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated] ) - - have object_ptr_kinds_eq_h: "object_ptr_kinds h2 = object_ptr_kinds h |\| {|cast new_element_ptr|}" - using new_element_new_ptr h2 new_element_ptr by blast - - moreover have object_ptr_kinds_eq_h2: "object_ptr_kinds h3 = object_ptr_kinds h2" - apply(rule writes_small_big[where P="\h h'. object_ptr_kinds h' = object_ptr_kinds h", OF set_tag_type_writes h3]) - using set_tag_type_pointers_preserved - by (auto simp add: reflp_def transp_def) - moreover have "document_ptr |\| document_ptr_kinds h3" - by (meson disc_nodes_h3 is_OK_returns_result_I local.get_disconnected_nodes_ptr_in_heap) - - ultimately show ?thesis - by (auto simp add: document_ptr_kinds_def) -qed - -lemma create_element_known_ptr: - assumes "h \ create_element document_ptr tag \\<^sub>r new_element_ptr" - shows "known_ptr (cast new_element_ptr)" -proof - - have "is_element_ptr new_element_ptr" - using assms - apply(auto simp add: create_element_def elim!: bind_returns_result_E)[1] - using new_element_is_element_ptr - by blast - then show ?thesis - by(auto simp add: known_ptr_impl DocumentClass.known_ptr_defs CharacterDataClass.known_ptr_defs ElementClass.known_ptr_defs) -qed -end - -locale l_create_element = l_create_element_defs - -interpretation - i_create_element?: l_create_element\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes set_disconnected_nodes_locs set_tag_type set_tag_type_locs type_wf create_element known_ptr - by(auto simp add: l_create_element\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_create_element\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def create_element_def instances) -declare l_create_element\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - - -subsubsection \create\_character\_data\ - -locale l_create_character_data\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs = - l_set_val_defs set_val set_val_locs + - l_get_disconnected_nodes_defs get_disconnected_nodes get_disconnected_nodes_locs + - l_set_disconnected_nodes_defs set_disconnected_nodes set_disconnected_nodes_locs - for set_val :: "(_) character_data_ptr \ char list \ ((_) heap, exception, unit) prog" - and set_val_locs :: "(_) character_data_ptr \ ((_) heap, exception, unit) prog set" - and get_disconnected_nodes :: "(_) document_ptr \ ((_) heap, exception, (_) node_ptr list) prog" - and get_disconnected_nodes_locs :: "(_) document_ptr \ ((_) heap \ (_) heap \ bool) set" - and set_disconnected_nodes :: "(_) document_ptr \ (_) node_ptr list \ ((_) heap, exception, unit) prog" - and set_disconnected_nodes_locs :: "(_) document_ptr \ ((_) heap, exception, unit) prog set" -begin -definition a_create_character_data :: "(_) document_ptr \ string \ (_, (_) character_data_ptr) dom_prog" - where - "a_create_character_data document_ptr text = do { - new_character_data_ptr \ new_character_data; - set_val new_character_data_ptr text; - disc_nodes \ get_disconnected_nodes document_ptr; - set_disconnected_nodes document_ptr (cast new_character_data_ptr # disc_nodes); - return new_character_data_ptr - }" -end - -locale l_create_character_data_defs = - fixes create_character_data :: "(_) document_ptr \ string \ (_, (_) character_data_ptr) dom_prog" - -global_interpretation l_create_character_data\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs set_val set_val_locs get_disconnected_nodes - get_disconnected_nodes_locs set_disconnected_nodes set_disconnected_nodes_locs - defines create_character_data = "l_create_character_data\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_create_character_data - set_val get_disconnected_nodes set_disconnected_nodes" - . - -locale l_create_character_data\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_create_character_data\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs set_val set_val_locs get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes set_disconnected_nodes_locs + - l_get_disconnected_nodes type_wf get_disconnected_nodes get_disconnected_nodes_locs + - l_set_val type_wf set_val set_val_locs + - l_create_character_data_defs create_character_data + - l_known_ptr known_ptr - for get_disconnected_nodes :: "(_) document_ptr \ ((_) heap, exception, (_) node_ptr list) prog" - and get_disconnected_nodes_locs :: "(_) document_ptr \ ((_) heap \ (_) heap \ bool) set" - and set_disconnected_nodes :: "(_) document_ptr \ (_) node_ptr list \ ((_) heap, exception, unit) prog" - and set_disconnected_nodes_locs :: "(_) document_ptr \ ((_) heap, exception, unit) prog set" - and set_val :: "(_) character_data_ptr \ char list \ ((_) heap, exception, unit) prog" - and set_val_locs :: "(_) character_data_ptr \ ((_) heap, exception, unit) prog set" - and type_wf :: "(_) heap \ bool" - and create_character_data :: "(_) document_ptr \ char list \ ((_) heap, exception, (_) character_data_ptr) prog" - and known_ptr :: "(_) object_ptr \ bool" + - assumes known_ptr_impl: "known_ptr = a_known_ptr" - assumes create_character_data_impl: "create_character_data = a_create_character_data" -begin -lemmas create_character_data_def = a_create_character_data_def[folded create_character_data_impl] - -lemma create_character_data_document_in_heap: - assumes "h \ ok (create_character_data document_ptr text)" - shows "document_ptr |\| document_ptr_kinds h" -proof - - obtain h' where "h \ create_character_data document_ptr text \\<^sub>h h'" - using assms(1) - by auto - then - obtain new_character_data_ptr h2 h3 disc_nodes_h3 where - new_character_data_ptr: "h \ new_character_data \\<^sub>r new_character_data_ptr" and - h2: "h \ new_character_data \\<^sub>h h2" and - h3: "h2 \ set_val new_character_data_ptr text \\<^sub>h h3" and - disc_nodes_h3: "h3 \ get_disconnected_nodes document_ptr \\<^sub>r disc_nodes_h3" and - h': "h3 \ set_disconnected_nodes document_ptr (cast new_character_data_ptr # disc_nodes_h3) \\<^sub>h h'" - by(auto simp add: create_character_data_def - elim!: bind_returns_heap_E - bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated] ) - - have object_ptr_kinds_eq_h: "object_ptr_kinds h2 = object_ptr_kinds h |\| {|cast new_character_data_ptr|}" - using new_character_data_new_ptr h2 new_character_data_ptr by blast - - moreover have object_ptr_kinds_eq_h2: "object_ptr_kinds h3 = object_ptr_kinds h2" - apply(rule writes_small_big[where P="\h h'. object_ptr_kinds h' = object_ptr_kinds h", OF set_val_writes h3]) - using set_val_pointers_preserved - by (auto simp add: reflp_def transp_def) - moreover have "document_ptr |\| document_ptr_kinds h3" - by (meson disc_nodes_h3 is_OK_returns_result_I local.get_disconnected_nodes_ptr_in_heap) - - ultimately show ?thesis - by (auto simp add: document_ptr_kinds_def) -qed - -lemma create_character_data_known_ptr: - assumes "h \ create_character_data document_ptr text \\<^sub>r new_character_data_ptr" - shows "known_ptr (cast new_character_data_ptr)" -proof - - have "is_character_data_ptr new_character_data_ptr" - using assms - apply(auto simp add: create_character_data_def elim!: bind_returns_result_E)[1] - using new_character_data_is_character_data_ptr - by blast - then show ?thesis - by(auto simp add: known_ptr_impl DocumentClass.known_ptr_defs CharacterDataClass.known_ptr_defs ElementClass.known_ptr_defs) -qed -end - -locale l_create_character_data = l_create_character_data_defs - -interpretation - i_create_character_data?: l_create_character_data\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes set_disconnected_nodes_locs set_val set_val_locs type_wf create_character_data known_ptr - by(auto simp add: l_create_character_data\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_create_character_data\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def create_character_data_def instances) -declare l_create_character_data\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances] - - - -subsubsection \create\_character\_data\ - -locale l_create_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs -begin -definition a_create_document :: "(_, (_) document_ptr) dom_prog" - where - "a_create_document = new_document" -end - -locale l_create_document_defs = - fixes create_document :: "(_, (_) document_ptr) dom_prog" - -global_interpretation l_create_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs - defines create_document = "l_create_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_create_document" - . - -locale l_create_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_create_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs + - l_create_document_defs + - assumes create_document_impl: "create_document = a_create_document" -begin -lemmas - create_document_def = create_document_impl[unfolded create_document_def, unfolded a_create_document_def] -end - -locale l_create_document = l_create_document_defs - -interpretation - i_create_document?: l_create_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M create_document - by(simp add: l_create_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def) -declare l_create_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances] - - -subsubsection \tree\_order\ - -locale l_to_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs = - l_get_child_nodes_defs get_child_nodes get_child_nodes_locs - for get_child_nodes :: "(_::linorder) object_ptr \ ((_) heap, exception, (_) node_ptr list) prog" - and get_child_nodes_locs :: "(_) object_ptr \ ((_) heap \ (_) heap \ bool) set" -begin -partial_function (dom_prog) a_to_tree_order :: "(_) object_ptr \ (_, (_) object_ptr list) dom_prog" - where - "a_to_tree_order ptr = (do { - children \ get_child_nodes ptr; - treeorders \ map_M a_to_tree_order (map (cast) children); - return (ptr # concat treeorders) - })" -end - -locale l_to_tree_order_defs = - fixes to_tree_order :: "(_) object_ptr \ (_, (_) object_ptr list) dom_prog" - -global_interpretation l_to_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_child_nodes get_child_nodes_locs defines - to_tree_order = "l_to_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_to_tree_order get_child_nodes" . -declare a_to_tree_order.simps [code] - -locale l_to_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_get_child_nodes type_wf known_ptr get_child_nodes get_child_nodes_locs + - l_to_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_child_nodes get_child_nodes_locs + - l_to_tree_order_defs to_tree_order - for known_ptr :: "(_::linorder) object_ptr \ bool" - and type_wf :: "(_) heap \ bool" - and get_child_nodes :: "(_) object_ptr \ ((_) heap, exception, (_) node_ptr list) prog" - and get_child_nodes_locs :: "(_) object_ptr \ ((_) heap \ (_) heap \ bool) set" - and to_tree_order :: "(_) object_ptr \ ((_) heap, exception, (_) object_ptr list) prog" + - assumes to_tree_order_impl: "to_tree_order = a_to_tree_order" -begin -lemmas to_tree_order_def = a_to_tree_order.simps[folded to_tree_order_impl] - -lemma to_tree_order_pure [simp]: "pure (to_tree_order ptr) h" -proof - - have "\ptr h h' x. h \ to_tree_order ptr \\<^sub>r x \ h \ to_tree_order ptr \\<^sub>h h' \ h = h'" - proof (induct rule: a_to_tree_order.fixp_induct[folded to_tree_order_impl]) - case 1 - then show ?case - by (rule admissible_dom_prog) - next - case 2 - then show ?case - by simp - next - case (3 f) - then have "\x h. pure (f x) h" - by (metis is_OK_returns_heap_E is_OK_returns_result_E pure_def) - then have "\xs h. pure (map_M f xs) h" - by(rule map_M_pure_I) - then show ?case - by(auto elim!: bind_returns_heap_E2) - qed - then show ?thesis - unfolding pure_def - by (metis is_OK_returns_heap_E is_OK_returns_result_E) -qed -end - -locale l_to_tree_order = - fixes to_tree_order :: "(_) object_ptr \ (_, (_) object_ptr list) dom_prog" - assumes to_tree_order_pure [simp]: "pure (to_tree_order ptr) h" - -interpretation - i_to_tree_order?: l_to_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf get_child_nodes get_child_nodes_locs - to_tree_order - apply(unfold_locales) - by (simp add: to_tree_order_def) -declare l_to_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma to_tree_order_is_l_to_tree_order [instances]: "l_to_tree_order to_tree_order" - using to_tree_order_pure l_to_tree_order_def by blast - - - -subsubsection \first\_in\_tree\_order\ - -locale l_first_in_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs = - l_to_tree_order_defs to_tree_order - for to_tree_order :: "(_) object_ptr \ ((_) heap, exception, (_) object_ptr list) prog" -begin -definition a_first_in_tree_order :: "(_) object_ptr \ ((_) object_ptr - \ (_, 'result option) dom_prog) \ (_, 'result option) dom_prog" - where - "a_first_in_tree_order ptr f = (do { - tree_order \ to_tree_order ptr; - results \ map_filter_M f tree_order; - (case results of - [] \ return None - | x#_\ return (Some x)) - })" -end - -locale l_first_in_tree_order_defs = - fixes first_in_tree_order :: "(_) object_ptr \ ((_) object_ptr \ (_, 'result option) dom_prog) - \ (_, 'result option) dom_prog" - -global_interpretation l_first_in_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs to_tree_order defines - first_in_tree_order = "l_first_in_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_first_in_tree_order to_tree_order" . - -locale l_first_in_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_first_in_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs to_tree_order + - l_first_in_tree_order_defs first_in_tree_order - for to_tree_order :: "(_) object_ptr \ ((_) heap, exception, (_) object_ptr list) prog" - and first_in_tree_order :: "(_) object_ptr \ ((_) object_ptr \ ((_) heap, exception, 'result option) prog) - \ ((_) heap, exception, 'result option) prog" + -assumes first_in_tree_order_impl: "first_in_tree_order = a_first_in_tree_order" -begin -lemmas first_in_tree_order_def = first_in_tree_order_impl[unfolded a_first_in_tree_order_def] -end - -locale l_first_in_tree_order - -interpretation i_first_in_tree_order?: - l_first_in_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M to_tree_order first_in_tree_order - by unfold_locales (simp add: first_in_tree_order_def) -declare l_first_in_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - - - -subsubsection \get\_element\_by\ - -locale l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs = - l_first_in_tree_order_defs first_in_tree_order + - l_to_tree_order_defs to_tree_order + - l_get_attribute_defs get_attribute get_attribute_locs - for to_tree_order :: "(_::linorder) object_ptr \ ((_) heap, exception, (_) object_ptr list) prog" - and first_in_tree_order :: "(_) object_ptr \ ((_) object_ptr - \ ((_) heap, exception, (_) element_ptr option) prog) - \ ((_) heap, exception, (_) element_ptr option) prog" - and get_attribute :: "(_) element_ptr \ char list \ ((_) heap, exception, char list option) prog" - and get_attribute_locs :: "(_) element_ptr \ ((_) heap \ (_) heap \ bool) set" -begin -definition a_get_element_by_id :: "(_) object_ptr \ attr_value \ (_, (_) element_ptr option) dom_prog" - where - "a_get_element_by_id ptr iden = first_in_tree_order ptr (\ptr. (case cast ptr of - Some element_ptr \ do { - id_opt \ get_attribute element_ptr ''id''; - (if id_opt = Some iden then return (Some element_ptr) else return None) - } - | _ \ return None - ))" - -definition a_get_elements_by_class_name :: "(_) object_ptr \ attr_value \ (_, (_) element_ptr list) dom_prog" - where - "a_get_elements_by_class_name ptr class_name = to_tree_order ptr \ - map_filter_M (\ptr. (case cast ptr of - Some element_ptr \ do { - class_name_opt \ get_attribute element_ptr ''class''; - (if class_name_opt = Some class_name then return (Some element_ptr) else return None) - } - | _ \ return None))" - -definition a_get_elements_by_tag_name :: "(_) object_ptr \ attr_value \ (_, (_) element_ptr list) dom_prog" - where - "a_get_elements_by_tag_name ptr tag_name = to_tree_order ptr \ - map_filter_M (\ptr. (case cast ptr of - Some element_ptr \ do { - this_tag_name \ get_M element_ptr tag_type; - (if this_tag_name = tag_name then return (Some element_ptr) else return None) - } - | _ \ return None))" -end - -locale l_get_element_by_defs = - fixes get_element_by_id :: "(_) object_ptr \ attr_value \ (_, (_) element_ptr option) dom_prog" - fixes get_elements_by_class_name :: "(_) object_ptr \ attr_value \ (_, (_) element_ptr list) dom_prog" - fixes get_elements_by_tag_name :: "(_) object_ptr \ attr_value \ (_, (_) element_ptr list) dom_prog" - -global_interpretation -l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs to_tree_order first_in_tree_order get_attribute get_attribute_locs -defines - get_element_by_id = "l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_element_by_id first_in_tree_order get_attribute" -and - get_elements_by_class_name = "l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_elements_by_class_name to_tree_order get_attribute" -and - get_elements_by_tag_name = "l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_elements_by_tag_name to_tree_order" . - -locale l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = - l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs to_tree_order first_in_tree_order get_attribute get_attribute_locs + - l_get_element_by_defs get_element_by_id get_elements_by_class_name get_elements_by_tag_name + - l_first_in_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M to_tree_order first_in_tree_order + - l_to_tree_order to_tree_order + - l_get_attribute type_wf get_attribute get_attribute_locs - for to_tree_order :: "(_::linorder) object_ptr \ ((_) heap, exception, (_) object_ptr list) prog" - and first_in_tree_order :: "(_) object_ptr \ ((_) object_ptr \ ((_) heap, exception, (_) element_ptr option) prog) - \ ((_) heap, exception, (_) element_ptr option) prog" - and get_attribute :: "(_) element_ptr \ char list \ ((_) heap, exception, char list option) prog" - and get_attribute_locs :: "(_) element_ptr \ ((_) heap \ (_) heap \ bool) set" - and get_element_by_id :: "(_) object_ptr \ char list \ ((_) heap, exception, (_) element_ptr option) prog" - and get_elements_by_class_name :: "(_) object_ptr \ char list \ ((_) heap, exception, (_) element_ptr list) prog" - and get_elements_by_tag_name :: "(_) object_ptr \ char list \ ((_) heap, exception, (_) element_ptr list) prog" - and type_wf :: "(_) heap \ bool" + - assumes get_element_by_id_impl: "get_element_by_id = a_get_element_by_id" - assumes get_elements_by_class_name_impl: "get_elements_by_class_name = a_get_elements_by_class_name" - assumes get_elements_by_tag_name_impl: "get_elements_by_tag_name = a_get_elements_by_tag_name" -begin -lemmas - get_element_by_id_def = get_element_by_id_impl[unfolded a_get_element_by_id_def] -lemmas - get_elements_by_class_name_def = get_elements_by_class_name_impl[unfolded a_get_elements_by_class_name_def] -lemmas - get_elements_by_tag_name_def = get_elements_by_tag_name_impl[unfolded a_get_elements_by_tag_name_def] - -lemma get_element_by_id_result_in_tree_order: - assumes "h \ get_element_by_id ptr iden \\<^sub>r Some element_ptr" - assumes "h \ to_tree_order ptr \\<^sub>r to" - shows "cast element_ptr \ set to" - using assms - by(auto simp add: get_element_by_id_def first_in_tree_order_def - elim!: map_filter_M_pure_E[where y=element_ptr] bind_returns_result_E2 - dest!: bind_returns_result_E3[rotated, OF assms(2), rotated] - intro!: map_filter_M_pure map_M_pure_I bind_pure_I - split: option.splits list.splits if_splits) - -lemma get_elements_by_class_name_result_in_tree_order: - assumes "h \ get_elements_by_class_name ptr name \\<^sub>r results" - assumes "h \ to_tree_order ptr \\<^sub>r to" - assumes "element_ptr \ set results" - shows "cast element_ptr \ set to" - using assms - by(auto simp add: get_elements_by_class_name_def first_in_tree_order_def - elim!: map_filter_M_pure_E[where y=element_ptr] bind_returns_result_E2 - dest!: bind_returns_result_E3[rotated, OF assms(2), rotated] - intro!: map_filter_M_pure map_M_pure_I bind_pure_I - split: option.splits list.splits if_splits) - -lemma get_elements_by_tag_name_result_in_tree_order: - assumes "h \ get_elements_by_tag_name ptr name \\<^sub>r results" - assumes "h \ to_tree_order ptr \\<^sub>r to" - assumes "element_ptr \ set results" - shows "cast element_ptr \ set to" - using assms - by(auto simp add: get_elements_by_tag_name_def first_in_tree_order_def - elim!: map_filter_M_pure_E[where y=element_ptr] bind_returns_result_E2 - dest!: bind_returns_result_E3[rotated, OF assms(2), rotated] - intro!: map_filter_M_pure map_M_pure_I bind_pure_I - split: option.splits list.splits if_splits) - -lemma get_elements_by_tag_name_pure [simp]: "pure (get_elements_by_tag_name ptr tag_name) h" - by(auto simp add: get_elements_by_tag_name_def - intro!: bind_pure_I map_filter_M_pure - split: option.splits) -end - -locale l_get_element_by = l_get_element_by_defs + l_to_tree_order_defs + - assumes get_element_by_id_result_in_tree_order: - "h \ get_element_by_id ptr iden \\<^sub>r Some element_ptr \ h \ to_tree_order ptr \\<^sub>r to - \ cast element_ptr \ set to" - assumes get_elements_by_tag_name_pure [simp]: "pure (get_elements_by_tag_name ptr tag_name) h" - -interpretation - i_get_element_by?: l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M to_tree_order first_in_tree_order get_attribute - get_attribute_locs get_element_by_id get_elements_by_class_name - get_elements_by_tag_name type_wf - using instances - apply(simp add: l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def) - by(simp add: get_element_by_id_def get_elements_by_class_name_def get_elements_by_tag_name_def) -declare l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances] - -lemma get_element_by_is_l_get_element_by [instances]: - "l_get_element_by get_element_by_id get_elements_by_tag_name to_tree_order" - apply(unfold_locales) - using get_element_by_id_result_in_tree_order get_elements_by_tag_name_pure - by fast+ -end diff --git a/Core_DOM/Core_SC_DOM/common/Core_DOM_Functions.thy b/Core_DOM/Core_SC_DOM/common/Core_DOM_Functions.thy new file mode 120000 index 0000000..9f7d671 --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/Core_DOM_Functions.thy @@ -0,0 +1 @@ +../../Core_DOM/common/Core_DOM_Functions.thy \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/Core_DOM_Tests.thy b/Core_DOM/Core_SC_DOM/common/Core_DOM_Tests.thy deleted file mode 100644 index 3819600..0000000 --- a/Core_DOM/Core_SC_DOM/common/Core_DOM_Tests.thy +++ /dev/null @@ -1,40 +0,0 @@ -(*********************************************************************************** - * Copyright (c) 2016-2018 The University of Sheffield, UK - * - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * * Redistributions of source code must retain the above copyright notice, this - * list of conditions and the following disclaimer. - * - * * Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - * SPDX-License-Identifier: BSD-2-Clause - ***********************************************************************************) - -section\Core DOM Test Cases\ -text\This theory aggregates the individual test cases for the core DOM.\ - -theory Core_DOM_Tests - imports - "tests/Document_adoptNode" - "tests/Document_getElementById" - "tests/Node_insertBefore" - "tests/Node_removeChild" -begin -end diff --git a/Core_DOM/Core_SC_DOM/common/Core_DOM_Tests.thy b/Core_DOM/Core_SC_DOM/common/Core_DOM_Tests.thy new file mode 120000 index 0000000..b585c8e --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/Core_DOM_Tests.thy @@ -0,0 +1 @@ +../../Core_DOM/common/Core_DOM_Tests.thy \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/classes/BaseClass.thy b/Core_DOM/Core_SC_DOM/common/classes/BaseClass.thy deleted file mode 100644 index 011bb9b..0000000 --- a/Core_DOM/Core_SC_DOM/common/classes/BaseClass.thy +++ /dev/null @@ -1,74 +0,0 @@ -(*********************************************************************************** - * Copyright (c) 2016-2018 The University of Sheffield, UK - * - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * * Redistributions of source code must retain the above copyright notice, this - * list of conditions and the following disclaimer. - * - * * Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - * SPDX-License-Identifier: BSD-2-Clause - ***********************************************************************************) - -section\The Class Infrastructure\ -text\In this theory, we introduce the basic infrastructure for our encoding -of classes.\ -theory BaseClass - imports - "HOL-Library.Finite_Map" - "../pointers/Ref" - "../Core_DOM_Basic_Datatypes" -begin - -named_theorems instances - -consts get :: 'a -consts put :: 'a -consts delete :: 'a - -text \Overall, the definition of the class types follows closely the one of the pointer - types. Instead of datatypes, we use records for our classes. This allows us to, first, - make use of record inheritance, which is, in addition to the type synonyms of - previous class types, the second place where the inheritance relationship of - our types manifest. Second, we get a convenient notation to define classes, in - addition to automatically generated getter and setter functions.\ - -text \Along with our class types, we also develop our heap type, which is a finite - map at its core. It is important to note that while the map stores a mapping - from @{term "object_ptr"} to @{term "Object"}, we restrict the type variables - of the record extension slot of @{term "Object"} in such a way that allows - down-casting, but requires a bit of taking-apart and re-assembling of our records - before they are stored in the heap.\ - -text \Throughout the theory files, we will use underscore case to reference pointer - types, and camel case for class types.\ - -text \Every class type contains at least one attribute; nothing. This is used for - two purposes: first, the record package does not allow records without any - attributes. Second, we will use the getter of nothing later to check whether a - class of the correct type could be retrieved, for which we will be able to use - our infrastructure regarding the behaviour of getters across different heaps.\ - - -locale l_type_wf = fixes type_wf :: "'heap \ bool" - -locale l_known_ptr = fixes known_ptr :: "'ptr \ bool" - -end diff --git a/Core_DOM/Core_SC_DOM/common/classes/BaseClass.thy b/Core_DOM/Core_SC_DOM/common/classes/BaseClass.thy new file mode 120000 index 0000000..78da9c7 --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/classes/BaseClass.thy @@ -0,0 +1 @@ +../../../Core_DOM/common/classes/BaseClass.thy \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/classes/CharacterDataClass.thy b/Core_DOM/Core_SC_DOM/common/classes/CharacterDataClass.thy deleted file mode 100644 index cf9786f..0000000 --- a/Core_DOM/Core_SC_DOM/common/classes/CharacterDataClass.thy +++ /dev/null @@ -1,350 +0,0 @@ -(*********************************************************************************** - * Copyright (c) 2016-2018 The University of Sheffield, UK - * - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * * Redistributions of source code must retain the above copyright notice, this - * list of conditions and the following disclaimer. - * - * * Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - * SPDX-License-Identifier: BSD-2-Clause - ***********************************************************************************) - -section\CharacterData\ -text\In this theory, we introduce the types for the CharacterData class.\ -theory CharacterDataClass - imports - ElementClass -begin - -subsubsection\CharacterData\ - -text\The type @{type "DOMString"} is a type synonym for @{type "string"}, defined - \autoref{sec:Core_DOM_Basic_Datatypes}.\ - -record RCharacterData = RNode + - nothing :: unit - val :: DOMString -register_default_tvars "'CharacterData RCharacterData_ext" -type_synonym 'CharacterData CharacterData = "'CharacterData option RCharacterData_scheme" -register_default_tvars "'CharacterData CharacterData" -type_synonym ('node_ptr, 'element_ptr, 'character_data_ptr, 'shadow_root_ptr, 'Node, - 'Element, 'CharacterData) Node - = "('node_ptr, 'element_ptr, 'character_data_ptr, 'shadow_root_ptr, - 'CharacterData option RCharacterData_ext + 'Node, 'Element) Node" -register_default_tvars "('node_ptr, 'element_ptr, 'character_data_ptr, 'shadow_root_ptr, 'Node, - 'Element, 'CharacterData) Node" -type_synonym ('node_ptr, 'element_ptr, 'character_data_ptr, 'shadow_root_ptr, 'Object, 'Node, - 'Element, 'CharacterData) Object - = "('node_ptr, 'element_ptr, 'character_data_ptr, 'shadow_root_ptr, 'Object, - 'CharacterData option RCharacterData_ext + 'Node, - 'Element) Object" -register_default_tvars "('node_ptr, 'element_ptr, 'character_data_ptr, 'shadow_root_ptr, 'Object, - 'Node, 'Element, 'CharacterData) Object" - -type_synonym ('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr, 'document_ptr, - 'shadow_root_ptr, 'Object, 'Node, 'Element, 'CharacterData) heap - = "('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr, 'document_ptr, 'shadow_root_ptr, - 'Object, 'CharacterData option RCharacterData_ext + 'Node, 'Element) heap" -register_default_tvars "('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr, 'document_ptr, - 'shadow_root_ptr, 'Object, 'Node, 'Element, 'CharacterData) heap" -type_synonym heap\<^sub>f\<^sub>i\<^sub>n\<^sub>a\<^sub>l = "(unit, unit, unit, unit, unit, unit, unit, unit, unit, unit) heap" - - -definition character_data_ptr_kinds :: "(_) heap \ (_) character_data_ptr fset" - where - "character_data_ptr_kinds heap = the |`| (cast |`| (ffilter is_character_data_ptr_kind - (node_ptr_kinds heap)))" - -lemma character_data_ptr_kinds_simp [simp]: - "character_data_ptr_kinds (Heap (fmupd (cast character_data_ptr) character_data (the_heap h))) - = {|character_data_ptr|} |\| character_data_ptr_kinds h" - apply(auto simp add: character_data_ptr_kinds_def)[1] - by force - -definition character_data_ptrs :: "(_) heap \ _ character_data_ptr fset" - where - "character_data_ptrs heap = ffilter is_character_data_ptr (character_data_ptr_kinds heap)" - -abbreviation "character_data_ptr_exts heap \ character_data_ptr_kinds heap - character_data_ptrs heap" - -definition cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a :: "(_) Node \ (_) CharacterData option" - where - "cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a node = (case RNode.more node of - Inr (Inl character_data) \ Some (RNode.extend (RNode.truncate node) character_data) - | _ \ None)" -adhoc_overloading cast cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a - -abbreviation cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a :: "(_) Object \ (_) CharacterData option" - where - "cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a obj \ (case cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e obj of Some node \ cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a node - | None \ None)" -adhoc_overloading cast cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a - -definition cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e :: "(_) CharacterData \ (_) Node" - where - "cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e character_data = RNode.extend (RNode.truncate character_data) - (Inr (Inl (RNode.more character_data)))" -adhoc_overloading cast cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e - -abbreviation cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t :: "(_) CharacterData \ (_) Object" - where - "cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr \ cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t (cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e ptr)" -adhoc_overloading cast cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t - -consts is_character_data_kind :: 'a -definition is_character_data_kind\<^sub>N\<^sub>o\<^sub>d\<^sub>e :: "(_) Node \ bool" - where - "is_character_data_kind\<^sub>N\<^sub>o\<^sub>d\<^sub>e ptr \ cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a ptr \ None" - -adhoc_overloading is_character_data_kind is_character_data_kind\<^sub>N\<^sub>o\<^sub>d\<^sub>e -lemmas is_character_data_kind_def = is_character_data_kind\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def - -abbreviation is_character_data_kind\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t :: "(_) Object \ bool" - where - "is_character_data_kind\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr \ cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a ptr \ None" -adhoc_overloading is_character_data_kind is_character_data_kind\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t - -lemma character_data_ptr_kinds_commutes [simp]: - "cast character_data_ptr |\| node_ptr_kinds h - \ character_data_ptr |\| character_data_ptr_kinds h" - apply(auto simp add: character_data_ptr_kinds_def)[1] - by (metis character_data_ptr_casts_commute2 comp_eq_dest_lhs ffmember_filter fimage_eqI - is_character_data_ptr_kind_none - option.distinct(1) option.sel) - -definition get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a :: "(_) character_data_ptr \ (_) heap \ (_) CharacterData option" - where - "get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr h = Option.bind (get\<^sub>N\<^sub>o\<^sub>d\<^sub>e (cast character_data_ptr) h) cast" -adhoc_overloading get get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a - -locale l_type_wf_def\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a -begin -definition a_type_wf :: "(_) heap \ bool" - where - "a_type_wf h = (ElementClass.type_wf h - \ (\character_data_ptr \ fset (character_data_ptr_kinds h). - get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr h \ None))" -end -global_interpretation l_type_wf_def\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a defines type_wf = a_type_wf . -lemmas type_wf_defs = a_type_wf_def - -locale l_type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a = l_type_wf type_wf for type_wf :: "((_) heap \ bool)" + - assumes type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a: "type_wf h \ CharacterDataClass.type_wf h" - -sublocale l_type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a \ l_type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t - apply(unfold_locales) - using ElementClass.a_type_wf_def - by (meson CharacterDataClass.a_type_wf_def l_type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_axioms l_type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def) - -locale l_get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_lemmas = l_type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a -begin -sublocale l_get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_lemmas by unfold_locales - -lemma get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_type_wf: - assumes "type_wf h" - shows "character_data_ptr |\| character_data_ptr_kinds h - \ get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr h \ None" - using l_type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_axioms assms - apply(simp add: type_wf_defs get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def l_type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def) - by (metis assms bind.bind_lzero character_data_ptr_kinds_commutes fmember.rep_eq local.get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_type_wf option.exhaust option.simps(3)) -end - -global_interpretation l_get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_lemmas type_wf - by unfold_locales - -definition put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a :: "(_) character_data_ptr \ (_) CharacterData \ (_) heap \ (_) heap" - where - "put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr character_data = put\<^sub>N\<^sub>o\<^sub>d\<^sub>e (cast character_data_ptr) - (cast character_data)" -adhoc_overloading put put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a - -lemma put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_ptr_in_heap: - assumes "put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr character_data h = h'" - shows "character_data_ptr |\| character_data_ptr_kinds h'" - using assms put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_ptr_in_heap - unfolding put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def character_data_ptr_kinds_def - by (metis character_data_ptr_kinds_commutes character_data_ptr_kinds_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_ptr_in_heap) - -lemma put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_put_ptrs: - assumes "put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr character_data h = h'" - shows "object_ptr_kinds h' = object_ptr_kinds h |\| {|cast character_data_ptr|}" - using assms - by (simp add: put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_put_ptrs) - - -lemma cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_inject [simp]: "cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e x = cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e y \ x = y" - apply(simp add: cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def RObject.extend_def RNode.extend_def) - by (metis (full_types) RNode.surjective old.unit.exhaust) - -lemma cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_none [simp]: - "cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a node = None \ \ (\character_data. cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e character_data = node)" - apply(auto simp add: cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def RObject.extend_def RNode.extend_def - split: sum.splits)[1] - by (metis (full_types) RNode.select_convs(2) RNode.surjective old.unit.exhaust) - -lemma cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_some [simp]: - "cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a node = Some character_data \ cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e character_data = node" - by(auto simp add: cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def RObject.extend_def RNode.extend_def - split: sum.splits) - -lemma cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_inv [simp]: - "cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a (cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e character_data) = Some character_data" - by simp - -lemma cast_element_not_character_data [simp]: - "(cast\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e element \ cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e character_data)" - "(cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e character_data \ cast\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e element)" - by(auto simp add: cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def cast\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def RNode.extend_def) - -lemma get_CharacterData_simp1 [simp]: - "get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr (put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr character_data h) - = Some character_data" - by(auto simp add: get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def) -lemma get_CharacterData_simp2 [simp]: - "character_data_ptr \ character_data_ptr' \ get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr - (put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr' character_data h) = get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr h" - by(auto simp add: get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def) - -lemma get_CharacterData_simp3 [simp]: - "get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr (put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr f h) = get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr h" - by(auto simp add: get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def) -lemma get_CharacterData_simp4 [simp]: - "get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a element_ptr (put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t character_data_ptr f h) = get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a element_ptr h" - by(auto simp add: get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def) - -lemma new\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a [simp]: - assumes "new\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_element_ptr, h')" - shows "get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a ptr h = get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a ptr h'" - using assms - by(auto simp add: new\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def) - - - -abbreviation "create_character_data_obj val_arg - \ \ RObject.nothing = (), RNode.nothing = (), RCharacterData.nothing = (), val = val_arg, \ = None \" - -definition new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a :: "(_) heap \ ((_) character_data_ptr \ (_) heap)" - where - "new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a h = - (let new_character_data_ptr = character_data_ptr.Ref (Suc (fMax (character_data_ptr.the_ref - |`| (character_data_ptrs h)))) in - (new_character_data_ptr, put new_character_data_ptr (create_character_data_obj '''') h))" - -lemma new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_ptr_in_heap: - assumes "new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a h = (new_character_data_ptr, h')" - shows "new_character_data_ptr |\| character_data_ptr_kinds h'" - using assms - unfolding new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def Let_def - using put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_ptr_in_heap by blast - -lemma new_character_data_ptr_new: - "character_data_ptr.Ref (Suc (fMax (finsert 0 (character_data_ptr.the_ref |`| character_data_ptrs h)))) - |\| character_data_ptrs h" - by (metis Suc_n_not_le_n character_data_ptr.sel(1) fMax_ge fimage_finsert finsertI1 finsertI2 set_finsert) - -lemma new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_ptr_not_in_heap: - assumes "new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a h = (new_character_data_ptr, h')" - shows "new_character_data_ptr |\| character_data_ptr_kinds h" - using assms - unfolding new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def - by (metis Pair_inject character_data_ptrs_def fMax_finsert fempty_iff ffmember_filter fimage_is_fempty is_character_data_ptr_ref max_0L new_character_data_ptr_new) - -lemma new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_new_ptr: - assumes "new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a h = (new_character_data_ptr, h')" - shows "object_ptr_kinds h' = object_ptr_kinds h |\| {|cast new_character_data_ptr|}" - using assms - by (metis Pair_inject new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_put_ptrs) - -lemma new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_is_character_data_ptr: - assumes "new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a h = (new_character_data_ptr, h')" - shows "is_character_data_ptr new_character_data_ptr" - using assms - by(auto simp add: new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def Let_def) - -lemma new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t [simp]: - assumes "new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a h = (new_character_data_ptr, h')" - assumes "ptr \ cast new_character_data_ptr" - shows "get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr h = get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr h'" - using assms - by(auto simp add: new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def Let_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def) - -lemma new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_get\<^sub>N\<^sub>o\<^sub>d\<^sub>e [simp]: - assumes "new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a h = (new_character_data_ptr, h')" - assumes "ptr \ cast new_character_data_ptr" - shows "get\<^sub>N\<^sub>o\<^sub>d\<^sub>e ptr h = get\<^sub>N\<^sub>o\<^sub>d\<^sub>e ptr h'" - using assms - by(auto simp add: new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def Let_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def) - -lemma new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t [simp]: - assumes "new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a h = (new_character_data_ptr, h')" - shows "get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr h = get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr h'" - using assms - by(auto simp add: new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def Let_def) - -lemma new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a [simp]: - assumes "new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a h = (new_character_data_ptr, h')" - assumes "ptr \ new_character_data_ptr" - shows "get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a ptr h = get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a ptr h'" - using assms - by(auto simp add: new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def Let_def) - - -locale l_known_ptr\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a -begin -definition a_known_ptr :: "(_) object_ptr \ bool" - where - "a_known_ptr ptr = (known_ptr ptr \ is_character_data_ptr ptr)" - -lemma known_ptr_not_character_data_ptr: - "\is_character_data_ptr ptr \ a_known_ptr ptr \ known_ptr ptr" - by(simp add: a_known_ptr_def) -end -global_interpretation l_known_ptr\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a defines known_ptr = a_known_ptr . -lemmas known_ptr_defs = a_known_ptr_def - - -locale l_known_ptrs\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a = l_known_ptr known_ptr for known_ptr :: "(_) object_ptr \ bool" -begin -definition a_known_ptrs :: "(_) heap \ bool" - where - "a_known_ptrs h = (\ptr \ fset (object_ptr_kinds h). known_ptr ptr)" - -lemma known_ptrs_known_ptr: "a_known_ptrs h \ ptr |\| object_ptr_kinds h \ known_ptr ptr" - apply(simp add: a_known_ptrs_def) - using notin_fset by fastforce - -lemma known_ptrs_preserved: - "object_ptr_kinds h = object_ptr_kinds h' \ a_known_ptrs h = a_known_ptrs h'" - by(auto simp add: a_known_ptrs_def) -lemma known_ptrs_subset: - "object_ptr_kinds h' |\| object_ptr_kinds h \ a_known_ptrs h \ a_known_ptrs h'" - by(simp add: a_known_ptrs_def less_eq_fset.rep_eq subsetD) -lemma known_ptrs_new_ptr: "object_ptr_kinds h' = object_ptr_kinds h |\| {|new_ptr|} \ known_ptr new_ptr \ a_known_ptrs h \ a_known_ptrs h'" - by(simp add: a_known_ptrs_def) -end -global_interpretation l_known_ptrs\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a known_ptr defines known_ptrs = a_known_ptrs . -lemmas known_ptrs_defs = a_known_ptrs_def - -lemma known_ptrs_is_l_known_ptrs: "l_known_ptrs known_ptr known_ptrs" - using known_ptrs_known_ptr known_ptrs_preserved known_ptrs_subset known_ptrs_new_ptr l_known_ptrs_def - by blast - -end diff --git a/Core_DOM/Core_SC_DOM/common/classes/CharacterDataClass.thy b/Core_DOM/Core_SC_DOM/common/classes/CharacterDataClass.thy new file mode 120000 index 0000000..e92f1cf --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/classes/CharacterDataClass.thy @@ -0,0 +1 @@ +../../../Core_DOM/common/classes/CharacterDataClass.thy \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/classes/DocumentClass.thy b/Core_DOM/Core_SC_DOM/common/classes/DocumentClass.thy deleted file mode 100644 index 0cc7880..0000000 --- a/Core_DOM/Core_SC_DOM/common/classes/DocumentClass.thy +++ /dev/null @@ -1,340 +0,0 @@ -(*********************************************************************************** - * Copyright (c) 2016-2018 The University of Sheffield, UK - * - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * * Redistributions of source code must retain the above copyright notice, this - * list of conditions and the following disclaimer. - * - * * Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - * SPDX-License-Identifier: BSD-2-Clause - ***********************************************************************************) - -section\Document\ -text\In this theory, we introduce the types for the Document class.\ -theory DocumentClass - imports - CharacterDataClass -begin - -text\The type @{type "doctype"} is a type synonym for @{type "string"}, defined - in \autoref{sec:Core_DOM_Basic_Datatypes}.\ - -record ('node_ptr, 'element_ptr, 'character_data_ptr) RDocument = RObject + - nothing :: unit - doctype :: doctype - document_element :: "(_) element_ptr option" - disconnected_nodes :: "('node_ptr, 'element_ptr, 'character_data_ptr) node_ptr list" -type_synonym - ('node_ptr, 'element_ptr, 'character_data_ptr, 'Document) Document - = "('node_ptr, 'element_ptr, 'character_data_ptr, 'Document option) RDocument_scheme" -register_default_tvars - "('node_ptr, 'element_ptr, 'character_data_ptr, 'Document) Document" -type_synonym - ('node_ptr, 'element_ptr, 'character_data_ptr, 'shadow_root_ptr, 'Object, 'Node, - 'Element, 'CharacterData, 'Document) Object - = "('node_ptr, 'element_ptr, 'character_data_ptr, 'shadow_root_ptr, - ('node_ptr, 'element_ptr, 'character_data_ptr, 'Document option) - RDocument_ext + 'Object, 'Node, 'Element, 'CharacterData) Object" -register_default_tvars "('node_ptr, 'element_ptr, 'character_data_ptr, 'shadow_root_ptr, - 'Object, 'Node, 'Element, 'CharacterData, 'Document) Object" - -type_synonym ('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr, 'document_ptr, - 'shadow_root_ptr, 'Object, 'Node, 'Element, 'CharacterData, 'Document) heap - = "('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr, 'document_ptr, - 'shadow_root_ptr, - ('node_ptr, 'element_ptr, 'character_data_ptr, 'Document option) RDocument_ext + 'Object, 'Node, - 'Element, 'CharacterData) heap" -register_default_tvars - "('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr, 'document_ptr, - 'shadow_root_ptr, 'Object, 'Node, 'Element, 'CharacterData, 'Document) heap" -type_synonym heap\<^sub>f\<^sub>i\<^sub>n\<^sub>a\<^sub>l = "(unit, unit, unit, unit, unit, unit, unit, unit, unit, unit, unit) heap" - - -definition document_ptr_kinds :: "(_) heap \ (_) document_ptr fset" - where - "document_ptr_kinds heap = the |`| (cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r |`| - (ffilter is_document_ptr_kind (object_ptr_kinds heap)))" - -definition document_ptrs :: "(_) heap \ (_) document_ptr fset" - where - "document_ptrs heap = ffilter is_document_ptr (document_ptr_kinds heap)" - -definition cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t :: "(_) Object \ (_) Document option" - where - "cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t obj = (case RObject.more obj of - Inr (Inl document) \ Some (RObject.extend (RObject.truncate obj) document) - | _ \ None)" -adhoc_overloading cast cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t - -definition cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t:: "(_) Document \ (_) Object" - where - "cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t document = (RObject.extend (RObject.truncate document) - (Inr (Inl (RObject.more document))))" -adhoc_overloading cast cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t - -definition is_document_kind :: "(_) Object \ bool" - where - "is_document_kind ptr \ cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr \ None" - -lemma document_ptr_kinds_simp [simp]: - "document_ptr_kinds (Heap (fmupd (cast document_ptr) document (the_heap h))) - = {|document_ptr|} |\| document_ptr_kinds h" - apply(auto simp add: document_ptr_kinds_def)[1] - by force - -lemma document_ptr_kinds_commutes [simp]: - "cast document_ptr |\| object_ptr_kinds h \ document_ptr |\| document_ptr_kinds h" - apply(auto simp add: object_ptr_kinds_def document_ptr_kinds_def)[1] - by (metis (no_types, lifting) document_ptr_casts_commute2 document_ptr_document_ptr_cast - ffmember_filter fimage_eqI fset.map_comp option.sel) - -definition get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t :: "(_) document_ptr \ (_) heap \ (_) Document option" - where - "get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr h = Option.bind (get (cast document_ptr) h) cast" -adhoc_overloading get get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t - -locale l_type_wf_def\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t -begin -definition a_type_wf :: "(_) heap \ bool" - where - "a_type_wf h = (CharacterDataClass.type_wf h \ - (\document_ptr \ fset (document_ptr_kinds h). get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr h \ None))" -end -global_interpretation l_type_wf_def\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t defines type_wf = a_type_wf . -lemmas type_wf_defs = a_type_wf_def - -locale l_type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t = l_type_wf type_wf for type_wf :: "((_) heap \ bool)" + - assumes type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t: "type_wf h \ DocumentClass.type_wf h" - -sublocale l_type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t \ l_type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a - apply(unfold_locales) - by (metis (full_types) type_wf_defs l_type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_axioms l_type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def) - -locale l_get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_lemmas = l_type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t -begin -sublocale l_get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_lemmas by unfold_locales -lemma get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_type_wf: - assumes "type_wf h" - shows "document_ptr |\| document_ptr_kinds h \ get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr h \ None" - using l_type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_axioms assms - apply(simp add: type_wf_defs get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def l_type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def) - by (metis document_ptr_kinds_commutes fmember.rep_eq is_none_bind is_none_simps(1) is_none_simps(2) local.get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf) -end - -global_interpretation l_get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_lemmas type_wf by unfold_locales - -definition put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t :: "(_) document_ptr \ (_) Document \ (_) heap \ (_) heap" - where - "put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr document = put (cast document_ptr) (cast document)" -adhoc_overloading put put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t - -lemma put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ptr_in_heap: - assumes "put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr document h = h'" - shows "document_ptr |\| document_ptr_kinds h'" - using assms - unfolding put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def - by (metis document_ptr_kinds_commutes put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_ptr_in_heap) - -lemma put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_put_ptrs: - assumes "put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr document h = h'" - shows "object_ptr_kinds h' = object_ptr_kinds h |\| {|cast document_ptr|}" - using assms - by (simp add: put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_put_ptrs) - - -lemma cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_inject [simp]: "cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t x = cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t y \ x = y" - apply(simp add: cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def RObject.extend_def) - by (metis (full_types) RObject.surjective old.unit.exhaust) - -lemma cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_none [simp]: - "cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t obj = None \ \ (\document. cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t document = obj)" - apply(auto simp add: cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def RObject.extend_def - split: sum.splits)[1] - by (metis (full_types) RObject.select_convs(2) RObject.surjective old.unit.exhaust) - -lemma cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_some [simp]: - "cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t obj = Some document \ cast document = obj" - by(auto simp add: cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def RObject.extend_def - split: sum.splits) - -lemma cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_inv [simp]: "cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t (cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t document) = Some document" - by simp - -lemma cast_document_not_node [simp]: - "cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t document \ cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t node" - "cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t node \ cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t document" - by(auto simp add: cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def RObject.extend_def) - -lemma get_document_ptr_simp1 [simp]: - "get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr (put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr document h) = Some document" - by(auto simp add: get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def) -lemma get_document_ptr_simp2 [simp]: - "document_ptr \ document_ptr' - \ get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr (put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr' document h) = get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr h" - by(auto simp add: get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def) - - -lemma get_document_ptr_simp3 [simp]: - "get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr (put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr f h) = get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr h" - by(auto simp add: get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def) -lemma get_document_ptr_simp4 [simp]: "get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr (put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr f h) = get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr h" - by(auto simp add: get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def) -lemma get_document_ptr_simp5 [simp]: - "get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr (put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr f h) = get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr h" - by(auto simp add: get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def) -lemma get_document_ptr_simp6 [simp]: "get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr (put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr f h) = get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr h" - by(auto simp add: get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def) - -lemma new\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t [simp]: - assumes "new\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_element_ptr, h')" - shows "get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr h = get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr h'" - using assms - by(auto simp add: new\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def) - -lemma new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t [simp]: - assumes "new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a h = (new_character_data_ptr, h')" - shows "get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr h = get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr h'" - using assms - by(auto simp add: new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def Let_def) - - - -abbreviation - create_document_obj :: "char list \ (_) element_ptr option \ (_) node_ptr list \ (_) Document" - where - "create_document_obj doctype_arg document_element_arg disconnected_nodes_arg - \ \ RObject.nothing = (), RDocument.nothing = (), doctype = doctype_arg, - document_element = document_element_arg, - disconnected_nodes = disconnected_nodes_arg, \ = None \" - -definition new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t :: "(_)heap \ ((_) document_ptr \ (_) heap)" - where - "new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = - (let new_document_ptr = document_ptr.Ref (Suc (fMax (finsert 0 (document_ptr.the_ref |`| (document_ptrs h))))) - in - (new_document_ptr, put new_document_ptr (create_document_obj '''' None []) h))" - -lemma new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ptr_in_heap: - assumes "new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_document_ptr, h')" - shows "new_document_ptr |\| document_ptr_kinds h'" - using assms - unfolding new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def - using put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ptr_in_heap by blast - -lemma new_document_ptr_new: - "document_ptr.Ref (Suc (fMax (finsert 0 (document_ptr.the_ref |`| document_ptrs h)))) - |\| document_ptrs h" - by (metis Suc_n_not_le_n document_ptr.sel(1) fMax_ge fimage_finsert finsertI1 finsertI2 set_finsert) - -lemma new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ptr_not_in_heap: - assumes "new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_document_ptr, h')" - shows "new_document_ptr |\| document_ptr_kinds h" - using assms - unfolding new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def - by (metis Pair_inject document_ptrs_def fMax_finsert fempty_iff ffmember_filter - fimage_is_fempty is_document_ptr_ref max_0L new_document_ptr_new) - -lemma new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_new_ptr: - assumes "new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_document_ptr, h')" - shows "object_ptr_kinds h' = object_ptr_kinds h |\| {|cast new_document_ptr|}" - using assms - by (metis Pair_inject new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_put_ptrs) - -lemma new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_is_document_ptr: - assumes "new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_document_ptr, h')" - shows "is_document_ptr new_document_ptr" - using assms - by(auto simp add: new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def) - -lemma new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t [simp]: - assumes "new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_document_ptr, h')" - assumes "ptr \ cast new_document_ptr" - shows "get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr h = get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr h'" - using assms - by(auto simp add: new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def) - -lemma new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_get\<^sub>N\<^sub>o\<^sub>d\<^sub>e [simp]: - assumes "new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_document_ptr, h')" - shows "get\<^sub>N\<^sub>o\<^sub>d\<^sub>e ptr h = get\<^sub>N\<^sub>o\<^sub>d\<^sub>e ptr h'" - using assms - apply(simp add: new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def) - by(auto simp add: get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def) - -lemma new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t [simp]: - assumes "new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_document_ptr, h')" - shows "get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr h = get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr h'" - using assms - by(auto simp add: new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def) - -lemma new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a [simp]: - assumes "new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_document_ptr, h')" - shows "get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a ptr h = get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a ptr h'" - using assms - by(auto simp add: new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def) - -lemma new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t [simp]: - assumes "new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_document_ptr, h')" - assumes "ptr \ new_document_ptr" - shows "get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr h = get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr h'" - using assms - by(auto simp add: new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def) - - -locale l_known_ptr\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t -begin -definition a_known_ptr :: "(_) object_ptr \ bool" - where - "a_known_ptr ptr = (known_ptr ptr \ is_document_ptr ptr)" - -lemma known_ptr_not_document_ptr: "\is_document_ptr ptr \ a_known_ptr ptr \ known_ptr ptr" - by(simp add: a_known_ptr_def) -end -global_interpretation l_known_ptr\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t defines known_ptr = a_known_ptr . -lemmas known_ptr_defs = a_known_ptr_def - - -locale l_known_ptrs\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t = l_known_ptr known_ptr for known_ptr :: "(_) object_ptr \ bool" -begin -definition a_known_ptrs :: "(_) heap \ bool" - where - "a_known_ptrs h = (\ptr \ fset (object_ptr_kinds h). known_ptr ptr)" - -lemma known_ptrs_known_ptr: "a_known_ptrs h \ ptr |\| object_ptr_kinds h \ known_ptr ptr" - apply(simp add: a_known_ptrs_def) - using notin_fset by fastforce - -lemma known_ptrs_preserved: - "object_ptr_kinds h = object_ptr_kinds h' \ a_known_ptrs h = a_known_ptrs h'" - by(auto simp add: a_known_ptrs_def) -lemma known_ptrs_subset: - "object_ptr_kinds h' |\| object_ptr_kinds h \ a_known_ptrs h \ a_known_ptrs h'" - by(simp add: a_known_ptrs_def less_eq_fset.rep_eq subsetD) -lemma known_ptrs_new_ptr: "object_ptr_kinds h' = object_ptr_kinds h |\| {|new_ptr|} \ known_ptr new_ptr \ a_known_ptrs h \ a_known_ptrs h'" - by(simp add: a_known_ptrs_def) -end -global_interpretation l_known_ptrs\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t known_ptr defines known_ptrs = a_known_ptrs . -lemmas known_ptrs_defs = a_known_ptrs_def - -lemma known_ptrs_is_l_known_ptrs [instances]: "l_known_ptrs known_ptr known_ptrs" - using known_ptrs_known_ptr known_ptrs_preserved l_known_ptrs_def known_ptrs_subset known_ptrs_new_ptr - by blast - -end diff --git a/Core_DOM/Core_SC_DOM/common/classes/DocumentClass.thy b/Core_DOM/Core_SC_DOM/common/classes/DocumentClass.thy new file mode 120000 index 0000000..9fd2a64 --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/classes/DocumentClass.thy @@ -0,0 +1 @@ +../../../Core_DOM/common/classes/DocumentClass.thy \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/classes/NodeClass.thy b/Core_DOM/Core_SC_DOM/common/classes/NodeClass.thy deleted file mode 100644 index fdbbff1..0000000 --- a/Core_DOM/Core_SC_DOM/common/classes/NodeClass.thy +++ /dev/null @@ -1,204 +0,0 @@ -(*********************************************************************************** - * Copyright (c) 2016-2018 The University of Sheffield, UK - * - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * * Redistributions of source code must retain the above copyright notice, this - * list of conditions and the following disclaimer. - * - * * Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - * SPDX-License-Identifier: BSD-2-Clause - ***********************************************************************************) - - -section\Node\ -text\In this theory, we introduce the types for the Node class.\ - -theory NodeClass - imports - ObjectClass - "../pointers/NodePointer" -begin - -subsubsection\Node\ - -record RNode = RObject - + nothing :: unit -register_default_tvars "'Node RNode_ext" -type_synonym 'Node Node = "'Node RNode_scheme" -register_default_tvars "'Node Node" -type_synonym ('Object, 'Node) Object = "('Node RNode_ext + 'Object) Object" -register_default_tvars "('Object, 'Node) Object" - -type_synonym ('object_ptr, 'node_ptr, 'Object, 'Node) heap - = "('node_ptr node_ptr + 'object_ptr, 'Node RNode_ext + 'Object) heap" -register_default_tvars - "('object_ptr, 'node_ptr, 'Object, 'Node) heap" -type_synonym heap\<^sub>f\<^sub>i\<^sub>n\<^sub>a\<^sub>l = "(unit, unit, unit, unit) heap" - - -definition node_ptr_kinds :: "(_) heap \ (_) node_ptr fset" - where - "node_ptr_kinds heap = - (the |`| (cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r |`| (ffilter is_node_ptr_kind (object_ptr_kinds heap))))" - -lemma node_ptr_kinds_simp [simp]: - "node_ptr_kinds (Heap (fmupd (cast node_ptr) node (the_heap h))) - = {|node_ptr|} |\| node_ptr_kinds h" - apply(auto simp add: node_ptr_kinds_def)[1] - by force - -definition cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e :: "(_) Object \ (_) Node option" - where - "cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e obj = (case RObject.more obj of Inl node - \ Some (RObject.extend (RObject.truncate obj) node) | _ \ None)" -adhoc_overloading cast cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e - -definition cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t:: "(_) Node \ (_) Object" - where - "cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t node = (RObject.extend (RObject.truncate node) (Inl (RObject.more node)))" -adhoc_overloading cast cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t - -definition is_node_kind :: "(_) Object \ bool" - where - "is_node_kind ptr \ cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e ptr \ None" - -definition get\<^sub>N\<^sub>o\<^sub>d\<^sub>e :: "(_) node_ptr \ (_) heap \ (_) Node option" - where - "get\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr h = Option.bind (get (cast node_ptr) h) cast" -adhoc_overloading get get\<^sub>N\<^sub>o\<^sub>d\<^sub>e - -locale l_type_wf_def\<^sub>N\<^sub>o\<^sub>d\<^sub>e -begin -definition a_type_wf :: "(_) heap \ bool" - where - "a_type_wf h = (ObjectClass.type_wf h - \ (\node_ptr \ fset( node_ptr_kinds h). get\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr h \ None))" -end -global_interpretation l_type_wf_def\<^sub>N\<^sub>o\<^sub>d\<^sub>e defines type_wf = a_type_wf . -lemmas type_wf_defs = a_type_wf_def - -locale l_type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e = l_type_wf type_wf for type_wf :: "((_) heap \ bool)" + - assumes type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e: "type_wf h \ NodeClass.type_wf h" - -sublocale l_type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e \ l_type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t - apply(unfold_locales) - using ObjectClass.a_type_wf_def by auto - -locale l_get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_lemmas = l_type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e -begin -sublocale l_get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_lemmas by unfold_locales -lemma get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_type_wf: - assumes "type_wf h" - shows "node_ptr |\| node_ptr_kinds h \ get\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr h \ None" - using l_type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e_axioms assms - apply(simp add: type_wf_defs get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def l_type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def) - by (metis bind_eq_None_conv ffmember_filter fimage_eqI fmember.rep_eq is_node_ptr_kind_cast - get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf node_ptr_casts_commute2 node_ptr_kinds_def option.sel option.simps(3)) -end - -global_interpretation l_get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_lemmas type_wf - by unfold_locales - -definition put\<^sub>N\<^sub>o\<^sub>d\<^sub>e :: "(_) node_ptr \ (_) Node \ (_) heap \ (_) heap" - where - "put\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr node = put (cast node_ptr) (cast node)" -adhoc_overloading put put\<^sub>N\<^sub>o\<^sub>d\<^sub>e - -lemma put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_ptr_in_heap: - assumes "put\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr node h = h'" - shows "node_ptr |\| node_ptr_kinds h'" - using assms - unfolding put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def node_ptr_kinds_def - by (metis ffmember_filter fimage_eqI is_node_ptr_kind_cast node_ptr_casts_commute2 - option.sel put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_ptr_in_heap) - -lemma put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_put_ptrs: - assumes "put\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr node h = h'" - shows "object_ptr_kinds h' = object_ptr_kinds h |\| {|cast node_ptr|}" - using assms - by (simp add: put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_put_ptrs) - -lemma node_ptr_kinds_commutes [simp]: - "cast node_ptr |\| object_ptr_kinds h \ node_ptr |\| node_ptr_kinds h" - apply(auto simp add: node_ptr_kinds_def split: option.splits)[1] - by (metis (no_types, lifting) ffmember_filter fimage_eqI fset.map_comp - is_node_ptr_kind_none node_ptr_casts_commute2 - option.distinct(1) option.sel) - -lemma node_empty [simp]: - "\RObject.nothing = (), RNode.nothing = (), \ = RNode.more node\ = node" - by simp - -lemma cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_inject [simp]: "cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t x = cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t y \ x = y" - apply(simp add: cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def RObject.extend_def) - by (metis (full_types) RObject.surjective old.unit.exhaust) - -lemma cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_none [simp]: - "cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e obj = None \ \ (\node. cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t node = obj)" - apply(auto simp add: cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def RObject.extend_def split: sum.splits)[1] - by (metis (full_types) RObject.select_convs(2) RObject.surjective old.unit.exhaust) - -lemma cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_some [simp]: "cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e obj = Some node \ cast node = obj" - by(auto simp add: cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def RObject.extend_def split: sum.splits) - -lemma cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_inv [simp]: "cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e (cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t node) = Some node" - by simp - -locale l_known_ptr\<^sub>N\<^sub>o\<^sub>d\<^sub>e -begin -definition a_known_ptr :: "(_) object_ptr \ bool" - where - "a_known_ptr ptr = False" -end -global_interpretation l_known_ptr\<^sub>N\<^sub>o\<^sub>d\<^sub>e defines known_ptr = a_known_ptr . -lemmas known_ptr_defs = a_known_ptr_def - - -locale l_known_ptrs\<^sub>N\<^sub>o\<^sub>d\<^sub>e = l_known_ptr known_ptr for known_ptr :: "(_) object_ptr \ bool" -begin -definition a_known_ptrs :: "(_) heap \ bool" - where - "a_known_ptrs h = (\ptr \ fset (object_ptr_kinds h). known_ptr ptr)" - -lemma known_ptrs_known_ptr: "a_known_ptrs h \ ptr |\| object_ptr_kinds h \ known_ptr ptr" - apply(simp add: a_known_ptrs_def) - using notin_fset by fastforce -lemma known_ptrs_preserved: "object_ptr_kinds h = object_ptr_kinds h' \ a_known_ptrs h = a_known_ptrs h'" - by(auto simp add: a_known_ptrs_def) -lemma known_ptrs_subset: "object_ptr_kinds h' |\| object_ptr_kinds h \ a_known_ptrs h \ a_known_ptrs h'" - by(simp add: a_known_ptrs_def less_eq_fset.rep_eq subsetD) -lemma known_ptrs_new_ptr: "object_ptr_kinds h' = object_ptr_kinds h |\| {|new_ptr|} \ known_ptr new_ptr \ a_known_ptrs h \ a_known_ptrs h'" - by(simp add: a_known_ptrs_def) -end -global_interpretation l_known_ptrs\<^sub>N\<^sub>o\<^sub>d\<^sub>e known_ptr defines known_ptrs = a_known_ptrs . -lemmas known_ptrs_defs = a_known_ptrs_def - -lemma known_ptrs_is_l_known_ptrs: "l_known_ptrs known_ptr known_ptrs" - using known_ptrs_known_ptr known_ptrs_preserved l_known_ptrs_def known_ptrs_subset known_ptrs_new_ptr - by blast - -lemma get_node_ptr_simp1 [simp]: "get\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr (put\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr node h) = Some node" - by(auto simp add: get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def) -lemma get_node_ptr_simp2 [simp]: - "node_ptr \ node_ptr' \ get\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr (put\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr' node h) = get\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr h" - by(auto simp add: get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def) - -end diff --git a/Core_DOM/Core_SC_DOM/common/classes/NodeClass.thy b/Core_DOM/Core_SC_DOM/common/classes/NodeClass.thy new file mode 120000 index 0000000..ab359cb --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/classes/NodeClass.thy @@ -0,0 +1 @@ +../../../Core_DOM/common/classes/NodeClass.thy \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/classes/ObjectClass.thy b/Core_DOM/Core_SC_DOM/common/classes/ObjectClass.thy deleted file mode 100644 index b3091ef..0000000 --- a/Core_DOM/Core_SC_DOM/common/classes/ObjectClass.thy +++ /dev/null @@ -1,217 +0,0 @@ -(*********************************************************************************** - * Copyright (c) 2016-2018 The University of Sheffield, UK - * - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * * Redistributions of source code must retain the above copyright notice, this - * list of conditions and the following disclaimer. - * - * * Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - * SPDX-License-Identifier: BSD-2-Clause - ***********************************************************************************) - -section\Object\ -text\In this theory, we introduce the definition of the class Object. This class is the -common superclass of our class model.\ - -theory ObjectClass - imports - BaseClass - "../pointers/ObjectPointer" -begin - -record RObject = - nothing :: unit -register_default_tvars "'Object RObject_ext" -type_synonym 'Object Object = "'Object RObject_scheme" -register_default_tvars "'Object Object" - -datatype ('object_ptr, 'Object) heap = Heap (the_heap: "((_) object_ptr, (_) Object) fmap") -register_default_tvars "('object_ptr, 'Object) heap" -type_synonym heap\<^sub>f\<^sub>i\<^sub>n\<^sub>a\<^sub>l = "(unit, unit) heap" - -definition object_ptr_kinds :: "(_) heap \ (_) object_ptr fset" - where - "object_ptr_kinds = fmdom \ the_heap" - -lemma object_ptr_kinds_simp [simp]: - "object_ptr_kinds (Heap (fmupd object_ptr object (the_heap h))) - = {|object_ptr|} |\| object_ptr_kinds h" - by(auto simp add: object_ptr_kinds_def) - -definition get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t :: "(_) object_ptr \ (_) heap \ (_) Object option" - where - "get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr h = fmlookup (the_heap h) ptr" -adhoc_overloading get get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t - -locale l_type_wf_def\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t -begin -definition a_type_wf :: "(_) heap \ bool" - where - "a_type_wf h = True" -end -global_interpretation l_type_wf_def\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t defines type_wf = a_type_wf . -lemmas type_wf_defs = a_type_wf_def - -locale l_type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t = l_type_wf type_wf for type_wf :: "((_) heap \ bool)" + - assumes type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t: "type_wf h \ ObjectClass.type_wf h" - -locale l_get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_lemmas = l_type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t -begin -lemma get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf: - assumes "type_wf h" - shows "object_ptr |\| object_ptr_kinds h \ get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr h \ None" - using l_type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_axioms assms - apply(simp add: type_wf_def get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def) - by (simp add: fmlookup_dom_iff object_ptr_kinds_def) -end - -global_interpretation l_get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_lemmas type_wf - by (simp add: l_get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_lemmas.intro l_type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t.intro) - -definition put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t :: "(_) object_ptr \ (_) Object \ (_) heap \ (_) heap" - where - "put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h = Heap (fmupd ptr obj (the_heap h))" -adhoc_overloading put put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t - -lemma put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_ptr_in_heap: - assumes "put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr object h = h'" - shows "object_ptr |\| object_ptr_kinds h'" - using assms - unfolding put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def - by auto - -lemma put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_put_ptrs: - assumes "put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr object h = h'" - shows "object_ptr_kinds h' = object_ptr_kinds h |\| {|object_ptr|}" - using assms - by (metis comp_apply fmdom_fmupd funion_finsert_right heap.sel object_ptr_kinds_def - sup_bot.right_neutral put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def) - -lemma object_more_extend_id [simp]: "more (extend x y) = y" - by(simp add: extend_def) - -lemma object_empty [simp]: "\nothing = (), \ = more x\ = x" - by simp - -locale l_known_ptr\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t -begin -definition a_known_ptr :: "(_) object_ptr \ bool" - where - "a_known_ptr ptr = False" - -lemma known_ptr_not_object_ptr: - "a_known_ptr ptr \ \is_object_ptr ptr \ known_ptr ptr" - by(simp add: a_known_ptr_def) -end -global_interpretation l_known_ptr\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t defines known_ptr = a_known_ptr . -lemmas known_ptr_defs = a_known_ptr_def - -locale l_known_ptrs = l_known_ptr known_ptr for known_ptr :: "(_) object_ptr \ bool" + - fixes known_ptrs :: "(_) heap \ bool" - assumes known_ptrs_known_ptr: "known_ptrs h \ ptr |\| object_ptr_kinds h \ known_ptr ptr" - assumes known_ptrs_preserved: "object_ptr_kinds h = object_ptr_kinds h' \ known_ptrs h = known_ptrs h'" - assumes known_ptrs_subset: "object_ptr_kinds h' |\| object_ptr_kinds h \ known_ptrs h \ known_ptrs h'" - assumes known_ptrs_new_ptr: "object_ptr_kinds h' = object_ptr_kinds h |\| {|new_ptr|} \ known_ptr new_ptr \ known_ptrs h \ known_ptrs h'" - -locale l_known_ptrs\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t = l_known_ptr known_ptr for known_ptr :: "(_) object_ptr \ bool" -begin -definition a_known_ptrs :: "(_) heap \ bool" - where - "a_known_ptrs h = (\ptr \ fset (object_ptr_kinds h). known_ptr ptr)" - -lemma known_ptrs_known_ptr: - "a_known_ptrs h \ ptr |\| object_ptr_kinds h \ known_ptr ptr" - apply(simp add: a_known_ptrs_def) - using notin_fset by fastforce - -lemma known_ptrs_preserved: "object_ptr_kinds h = object_ptr_kinds h' \ a_known_ptrs h = a_known_ptrs h'" - by(auto simp add: a_known_ptrs_def) -lemma known_ptrs_subset: "object_ptr_kinds h' |\| object_ptr_kinds h \ a_known_ptrs h \ a_known_ptrs h'" - by(simp add: a_known_ptrs_def less_eq_fset.rep_eq subsetD) -lemma known_ptrs_new_ptr: "object_ptr_kinds h' = object_ptr_kinds h |\| {|new_ptr|} \ known_ptr new_ptr \ a_known_ptrs h \ a_known_ptrs h'" - by(simp add: a_known_ptrs_def) -end -global_interpretation l_known_ptrs\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t known_ptr defines known_ptrs = a_known_ptrs . -lemmas known_ptrs_defs = a_known_ptrs_def - -lemma known_ptrs_is_l_known_ptrs: "l_known_ptrs known_ptr known_ptrs" - using known_ptrs_known_ptr known_ptrs_preserved l_known_ptrs_def known_ptrs_subset known_ptrs_new_ptr - by blast - - -lemma get_object_ptr_simp1 [simp]: "get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr object h) = Some object" - by(simp add: get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def) -lemma get_object_ptr_simp2 [simp]: - "object_ptr \ object_ptr' - \ get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr' object h) = get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr h" - by(simp add: get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def) - - -subsection\Limited Heap Modifications\ - -definition heap_unchanged_except :: "(_) object_ptr set \ (_) heap \ (_) heap \ bool" - where - "heap_unchanged_except S h h' = (\ptr \ (fset (object_ptr_kinds h) - \ (fset (object_ptr_kinds h'))) - S. get ptr h = get ptr h')" - -definition delete\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t :: "(_) object_ptr \ (_) heap \ (_) heap option" where - "delete\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr h = (if ptr |\| object_ptr_kinds h then Some (Heap (fmdrop ptr (the_heap h))) - else None)" - -lemma delete\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_pointer_removed: - assumes "delete\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr h = Some h'" - shows "ptr |\| object_ptr_kinds h'" - using assms - by(auto simp add: delete\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def object_ptr_kinds_def split: if_splits) - -lemma delete\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_pointer_ptr_in_heap: - assumes "delete\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr h = Some h'" - shows "ptr |\| object_ptr_kinds h" - using assms - by(auto simp add: delete\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def object_ptr_kinds_def split: if_splits) - -lemma delete\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_ok: - assumes "ptr |\| object_ptr_kinds h" - shows "delete\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr h \ None" - using assms - by(auto simp add: delete\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def object_ptr_kinds_def split: if_splits) - - -subsection \Code Generator Setup\ - -definition "create_heap xs = Heap (fmap_of_list xs)" - -code_datatype ObjectClass.heap.Heap create_heap - -lemma object_ptr_kinds_code3 [code]: - "fmlookup (the_heap (create_heap xs)) x = map_of xs x" - by(auto simp add: create_heap_def fmlookup_of_list) - -lemma object_ptr_kinds_code4 [code]: - "the_heap (create_heap xs) = fmap_of_list xs" - by(simp add: create_heap_def) - -lemma object_ptr_kinds_code5 [code]: - "the_heap (Heap x) = x" - by simp - - -end diff --git a/Core_DOM/Core_SC_DOM/common/classes/ObjectClass.thy b/Core_DOM/Core_SC_DOM/common/classes/ObjectClass.thy new file mode 120000 index 0000000..694de1b --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/classes/ObjectClass.thy @@ -0,0 +1 @@ +../../../Core_DOM/common/classes/ObjectClass.thy \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/monads/BaseMonad.thy b/Core_DOM/Core_SC_DOM/common/monads/BaseMonad.thy deleted file mode 100644 index 346c768..0000000 --- a/Core_DOM/Core_SC_DOM/common/monads/BaseMonad.thy +++ /dev/null @@ -1,376 +0,0 @@ -(*********************************************************************************** - * Copyright (c) 2016-2018 The University of Sheffield, UK - * - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * * Redistributions of source code must retain the above copyright notice, this - * list of conditions and the following disclaimer. - * - * * Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - * SPDX-License-Identifier: BSD-2-Clause - ***********************************************************************************) - -section\The Monad Infrastructure\ -text\In this theory, we introduce the basic infrastructure for our monadic class encoding.\ -theory BaseMonad - imports - "../classes/BaseClass" - "../preliminaries/Heap_Error_Monad" -begin -subsection\Datatypes\ - -datatype exception = NotFoundError | SegmentationFault | HierarchyRequestError | AssertException - | NonTerminationException | InvokeError | TypeError | DebugException nat - -lemma finite_set_in [simp]: "x \ fset FS \ x |\| FS" - by (meson notin_fset) - -consts put_M :: 'a -consts get_M :: 'a -consts delete_M :: 'a - -lemma sorted_list_of_set_eq [dest]: - "sorted_list_of_set (fset x) = sorted_list_of_set (fset y) \ x = y" - by (metis finite_fset fset_inject sorted_list_of_set(1)) - - -locale l_ptr_kinds_M = - fixes ptr_kinds :: "'heap \ 'ptr::linorder fset" -begin -definition a_ptr_kinds_M :: "('heap, exception, 'ptr list) prog" - where - "a_ptr_kinds_M = do { - h \ get_heap; - return (sorted_list_of_set (fset (ptr_kinds h))) - }" - -lemma ptr_kinds_M_ok [simp]: "h \ ok a_ptr_kinds_M" - by(simp add: a_ptr_kinds_M_def) - -lemma ptr_kinds_M_pure [simp]: "pure a_ptr_kinds_M h" - by (auto simp add: a_ptr_kinds_M_def intro: bind_pure_I) - -lemma ptr_kinds_ptr_kinds_M [simp]: "ptr \ set |h \ a_ptr_kinds_M|\<^sub>r \ ptr |\| ptr_kinds h" - by(simp add: a_ptr_kinds_M_def) - -lemma ptr_kinds_M_ptr_kinds [simp]: - "h \ a_ptr_kinds_M \\<^sub>r xa \ xa = sorted_list_of_set (fset (ptr_kinds h))" - by(auto simp add: a_ptr_kinds_M_def) -lemma ptr_kinds_M_ptr_kinds_returns_result [simp]: - "h \ a_ptr_kinds_M \ f \\<^sub>r x \ h \ f (sorted_list_of_set (fset (ptr_kinds h))) \\<^sub>r x" - by(auto simp add: a_ptr_kinds_M_def) -lemma ptr_kinds_M_ptr_kinds_returns_heap [simp]: - "h \ a_ptr_kinds_M \ f \\<^sub>h h' \ h \ f (sorted_list_of_set (fset (ptr_kinds h))) \\<^sub>h h'" - by(auto simp add: a_ptr_kinds_M_def) -end - -locale l_get_M = - fixes get :: "'ptr \ 'heap \ 'obj option" - fixes type_wf :: "'heap \ bool" - fixes ptr_kinds :: "'heap \ 'ptr fset" - assumes "type_wf h \ ptr |\| ptr_kinds h \ get ptr h \ None" - assumes "get ptr h \ None \ ptr |\| ptr_kinds h" -begin - -definition a_get_M :: "'ptr \ ('obj \ 'result) \ ('heap, exception, 'result) prog" - where - "a_get_M ptr getter = (do { - h \ get_heap; - (case get ptr h of - Some res \ return (getter res) - | None \ error SegmentationFault) - })" - -lemma get_M_pure [simp]: "pure (a_get_M ptr getter) h" - by(auto simp add: a_get_M_def bind_pure_I split: option.splits) - -lemma get_M_ok: - "type_wf h \ ptr |\| ptr_kinds h \ h \ ok (a_get_M ptr getter)" - apply(simp add: a_get_M_def) - by (metis l_get_M_axioms l_get_M_def option.case_eq_if return_ok) -lemma get_M_ptr_in_heap: - "h \ ok (a_get_M ptr getter) \ ptr |\| ptr_kinds h" - apply(simp add: a_get_M_def) - by (metis error_returns_result is_OK_returns_result_E l_get_M_axioms l_get_M_def option.simps(4)) - -end - -locale l_put_M = l_get_M get for get :: "'ptr \ 'heap \ 'obj option" + - fixes put :: "'ptr \ 'obj \ 'heap \ 'heap" -begin -definition a_put_M :: "'ptr \ (('v \ 'v) \ 'obj \ 'obj) \ 'v \ ('heap, exception, unit) prog" - where - "a_put_M ptr setter v = (do { - obj \ a_get_M ptr id; - h \ get_heap; - return_heap (put ptr (setter (\_. v) obj) h) - })" - -lemma put_M_ok: - "type_wf h \ ptr |\| ptr_kinds h \ h \ ok (a_put_M ptr setter v)" - by(auto simp add: a_put_M_def intro!: bind_is_OK_I2 dest: get_M_ok elim!: bind_is_OK_E) - -lemma put_M_ptr_in_heap: - "h \ ok (a_put_M ptr setter v) \ ptr |\| ptr_kinds h" - by(auto simp add: a_put_M_def intro!: bind_is_OK_I2 elim: get_M_ptr_in_heap - dest: is_OK_returns_result_I elim!: bind_is_OK_E) - -end - -subsection \Setup for Defining Partial Functions\ - -lemma execute_admissible: - "ccpo.admissible (fun_lub (flat_lub (Inl (e::'e)))) (fun_ord (flat_ord (Inl e))) - ((\a. \(h::'heap) h2 (r::'result). h \ a = Inr (r, h2) \ P h h2 r) \ Prog)" -proof (unfold comp_def, rule ccpo.admissibleI, clarify) - fix A :: "('heap \ 'e + 'result \ 'heap) set" - let ?lub = "Prog (fun_lub (flat_lub (Inl e)) A)" - fix h h2 r - assume 1: "Complete_Partial_Order.chain (fun_ord (flat_ord (Inl e))) A" - and 2: "\xa\A. \h h2 r. h \ Prog xa = Inr (r, h2) \ P h h2 r" - and 4: "h \ Prog (fun_lub (flat_lub (Inl e)) A) = Inr (r, h2)" - have h1:"\a. Complete_Partial_Order.chain (flat_ord (Inl e)) {y. \f\A. y = f a}" - by (rule chain_fun[OF 1]) - show "P h h2 r" - using chain_fun[OF 1] flat_lub_in_chain[OF chain_fun[OF 1]] 2 4 unfolding execute_def fun_lub_def - by force -qed - -lemma execute_admissible2: - "ccpo.admissible (fun_lub (flat_lub (Inl (e::'e)))) (fun_ord (flat_ord (Inl e))) - ((\a. \(h::'heap) h' h2 h2' (r::'result) r'. - h \ a = Inr (r, h2) \ h' \ a = Inr (r', h2') \ P h h' h2 h2' r r') \ Prog)" -proof (unfold comp_def, rule ccpo.admissibleI, clarify) - fix A :: "('heap \ 'e + 'result \ 'heap) set" - let ?lub = "Prog (fun_lub (flat_lub (Inl e)) A)" - fix h h' h2 h2' r r' - assume 1: "Complete_Partial_Order.chain (fun_ord (flat_ord (Inl e))) A" - and 2 [rule_format]: "\xa\A. \h h' h2 h2' r r'. h \ Prog xa = Inr (r, h2) - \ h' \ Prog xa = Inr (r', h2') \ P h h' h2 h2' r r'" - and 4: "h \ Prog (fun_lub (flat_lub (Inl e)) A) = Inr (r, h2)" - and 5: "h' \ Prog (fun_lub (flat_lub (Inl e)) A) = Inr (r', h2')" - have h1:"\a. Complete_Partial_Order.chain (flat_ord (Inl e)) {y. \f\A. y = f a}" - by (rule chain_fun[OF 1]) - have "h \ ?lub \ {y. \f\A. y = f h}" - using flat_lub_in_chain[OF h1] 4 - unfolding execute_def fun_lub_def - by auto - moreover have "h' \ ?lub \ {y. \f\A. y = f h'}" - using flat_lub_in_chain[OF h1] 5 - unfolding execute_def fun_lub_def - by auto - ultimately obtain f where - "f \ A" and - "h \ Prog f = Inr (r, h2)" and - "h' \ Prog f = Inr (r', h2')" - using 1 4 5 - apply(auto simp add: chain_def fun_ord_def flat_ord_def execute_def)[1] - by (metis Inl_Inr_False) - then show "P h h' h2 h2' r r'" - by(fact 2) -qed - -definition dom_prog_ord :: - "('heap, exception, 'result) prog \ ('heap, exception, 'result) prog \ bool" where - "dom_prog_ord = img_ord (\a b. execute b a) (fun_ord (flat_ord (Inl NonTerminationException)))" - -definition dom_prog_lub :: - "('heap, exception, 'result) prog set \ ('heap, exception, 'result) prog" where - "dom_prog_lub = img_lub (\a b. execute b a) Prog (fun_lub (flat_lub (Inl NonTerminationException)))" - -lemma dom_prog_lub_empty: "dom_prog_lub {} = error NonTerminationException" - by(simp add: dom_prog_lub_def img_lub_def fun_lub_def flat_lub_def error_def) - -lemma dom_prog_interpretation: "partial_function_definitions dom_prog_ord dom_prog_lub" -proof - - have "partial_function_definitions (fun_ord (flat_ord (Inl NonTerminationException))) - (fun_lub (flat_lub (Inl NonTerminationException)))" - by (rule partial_function_lift) (rule flat_interpretation) - then show ?thesis - apply (simp add: dom_prog_lub_def dom_prog_ord_def flat_interpretation execute_def) - using partial_function_image prog.expand prog.sel by blast -qed - -interpretation dom_prog: partial_function_definitions dom_prog_ord dom_prog_lub - rewrites "dom_prog_lub {} \ error NonTerminationException" - by (fact dom_prog_interpretation)(simp add: dom_prog_lub_empty) - -lemma admissible_dom_prog: - "dom_prog.admissible (\f. \x h h' r. h \ f x \\<^sub>r r \ h \ f x \\<^sub>h h' \ P x h h' r)" -proof (rule admissible_fun[OF dom_prog_interpretation]) - fix x - show "ccpo.admissible dom_prog_lub dom_prog_ord (\a. \h h' r. h \ a \\<^sub>r r \ h \ a \\<^sub>h h' - \ P x h h' r)" - unfolding dom_prog_ord_def dom_prog_lub_def - proof (intro admissible_image partial_function_lift flat_interpretation) - show "ccpo.admissible (fun_lub (flat_lub (Inl NonTerminationException))) - (fun_ord (flat_ord (Inl NonTerminationException))) - ((\a. \h h' r. h \ a \\<^sub>r r \ h \ a \\<^sub>h h' \ P x h h' r) \ Prog)" - by(auto simp add: execute_admissible returns_result_def returns_heap_def split: sum.splits) - next - show "\x y. (\b. b \ x) = (\b. b \ y) \ x = y" - by(simp add: execute_def prog.expand) - next - show "\x. (\b. b \ Prog x) = x" - by(simp add: execute_def) - qed -qed - -lemma admissible_dom_prog2: - "dom_prog.admissible (\f. \x h h2 h' h2' r r2. h \ f x \\<^sub>r r \ h \ f x \\<^sub>h h' - \ h2 \ f x \\<^sub>r r2 \ h2 \ f x \\<^sub>h h2' \ P x h h2 h' h2' r r2)" -proof (rule admissible_fun[OF dom_prog_interpretation]) - fix x - show "ccpo.admissible dom_prog_lub dom_prog_ord (\a. \h h2 h' h2' r r2. h \ a \\<^sub>r r - \ h \ a \\<^sub>h h' \ h2 \ a \\<^sub>r r2 \ h2 \ a \\<^sub>h h2' \ P x h h2 h' h2' r r2)" - unfolding dom_prog_ord_def dom_prog_lub_def - proof (intro admissible_image partial_function_lift flat_interpretation) - show "ccpo.admissible (fun_lub (flat_lub (Inl NonTerminationException))) - (fun_ord (flat_ord (Inl NonTerminationException))) - ((\a. \h h2 h' h2' r r2. h \ a \\<^sub>r r \ h \ a \\<^sub>h h' \ h2 \ a \\<^sub>r r2 \ h2 \ a \\<^sub>h h2' - \ P x h h2 h' h2' r r2) \ Prog)" - by(auto simp add: returns_result_def returns_heap_def intro!: ccpo.admissibleI - dest!: ccpo.admissibleD[OF execute_admissible2[where P="P x"]] - split: sum.splits) - next - show "\x y. (\b. b \ x) = (\b. b \ y) \ x = y" - by(simp add: execute_def prog.expand) - next - show "\x. (\b. b \ Prog x) = x" - by(simp add: execute_def) - qed -qed - -lemma fixp_induct_dom_prog: - fixes F :: "'c \ 'c" and - U :: "'c \ 'b \ ('heap, exception, 'result) prog" and - C :: "('b \ ('heap, exception, 'result) prog) \ 'c" and - P :: "'b \ 'heap \ 'heap \ 'result \ bool" - assumes mono: "\x. monotone (fun_ord dom_prog_ord) dom_prog_ord (\f. U (F (C f)) x)" - assumes eq: "f \ C (ccpo.fixp (fun_lub dom_prog_lub) (fun_ord dom_prog_ord) (\f. U (F (C f))))" - assumes inverse2: "\f. U (C f) = f" - assumes step: "\f x h h' r. (\x h h' r. h \ (U f x) \\<^sub>r r \ h \ (U f x) \\<^sub>h h' \ P x h h' r) - \ h \ (U (F f) x) \\<^sub>r r \ h \ (U (F f) x) \\<^sub>h h' \ P x h h' r" - assumes defined: "h \ (U f x) \\<^sub>r r" and "h \ (U f x) \\<^sub>h h'" - shows "P x h h' r" - using step defined dom_prog.fixp_induct_uc[of U F C, OF mono eq inverse2 admissible_dom_prog, of P] - by (metis assms(6) error_returns_heap) - -declaration \Partial_Function.init "dom_prog" @{term dom_prog.fixp_fun} - @{term dom_prog.mono_body} @{thm dom_prog.fixp_rule_uc} @{thm dom_prog.fixp_induct_uc} - (SOME @{thm fixp_induct_dom_prog})\ - - -abbreviation "mono_dom_prog \ monotone (fun_ord dom_prog_ord) dom_prog_ord" - -lemma dom_prog_ordI: - assumes "\h. h \ f \\<^sub>e NonTerminationException \ h \ f = h \ g" - shows "dom_prog_ord f g" -proof(auto simp add: dom_prog_ord_def img_ord_def fun_ord_def flat_ord_def)[1] - fix x - assume "x \ f \ x \ g" - then show "x \ f = Inl NonTerminationException" - using assms[where h=x] - by(auto simp add: returns_error_def split: sum.splits) -qed - -lemma dom_prog_ordE: - assumes "dom_prog_ord x y" - obtains "h \ x \\<^sub>e NonTerminationException" | " h \ x = h \ y" - using assms unfolding dom_prog_ord_def img_ord_def fun_ord_def flat_ord_def - using returns_error_def by force - - -lemma bind_mono [partial_function_mono]: - fixes B :: "('a \ ('heap, exception, 'result) prog) \ ('heap, exception, 'result2) prog" - assumes mf: "mono_dom_prog B" and mg: "\y. mono_dom_prog (\f. C y f)" - shows "mono_dom_prog (\f. B f \ (\y. C y f))" -proof (rule monotoneI) - fix f g :: "'a \ ('heap, exception, 'result) prog" - assume fg: "dom_prog.le_fun f g" - from mf - have 1: "dom_prog_ord (B f) (B g)" by (rule monotoneD) (rule fg) - from mg - have 2: "\y'. dom_prog_ord (C y' f) (C y' g)" by (rule monotoneD) (rule fg) - - have "dom_prog_ord (B f \ (\y. C y f)) (B g \ (\y. C y f))" - (is "dom_prog_ord ?L ?R") - proof (rule dom_prog_ordI) - fix h - from 1 show "h \ ?L \\<^sub>e NonTerminationException \ h \ ?L = h \ ?R" - apply(rule dom_prog_ordE) - apply(auto)[1] - using bind_cong by fastforce - qed - also - have h1: "dom_prog_ord (B g \ (\y'. C y' f)) (B g \ (\y'. C y' g))" - (is "dom_prog_ord ?L ?R") - proof (rule dom_prog_ordI) - (* { *) - fix h - show "h \ ?L \\<^sub>e NonTerminationException \ h \ ?L = h \ ?R" - proof (cases "h \ ok (B g)") - case True - then obtain x h' where x: "h \ B g \\<^sub>r x" and h': "h \ B g \\<^sub>h h'" - by blast - then have "dom_prog_ord (C x f) (C x g)" - using 2 by simp - then show ?thesis - using x h' - apply(auto intro!: bind_returns_error_I3 dest: returns_result_eq dest!: dom_prog_ordE)[1] - apply(auto simp add: execute_bind_simp)[1] - using "2" dom_prog_ordE by metis - next - case False - then obtain e where e: "h \ B g \\<^sub>e e" - by(simp add: is_OK_def returns_error_def split: sum.splits) - have "h \ B g \ (\y'. C y' f) \\<^sub>e e" - using e by(auto) - moreover have "h \ B g \ (\y'. C y' g) \\<^sub>e e" - using e by auto - ultimately show ?thesis - using bind_returns_error_eq by metis - qed - qed - finally (dom_prog.leq_trans) - show "dom_prog_ord (B f \ (\y. C y f)) (B g \ (\y'. C y' g))" . -qed - -lemma mono_dom_prog1 [partial_function_mono]: - fixes g :: "('a \ ('heap, exception, 'result) prog) \ 'b \ ('heap, exception, 'result) prog" - assumes "\x. (mono_dom_prog (\f. g f x))" - shows "mono_dom_prog (\f. map_M (g f) xs)" - using assms - apply (induct xs) - by(auto simp add: call_mono dom_prog.const_mono intro!: bind_mono) - -lemma mono_dom_prog2 [partial_function_mono]: - fixes g :: "('a \ ('heap, exception, 'result) prog) \ 'b \ ('heap, exception, 'result) prog" - assumes "\x. (mono_dom_prog (\f. g f x))" - shows "mono_dom_prog (\f. forall_M (g f) xs)" - using assms - apply (induct xs) - by(auto simp add: call_mono dom_prog.const_mono intro!: bind_mono) - -lemma sorted_list_set_cong [simp]: - "sorted_list_of_set (fset FS) = sorted_list_of_set (fset FS') \ FS = FS'" - by auto - -end diff --git a/Core_DOM/Core_SC_DOM/common/monads/BaseMonad.thy b/Core_DOM/Core_SC_DOM/common/monads/BaseMonad.thy new file mode 120000 index 0000000..0db4bd7 --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/monads/BaseMonad.thy @@ -0,0 +1 @@ +../../../Core_DOM/common/monads/BaseMonad.thy \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/monads/CharacterDataMonad.thy b/Core_DOM/Core_SC_DOM/common/monads/CharacterDataMonad.thy deleted file mode 100644 index 209d410..0000000 --- a/Core_DOM/Core_SC_DOM/common/monads/CharacterDataMonad.thy +++ /dev/null @@ -1,531 +0,0 @@ -(*********************************************************************************** - * Copyright (c) 2016-2018 The University of Sheffield, UK - * - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * * Redistributions of source code must retain the above copyright notice, this - * list of conditions and the following disclaimer. - * - * * Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - * SPDX-License-Identifier: BSD-2-Clause - ***********************************************************************************) - -section\CharacterData\ -text\In this theory, we introduce the monadic method setup for the CharacterData class.\ -theory CharacterDataMonad - imports - ElementMonad - "../classes/CharacterDataClass" -begin - -type_synonym ('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr, 'document_ptr, - 'shadow_root_ptr, 'Object, 'Node, 'Element, 'CharacterData, 'result) dom_prog - = "((_) heap, exception, 'result) prog" -register_default_tvars - "('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr, 'document_ptr, 'shadow_root_ptr, - 'Object, 'Node, 'Element, 'CharacterData, 'result) dom_prog" - - -global_interpretation l_ptr_kinds_M character_data_ptr_kinds - defines character_data_ptr_kinds_M = a_ptr_kinds_M . -lemmas character_data_ptr_kinds_M_defs = a_ptr_kinds_M_def - -lemma character_data_ptr_kinds_M_eq: - assumes "|h \ node_ptr_kinds_M|\<^sub>r = |h' \ node_ptr_kinds_M|\<^sub>r" - shows "|h \ character_data_ptr_kinds_M|\<^sub>r = |h' \ character_data_ptr_kinds_M|\<^sub>r" - using assms - by(auto simp add: character_data_ptr_kinds_M_defs node_ptr_kinds_M_defs - character_data_ptr_kinds_def) - -lemma character_data_ptr_kinds_M_reads: - "reads (\node_ptr. {preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t node_ptr RObject.nothing)}) character_data_ptr_kinds_M h h'" - using node_ptr_kinds_M_reads - apply(simp add: reads_def node_ptr_kinds_M_defs character_data_ptr_kinds_M_defs - character_data_ptr_kinds_def preserved_def) - by (smt node_ptr_kinds_small preserved_def unit_all_impI) - -global_interpretation l_dummy defines get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a = "l_get_M.a_get_M get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a" . -lemma get_M_is_l_get_M: "l_get_M get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a type_wf character_data_ptr_kinds" - apply(simp add: get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_type_wf l_get_M_def) - by (metis (no_types, hide_lams) NodeMonad.get_M_is_l_get_M bind_eq_Some_conv - character_data_ptr_kinds_commutes get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def l_get_M_def option.distinct(1)) -lemmas get_M_defs = get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def[unfolded l_get_M.a_get_M_def[OF get_M_is_l_get_M]] - -adhoc_overloading get_M get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a - -locale l_get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_lemmas = l_type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a -begin -sublocale l_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_lemmas by unfold_locales - -interpretation l_get_M get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a type_wf character_data_ptr_kinds - apply(unfold_locales) - apply (simp add: get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_type_wf local.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a) - by (meson CharacterDataMonad.get_M_is_l_get_M l_get_M_def) -lemmas get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_ok = get_M_ok[folded get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def] -end - -global_interpretation l_get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_lemmas type_wf by unfold_locales - - -global_interpretation l_put_M type_wf character_data_ptr_kinds get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a - rewrites "a_get_M = get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a" defines put_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a = a_put_M - apply (simp add: get_M_is_l_get_M l_put_M_def) - by (simp add: get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def) - -lemmas put_M_defs = a_put_M_def -adhoc_overloading put_M put_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a - - -locale l_put_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_lemmas = l_type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a -begin -sublocale l_put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_lemmas by unfold_locales - -interpretation l_put_M type_wf character_data_ptr_kinds get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a - apply(unfold_locales) - using get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_type_wf l_type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a local.l_type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_axioms - apply blast - by (meson CharacterDataMonad.get_M_is_l_get_M l_get_M_def) -lemmas put_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_ok = put_M_ok[folded put_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def] -end - -global_interpretation l_put_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_lemmas type_wf by unfold_locales - - - -lemma CharacterData_simp1 [simp]: - "(\x. getter (setter (\_. v) x) = v) \ h \ put_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr setter v \\<^sub>h h' - \ h' \ get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr getter \\<^sub>r v" - by(auto simp add: put_M_defs get_M_defs split: option.splits) -lemma CharacterData_simp2 [simp]: - "character_data_ptr \ character_data_ptr' - \ h \ put_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr setter v \\<^sub>h h' - \ preserved (get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr' getter) h h'" - by(auto simp add: put_M_defs get_M_defs preserved_def split: option.splits dest: get_heap_E) -lemma CharacterData_simp3 [simp]: " - (\x. getter (setter (\_. v) x) = getter x) - \ h \ put_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr setter v \\<^sub>h h' - \ preserved (get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr' getter) h h'" - apply(cases "character_data_ptr = character_data_ptr'") - by(auto simp add: put_M_defs get_M_defs preserved_def split: option.splits dest: get_heap_E) -lemma CharacterData_simp4 [simp]: - "h \ put_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr setter v \\<^sub>h h' - \ preserved (get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr getter) h h'" - by(auto simp add: put_M_defs ElementMonad.get_M_defs preserved_def - split: option.splits dest: get_heap_E) -lemma CharacterData_simp5 [simp]: - "h \ put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr setter v \\<^sub>h h' - \ preserved (get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr getter) h h'" - by(auto simp add: ElementMonad.put_M_defs get_M_defs preserved_def - split: option.splits dest: get_heap_E) -lemma CharacterData_simp6 [simp]: - "(\x. getter (cast (setter (\_. v) x)) = getter (cast x)) - \ h \ put_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr setter v \\<^sub>h h' - \ preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr getter) h h'" - apply (cases "cast character_data_ptr = object_ptr") - by(auto simp add: put_M_defs get_M_defs ObjectMonad.get_M_defs NodeMonad.get_M_defs - get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def preserved_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def - bind_eq_Some_conv split: option.splits) -lemma CharacterData_simp7 [simp]: - "(\x. getter (cast (setter (\_. v) x)) = getter (cast x)) - \ h \ put_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr setter v \\<^sub>h h' - \ preserved (get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr getter) h h'" - apply(cases "cast character_data_ptr = node_ptr") - by(auto simp add: put_M_defs get_M_defs ObjectMonad.get_M_defs NodeMonad.get_M_defs - get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def preserved_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def - bind_eq_Some_conv split: option.splits) - -lemma CharacterData_simp8 [simp]: - "cast character_data_ptr \ node_ptr - \ h \ put_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr setter v \\<^sub>h h' - \ preserved (get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr getter) h h'" - by(auto simp add: put_M_defs get_M_defs get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def NodeMonad.get_M_defs - preserved_def split: option.splits dest: get_heap_E) -lemma CharacterData_simp9 [simp]: - "h \ put_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr setter v \\<^sub>h h' - \ (\x. getter (cast (setter (\_. v) x)) = getter (cast x)) - \ preserved (get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr getter) h h'" - apply(cases "cast character_data_ptr \ node_ptr") - by(auto simp add: put_M_defs get_M_defs get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def - NodeMonad.get_M_defs preserved_def split: option.splits bind_splits - dest: get_heap_E) -lemma CharacterData_simp10 [simp]: - "cast character_data_ptr \ node_ptr - \ h \ put_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr setter v \\<^sub>h h' - \ preserved (get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr getter) h h'" - by(auto simp add: NodeMonad.put_M_defs get_M_defs get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def NodeMonad.get_M_defs - preserved_def split: option.splits dest: get_heap_E) - -lemma CharacterData_simp11 [simp]: - "cast character_data_ptr \ object_ptr - \ h \ put_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr setter v \\<^sub>h h' - \ preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr getter) h h'" - by(auto simp add: put_M_defs get_M_defs get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def - ObjectMonad.get_M_defs preserved_def - split: option.splits dest: get_heap_E) - -lemma CharacterData_simp12 [simp]: - "h \ put_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr setter v \\<^sub>h h' - \ (\x. getter (cast (setter (\_. v) x)) = getter (cast x)) - \ preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr getter) h h'" - apply(cases "cast character_data_ptr \ object_ptr") - apply(auto simp add: put_M_defs get_M_defs get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def - get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def ObjectMonad.get_M_defs preserved_def - split: option.splits bind_splits dest: get_heap_E)[1] - by(auto simp add: put_M_defs get_M_defs get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def - get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def ObjectMonad.get_M_defs preserved_def - split: option.splits bind_splits dest: get_heap_E)[1] - -lemma CharacterData_simp13 [simp]: - "cast character_data_ptr \ object_ptr \ h \ put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr setter v \\<^sub>h h' - \ preserved (get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr getter) h h'" - by(auto simp add: ObjectMonad.put_M_defs get_M_defs get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def - ObjectMonad.get_M_defs preserved_def split: option.splits dest: get_heap_E) - -lemma new_element_get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a: - "h \ new_element \\<^sub>h h' \ preserved (get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a ptr getter) h h'" - by(auto simp add: new_element_def get_M_defs preserved_def split: prod.splits option.splits - elim!: bind_returns_result_E bind_returns_heap_E) - - -subsection\Creating CharacterData\ - -definition new_character_data :: "(_, (_) character_data_ptr) dom_prog" - where - "new_character_data = do { - h \ get_heap; - (new_ptr, h') \ return (new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a h); - return_heap h'; - return new_ptr - }" - -lemma new_character_data_ok [simp]: - "h \ ok new_character_data" - by(auto simp add: new_character_data_def split: prod.splits) - -lemma new_character_data_ptr_in_heap: - assumes "h \ new_character_data \\<^sub>h h'" - and "h \ new_character_data \\<^sub>r new_character_data_ptr" - shows "new_character_data_ptr |\| character_data_ptr_kinds h'" - using assms - unfolding new_character_data_def - by(auto simp add: new_character_data_def new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def Let_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_ptr_in_heap - is_OK_returns_result_I - elim!: bind_returns_result_E bind_returns_heap_E) - -lemma new_character_data_ptr_not_in_heap: - assumes "h \ new_character_data \\<^sub>h h'" - and "h \ new_character_data \\<^sub>r new_character_data_ptr" - shows "new_character_data_ptr |\| character_data_ptr_kinds h" - using assms new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_ptr_not_in_heap - by(auto simp add: new_character_data_def split: prod.splits - elim!: bind_returns_result_E bind_returns_heap_E) - -lemma new_character_data_new_ptr: - assumes "h \ new_character_data \\<^sub>h h'" - and "h \ new_character_data \\<^sub>r new_character_data_ptr" - shows "object_ptr_kinds h' = object_ptr_kinds h |\| {|cast new_character_data_ptr|}" - using assms new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_new_ptr - by(auto simp add: new_character_data_def split: prod.splits - elim!: bind_returns_result_E bind_returns_heap_E) - -lemma new_character_data_is_character_data_ptr: - assumes "h \ new_character_data \\<^sub>r new_character_data_ptr" - shows "is_character_data_ptr new_character_data_ptr" - using assms new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_is_character_data_ptr - by(auto simp add: new_character_data_def elim!: bind_returns_result_E split: prod.splits) - -lemma new_character_data_child_nodes: - assumes "h \ new_character_data \\<^sub>h h'" - assumes "h \ new_character_data \\<^sub>r new_character_data_ptr" - shows "h' \ get_M new_character_data_ptr val \\<^sub>r ''''" - using assms - by(auto simp add: get_M_defs new_character_data_def new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def Let_def - split: option.splits prod.splits elim!: bind_returns_result_E bind_returns_heap_E) - -lemma new_character_data_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t: - "h \ new_character_data \\<^sub>h h' \ h \ new_character_data \\<^sub>r new_character_data_ptr - \ ptr \ cast new_character_data_ptr \ preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr getter) h h'" - by(auto simp add: new_character_data_def ObjectMonad.get_M_defs preserved_def - split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E) -lemma new_character_data_get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e: - "h \ new_character_data \\<^sub>h h' \ h \ new_character_data \\<^sub>r new_character_data_ptr - \ ptr \ cast new_character_data_ptr \ preserved (get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e ptr getter) h h'" - by(auto simp add: new_character_data_def NodeMonad.get_M_defs preserved_def - split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E) -lemma new_character_data_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t: - "h \ new_character_data \\<^sub>h h' \ h \ new_character_data \\<^sub>r new_character_data_ptr - \ preserved (get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr getter) h h'" - by(auto simp add: new_character_data_def ElementMonad.get_M_defs preserved_def - split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E) -lemma new_character_data_get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a: - "h \ new_character_data \\<^sub>h h' \ h \ new_character_data \\<^sub>r new_character_data_ptr - \ ptr \ new_character_data_ptr \ preserved (get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a ptr getter) h h'" - by(auto simp add: new_character_data_def get_M_defs preserved_def - split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E) - - - -subsection\Modified Heaps\ - -lemma get_CharacterData_ptr_simp [simp]: - "get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h) - = (if ptr = cast character_data_ptr then cast obj else get character_data_ptr h)" - by(auto simp add: get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def split: option.splits Option.bind_splits) - -lemma Character_data_ptr_kinds_simp [simp]: - "character_data_ptr_kinds (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h) = character_data_ptr_kinds h |\| - (if is_character_data_ptr_kind ptr then {|the (cast ptr)|} else {||})" - by(auto simp add: character_data_ptr_kinds_def is_node_ptr_kind_def split: option.splits) - -lemma type_wf_put_I: - assumes "type_wf h" - assumes "ElementClass.type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)" - assumes "is_character_data_ptr_kind ptr \ is_character_data_kind obj" - shows "type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)" - using assms - by(auto simp add: type_wf_defs split: option.splits) - -lemma type_wf_put_ptr_not_in_heap_E: - assumes "type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)" - assumes "ptr |\| object_ptr_kinds h" - shows "type_wf h" - using assms - apply(auto simp add: type_wf_defs elim!: ElementMonad.type_wf_put_ptr_not_in_heap_E - split: option.splits if_splits) - using assms(2) node_ptr_kinds_commutes by blast - -lemma type_wf_put_ptr_in_heap_E: - assumes "type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)" - assumes "ptr |\| object_ptr_kinds h" - assumes "ElementClass.type_wf h" - assumes "is_character_data_ptr_kind ptr \ is_character_data_kind (the (get ptr h))" - shows "type_wf h" - using assms - apply(auto simp add: type_wf_defs split: option.splits if_splits)[1] - by (metis (no_types, lifting) ElementClass.get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf assms(2) bind.bind_lunit cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_inv cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_inv get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def notin_fset option.collapse) - -subsection\Preserving Types\ - -lemma new_element_type_wf_preserved [simp]: - assumes "h \ new_element \\<^sub>h h'" - shows "type_wf h = type_wf h'" - using assms - apply(auto simp add: new_element_def new\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def - elim!: bind_returns_heap_E type_wf_put_ptr_not_in_heap_E - intro!: type_wf_put_I split: if_splits)[1] - using CharacterDataClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t assms new_element_type_wf_preserved apply blast - using element_ptrs_def apply fastforce - using CharacterDataClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t assms new_element_type_wf_preserved apply blast - by (metis Suc_n_not_le_n element_ptr.sel(1) element_ptrs_def fMax_ge ffmember_filter - fimage_eqI is_element_ptr_ref) - -lemma new_element_is_l_new_element: "l_new_element type_wf" - using l_new_element.intro new_element_type_wf_preserved - by blast - -lemma put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_tag_type_type_wf_preserved [simp]: - "h \ put_M element_ptr tag_type_update v \\<^sub>h h' \ type_wf h = type_wf h'" - apply(auto simp add: ElementMonad.put_M_defs put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def - dest!: get_heap_E - elim!: bind_returns_heap_E2 - intro!: type_wf_put_I ElementMonad.type_wf_put_I NodeMonad.type_wf_put_I - ObjectMonad.type_wf_put_I)[1] - apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs - NodeClass.type_wf_defs ElementMonad.get_M_defs split: option.splits)[1] - apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs - NodeClass.type_wf_defs ElementMonad.get_M_defs split: option.splits)[1] - apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs - NodeClass.type_wf_defs ElementMonad.get_M_defs split: option.splits)[1] - apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs - NodeClass.type_wf_defs ElementMonad.get_M_defs split: option.splits)[1] - apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs - NodeClass.type_wf_defs ElementMonad.get_M_defs split: option.splits)[1] - using ObjectMonad.type_wf_put_ptr_in_heap_E ObjectMonad.type_wf_put_ptr_not_in_heap_E apply blast - apply (metis (no_types, lifting) bind_eq_Some_conv finite_set_in get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def) - apply (metis finite_set_in) - done - - -lemma put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_child_nodes_type_wf_preserved [simp]: - "h \ put_M element_ptr child_nodes_update v \\<^sub>h h' \ type_wf h = type_wf h'" - apply(auto simp add: ElementMonad.put_M_defs put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def - dest!: get_heap_E elim!: bind_returns_heap_E2 - intro!: type_wf_put_I ElementMonad.type_wf_put_I - NodeMonad.type_wf_put_I ObjectMonad.type_wf_put_I)[1] - apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs - NodeClass.type_wf_defs ElementMonad.get_M_defs - split: option.splits)[1] - apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs - NodeClass.type_wf_defs ElementMonad.get_M_defs - split: option.splits)[1] - apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs - NodeClass.type_wf_defs ElementMonad.get_M_defs - split: option.splits)[1] - apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs - NodeClass.type_wf_defs ElementMonad.get_M_defs - split: option.splits)[1] - apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs - NodeClass.type_wf_defs ElementMonad.get_M_defs - split: option.splits)[1] - using ObjectMonad.type_wf_put_ptr_in_heap_E ObjectMonad.type_wf_put_ptr_not_in_heap_E apply blast - apply (metis (no_types, lifting) bind_eq_Some_conv finite_set_in get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def) - apply (metis finite_set_in) - done - -lemma put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_attrs_type_wf_preserved [simp]: - "h \ put_M element_ptr attrs_update v \\<^sub>h h' \ type_wf h = type_wf h'" - apply(auto simp add: ElementMonad.put_M_defs put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def - dest!: get_heap_E - elim!: bind_returns_heap_E2 - intro!: type_wf_put_I ElementMonad.type_wf_put_I NodeMonad.type_wf_put_I - ObjectMonad.type_wf_put_I)[1] - apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs NodeClass.type_wf_defs - ElementMonad.get_M_defs split: option.splits)[1] - apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs NodeClass.type_wf_defs - ElementMonad.get_M_defs split: option.splits)[1] - apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs NodeClass.type_wf_defs - ElementMonad.get_M_defs split: option.splits)[1] - apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs NodeClass.type_wf_defs - ElementMonad.get_M_defs split: option.splits)[1] - apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs NodeClass.type_wf_defs - ElementMonad.get_M_defs split: option.splits)[1] - using ObjectMonad.type_wf_put_ptr_in_heap_E ObjectMonad.type_wf_put_ptr_not_in_heap_E apply blast - apply (metis (no_types, lifting) bind_eq_Some_conv finite_set_in get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def) - apply (metis finite_set_in) - done - -lemma put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_shadow_root_opt_type_wf_preserved [simp]: - "h \ put_M element_ptr shadow_root_opt_update v \\<^sub>h h' \ type_wf h = type_wf h'" - apply(auto simp add: ElementMonad.put_M_defs put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def - dest!: get_heap_E - elim!: bind_returns_heap_E2 - intro!: type_wf_put_I ElementMonad.type_wf_put_I NodeMonad.type_wf_put_I - ObjectMonad.type_wf_put_I)[1] - apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs NodeClass.type_wf_defs - ElementMonad.get_M_defs split: option.splits)[1] - apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs NodeClass.type_wf_defs - ElementMonad.get_M_defs split: option.splits)[1] - apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs NodeClass.type_wf_defs - ElementMonad.get_M_defs split: option.splits)[1] - apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs NodeClass.type_wf_defs - ElementMonad.get_M_defs split: option.splits)[1] - apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs NodeClass.type_wf_defs - ElementMonad.get_M_defs split: option.splits)[1] - using ObjectMonad.type_wf_put_ptr_in_heap_E ObjectMonad.type_wf_put_ptr_not_in_heap_E apply blast - apply (metis (no_types, lifting) bind_eq_Some_conv finite_set_in get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def) - apply (metis finite_set_in) - done - - -lemma new_character_data_type_wf_preserved [simp]: - "h \ new_character_data \\<^sub>h h' \ type_wf h = type_wf h'" - apply(auto simp add: new_character_data_def new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def Let_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def - elim!: bind_returns_heap_E type_wf_put_ptr_not_in_heap_E - intro!: type_wf_put_I ElementMonad.type_wf_put_I NodeMonad.type_wf_put_I ObjectMonad.type_wf_put_I - split: if_splits)[1] - apply(simp_all add: type_wf_defs ElementClass.type_wf_defs NodeClass.type_wf_defs is_node_kind_def) - by (meson new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_ptr_not_in_heap) - -locale l_new_character_data = l_type_wf + - assumes new_character_data_types_preserved: "h \ new_character_data \\<^sub>h h' \ type_wf h = type_wf h'" - -lemma new_character_data_is_l_new_character_data: "l_new_character_data type_wf" - using l_new_character_data.intro new_character_data_type_wf_preserved - by blast - -lemma put_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_val_type_wf_preserved [simp]: - "h \ put_M character_data_ptr val_update v \\<^sub>h h' \ type_wf h = type_wf h'" - apply(auto simp add: CharacterDataMonad.put_M_defs put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def - CharacterDataClass.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e CharacterDataClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t - is_node_kind_def - dest!: get_heap_E - elim!: bind_returns_heap_E2 - intro!: type_wf_put_I ElementMonad.type_wf_put_I NodeMonad.type_wf_put_I - ObjectMonad.type_wf_put_I)[1] - apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs - NodeClass.type_wf_defs CharacterDataMonad.get_M_defs - split: option.splits)[1] - apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs - NodeClass.type_wf_defs CharacterDataMonad.get_M_defs - ObjectClass.a_type_wf_def - split: option.splits)[1] - apply (metis (no_types, lifting) bind_eq_Some_conv finite_set_in get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def) - apply (metis finite_set_in) - done - -lemma character_data_ptr_kinds_small: - assumes "\object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'" - shows "character_data_ptr_kinds h = character_data_ptr_kinds h'" - by(simp add: character_data_ptr_kinds_def node_ptr_kinds_def preserved_def - object_ptr_kinds_preserved_small[OF assms]) - -lemma character_data_ptr_kinds_preserved: - assumes "writes SW setter h h'" - assumes "h \ setter \\<^sub>h h'" - assumes "\h h'. \w \ SW. h \ w \\<^sub>h h' - \ (\object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h')" - shows "character_data_ptr_kinds h = character_data_ptr_kinds h'" - using writes_small_big[OF assms] - apply(simp add: reflp_def transp_def preserved_def character_data_ptr_kinds_def) - by (metis assms node_ptr_kinds_preserved) - - -lemma type_wf_preserved_small: - assumes "\object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'" - assumes "\node_ptr. preserved (get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr RNode.nothing) h h'" - assumes "\element_ptr. preserved (get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr RElement.nothing) h h'" - assumes "\character_data_ptr. preserved (get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr - RCharacterData.nothing) h h'" - shows "type_wf h = type_wf h'" - using type_wf_preserved_small[OF assms(1) assms(2) assms(3)] - allI[OF assms(4), of id, simplified] character_data_ptr_kinds_small[OF assms(1)] - apply(auto simp add: type_wf_defs preserved_def get_M_defs character_data_ptr_kinds_small[OF assms(1)] - split: option.splits)[1] - apply(force) - by force - -lemma type_wf_preserved: - assumes "writes SW setter h h'" - assumes "h \ setter \\<^sub>h h'" - assumes "\h h' w. w \ SW \ h \ w \\<^sub>h h' - \ \object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'" - assumes "\h h' w. w \ SW \ h \ w \\<^sub>h h' - \ \node_ptr. preserved (get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr RNode.nothing) h h'" - assumes "\h h' w. w \ SW \ h \ w \\<^sub>h h' - \ \element_ptr. preserved (get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr RElement.nothing) h h'" - assumes "\h h' w. w \ SW \ h \ w \\<^sub>h h' - \ \character_data_ptr. preserved (get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr - RCharacterData.nothing) h h'" - shows "type_wf h = type_wf h'" -proof - - have "\h h' w. w \ SW \ h \ w \\<^sub>h h' \ type_wf h = type_wf h'" - using assms type_wf_preserved_small by fast - with assms(1) assms(2) show ?thesis - apply(rule writes_small_big) - by(auto simp add: reflp_def transp_def) -qed - -lemma type_wf_drop: "type_wf h \ type_wf (Heap (fmdrop ptr (the_heap h)))" - apply(auto simp add: type_wf_def ElementMonad.type_wf_drop - l_type_wf_def\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a.a_type_wf_def)[1] - using type_wf_drop - by (metis (no_types, lifting) ElementClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ObjectClass.get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf character_data_ptr_kinds_commutes finite_set_in fmlookup_drop get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def node_ptr_kinds_commutes object_ptr_kinds_code5) - -end diff --git a/Core_DOM/Core_SC_DOM/common/monads/CharacterDataMonad.thy b/Core_DOM/Core_SC_DOM/common/monads/CharacterDataMonad.thy new file mode 120000 index 0000000..b1eb8c7 --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/monads/CharacterDataMonad.thy @@ -0,0 +1 @@ +../../../Core_DOM/common/monads/CharacterDataMonad.thy \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/monads/DocumentMonad.thy b/Core_DOM/Core_SC_DOM/common/monads/DocumentMonad.thy deleted file mode 100644 index 2ff02bc..0000000 --- a/Core_DOM/Core_SC_DOM/common/monads/DocumentMonad.thy +++ /dev/null @@ -1,603 +0,0 @@ -(*********************************************************************************** - * Copyright (c) 2016-2018 The University of Sheffield, UK - * - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * * Redistributions of source code must retain the above copyright notice, this - * list of conditions and the following disclaimer. - * - * * Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - * SPDX-License-Identifier: BSD-2-Clause - ***********************************************************************************) - -section\Document\ -text\In this theory, we introduce the monadic method setup for the Document class.\ - -theory DocumentMonad - imports - CharacterDataMonad - "../classes/DocumentClass" -begin - -type_synonym ('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr, 'document_ptr, - 'shadow_root_ptr, 'Object, 'Node, 'Element, 'CharacterData, 'Document, 'result) dom_prog - = "((_) heap, exception, 'result) prog" -register_default_tvars "('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr, 'document_ptr, - 'shadow_root_ptr, 'Object, 'Node, 'Element, 'CharacterData, 'Document, 'result) dom_prog" - - -global_interpretation l_ptr_kinds_M document_ptr_kinds defines document_ptr_kinds_M = a_ptr_kinds_M . -lemmas document_ptr_kinds_M_defs = a_ptr_kinds_M_def - -lemma document_ptr_kinds_M_eq: - assumes "|h \ object_ptr_kinds_M|\<^sub>r = |h' \ object_ptr_kinds_M|\<^sub>r" - shows "|h \ document_ptr_kinds_M|\<^sub>r = |h' \ document_ptr_kinds_M|\<^sub>r" - using assms - by(auto simp add: document_ptr_kinds_M_defs object_ptr_kinds_M_defs document_ptr_kinds_def) - -lemma document_ptr_kinds_M_reads: - "reads (\object_ptr. {preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing)}) document_ptr_kinds_M h h'" - using object_ptr_kinds_M_reads - apply(simp add: reads_def object_ptr_kinds_M_defs document_ptr_kinds_M_defs - document_ptr_kinds_def preserved_def cong del: image_cong_simp) - apply (metis (mono_tags, hide_lams) object_ptr_kinds_preserved_small old.unit.exhaust preserved_def) - done - -global_interpretation l_dummy defines get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t = "l_get_M.a_get_M get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t" . -lemma get_M_is_l_get_M: "l_get_M get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t type_wf document_ptr_kinds" - apply(simp add: get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_type_wf l_get_M_def) - by (metis ObjectClass.get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf ObjectClass.type_wf_defs bind_eq_None_conv - document_ptr_kinds_commutes get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def option.simps(3)) -lemmas get_M_defs = get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def[unfolded l_get_M.a_get_M_def[OF get_M_is_l_get_M]] - -adhoc_overloading get_M get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t - -locale l_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_lemmas = l_type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t -begin -sublocale l_get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_lemmas by unfold_locales - -interpretation l_get_M get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t type_wf document_ptr_kinds - apply(unfold_locales) - apply (simp add: get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_type_wf local.type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t) - by (meson DocumentMonad.get_M_is_l_get_M l_get_M_def) -lemmas get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok = get_M_ok[folded get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def] -end - -global_interpretation l_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_lemmas type_wf by unfold_locales - - -global_interpretation l_put_M type_wf document_ptr_kinds get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t - rewrites "a_get_M = get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t" defines put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t = a_put_M - apply (simp add: get_M_is_l_get_M l_put_M_def) - by (simp add: get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def) - -lemmas put_M_defs = a_put_M_def -adhoc_overloading put_M put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t - - -locale l_put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_lemmas = l_type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t -begin -sublocale l_put_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_lemmas by unfold_locales - -interpretation l_put_M type_wf document_ptr_kinds get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t - apply(unfold_locales) - apply (simp add: get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_type_wf local.type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t) - by (meson DocumentMonad.get_M_is_l_get_M l_get_M_def) -lemmas put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok = put_M_ok[folded put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def] -end - -global_interpretation l_put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_lemmas type_wf by unfold_locales - - -lemma document_put_get [simp]: - "h \ put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr setter v \\<^sub>h h' - \ (\x. getter (setter (\_. v) x) = v) - \ h' \ get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr getter \\<^sub>r v" - by(auto simp add: put_M_defs get_M_defs split: option.splits) -lemma get_M_Mdocument_preserved1 [simp]: - "document_ptr \ document_ptr' - \ h \ put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr setter v \\<^sub>h h' - \ preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr' getter) h h'" - by(auto simp add: put_M_defs get_M_defs preserved_def split: option.splits dest: get_heap_E) -lemma document_put_get_preserved [simp]: - "h \ put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr setter v \\<^sub>h h' - \ (\x. getter (setter (\_. v) x) = getter x) - \ preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr' getter) h h'" - apply(cases "document_ptr = document_ptr'") - by(auto simp add: put_M_defs get_M_defs preserved_def split: option.splits dest: get_heap_E) - -lemma get_M_Mdocument_preserved2 [simp]: - "h \ put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr setter v \\<^sub>h h' \ preserved (get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr getter) h h'" - by(auto simp add: put_M_defs get_M_defs NodeMonad.get_M_defs get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def - put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def preserved_def split: option.splits dest: get_heap_E) - -lemma get_M_Mdocument_preserved3 [simp]: - "cast document_ptr \ object_ptr - \ h \ put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr setter v \\<^sub>h h' - \ preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr getter) h h'" - by(auto simp add: put_M_defs get_M_defs get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def ObjectMonad.get_M_defs - preserved_def split: option.splits dest: get_heap_E) -lemma get_M_Mdocument_preserved4 [simp]: - "h \ put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr setter v \\<^sub>h h' - \ (\x. getter (cast (setter (\_. v) x)) = getter (cast x)) - \ preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr getter) h h'" - apply(cases "cast document_ptr \ object_ptr")[1] - by(auto simp add: put_M_defs get_M_defs get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def - ObjectMonad.get_M_defs preserved_def - split: option.splits bind_splits dest: get_heap_E) - -lemma get_M_Mdocument_preserved5 [simp]: - "cast document_ptr \ object_ptr - \ h \ put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr setter v \\<^sub>h h' - \ preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr getter) h h'" - by(auto simp add: ObjectMonad.put_M_defs get_M_defs get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def ObjectMonad.get_M_defs - preserved_def split: option.splits dest: get_heap_E) - -lemma get_M_Mdocument_preserved6 [simp]: - "h \ put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr setter v \\<^sub>h h' \ preserved (get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr getter) h h'" - by(auto simp add: put_M_defs ElementMonad.get_M_defs preserved_def - split: option.splits dest: get_heap_E) -lemma get_M_Mdocument_preserved7 [simp]: - "h \ put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr setter v \\<^sub>h h' \ preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr getter) h h'" - by(auto simp add: ElementMonad.put_M_defs get_M_defs preserved_def - split: option.splits dest: get_heap_E) -lemma get_M_Mdocument_preserved8 [simp]: - "h \ put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr setter v \\<^sub>h h' - \ preserved (get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr getter) h h'" - by(auto simp add: put_M_defs CharacterDataMonad.get_M_defs preserved_def - split: option.splits dest: get_heap_E) -lemma get_M_Mdocument_preserved9 [simp]: - "h \ put_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr setter v \\<^sub>h h' - \ preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr getter) h h'" - by(auto simp add: CharacterDataMonad.put_M_defs get_M_defs preserved_def - split: option.splits dest: get_heap_E) -lemma get_M_Mdocument_preserved10 [simp]: - "(\x. getter (cast (setter (\_. v) x)) = getter (cast x)) - \ h \ put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr setter v \\<^sub>h h' \ preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr getter) h h'" - apply(cases "cast document_ptr = object_ptr") - by(auto simp add: put_M_defs get_M_defs ObjectMonad.get_M_defs NodeMonad.get_M_defs get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def - get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def preserved_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def bind_eq_Some_conv - split: option.splits) - -lemma new_element_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t: - "h \ new_element \\<^sub>h h' \ preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr getter) h h'" - by(auto simp add: new_element_def get_M_defs preserved_def - split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E) - -lemma new_character_data_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t: - "h \ new_character_data \\<^sub>h h' \ preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr getter) h h'" - by(auto simp add: new_character_data_def get_M_defs preserved_def - split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E) - - -subsection \Creating Documents\ - -definition new_document :: "(_, (_) document_ptr) dom_prog" - where - "new_document = do { - h \ get_heap; - (new_ptr, h') \ return (new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h); - return_heap h'; - return new_ptr - }" - -lemma new_document_ok [simp]: - "h \ ok new_document" - by(auto simp add: new_document_def split: prod.splits) - -lemma new_document_ptr_in_heap: - assumes "h \ new_document \\<^sub>h h'" - and "h \ new_document \\<^sub>r new_document_ptr" - shows "new_document_ptr |\| document_ptr_kinds h'" - using assms - unfolding new_document_def - by(auto simp add: new_document_def new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ptr_in_heap is_OK_returns_result_I - elim!: bind_returns_result_E bind_returns_heap_E) - -lemma new_document_ptr_not_in_heap: - assumes "h \ new_document \\<^sub>h h'" - and "h \ new_document \\<^sub>r new_document_ptr" - shows "new_document_ptr |\| document_ptr_kinds h" - using assms new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ptr_not_in_heap - by(auto simp add: new_document_def split: prod.splits elim!: bind_returns_result_E bind_returns_heap_E) - -lemma new_document_new_ptr: - assumes "h \ new_document \\<^sub>h h'" - and "h \ new_document \\<^sub>r new_document_ptr" - shows "object_ptr_kinds h' = object_ptr_kinds h |\| {|cast new_document_ptr|}" - using assms new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_new_ptr - by(auto simp add: new_document_def split: prod.splits elim!: bind_returns_result_E bind_returns_heap_E) - -lemma new_document_is_document_ptr: - assumes "h \ new_document \\<^sub>r new_document_ptr" - shows "is_document_ptr new_document_ptr" - using assms new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_is_document_ptr - by(auto simp add: new_document_def elim!: bind_returns_result_E split: prod.splits) - -lemma new_document_doctype: - assumes "h \ new_document \\<^sub>h h'" - assumes "h \ new_document \\<^sub>r new_document_ptr" - shows "h' \ get_M new_document_ptr doctype \\<^sub>r ''''" - using assms - by(auto simp add: get_M_defs new_document_def new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def - split: option.splits prod.splits elim!: bind_returns_result_E bind_returns_heap_E) - -lemma new_document_document_element: - assumes "h \ new_document \\<^sub>h h'" - assumes "h \ new_document \\<^sub>r new_document_ptr" - shows "h' \ get_M new_document_ptr document_element \\<^sub>r None" - using assms - by(auto simp add: get_M_defs new_document_def new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def - split: option.splits prod.splits elim!: bind_returns_result_E bind_returns_heap_E) - -lemma new_document_disconnected_nodes: - assumes "h \ new_document \\<^sub>h h'" - assumes "h \ new_document \\<^sub>r new_document_ptr" - shows "h' \ get_M new_document_ptr disconnected_nodes \\<^sub>r []" - using assms - by(auto simp add: get_M_defs new_document_def new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def - split: option.splits prod.splits elim!: bind_returns_result_E bind_returns_heap_E) - - -lemma new_document_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t: - "h \ new_document \\<^sub>h h' \ h \ new_document \\<^sub>r new_document_ptr - \ ptr \ cast new_document_ptr \ preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr getter) h h'" - by(auto simp add: new_document_def ObjectMonad.get_M_defs preserved_def - split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E) -lemma new_document_get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e: - "h \ new_document \\<^sub>h h' \ h \ new_document \\<^sub>r new_document_ptr - \ preserved (get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e ptr getter) h h'" - by(auto simp add: new_document_def NodeMonad.get_M_defs preserved_def - split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E) -lemma new_document_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t: - "h \ new_document \\<^sub>h h' \ h \ new_document \\<^sub>r new_document_ptr - \ preserved (get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr getter) h h'" - by(auto simp add: new_document_def ElementMonad.get_M_defs preserved_def - split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E) -lemma new_document_get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a: - "h \ new_document \\<^sub>h h' \ h \ new_document \\<^sub>r new_document_ptr - \ preserved (get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a ptr getter) h h'" - by(auto simp add: new_document_def CharacterDataMonad.get_M_defs preserved_def - split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E) -lemma new_document_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t: - "h \ new_document \\<^sub>h h' - \ h \ new_document \\<^sub>r new_document_ptr \ ptr \ new_document_ptr - \ preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr getter) h h'" - by(auto simp add: new_document_def get_M_defs preserved_def - split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E) - - - -subsection \Modified Heaps\ - -lemma get_document_ptr_simp [simp]: - "get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h) - = (if ptr = cast document_ptr then cast obj else get document_ptr h)" - by(auto simp add: get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def split: option.splits Option.bind_splits) - -lemma document_ptr_kidns_simp [simp]: - "document_ptr_kinds (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h) - = document_ptr_kinds h |\| (if is_document_ptr_kind ptr then {|the (cast ptr)|} else {||})" - by(auto simp add: document_ptr_kinds_def split: option.splits) - -lemma type_wf_put_I: - assumes "type_wf h" - assumes "CharacterDataClass.type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)" - assumes "is_document_ptr_kind ptr \ is_document_kind obj" - shows "type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)" - using assms - by(auto simp add: type_wf_defs is_document_kind_def split: option.splits) - -lemma type_wf_put_ptr_not_in_heap_E: - assumes "type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)" - assumes "ptr |\| object_ptr_kinds h" - shows "type_wf h" - using assms - by(auto simp add: type_wf_defs elim!: CharacterDataMonad.type_wf_put_ptr_not_in_heap_E - split: option.splits if_splits) - -lemma type_wf_put_ptr_in_heap_E: - assumes "type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)" - assumes "ptr |\| object_ptr_kinds h" - assumes "CharacterDataClass.type_wf h" - assumes "is_document_ptr_kind ptr \ is_document_kind (the (get ptr h))" - shows "type_wf h" - using assms - apply(auto simp add: type_wf_defs elim!: CharacterDataMonad.type_wf_put_ptr_in_heap_E - split: option.splits if_splits)[1] - by (metis (no_types, lifting) CharacterDataClass.get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf bind.bind_lunit get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def is_document_kind_def notin_fset option.exhaust_sel) - - - -subsection \Preserving Types\ - -lemma new_element_type_wf_preserved [simp]: - "h \ new_element \\<^sub>h h' \ type_wf h = type_wf h'" - apply(auto simp add: new_element_def new\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def - DocumentClass.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t - DocumentClass.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e DocumentClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t - is_node_kind_def element_ptrs_def - elim!: bind_returns_heap_E type_wf_put_ptr_not_in_heap_E - intro!: type_wf_put_I CharacterDataMonad.type_wf_put_I ElementMonad.type_wf_put_I - NodeMonad.type_wf_put_I ObjectMonad.type_wf_put_I - split: if_splits)[1] - apply fastforce - by (metis Suc_n_not_le_n element_ptr.sel(1) element_ptrs_def fMax_ge ffmember_filter - fimage_eqI is_element_ptr_ref) - -lemma new_element_is_l_new_element [instances]: - "l_new_element type_wf" - using l_new_element.intro new_element_type_wf_preserved - by blast - -lemma put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_tag_type_type_wf_preserved [simp]: - "h \ put_M element_ptr tag_type_update v \\<^sub>h h' \ type_wf h = type_wf h'" - apply(auto simp add: ElementMonad.put_M_defs put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def - DocumentClass.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t - DocumentClass.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e DocumentClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t - is_node_kind_def - dest!: get_heap_E - elim!: bind_returns_heap_E2 - intro!: type_wf_put_I CharacterDataMonad.type_wf_put_I ElementMonad.type_wf_put_I - NodeMonad.type_wf_put_I ObjectMonad.type_wf_put_I)[1] - apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs NodeClass.type_wf_defs - ElementMonad.get_M_defs ObjectClass.type_wf_defs - CharacterDataClass.type_wf_defs split: option.splits)[1] - apply (metis NodeClass.a_type_wf_def NodeClass.get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_type_wf ObjectClass.a_type_wf_def bind.bind_lzero finite_set_in get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def l_type_wf_def\<^sub>N\<^sub>o\<^sub>d\<^sub>e.a_type_wf_def option.collapse option.distinct(1) option.simps(3)) - by (metis fmember.rep_eq) - -lemma put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_child_nodes_type_wf_preserved [simp]: - "h \ put_M element_ptr child_nodes_update v \\<^sub>h h' \ type_wf h = type_wf h'" - apply(auto simp add: ElementMonad.put_M_defs put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def - DocumentClass.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t - DocumentClass.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e DocumentClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t - is_node_kind_def - dest!: get_heap_E - elim!: bind_returns_heap_E2 - intro!: type_wf_put_I CharacterDataMonad.type_wf_put_I ElementMonad.type_wf_put_I - NodeMonad.type_wf_put_I ObjectMonad.type_wf_put_I)[1] - apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs - NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs - CharacterDataClass.type_wf_defs split: option.splits)[1] - apply (metis NodeClass.a_type_wf_def NodeClass.get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_type_wf ObjectClass.a_type_wf_def bind.bind_lzero finite_set_in get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def l_type_wf_def\<^sub>N\<^sub>o\<^sub>d\<^sub>e.a_type_wf_def option.collapse option.distinct(1) option.simps(3)) - by (metis fmember.rep_eq) - -lemma put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_attrs_type_wf_preserved [simp]: - "h \ put_M element_ptr attrs_update v \\<^sub>h h' \ type_wf h = type_wf h'" - apply(auto simp add: ElementMonad.put_M_defs put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def - DocumentClass.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t - DocumentClass.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e DocumentClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t - is_node_kind_def - dest!: get_heap_E - elim!: bind_returns_heap_E2 - intro!: type_wf_put_I CharacterDataMonad.type_wf_put_I ElementMonad.type_wf_put_I - NodeMonad.type_wf_put_I ObjectMonad.type_wf_put_I)[1] - apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs - NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs - CharacterDataClass.type_wf_defs split: option.splits)[1] - apply (metis NodeClass.a_type_wf_def NodeClass.get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_type_wf ObjectClass.a_type_wf_def bind.bind_lzero finite_set_in get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def l_type_wf_def\<^sub>N\<^sub>o\<^sub>d\<^sub>e.a_type_wf_def option.collapse option.distinct(1) option.simps(3)) - by (metis fmember.rep_eq) - -lemma put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_shadow_root_opt_type_wf_preserved [simp]: - "h \ put_M element_ptr shadow_root_opt_update v \\<^sub>h h' \ type_wf h = type_wf h'" - apply(auto simp add: ElementMonad.put_M_defs put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def - DocumentClass.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t - DocumentClass.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e DocumentClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t - is_node_kind_def - dest!: get_heap_E - elim!: bind_returns_heap_E2 - intro!: type_wf_put_I CharacterDataMonad.type_wf_put_I ElementMonad.type_wf_put_I - NodeMonad.type_wf_put_I ObjectMonad.type_wf_put_I)[1] - apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs - NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs - CharacterDataClass.type_wf_defs split: option.splits)[1] - apply (metis NodeClass.a_type_wf_def NodeClass.get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_type_wf ObjectClass.a_type_wf_def bind.bind_lzero finite_set_in get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def l_type_wf_def\<^sub>N\<^sub>o\<^sub>d\<^sub>e.a_type_wf_def option.collapse option.distinct(1) option.simps(3)) - by (metis fmember.rep_eq) - -lemma new_character_data_type_wf_preserved [simp]: - "h \ new_character_data \\<^sub>h h' \ type_wf h = type_wf h'" - apply(auto simp add: ElementMonad.put_M_defs put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def - DocumentClass.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t - DocumentClass.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e DocumentClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t - is_node_kind_def - new_character_data_def new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def Let_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def - dest!: get_heap_E - elim!: bind_returns_heap_E2 bind_returns_heap_E type_wf_put_ptr_not_in_heap_E - intro!: type_wf_put_I CharacterDataMonad.type_wf_put_I ElementMonad.type_wf_put_I - NodeMonad.type_wf_put_I ObjectMonad.type_wf_put_I)[1] - by (meson new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_ptr_not_in_heap) - -lemma new_character_data_is_l_new_character_data [instances]: - "l_new_character_data type_wf" - using l_new_character_data.intro new_character_data_type_wf_preserved - by blast - -lemma put_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_val_type_wf_preserved [simp]: - "h \ put_M character_data_ptr val_update v \\<^sub>h h' \ type_wf h = type_wf h'" - apply(auto simp add: CharacterDataMonad.put_M_defs put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def - DocumentClass.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t - DocumentClass.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e DocumentClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t is_node_kind_def - dest!: get_heap_E elim!: bind_returns_heap_E2 - intro!: type_wf_put_I CharacterDataMonad.type_wf_put_I ElementMonad.type_wf_put_I - NodeMonad.type_wf_put_I ObjectMonad.type_wf_put_I)[1] - apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs - NodeClass.type_wf_defs CharacterDataMonad.get_M_defs ObjectClass.type_wf_defs - CharacterDataClass.type_wf_defs split: option.splits)[1] - apply (metis bind.bind_lzero finite_set_in get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def option.distinct(1) option.exhaust_sel) - by (metis finite_set_in) - - -lemma new_document_type_wf_preserved [simp]: "h \ new_document \\<^sub>h h' \ type_wf h = type_wf h'" - apply(auto simp add: new_document_def new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def - DocumentClass.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t - DocumentClass.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e DocumentClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t - is_node_ptr_kind_none - elim!: bind_returns_heap_E type_wf_put_ptr_not_in_heap_E - intro!: type_wf_put_I ElementMonad.type_wf_put_I CharacterDataMonad.type_wf_put_I - NodeMonad.type_wf_put_I ObjectMonad.type_wf_put_I - split: if_splits)[1] - apply(auto simp add: type_wf_defs ElementClass.type_wf_defs CharacterDataClass.type_wf_defs - NodeClass.type_wf_defs ObjectClass.type_wf_defs is_document_kind_def - split: option.splits)[1] - using document_ptrs_def apply fastforce - apply (simp add: is_document_kind_def) - apply (metis Suc_n_not_le_n document_ptr.sel(1) document_ptrs_def fMax_ge ffmember_filter fimage_eqI is_document_ptr_ref) - done - -locale l_new_document = l_type_wf + - assumes new_document_types_preserved: "h \ new_document \\<^sub>h h' \ type_wf h = type_wf h'" - -lemma new_document_is_l_new_document [instances]: "l_new_document type_wf" - using l_new_document.intro new_document_type_wf_preserved - by blast - -lemma put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_doctype_type_wf_preserved [simp]: - "h \ put_M document_ptr doctype_update v \\<^sub>h h' \ type_wf h = type_wf h'" - apply(auto simp add: put_M_defs put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def dest!: get_heap_E - elim!: bind_returns_heap_E2 - intro!: type_wf_put_I CharacterDataMonad.type_wf_put_I - ElementMonad.type_wf_put_I NodeMonad.type_wf_put_I ObjectMonad.type_wf_put_I)[1] - apply(auto simp add: is_document_kind_def type_wf_defs ElementClass.type_wf_defs - NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs - CharacterDataClass.type_wf_defs split: option.splits)[1] - apply(auto simp add: is_document_kind_def type_wf_defs ElementClass.type_wf_defs - NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs - CharacterDataClass.type_wf_defs split: option.splits)[1] - apply(auto simp add: is_document_kind_def type_wf_defs ElementClass.type_wf_defs - NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs - CharacterDataClass.type_wf_defs split: option.splits)[1] - apply(auto simp add: is_document_kind_def type_wf_defs ElementClass.type_wf_defs - NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs - CharacterDataClass.type_wf_defs split: option.splits)[1] - apply(auto simp add: is_document_kind_def type_wf_defs ElementClass.type_wf_defs - NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs - CharacterDataClass.type_wf_defs split: option.splits)[1] - apply(auto simp add: is_document_kind_def type_wf_defs ElementClass.type_wf_defs - NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs - CharacterDataClass.type_wf_defs split: option.splits)[1] - apply(auto simp add: is_document_kind_def type_wf_defs ElementClass.type_wf_defs - NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs - CharacterDataClass.type_wf_defs split: option.splits)[1] - apply(auto simp add: is_document_kind_def type_wf_defs ElementClass.type_wf_defs - NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs - CharacterDataClass.type_wf_defs split: option.splits)[1] - apply(auto simp add: get_M_defs) - by (metis (mono_tags) error_returns_result finite_set_in option.exhaust_sel option.simps(4)) - -lemma put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_document_element_type_wf_preserved [simp]: - "h \ put_M document_ptr document_element_update v \\<^sub>h h' \ type_wf h = type_wf h'" - apply(auto simp add: put_M_defs put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def - DocumentClass.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a - DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t - DocumentClass.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e - DocumentClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t is_node_ptr_kind_none - cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_none is_document_kind_def - dest!: get_heap_E - elim!: bind_returns_heap_E2 - intro!: type_wf_put_I CharacterDataMonad.type_wf_put_I - ElementMonad.type_wf_put_I NodeMonad.type_wf_put_I - ObjectMonad.type_wf_put_I)[1] - apply(auto simp add: get_M_defs is_document_kind_def type_wf_defs ElementClass.type_wf_defs - NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs - CharacterDataClass.type_wf_defs - split: option.splits)[1] - by (metis finite_set_in) - -lemma put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_disconnected_nodes_type_wf_preserved [simp]: - "h \ put_M document_ptr disconnected_nodes_update v \\<^sub>h h' \ type_wf h = type_wf h'" - apply(auto simp add: put_M_defs put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def - DocumentClass.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a - DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t - DocumentClass.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e - DocumentClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t - is_node_ptr_kind_none - cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_none is_document_kind_def - dest!: get_heap_E - elim!: bind_returns_heap_E2 - intro!: type_wf_put_I CharacterDataMonad.type_wf_put_I - ElementMonad.type_wf_put_I NodeMonad.type_wf_put_I - ObjectMonad.type_wf_put_I)[1] - apply(auto simp add: is_document_kind_def get_M_defs type_wf_defs ElementClass.type_wf_defs - NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs - CharacterDataClass.type_wf_defs split: option.splits)[1] - by (metis finite_set_in) - -lemma document_ptr_kinds_small: - assumes "\object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'" - shows "document_ptr_kinds h = document_ptr_kinds h'" - by(simp add: document_ptr_kinds_def preserved_def object_ptr_kinds_preserved_small[OF assms]) - -lemma document_ptr_kinds_preserved: - assumes "writes SW setter h h'" - assumes "h \ setter \\<^sub>h h'" - assumes "\h h'. \w \ SW. h \ w \\<^sub>h h' - \ (\object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h')" - shows "document_ptr_kinds h = document_ptr_kinds h'" - using writes_small_big[OF assms] - apply(simp add: reflp_def transp_def preserved_def document_ptr_kinds_def) - by (metis assms object_ptr_kinds_preserved) - -lemma type_wf_preserved_small: - assumes "\object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'" - assumes "\node_ptr. preserved (get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr RNode.nothing) h h'" - assumes "\element_ptr. preserved (get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr RElement.nothing) h h'" - assumes "\character_data_ptr. preserved - (get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr RCharacterData.nothing) h h'" - assumes "\document_ptr. preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr RDocument.nothing) h h'" - shows "DocumentClass.type_wf h = DocumentClass.type_wf h'" - using type_wf_preserved_small[OF assms(1) assms(2) assms(3) assms(4)] - allI[OF assms(5), of id, simplified] document_ptr_kinds_small[OF assms(1)] - apply(auto simp add: type_wf_defs )[1] - apply(auto simp add: type_wf_defs preserved_def get_M_defs document_ptr_kinds_small[OF assms(1)] - split: option.splits)[1] - apply force - apply(auto simp add: type_wf_defs preserved_def get_M_defs document_ptr_kinds_small[OF assms(1)] - split: option.splits)[1] - by force - -lemma type_wf_preserved: - assumes "writes SW setter h h'" - assumes "h \ setter \\<^sub>h h'" - assumes "\h h' w. w \ SW \ h \ w \\<^sub>h h' - \ \object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'" - assumes "\h h' w. w \ SW \ h \ w \\<^sub>h h' - \ \node_ptr. preserved (get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr RNode.nothing) h h'" - assumes "\h h' w. w \ SW \ h \ w \\<^sub>h h' - \ \element_ptr. preserved (get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr RElement.nothing) h h'" - assumes "\h h' w. w \ SW \ h \ w \\<^sub>h h' - \ \character_data_ptr. preserved - (get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr RCharacterData.nothing) h h'" - assumes "\h h' w. w \ SW \ h \ w \\<^sub>h h' - \ \document_ptr. preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr RDocument.nothing) h h'" - shows "DocumentClass.type_wf h = DocumentClass.type_wf h'" -proof - - have "\h h' w. w \ SW \ h \ w \\<^sub>h h' \ DocumentClass.type_wf h = DocumentClass.type_wf h'" - using assms type_wf_preserved_small by fast - with assms(1) assms(2) show ?thesis - apply(rule writes_small_big) - by(auto simp add: reflp_def transp_def) -qed - -lemma type_wf_drop: "type_wf h \ type_wf (Heap (fmdrop ptr (the_heap h)))" - apply(auto simp add: type_wf_defs)[1] - using type_wf_drop - apply blast - by (metis (no_types, lifting) CharacterDataClass.get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf CharacterDataMonad.type_wf_drop document_ptr_kinds_commutes finite_set_in fmlookup_drop get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def heap.sel) -end diff --git a/Core_DOM/Core_SC_DOM/common/monads/DocumentMonad.thy b/Core_DOM/Core_SC_DOM/common/monads/DocumentMonad.thy new file mode 120000 index 0000000..878a3f4 --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/monads/DocumentMonad.thy @@ -0,0 +1 @@ +../../../Core_DOM/common/monads/DocumentMonad.thy \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/monads/ElementMonad.thy b/Core_DOM/Core_SC_DOM/common/monads/ElementMonad.thy deleted file mode 100644 index 44ddd85..0000000 --- a/Core_DOM/Core_SC_DOM/common/monads/ElementMonad.thy +++ /dev/null @@ -1,445 +0,0 @@ -(*********************************************************************************** - * Copyright (c) 2016-2018 The University of Sheffield, UK - * - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * * Redistributions of source code must retain the above copyright notice, this - * list of conditions and the following disclaimer. - * - * * Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - * SPDX-License-Identifier: BSD-2-Clause - ***********************************************************************************) - -section\Element\ -text\In this theory, we introduce the monadic method setup for the Element class.\ -theory ElementMonad - imports - NodeMonad - "ElementClass" -begin - -type_synonym ('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr, 'document_ptr, - 'shadow_root_ptr, 'Object, 'Node, 'Element,'result) dom_prog - = "((_) heap, exception, 'result) prog" -register_default_tvars "('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr, - 'document_ptr, 'shadow_root_ptr, 'Object, 'Node, 'Element,'result) dom_prog" - - -global_interpretation l_ptr_kinds_M element_ptr_kinds defines element_ptr_kinds_M = a_ptr_kinds_M . -lemmas element_ptr_kinds_M_defs = a_ptr_kinds_M_def - - -lemma element_ptr_kinds_M_eq: - assumes "|h \ node_ptr_kinds_M|\<^sub>r = |h' \ node_ptr_kinds_M|\<^sub>r" - shows "|h \ element_ptr_kinds_M|\<^sub>r = |h' \ element_ptr_kinds_M|\<^sub>r" - using assms - by(auto simp add: element_ptr_kinds_M_defs node_ptr_kinds_M_defs element_ptr_kinds_def) - -lemma element_ptr_kinds_M_reads: - "reads (\element_ptr. {preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t element_ptr RObject.nothing)}) element_ptr_kinds_M h h'" - apply(simp add: reads_def node_ptr_kinds_M_defs element_ptr_kinds_M_defs element_ptr_kinds_def - node_ptr_kinds_M_reads preserved_def cong del: image_cong_simp) - apply (metis (mono_tags, hide_lams) node_ptr_kinds_small old.unit.exhaust preserved_def) - done - -global_interpretation l_dummy defines get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t = "l_get_M.a_get_M get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t" . -lemma get_M_is_l_get_M: "l_get_M get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t type_wf element_ptr_kinds" - apply(simp add: get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_type_wf l_get_M_def) - by (metis (no_types, lifting) ObjectClass.get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf ObjectClass.type_wf_defs - bind_eq_Some_conv bind_eq_Some_conv element_ptr_kinds_commutes get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def - get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def node_ptr_kinds_commutes option.simps(3)) -lemmas get_M_defs = get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def[unfolded l_get_M.a_get_M_def[OF get_M_is_l_get_M]] - -adhoc_overloading get_M get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t - -locale l_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_lemmas = l_type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t -begin -sublocale l_get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e_lemmas by unfold_locales - -interpretation l_get_M get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t type_wf element_ptr_kinds - apply(unfold_locales) - apply (simp add: get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_type_wf local.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t) - by (meson ElementMonad.get_M_is_l_get_M l_get_M_def) -lemmas get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok = get_M_ok[folded get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def] -lemmas get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ptr_in_heap = get_M_ptr_in_heap[folded get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def] -end - -global_interpretation l_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_lemmas type_wf by unfold_locales - - -global_interpretation l_put_M type_wf element_ptr_kinds get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t - rewrites "a_get_M = get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t" - defines put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t = a_put_M - apply (simp add: get_M_is_l_get_M l_put_M_def) - by (simp add: get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def) - -lemmas put_M_defs = a_put_M_def -adhoc_overloading put_M put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t - - -locale l_put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_lemmas = l_type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t -begin -sublocale l_put_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e_lemmas by unfold_locales - -interpretation l_put_M type_wf element_ptr_kinds get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t - apply(unfold_locales) - apply (simp add: get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_type_wf local.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t) - by (meson ElementMonad.get_M_is_l_get_M l_get_M_def) - -lemmas put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok = put_M_ok[folded put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def] -end - -global_interpretation l_put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_lemmas type_wf by unfold_locales - - -lemma element_put_get [simp]: - "h \ put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr setter v \\<^sub>h h' \ (\x. getter (setter (\_. v) x) = v) - \ h' \ get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr getter \\<^sub>r v" - by(auto simp add: put_M_defs get_M_defs split: option.splits) -lemma get_M_Element_preserved1 [simp]: - "element_ptr \ element_ptr' \ h \ put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr setter v \\<^sub>h h' - \ preserved (get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr' getter) h h'" - by(auto simp add: put_M_defs get_M_defs preserved_def split: option.splits dest: get_heap_E) -lemma element_put_get_preserved [simp]: - "(\x. getter (setter (\_. v) x) = getter x) \ h \ put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr setter v \\<^sub>h h' - \ preserved (get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr' getter) h h'" - apply(cases "element_ptr = element_ptr'") - by(auto simp add: put_M_defs get_M_defs preserved_def - split: option.splits dest: get_heap_E) -lemma get_M_Element_preserved3 [simp]: - "(\x. getter (cast (setter (\_. v) x)) = getter (cast x)) - \ h \ put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr setter v \\<^sub>h h' \ preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr getter) h h'" - apply(cases "cast element_ptr = object_ptr") - by (auto simp add: put_M_defs get_M_defs ObjectMonad.get_M_defs NodeMonad.get_M_defs get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def - get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def preserved_def put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def bind_eq_Some_conv - split: option.splits) -lemma get_M_Element_preserved4 [simp]: - "(\x. getter (cast (setter (\_. v) x)) = getter (cast x)) - \ h \ put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr setter v \\<^sub>h h' \ preserved (get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr getter) h h'" - apply(cases "cast element_ptr = node_ptr") - by(auto simp add: put_M_defs get_M_defs ObjectMonad.get_M_defs NodeMonad.get_M_defs get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def - get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def preserved_def put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def bind_eq_Some_conv - split: option.splits) - -lemma get_M_Element_preserved5 [simp]: - "cast element_ptr \ node_ptr \ h \ put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr setter v \\<^sub>h h' - \ preserved (get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr getter) h h'" - by(auto simp add: put_M_defs get_M_defs get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def NodeMonad.get_M_defs preserved_def - split: option.splits dest: get_heap_E) -lemma get_M_Element_preserved6 [simp]: - "h \ put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr setter v \\<^sub>h h' - \ (\x. getter (cast (setter (\_. v) x)) = getter (cast x)) - \ preserved (get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr getter) h h'" - apply(cases "cast element_ptr \ node_ptr") - by(auto simp add: put_M_defs get_M_defs get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def NodeMonad.get_M_defs preserved_def - split: option.splits bind_splits dest: get_heap_E) - -lemma get_M_Element_preserved7 [simp]: - "cast element_ptr \ node_ptr \ h \ put_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr setter v \\<^sub>h h' - \ preserved (get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr getter) h h'" - by(auto simp add: NodeMonad.put_M_defs get_M_defs get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def NodeMonad.get_M_defs preserved_def - split: option.splits dest: get_heap_E) - -lemma get_M_Element_preserved8 [simp]: - "cast element_ptr \ object_ptr \ h \ put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr setter v \\<^sub>h h' - \ preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr getter) h h'" - by(auto simp add: put_M_defs get_M_defs get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def - ObjectMonad.get_M_defs preserved_def - split: option.splits dest: get_heap_E) -lemma get_M_Element_preserved9 [simp]: - "h \ put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr setter v \\<^sub>h h' - \ (\x. getter (cast (setter (\_. v) x)) = getter (cast x)) - \ preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr getter) h h'" - apply(cases "cast element_ptr \ object_ptr") - by(auto simp add: put_M_defs get_M_defs get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def - ObjectMonad.get_M_defs preserved_def - split: option.splits bind_splits dest: get_heap_E) - -lemma get_M_Element_preserved10 [simp]: - "cast element_ptr \ object_ptr \ h \ put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr setter v \\<^sub>h h' - \ preserved (get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr getter) h h'" - by(auto simp add: ObjectMonad.put_M_defs get_M_defs get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def - ObjectMonad.get_M_defs preserved_def - split: option.splits dest: get_heap_E) - -subsection\Creating Elements\ - -definition new_element :: "(_, (_) element_ptr) dom_prog" - where - "new_element = do { - h \ get_heap; - (new_ptr, h') \ return (new\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t h); - return_heap h'; - return new_ptr - }" - -lemma new_element_ok [simp]: - "h \ ok new_element" - by(auto simp add: new_element_def split: prod.splits) - -lemma new_element_ptr_in_heap: - assumes "h \ new_element \\<^sub>h h'" - and "h \ new_element \\<^sub>r new_element_ptr" - shows "new_element_ptr |\| element_ptr_kinds h'" - using assms - unfolding new_element_def - by(auto simp add: new_element_def new\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ptr_in_heap is_OK_returns_result_I - elim!: bind_returns_result_E bind_returns_heap_E) - -lemma new_element_ptr_not_in_heap: - assumes "h \ new_element \\<^sub>h h'" - and "h \ new_element \\<^sub>r new_element_ptr" - shows "new_element_ptr |\| element_ptr_kinds h" - using assms new\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ptr_not_in_heap - by(auto simp add: new_element_def split: prod.splits elim!: bind_returns_result_E - bind_returns_heap_E) - -lemma new_element_new_ptr: - assumes "h \ new_element \\<^sub>h h'" - and "h \ new_element \\<^sub>r new_element_ptr" - shows "object_ptr_kinds h' = object_ptr_kinds h |\| {|cast new_element_ptr|}" - using assms new\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_new_ptr - by(auto simp add: new_element_def split: prod.splits elim!: bind_returns_result_E - bind_returns_heap_E) - -lemma new_element_is_element_ptr: - assumes "h \ new_element \\<^sub>r new_element_ptr" - shows "is_element_ptr new_element_ptr" - using assms new\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_is_element_ptr - by(auto simp add: new_element_def elim!: bind_returns_result_E split: prod.splits) - -lemma new_element_child_nodes: - assumes "h \ new_element \\<^sub>h h'" - assumes "h \ new_element \\<^sub>r new_element_ptr" - shows "h' \ get_M new_element_ptr child_nodes \\<^sub>r []" - using assms - by(auto simp add: get_M_defs new_element_def new\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def - split: option.splits prod.splits elim!: bind_returns_result_E bind_returns_heap_E) - -lemma new_element_tag_type: - assumes "h \ new_element \\<^sub>h h'" - assumes "h \ new_element \\<^sub>r new_element_ptr" - shows "h' \ get_M new_element_ptr tag_type \\<^sub>r ''''" - using assms - by(auto simp add: get_M_defs new_element_def new\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def - split: option.splits prod.splits elim!: bind_returns_result_E bind_returns_heap_E) - -lemma new_element_attrs: - assumes "h \ new_element \\<^sub>h h'" - assumes "h \ new_element \\<^sub>r new_element_ptr" - shows "h' \ get_M new_element_ptr attrs \\<^sub>r fmempty" - using assms - by(auto simp add: get_M_defs new_element_def new\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def - split: option.splits prod.splits elim!: bind_returns_result_E bind_returns_heap_E) - -lemma new_element_shadow_root_opt: - assumes "h \ new_element \\<^sub>h h'" - assumes "h \ new_element \\<^sub>r new_element_ptr" - shows "h' \ get_M new_element_ptr shadow_root_opt \\<^sub>r None" - using assms - by(auto simp add: get_M_defs new_element_def new\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def - split: option.splits prod.splits elim!: bind_returns_result_E bind_returns_heap_E) - -lemma new_element_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t: - "h \ new_element \\<^sub>h h' \ h \ new_element \\<^sub>r new_element_ptr \ ptr \ cast new_element_ptr - \ preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr getter) h h'" - by(auto simp add: new_element_def ObjectMonad.get_M_defs preserved_def - split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E) -lemma new_element_get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e: - "h \ new_element \\<^sub>h h' \ h \ new_element \\<^sub>r new_element_ptr \ ptr \ cast new_element_ptr - \ preserved (get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e ptr getter) h h'" - by(auto simp add: new_element_def NodeMonad.get_M_defs preserved_def - split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E) -lemma new_element_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t: - "h \ new_element \\<^sub>h h' \ h \ new_element \\<^sub>r new_element_ptr \ ptr \ new_element_ptr - \ preserved (get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr getter) h h'" - by(auto simp add: new_element_def get_M_defs preserved_def - split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E) - -subsection\Modified Heaps\ - -lemma get_Element_ptr_simp [simp]: - "get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h) - = (if ptr = cast element_ptr then cast obj else get element_ptr h)" - by(auto simp add: get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def split: option.splits Option.bind_splits) - - -lemma element_ptr_kinds_simp [simp]: - "element_ptr_kinds (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h) - = element_ptr_kinds h |\| (if is_element_ptr_kind ptr then {|the (cast ptr)|} else {||})" - by(auto simp add: element_ptr_kinds_def is_node_ptr_kind_def split: option.splits) - -lemma type_wf_put_I: - assumes "type_wf h" - assumes "NodeClass.type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)" - assumes "is_element_ptr_kind ptr \ is_element_kind obj" - shows "type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)" - using assms - by(auto simp add: type_wf_defs split: option.splits) - -lemma type_wf_put_ptr_not_in_heap_E: - assumes "type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)" - assumes "ptr |\| object_ptr_kinds h" - shows "type_wf h" - using assms - apply(auto simp add: type_wf_defs elim!: NodeMonad.type_wf_put_ptr_not_in_heap_E - split: option.splits if_splits)[1] - using assms(2) node_ptr_kinds_commutes by blast - -lemma type_wf_put_ptr_in_heap_E: - assumes "type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)" - assumes "ptr |\| object_ptr_kinds h" - assumes "NodeClass.type_wf h" - assumes "is_element_ptr_kind ptr \ is_element_kind (the (get ptr h))" - shows "type_wf h" - using assms - apply(auto simp add: type_wf_defs split: option.splits if_splits)[1] - by (metis (no_types, lifting) NodeClass.l_get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_lemmas_axioms assms(2) bind.bind_lunit - cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_inv cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_inv finite_set_in get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def - l_get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_lemmas.get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf option.collapse) - -subsection\Preserving Types\ - -lemma new_element_type_wf_preserved [simp]: "h \ new_element \\<^sub>h h' \ type_wf h = type_wf h'" - apply(auto simp add: type_wf_defs NodeClass.type_wf_defs ObjectClass.type_wf_defs new\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def - new_element_def Let_def put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def - get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def - split: prod.splits if_splits elim!: bind_returns_heap_E)[1] - apply (metis element_ptr_kinds_commutes element_ptrs_def fempty_iff ffmember_filter finite_set_in - is_element_ptr_ref) - apply (metis element_ptrs_def fempty_iff ffmember_filter finite_set_in is_element_ptr_ref) - apply (metis (no_types, lifting) Suc_n_not_le_n element_ptr.sel(1) element_ptr_kinds_commutes - element_ptrs_def fMax_ge ffmember_filter fimage_eqI is_element_ptr_ref notin_fset) - apply (metis (no_types, lifting) Suc_n_not_le_n element_ptr.sel(1) element_ptrs_def - fMax_ge ffmember_filter fimage_eqI finite_set_in is_element_ptr_ref) - done - -locale l_new_element = l_type_wf + - assumes new_element_types_preserved: "h \ new_element \\<^sub>h h' \ type_wf h = type_wf h'" - -lemma new_element_is_l_new_element: "l_new_element type_wf" - using l_new_element.intro new_element_type_wf_preserved - by blast - -lemma put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_tag_type_type_wf_preserved [simp]: - "h \ put_M element_ptr tag_type_update v \\<^sub>h h' \ type_wf h = type_wf h'" - apply(auto simp add: type_wf_defs NodeClass.type_wf_defs ObjectClass.type_wf_defs - Let_def put_M_defs get_M_defs put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def - get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def - split: prod.splits option.splits Option.bind_splits elim!: bind_returns_heap_E)[1] - apply (metis finite_set_in option.inject) - apply (metis cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_inv finite_set_in option.sel) - done - -lemma put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_child_nodes_type_wf_preserved [simp]: - "h \ put_M element_ptr child_nodes_update v \\<^sub>h h' \ type_wf h = type_wf h'" - apply(auto simp add: type_wf_defs NodeClass.type_wf_defs ObjectClass.type_wf_defs - Let_def put_M_defs get_M_defs put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def - get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def - split: prod.splits option.splits Option.bind_splits elim!: bind_returns_heap_E)[1] - apply (metis finite_set_in option.inject) - apply (metis cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_inv finite_set_in option.sel) - done - -lemma put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_attrs_type_wf_preserved [simp]: - "h \ put_M element_ptr attrs_update v \\<^sub>h h' \ type_wf h = type_wf h'" - apply(auto simp add: type_wf_defs NodeClass.type_wf_defs ObjectClass.type_wf_defs Let_def - put_M_defs get_M_defs put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def - get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def - split: prod.splits option.splits Option.bind_splits elim!: bind_returns_heap_E)[1] - apply (metis finite_set_in option.inject) - apply (metis cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_inv finite_set_in option.sel) - done - -lemma put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_shadow_root_opt_type_wf_preserved [simp]: - "h \ put_M element_ptr shadow_root_opt_update v \\<^sub>h h' \ type_wf h = type_wf h'" - apply(auto simp add: type_wf_defs NodeClass.type_wf_defs ObjectClass.type_wf_defs - Let_def put_M_defs get_M_defs put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def - get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def - split: prod.splits option.splits Option.bind_splits elim!: bind_returns_heap_E)[1] - apply (metis finite_set_in option.inject) - apply (metis cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_inv finite_set_in option.sel) - done - -lemma put_M_pointers_preserved: - assumes "h \ put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr setter v \\<^sub>h h'" - shows "object_ptr_kinds h = object_ptr_kinds h'" - using assms - apply(auto simp add: put_M_defs put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def - elim!: bind_returns_heap_E2 dest!: get_heap_E)[1] - by (meson get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ptr_in_heap is_OK_returns_result_I) - -lemma element_ptr_kinds_preserved: - assumes "writes SW setter h h'" - assumes "h \ setter \\<^sub>h h'" - assumes "\h h'. \w \ SW. h \ w \\<^sub>h h' - \ (\object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h')" - shows "element_ptr_kinds h = element_ptr_kinds h'" - using writes_small_big[OF assms] - apply(simp add: reflp_def transp_def preserved_def element_ptr_kinds_def) - by (metis assms node_ptr_kinds_preserved) - - -lemma element_ptr_kinds_small: - assumes "\object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'" - shows "element_ptr_kinds h = element_ptr_kinds h'" - by(simp add: element_ptr_kinds_def node_ptr_kinds_def preserved_def - object_ptr_kinds_preserved_small[OF assms]) - -lemma type_wf_preserved_small: - assumes "\object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'" - assumes "\node_ptr. preserved (get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr RNode.nothing) h h'" - assumes "\element_ptr. preserved (get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr RElement.nothing) h h'" - shows "type_wf h = type_wf h'" - using type_wf_preserved_small[OF assms(1) assms(2)] allI[OF assms(3), of id, simplified] - apply(auto simp add: type_wf_defs )[1] - apply(auto simp add: preserved_def get_M_defs element_ptr_kinds_small[OF assms(1)] - split: option.splits,force)[1] - by(auto simp add: preserved_def get_M_defs element_ptr_kinds_small[OF assms(1)] - split: option.splits,force) - -lemma type_wf_preserved: - assumes "writes SW setter h h'" - assumes "h \ setter \\<^sub>h h'" - assumes "\h h' w. w \ SW \ h \ w \\<^sub>h h' - \ \object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'" - assumes "\h h' w. w \ SW \ h \ w \\<^sub>h h' - \ \node_ptr. preserved (get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr RNode.nothing) h h'" - assumes "\h h' w. w \ SW \ h \ w \\<^sub>h h' - \ \element_ptr. preserved (get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr RElement.nothing) h h'" - shows "type_wf h = type_wf h'" -proof - - have "\h h' w. w \ SW \ h \ w \\<^sub>h h' \ type_wf h = type_wf h'" - using assms type_wf_preserved_small by fast - with assms(1) assms(2) show ?thesis - apply(rule writes_small_big) - by(auto simp add: reflp_def transp_def) -qed - -lemma type_wf_drop: "type_wf h \ type_wf (Heap (fmdrop ptr (the_heap h)))" - apply(auto simp add: type_wf_defs NodeClass.type_wf_defs ObjectClass.type_wf_defs - node_ptr_kinds_def object_ptr_kinds_def is_node_ptr_kind_def - get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def)[1] - apply (metis (no_types, lifting) element_ptr_kinds_commutes finite_set_in fmdom_notD fmdom_notI - fmlookup_drop heap.sel node_ptr_kinds_commutes o_apply object_ptr_kinds_def) - by (metis element_ptr_kinds_commutes fmdom_notI fmdrop_lookup heap.sel node_ptr_kinds_commutes - o_apply object_ptr_kinds_def) - -end diff --git a/Core_DOM/Core_SC_DOM/common/monads/ElementMonad.thy b/Core_DOM/Core_SC_DOM/common/monads/ElementMonad.thy new file mode 120000 index 0000000..bbc395b --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/monads/ElementMonad.thy @@ -0,0 +1 @@ +../../../Core_DOM/common/monads/ElementMonad.thy \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/monads/NodeMonad.thy b/Core_DOM/Core_SC_DOM/common/monads/NodeMonad.thy deleted file mode 100644 index b5616b0..0000000 --- a/Core_DOM/Core_SC_DOM/common/monads/NodeMonad.thy +++ /dev/null @@ -1,218 +0,0 @@ -(*********************************************************************************** - * Copyright (c) 2016-2018 The University of Sheffield, UK - * - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * * Redistributions of source code must retain the above copyright notice, this - * list of conditions and the following disclaimer. - * - * * Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - * SPDX-License-Identifier: BSD-2-Clause - ***********************************************************************************) - -section\Node\ -text\In this theory, we introduce the monadic method setup for the Node class.\ -theory NodeMonad - imports - ObjectMonad - "../classes/NodeClass" -begin - -type_synonym ('object_ptr, 'node_ptr, 'Object, 'Node, 'result) dom_prog - = "((_) heap, exception, 'result) prog" -register_default_tvars "('object_ptr, 'node_ptr, 'Object, 'Node, 'result) dom_prog" - - -global_interpretation l_ptr_kinds_M node_ptr_kinds defines node_ptr_kinds_M = a_ptr_kinds_M . -lemmas node_ptr_kinds_M_defs = a_ptr_kinds_M_def - -lemma node_ptr_kinds_M_eq: - assumes "|h \ object_ptr_kinds_M|\<^sub>r = |h' \ object_ptr_kinds_M|\<^sub>r" - shows "|h \ node_ptr_kinds_M|\<^sub>r = |h' \ node_ptr_kinds_M|\<^sub>r" - using assms - by(auto simp add: node_ptr_kinds_M_defs object_ptr_kinds_M_defs node_ptr_kinds_def) - - -global_interpretation l_dummy defines get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e = "l_get_M.a_get_M get\<^sub>N\<^sub>o\<^sub>d\<^sub>e" . -lemma get_M_is_l_get_M: "l_get_M get\<^sub>N\<^sub>o\<^sub>d\<^sub>e type_wf node_ptr_kinds" - apply(simp add: get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_type_wf l_get_M_def) - by (metis ObjectClass.a_type_wf_def ObjectClass.get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf bind_eq_None_conv get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def - node_ptr_kinds_commutes option.simps(3)) -lemmas get_M_defs = get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def[unfolded l_get_M.a_get_M_def[OF get_M_is_l_get_M]] - -adhoc_overloading get_M get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e - -locale l_get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e_lemmas = l_type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e -begin -sublocale l_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_lemmas by unfold_locales - -interpretation l_get_M get\<^sub>N\<^sub>o\<^sub>d\<^sub>e type_wf node_ptr_kinds - apply(unfold_locales) - apply (simp add: get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_type_wf local.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e) - by (meson NodeMonad.get_M_is_l_get_M l_get_M_def) -lemmas get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e_ok = get_M_ok[folded get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def] -end - -global_interpretation l_get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e_lemmas type_wf by unfold_locales - -lemma node_ptr_kinds_M_reads: - "reads (\object_ptr. {preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing)}) node_ptr_kinds_M h h'" - using object_ptr_kinds_M_reads - apply(simp add: reads_def node_ptr_kinds_M_defs node_ptr_kinds_def - object_ptr_kinds_M_reads preserved_def) - by (smt object_ptr_kinds_preserved_small preserved_def unit_all_impI) - -global_interpretation l_put_M type_wf node_ptr_kinds get\<^sub>N\<^sub>o\<^sub>d\<^sub>e put\<^sub>N\<^sub>o\<^sub>d\<^sub>e - rewrites "a_get_M = get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e" - defines put_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e = a_put_M - apply (simp add: get_M_is_l_get_M l_put_M_def) - by (simp add: get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def) - -lemmas put_M_defs = a_put_M_def -adhoc_overloading put_M put_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e - - -locale l_put_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e_lemmas = l_type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e -begin -sublocale l_put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_lemmas by unfold_locales - -interpretation l_put_M type_wf node_ptr_kinds get\<^sub>N\<^sub>o\<^sub>d\<^sub>e put\<^sub>N\<^sub>o\<^sub>d\<^sub>e - apply(unfold_locales) - apply (simp add: get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_type_wf local.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e) - by (meson NodeMonad.get_M_is_l_get_M l_get_M_def) -lemmas put_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e_ok = put_M_ok[folded put_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def] -end - -global_interpretation l_put_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e_lemmas type_wf by unfold_locales - -lemma get_M_Object_preserved1 [simp]: - "(\x. getter (cast (setter (\_. v) x)) = getter (cast x)) \ h \ put_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr setter v \\<^sub>h h' - \ preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr getter) h h'" - apply(cases "cast node_ptr = object_ptr") - by(auto simp add: put_M_defs get_M_defs ObjectMonad.get_M_defs get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def preserved_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def - bind_eq_Some_conv - split: option.splits) - -lemma get_M_Object_preserved2 [simp]: - "cast node_ptr \ object_ptr \ h \ put_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr setter v \\<^sub>h h' - \ preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr getter) h h'" - by(auto simp add: put_M_defs get_M_defs get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def ObjectMonad.get_M_defs preserved_def - split: option.splits dest: get_heap_E) -lemma get_M_Object_preserved3 [simp]: - "h \ put_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr setter v \\<^sub>h h' \ (\x. getter (cast (setter (\_. v) x)) = getter (cast x)) - \ preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr getter) h h'" - apply(cases "cast node_ptr \ object_ptr") - by(auto simp add: put_M_defs get_M_defs get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def ObjectMonad.get_M_defs preserved_def - split: option.splits bind_splits dest: get_heap_E) - -lemma get_M_Object_preserved4 [simp]: - "cast node_ptr \ object_ptr \ h \ put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr setter v \\<^sub>h h' - \ preserved (get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr getter) h h'" - by(auto simp add: ObjectMonad.put_M_defs get_M_defs get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def ObjectMonad.get_M_defs preserved_def - split: option.splits dest: get_heap_E) - -subsection\Modified Heaps\ - -lemma get_node_ptr_simp [simp]: - "get\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h) = (if ptr = cast node_ptr then cast obj else get node_ptr h)" - by(auto simp add: get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def) - -lemma node_ptr_kinds_simp [simp]: - "node_ptr_kinds (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h) - = node_ptr_kinds h |\| (if is_node_ptr_kind ptr then {|the (cast ptr)|} else {||})" - by(auto simp add: node_ptr_kinds_def) - -lemma type_wf_put_I: - assumes "type_wf h" - assumes "ObjectClass.type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)" - assumes "is_node_ptr_kind ptr \ is_node_kind obj" - shows "type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)" - using assms - apply(auto simp add: type_wf_defs split: option.splits)[1] - using cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_none is_node_kind_def apply blast - using cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_none is_node_kind_def apply blast - done - -lemma type_wf_put_ptr_not_in_heap_E: - assumes "type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)" - assumes "ptr |\| object_ptr_kinds h" - shows "type_wf h" - using assms - by(auto simp add: type_wf_defs elim!: ObjectMonad.type_wf_put_ptr_not_in_heap_E - split: option.splits if_splits) - -lemma type_wf_put_ptr_in_heap_E: - assumes "type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)" - assumes "ptr |\| object_ptr_kinds h" - assumes "ObjectClass.type_wf h" - assumes "is_node_ptr_kind ptr \ is_node_kind (the (get ptr h))" - shows "type_wf h" - using assms - apply(auto simp add: type_wf_defs split: option.splits if_splits) - by (metis ObjectClass.get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf bind.bind_lunit finite_set_in get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def is_node_kind_def option.exhaust_sel) - - -subsection\Preserving Types\ - -lemma node_ptr_kinds_small: - assumes "\object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'" - shows "node_ptr_kinds h = node_ptr_kinds h'" - by(simp add: node_ptr_kinds_def preserved_def object_ptr_kinds_preserved_small[OF assms]) - -lemma node_ptr_kinds_preserved: - assumes "writes SW setter h h'" - assumes "h \ setter \\<^sub>h h'" - assumes "\h h'. \w \ SW. h \ w \\<^sub>h h' - \ (\object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h')" - shows "node_ptr_kinds h = node_ptr_kinds h'" - using writes_small_big[OF assms] - apply(simp add: reflp_def transp_def preserved_def node_ptr_kinds_def) - by (metis assms object_ptr_kinds_preserved) - - -lemma type_wf_preserved_small: - assumes "\object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'" - assumes "\node_ptr. preserved (get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr RNode.nothing) h h'" - shows "type_wf h = type_wf h'" - using type_wf_preserved allI[OF assms(2), of id, simplified] - apply(auto simp add: type_wf_defs) - apply(auto simp add: preserved_def get_M_defs node_ptr_kinds_small[OF assms(1)] - split: option.splits)[1] - apply (metis notin_fset option.simps(3)) - by(auto simp add: preserved_def get_M_defs node_ptr_kinds_small[OF assms(1)] - split: option.splits, force)[1] - -lemma type_wf_preserved: - assumes "writes SW setter h h'" - assumes "h \ setter \\<^sub>h h'" - assumes "\h h' w. w \ SW \ h \ w \\<^sub>h h' - \ \object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'" - assumes "\h h' w. w \ SW \ h \ w \\<^sub>h h' - \ \node_ptr. preserved (get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr RNode.nothing) h h'" - shows "type_wf h = type_wf h'" -proof - - have "\h h' w. w \ SW \ h \ w \\<^sub>h h' \ type_wf h = type_wf h'" - using assms type_wf_preserved_small by fast - with assms(1) assms(2) show ?thesis - apply(rule writes_small_big) - by(auto simp add: reflp_def transp_def) -qed -end - diff --git a/Core_DOM/Core_SC_DOM/common/monads/NodeMonad.thy b/Core_DOM/Core_SC_DOM/common/monads/NodeMonad.thy new file mode 120000 index 0000000..8cc3284 --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/monads/NodeMonad.thy @@ -0,0 +1 @@ +../../../Core_DOM/common/monads/NodeMonad.thy \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/monads/ObjectMonad.thy b/Core_DOM/Core_SC_DOM/common/monads/ObjectMonad.thy deleted file mode 100644 index 69c3a86..0000000 --- a/Core_DOM/Core_SC_DOM/common/monads/ObjectMonad.thy +++ /dev/null @@ -1,258 +0,0 @@ -(*********************************************************************************** - * Copyright (c) 2016-2018 The University of Sheffield, UK - * - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * * Redistributions of source code must retain the above copyright notice, this - * list of conditions and the following disclaimer. - * - * * Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - * SPDX-License-Identifier: BSD-2-Clause - ***********************************************************************************) - -section\Object\ -text\In this theory, we introduce the monadic method setup for the Object class.\ -theory ObjectMonad - imports - BaseMonad - "../classes/ObjectClass" -begin - -type_synonym ('object_ptr, 'Object, 'result) dom_prog - = "((_) heap, exception, 'result) prog" -register_default_tvars "('object_ptr, 'Object, 'result) dom_prog" - -global_interpretation l_ptr_kinds_M object_ptr_kinds defines object_ptr_kinds_M = a_ptr_kinds_M . -lemmas object_ptr_kinds_M_defs = a_ptr_kinds_M_def - - -global_interpretation l_dummy defines get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t = "l_get_M.a_get_M get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t" . -lemma get_M_is_l_get_M: "l_get_M get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t type_wf object_ptr_kinds" - by (simp add: a_type_wf_def get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf l_get_M_def) -lemmas get_M_defs = get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def[unfolded l_get_M.a_get_M_def[OF get_M_is_l_get_M]] - -adhoc_overloading get_M get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t - -locale l_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_lemmas = l_type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t -begin -interpretation l_get_M get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t type_wf object_ptr_kinds - apply(unfold_locales) - apply (simp add: get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf local.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t) - by (simp add: a_type_wf_def get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf) -lemmas get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_ok = get_M_ok[folded get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def] -lemmas get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_ptr_in_heap = get_M_ptr_in_heap[folded get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def] -end - -global_interpretation l_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_lemmas type_wf - by (simp add: l_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_lemmas_def l_type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_axioms) - -lemma object_ptr_kinds_M_reads: - "reads (\object_ptr. {preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing)}) object_ptr_kinds_M h h'" - apply(auto simp add: object_ptr_kinds_M_defs get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf type_wf_defs reads_def - preserved_def get_M_defs - split: option.splits)[1] - using a_type_wf_def get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf by blast+ - - -global_interpretation l_put_M type_wf object_ptr_kinds get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t - rewrites "a_get_M = get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t" - defines put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t = a_put_M - apply (simp add: get_M_is_l_get_M l_put_M_def) - by (simp add: get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def) -lemmas put_M_defs = a_put_M_def -adhoc_overloading put_M put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t - - -locale l_put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_lemmas = l_type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t -begin -interpretation l_put_M type_wf object_ptr_kinds get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t - apply(unfold_locales) - using get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf l_type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t local.l_type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_axioms apply blast - by (simp add: a_type_wf_def get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf) -lemmas put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_ok = put_M_ok[folded put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def] -lemmas put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_ptr_in_heap = put_M_ptr_in_heap[folded put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def] -end - -global_interpretation l_put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_lemmas type_wf - by (simp add: l_put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_lemmas_def l_type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_axioms) - - -definition check_in_heap :: "(_) object_ptr \ (_, unit) dom_prog" - where - "check_in_heap ptr = do { - h \ get_heap; - (if ptr |\| object_ptr_kinds h then - return () - else - error SegmentationFault - )}" - -lemma check_in_heap_ptr_in_heap: "ptr |\| object_ptr_kinds h \ h \ ok (check_in_heap ptr)" - by(auto simp add: check_in_heap_def) -lemma check_in_heap_pure [simp]: "pure (check_in_heap ptr) h" - by(auto simp add: check_in_heap_def intro!: bind_pure_I) -lemma check_in_heap_is_OK [simp]: - "ptr |\| object_ptr_kinds h \ h \ ok (check_in_heap ptr \ f) = h \ ok (f ())" - by(simp add: check_in_heap_def) -lemma check_in_heap_returns_result [simp]: - "ptr |\| object_ptr_kinds h \ h \ (check_in_heap ptr \ f) \\<^sub>r x = h \ f () \\<^sub>r x" - by(simp add: check_in_heap_def) -lemma check_in_heap_returns_heap [simp]: - "ptr |\| object_ptr_kinds h \ h \ (check_in_heap ptr \ f) \\<^sub>h h' = h \ f () \\<^sub>h h'" - by(simp add: check_in_heap_def) - -lemma check_in_heap_reads: - "reads {preserved (get_M object_ptr nothing)} (check_in_heap object_ptr) h h'" - apply(simp add: check_in_heap_def reads_def preserved_def) - by (metis a_type_wf_def get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_ok get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_ptr_in_heap is_OK_returns_result_E - is_OK_returns_result_I unit_all_impI) - -subsection\Invoke\ - -fun invoke_rec :: "(((_) object_ptr \ bool) \ ((_) object_ptr \ 'args - \ (_, 'result) dom_prog)) list \ (_) object_ptr \ 'args - \ (_, 'result) dom_prog" - where - "invoke_rec ((P, f)#xs) ptr args = (if P ptr then f ptr args else invoke_rec xs ptr args)" - | "invoke_rec [] ptr args = error InvokeError" - -definition invoke :: "(((_) object_ptr \ bool) \ ((_) object_ptr \ 'args - \ (_, 'result) dom_prog)) list - \ (_) object_ptr \ 'args \ (_, 'result) dom_prog" - where - "invoke xs ptr args = do { check_in_heap ptr; invoke_rec xs ptr args}" - -lemma invoke_split: "P (invoke ((Pred, f) # xs) ptr args) = - ((\(Pred ptr) \ P (invoke xs ptr args)) - \ (Pred ptr \ P (do {check_in_heap ptr; f ptr args})))" - by(simp add: invoke_def) - -lemma invoke_split_asm: "P (invoke ((Pred, f) # xs) ptr args) = - (\((\(Pred ptr) \ (\ P (invoke xs ptr args))) - \ (Pred ptr \ (\ P (do {check_in_heap ptr; f ptr args})))))" - by(simp add: invoke_def) -lemmas invoke_splits = invoke_split invoke_split_asm - -lemma invoke_ptr_in_heap: "h \ ok (invoke xs ptr args) \ ptr |\| object_ptr_kinds h" - by (metis bind_is_OK_E check_in_heap_ptr_in_heap invoke_def is_OK_returns_heap_I) - -lemma invoke_pure [simp]: "pure (invoke [] ptr args) h" - by(auto simp add: invoke_def intro!: bind_pure_I) - -lemma invoke_is_OK [simp]: - "ptr |\| object_ptr_kinds h \ Pred ptr - \ h \ ok (invoke ((Pred, f) # xs) ptr args) = h \ ok (f ptr args)" - by(simp add: invoke_def) -lemma invoke_returns_result [simp]: - "ptr |\| object_ptr_kinds h \ Pred ptr - \ h \ (invoke ((Pred, f) # xs) ptr args) \\<^sub>r x = h \ f ptr args \\<^sub>r x" - by(simp add: invoke_def) -lemma invoke_returns_heap [simp]: - "ptr |\| object_ptr_kinds h \ Pred ptr - \ h \ (invoke ((Pred, f) # xs) ptr args) \\<^sub>h h' = h \ f ptr args \\<^sub>h h'" - by(simp add: invoke_def) - -lemma invoke_not [simp]: "\Pred ptr \ invoke ((Pred, f) # xs) ptr args = invoke xs ptr args" - by(auto simp add: invoke_def) - -lemma invoke_empty [simp]: "\h \ ok (invoke [] ptr args)" - by(auto simp add: invoke_def check_in_heap_def) - -lemma invoke_empty_reads [simp]: "\P \ S. reflp P \ transp P \ reads S (invoke [] ptr args) h h'" - apply(simp add: invoke_def reads_def preserved_def) - by (meson bind_returns_result_E error_returns_result) - - -subsection\Modified Heaps\ - -lemma get_object_ptr_simp [simp]: - "get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h) = (if ptr = object_ptr then Some obj else get object_ptr h)" - by(auto simp add: get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def split: option.splits Option.bind_splits) - -lemma object_ptr_kinds_simp [simp]: "object_ptr_kinds (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h) = object_ptr_kinds h |\| {|ptr|}" - by(auto simp add: object_ptr_kinds_def put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def split: option.splits) - -lemma type_wf_put_I: - assumes "type_wf h" - shows "type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)" - using assms - by(auto simp add: type_wf_defs split: option.splits) - -lemma type_wf_put_ptr_not_in_heap_E: - assumes "type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)" - assumes "ptr |\| object_ptr_kinds h" - shows "type_wf h" - using assms - by(auto simp add: type_wf_defs split: option.splits if_splits) - -lemma type_wf_put_ptr_in_heap_E: - assumes "type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)" - assumes "ptr |\| object_ptr_kinds h" - shows "type_wf h" - using assms - by(auto simp add: type_wf_defs split: option.splits if_splits) - - -subsection\Preserving Types\ - -lemma type_wf_preserved: "type_wf h = type_wf h'" - by(auto simp add: type_wf_defs) - - -lemma object_ptr_kinds_preserved_small: - assumes "\object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'" - shows "object_ptr_kinds h = object_ptr_kinds h'" - using assms - apply(auto simp add: object_ptr_kinds_def preserved_def get_M_defs get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def - split: option.splits)[1] - apply (metis (mono_tags, lifting) domIff error_returns_result fmdom.rep_eq fmember.rep_eq - old.unit.exhaust option.case_eq_if return_returns_result) - by (metis (mono_tags, lifting) domIff error_returns_result fmdom.rep_eq fmember.rep_eq - old.unit.exhaust option.case_eq_if return_returns_result) - -lemma object_ptr_kinds_preserved: - assumes "writes SW setter h h'" - assumes "h \ setter \\<^sub>h h'" - assumes "\h h' w object_ptr. w \ SW \ h \ w \\<^sub>h h' - \ preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'" - shows "object_ptr_kinds h = object_ptr_kinds h'" -proof - - { - fix object_ptr w - have "preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'" - apply(rule writes_small_big[OF assms]) - by auto - } - then show ?thesis - using object_ptr_kinds_preserved_small by blast -qed - - -lemma reads_writes_preserved2: - assumes "writes SW setter h h'" - assumes "h \ setter \\<^sub>h h'" - assumes "\h h' x. \w \ SW. h \ w \\<^sub>h h' \ preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr getter) h h'" - shows "preserved (get_M ptr getter) h h'" - apply(clarsimp simp add: preserved_def) - using reads_singleton assms(1) assms(2) - apply(rule reads_writes_preserved) - using assms(3) - by(auto simp add: preserved_def) -end diff --git a/Core_DOM/Core_SC_DOM/common/monads/ObjectMonad.thy b/Core_DOM/Core_SC_DOM/common/monads/ObjectMonad.thy new file mode 120000 index 0000000..905cb9a --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/monads/ObjectMonad.thy @@ -0,0 +1 @@ +../../../Core_DOM/common/monads/ObjectMonad.thy \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/pointers/CharacterDataPointer.thy b/Core_DOM/Core_SC_DOM/common/pointers/CharacterDataPointer.thy deleted file mode 100644 index 147eb15..0000000 --- a/Core_DOM/Core_SC_DOM/common/pointers/CharacterDataPointer.thy +++ /dev/null @@ -1,199 +0,0 @@ -(*********************************************************************************** - * Copyright (c) 2016-2018 The University of Sheffield, UK - * - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * * Redistributions of source code must retain the above copyright notice, this - * list of conditions and the following disclaimer. - * - * * Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - * SPDX-License-Identifier: BSD-2-Clause - ***********************************************************************************) - -section\CharacterData\ -text\In this theory, we introduce the typed pointers for the class CharacterData.\ -theory CharacterDataPointer - imports - ElementPointer -begin - -datatype 'character_data_ptr character_data_ptr = Ref (the_ref: ref) | Ext 'character_data_ptr -register_default_tvars "'character_data_ptr character_data_ptr" -type_synonym ('node_ptr, 'element_ptr, 'character_data_ptr) node_ptr - = "('character_data_ptr character_data_ptr + 'node_ptr, 'element_ptr) node_ptr" -register_default_tvars "('node_ptr, 'element_ptr, 'character_data_ptr) node_ptr" -type_synonym ('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr) object_ptr - = "('object_ptr, 'character_data_ptr character_data_ptr + 'node_ptr, 'element_ptr) object_ptr" -register_default_tvars "('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr) object_ptr" - -definition cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) character_data_ptr \ (_) node_ptr" - where - "cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr = node_ptr.Ext (Inr (Inl ptr))" - -abbreviation cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) character_data_ptr \ (_) object_ptr" - where - "cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr \ cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r (cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr)" - -definition cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) node_ptr \ (_) character_data_ptr option" - where - "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr = (case node_ptr of - node_ptr.Ext (Inr (Inl character_data_ptr)) \ Some character_data_ptr - | _ \ None)" - -abbreviation cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) object_ptr \ (_) character_data_ptr option" - where - "cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr \ (case cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr of - Some node_ptr \ cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr - | None \ None)" - -adhoc_overloading cast cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r - cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r - -consts is_character_data_ptr_kind :: 'a -definition is_character_data_ptr_kind\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) node_ptr \ bool" - where - "is_character_data_ptr_kind\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr = (case cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr - of Some _ \ True | _ \ False)" - -abbreviation is_character_data_ptr_kind\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) object_ptr \ bool" - where - "is_character_data_ptr_kind\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr \ (case cast ptr of - Some node_ptr \ is_character_data_ptr_kind\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr - | None \ False)" - -adhoc_overloading is_character_data_ptr_kind is_character_data_ptr_kind\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r - is_character_data_ptr_kind\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r -lemmas is_character_data_ptr_kind_def = is_character_data_ptr_kind\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def - -consts is_character_data_ptr :: 'a -definition is_character_data_ptr\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) character_data_ptr \ bool" - where - "is_character_data_ptr\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr = (case ptr - of character_data_ptr.Ref _ \ True | _ \ False)" - -abbreviation is_character_data_ptr\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) node_ptr \ bool" - where - "is_character_data_ptr\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr \ (case cast ptr of - Some character_data_ptr \ is_character_data_ptr\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r character_data_ptr - | _ \ False)" - -abbreviation is_character_data_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) object_ptr \ bool" - where - "is_character_data_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr \ (case cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr of - Some node_ptr \ is_character_data_ptr\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr - | None \ False)" - -adhoc_overloading is_character_data_ptr - is_character_data_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r is_character_data_ptr\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r is_character_data_ptr\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r -lemmas is_character_data_ptr_def = is_character_data_ptr\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def - -consts is_character_data_ptr_ext :: 'a -abbreviation - "is_character_data_ptr_ext\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr \ \ is_character_data_ptr\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr" - -abbreviation "is_character_data_ptr_ext\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr \ (case cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr of - Some character_data_ptr \ is_character_data_ptr_ext\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r character_data_ptr -| None \ False)" - -abbreviation "is_character_data_ptr_ext\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr \ (case cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr of - Some node_ptr \ is_character_data_ptr_ext\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr -| None \ False)" - -adhoc_overloading is_character_data_ptr_ext - is_character_data_ptr_ext\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r is_character_data_ptr_ext\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r is_character_data_ptr_ext\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r - -instantiation character_data_ptr :: (linorder) linorder -begin -definition - less_eq_character_data_ptr :: "(_::linorder) character_data_ptr \ (_) character_data_ptr \ bool" - where - "less_eq_character_data_ptr x y \ (case x of Ext i \ (case y of Ext j \ i \ j | Ref _ \ False) - | Ref i \ (case y of Ext _ \ True | Ref j \ i \ j))" -definition - less_character_data_ptr :: "(_::linorder) character_data_ptr \ (_) character_data_ptr \ bool" - where "less_character_data_ptr x y \ x \ y \ \ y \ x" -instance - apply(standard) - by(auto simp add: less_eq_character_data_ptr_def less_character_data_ptr_def - split: character_data_ptr.splits) -end - -lemma is_character_data_ptr_ref [simp]: "is_character_data_ptr (character_data_ptr.Ref n)" - by(simp add: is_character_data_ptr\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def) - -lemma cast_element_ptr_not_character_data_ptr [simp]: - "(cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r element_ptr \ cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r character_data_ptr)" - "(cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r character_data_ptr \ cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r element_ptr)" - unfolding cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def - by(auto) - -lemma is_character_data_ptr_kind_not_element_ptr [simp]: - "\ is_character_data_ptr_kind (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r element_ptr)" - unfolding is_character_data_ptr_kind_def cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def - by auto -lemma is_element_ptr_kind_not_character_data_ptr [simp]: - "\ is_element_ptr_kind (cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r character_data_ptr)" - using is_element_ptr_kind_obtains by fastforce - -lemma is_character_data_ptr_kind\<^sub>_cast [simp]: - "is_character_data_ptr_kind (cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r character_data_ptr)" - by (simp add: cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def - is_character_data_ptr_kind\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def) - -lemma character_data_ptr_casts_commute [simp]: - "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr = Some character_data_ptr - \ cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r character_data_ptr = node_ptr" - unfolding cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def - by(auto split: node_ptr.splits sum.splits) - -lemma character_data_ptr_casts_commute2 [simp]: - "(cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r (cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r character_data_ptr) = Some character_data_ptr)" - by simp - -lemma character_data_ptr_casts_commute3 [simp]: - assumes "is_character_data_ptr_kind\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr" - shows "cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r (the (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr)) = node_ptr" - using assms - by(auto simp add: is_character_data_ptr_kind\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def - cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def - split: node_ptr.splits sum.splits) - -lemma is_character_data_ptr_kind_obtains: - assumes "is_character_data_ptr_kind\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr" - obtains character_data_ptr where "cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r character_data_ptr = node_ptr" - by (metis assms is_character_data_ptr_kind\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def case_optionE - character_data_ptr_casts_commute) - -lemma is_character_data_ptr_kind_none: - assumes "\is_character_data_ptr_kind\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr" - shows "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr = None" - using assms - unfolding is_character_data_ptr_kind\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def - by(auto split: node_ptr.splits sum.splits) - -lemma cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_inject [simp]: - "cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r x = cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r y \ x = y" - by(simp add: cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def) - -lemma cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r_ext_none [simp]: - "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r (node_ptr.Ext (Inr (Inr node_ext_ptr))) = None" - by(simp add: cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def) - -end diff --git a/Core_DOM/Core_SC_DOM/common/pointers/CharacterDataPointer.thy b/Core_DOM/Core_SC_DOM/common/pointers/CharacterDataPointer.thy new file mode 120000 index 0000000..0b21513 --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/pointers/CharacterDataPointer.thy @@ -0,0 +1 @@ +../../../Core_DOM/common/pointers/CharacterDataPointer.thy \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/pointers/DocumentPointer.thy b/Core_DOM/Core_SC_DOM/common/pointers/DocumentPointer.thy deleted file mode 100644 index f207887..0000000 --- a/Core_DOM/Core_SC_DOM/common/pointers/DocumentPointer.thy +++ /dev/null @@ -1,154 +0,0 @@ -(*********************************************************************************** - * Copyright (c) 2016-2018 The University of Sheffield, UK - * - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * * Redistributions of source code must retain the above copyright notice, this - * list of conditions and the following disclaimer. - * - * * Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - * SPDX-License-Identifier: BSD-2-Clause - ***********************************************************************************) - -section\Document\ -text\In this theory, we introduce the typed pointers for the class Document.\ -theory DocumentPointer - imports - CharacterDataPointer -begin - -datatype 'document_ptr document_ptr = Ref (the_ref: ref) | Ext 'document_ptr -register_default_tvars "'document_ptr document_ptr" -type_synonym ('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr, 'document_ptr) object_ptr - = "('document_ptr document_ptr + 'object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr) object_ptr" -register_default_tvars "('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr, 'document_ptr) object_ptr" - -definition cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_)document_ptr \ (_) object_ptr" - where - "cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr = object_ptr.Ext (Inr (Inl ptr))" - -definition cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) object_ptr \ (_) document_ptr option" - where - "cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr = (case ptr of - object_ptr.Ext (Inr (Inl document_ptr)) \ Some document_ptr - | _ \ None)" - -adhoc_overloading cast cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r - - -definition is_document_ptr_kind :: "(_) object_ptr \ bool" - where - "is_document_ptr_kind ptr = (case cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr of - Some _ \ True | None \ False)" - -consts is_document_ptr :: 'a -definition is_document_ptr\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) document_ptr \ bool" - where - "is_document_ptr\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr = (case ptr of document_ptr.Ref _ \ True | _ \ False)" - -abbreviation is_document_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) object_ptr \ bool" - where - "is_document_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr \ (case cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr of - Some document_ptr \ is_document_ptr\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr - | None \ False)" -adhoc_overloading is_document_ptr is_document_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r is_document_ptr\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r -lemmas is_document_ptr_def = is_document_ptr\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def - -consts is_document_ptr_ext :: 'a -abbreviation "is_document_ptr_ext\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr \ \ is_document_ptr\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr" - -abbreviation "is_document_ptr_ext\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr \ (case cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr of - Some document_ptr \ is_document_ptr_ext\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr -| None \ False)" -adhoc_overloading is_document_ptr_ext is_document_ptr_ext\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r is_document_ptr_ext\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r - -instantiation document_ptr :: (linorder) linorder -begin -definition less_eq_document_ptr :: "(_::linorder) document_ptr \ (_) document_ptr \ bool" - where "less_eq_document_ptr x y \ (case x of Ext i \ (case y of Ext j \ i \ j | Ref _ \ False) - | Ref i \ (case y of Ext _ \ True | Ref j \ i \ j))" -definition less_document_ptr :: "(_::linorder) document_ptr \ (_) document_ptr \ bool" - where "less_document_ptr x y \ x \ y \ \ y \ x" -instance - apply(standard) - by(auto simp add: less_eq_document_ptr_def less_document_ptr_def split: document_ptr.splits) -end - -lemma is_document_ptr_ref [simp]: "is_document_ptr (document_ptr.Ref n)" - by(simp add: is_document_ptr\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def) - -lemma cast_document_ptr_not_node_ptr [simp]: - "cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr \ cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr" - "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr \ cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr" - unfolding cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def - by auto - -lemma document_ptr_no_node_ptr_cast [simp]: - "\ is_document_ptr_kind (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr)" - by(simp add: cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def is_document_ptr_kind_def) -lemma node_ptr_no_document_ptr_cast [simp]: - "\ is_node_ptr_kind (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)" - using is_node_ptr_kind_obtains by fastforce - -lemma document_ptr_document_ptr_cast [simp]: - "is_document_ptr_kind (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)" - by (simp add: cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def is_document_ptr_kind_def) - -lemma document_ptr_casts_commute [simp]: - "cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr = Some document_ptr \ cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr = ptr" - unfolding cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def - by(auto split: object_ptr.splits sum.splits) - -lemma document_ptr_casts_commute2 [simp]: - "(cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr) = Some document_ptr)" - by simp - -lemma document_ptr_casts_commute3 [simp]: - assumes "is_document_ptr_kind ptr" - shows "cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r (the (cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr)) = ptr" - using assms - by(auto simp add: is_document_ptr_kind_def cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def - split: object_ptr.splits sum.splits) - -lemma is_document_ptr_kind_obtains: - assumes "is_document_ptr_kind ptr" - obtains document_ptr where "ptr = cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr" - using assms is_document_ptr_kind_def - by (metis case_optionE document_ptr_casts_commute) - -lemma is_document_ptr_kind_none: - assumes "\is_document_ptr_kind ptr" - shows "cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr = None" - using assms - unfolding is_document_ptr_kind_def cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def - by (auto split: object_ptr.splits sum.splits) - -lemma cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_inject [simp]: - "cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r x = cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r y \ x = y" - by(simp add: cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def) - -lemma cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_ext_none [simp]: - "cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r (object_ptr.Ext (Inr (Inr (Inr object_ext_ptr)))) = None" - by(simp add: cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def) - -lemma is_document_ptr_kind_not_element_ptr_kind [dest]: - "is_document_ptr_kind ptr \ \ is_element_ptr_kind ptr" - by(auto simp add: split: option.splits) -end diff --git a/Core_DOM/Core_SC_DOM/common/pointers/DocumentPointer.thy b/Core_DOM/Core_SC_DOM/common/pointers/DocumentPointer.thy new file mode 120000 index 0000000..305d022 --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/pointers/DocumentPointer.thy @@ -0,0 +1 @@ +../../../Core_DOM/common/pointers/DocumentPointer.thy \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/pointers/ElementPointer.thy b/Core_DOM/Core_SC_DOM/common/pointers/ElementPointer.thy deleted file mode 100644 index 99be418..0000000 --- a/Core_DOM/Core_SC_DOM/common/pointers/ElementPointer.thy +++ /dev/null @@ -1,178 +0,0 @@ -(*********************************************************************************** - * Copyright (c) 2016-2018 The University of Sheffield, UK - * - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * * Redistributions of source code must retain the above copyright notice, this - * list of conditions and the following disclaimer. - * - * * Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - * SPDX-License-Identifier: BSD-2-Clause - ***********************************************************************************) - -section\Element\ -text\In this theory, we introduce the typed pointers for the class Element.\ -theory ElementPointer - imports - NodePointer -begin - -datatype 'element_ptr element_ptr = Ref (the_ref: ref) | Ext 'element_ptr -register_default_tvars "'element_ptr element_ptr" - -type_synonym ('node_ptr, 'element_ptr) node_ptr - = "('element_ptr element_ptr + 'node_ptr) node_ptr" -register_default_tvars "('node_ptr, 'element_ptr) node_ptr" -type_synonym ('object_ptr, 'node_ptr, 'element_ptr) object_ptr - = "('object_ptr, 'element_ptr element_ptr + 'node_ptr) object_ptr" -register_default_tvars "('object_ptr, 'node_ptr, 'element_ptr) object_ptr" - - -definition cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) element_ptr \ (_) element_ptr" - where - "cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r = id" - -definition cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) element_ptr \ (_) node_ptr" - where - "cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr = node_ptr.Ext (Inl ptr)" - -abbreviation cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) element_ptr \ (_) object_ptr" - where - "cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr \ cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr)" - -definition cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) node_ptr \ (_) element_ptr option" - where - "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr = (case node_ptr of node_ptr.Ext (Inl element_ptr) - \ Some element_ptr | _ \ None)" - -abbreviation cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) object_ptr \ (_) element_ptr option" - where - "cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr \ (case cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr of - Some node_ptr \ cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr - | None \ None)" - -adhoc_overloading cast cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r - cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r - -consts is_element_ptr_kind :: 'a -definition is_element_ptr_kind\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) node_ptr \ bool" - where - "is_element_ptr_kind\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr = (case cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr of Some _ \ True | _ \ False)" - -abbreviation is_element_ptr_kind\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) object_ptr \ bool" - where - "is_element_ptr_kind\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr \ (case cast ptr of - Some node_ptr \ is_element_ptr_kind\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr - | None \ False)" - -adhoc_overloading is_element_ptr_kind is_element_ptr_kind\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r is_element_ptr_kind\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r -lemmas is_element_ptr_kind_def = is_element_ptr_kind\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def - -consts is_element_ptr :: 'a -definition is_element_ptr\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) element_ptr \ bool" - where - "is_element_ptr\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr = (case ptr of element_ptr.Ref _ \ True | _ \ False)" - -abbreviation is_element_ptr\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) node_ptr \ bool" - where - "is_element_ptr\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr \ (case cast ptr of - Some element_ptr \ is_element_ptr\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r element_ptr - | _ \ False)" - -abbreviation is_element_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) object_ptr \ bool" - where - "is_element_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr \ (case cast ptr of - Some node_ptr \ is_element_ptr\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr - | None \ False)" - -adhoc_overloading is_element_ptr is_element_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r is_element_ptr\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r is_element_ptr\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r -lemmas is_element_ptr_def = is_element_ptr\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def - -consts is_element_ptr_ext :: 'a -abbreviation "is_element_ptr_ext\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr \ \ is_element_ptr\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr" - -abbreviation "is_element_ptr_ext\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr \ is_element_ptr_kind ptr \ (\ is_element_ptr\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr)" - -abbreviation "is_element_ptr_ext\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr \ is_element_ptr_kind ptr \ (\ is_element_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr)" -adhoc_overloading is_element_ptr_ext is_element_ptr_ext\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r is_element_ptr_ext\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r - - -instantiation element_ptr :: (linorder) linorder -begin -definition - less_eq_element_ptr :: "(_::linorder) element_ptr \ (_)element_ptr \ bool" - where - "less_eq_element_ptr x y \ (case x of Ext i \ (case y of Ext j \ i \ j | Ref _ \ False) - | Ref i \ (case y of Ext _ \ True | Ref j \ i \ j))" -definition - less_element_ptr :: "(_::linorder) element_ptr \ (_) element_ptr \ bool" - where "less_element_ptr x y \ x \ y \ \ y \ x" -instance - apply(standard) - by(auto simp add: less_eq_element_ptr_def less_element_ptr_def split: element_ptr.splits) -end - -lemma is_element_ptr_ref [simp]: "is_element_ptr (element_ptr.Ref n)" - by(simp add: is_element_ptr\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def) - -lemma element_ptr_casts_commute [simp]: - "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr = Some element_ptr \ cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r element_ptr = node_ptr" - unfolding cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def - by(auto split: node_ptr.splits sum.splits) - -lemma element_ptr_casts_commute2 [simp]: - "(cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r element_ptr) = Some element_ptr)" - by simp - -lemma element_ptr_casts_commute3 [simp]: - assumes "is_element_ptr_kind\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr" - shows "cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r (the (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr)) = node_ptr" - using assms - by(auto simp add: is_element_ptr_kind_def cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def - split: node_ptr.splits sum.splits) - -lemma is_element_ptr_kind_obtains: - assumes "is_element_ptr_kind node_ptr" - obtains element_ptr where "node_ptr = cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r element_ptr" - by (metis assms is_element_ptr_kind_def case_optionE element_ptr_casts_commute) - -lemma is_element_ptr_kind_none: - assumes "\is_element_ptr_kind node_ptr" - shows "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr = None" - using assms - unfolding is_element_ptr_kind_def cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def - by(auto split: node_ptr.splits sum.splits) - -lemma is_element_ptr_kind_cast [simp]: - "is_element_ptr_kind (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r element_ptr)" - by (metis element_ptr_casts_commute is_element_ptr_kind_none option.distinct(1)) - -lemma cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_inject [simp]: - "cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r x = cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r y \ x = y" - by(simp add: cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def) - -lemma cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_ext_none [simp]: - "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r (node_ptr.Ext (Inr (Inr node_ext_ptr))) = None" - by(simp add: cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def) - -lemma is_element_ptr_implies_kind [dest]: "is_element_ptr\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr \ is_element_ptr_kind\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr" - by(auto split: option.splits) - -end diff --git a/Core_DOM/Core_SC_DOM/common/pointers/ElementPointer.thy b/Core_DOM/Core_SC_DOM/common/pointers/ElementPointer.thy new file mode 120000 index 0000000..a4c5305 --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/pointers/ElementPointer.thy @@ -0,0 +1 @@ +../../../Core_DOM/common/pointers/ElementPointer.thy \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/pointers/NodePointer.thy b/Core_DOM/Core_SC_DOM/common/pointers/NodePointer.thy deleted file mode 100644 index f3bd2ca..0000000 --- a/Core_DOM/Core_SC_DOM/common/pointers/NodePointer.thy +++ /dev/null @@ -1,111 +0,0 @@ -(*********************************************************************************** - * Copyright (c) 2016-2018 The University of Sheffield, UK - * - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * * Redistributions of source code must retain the above copyright notice, this - * list of conditions and the following disclaimer. - * - * * Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - * SPDX-License-Identifier: BSD-2-Clause - ***********************************************************************************) - -section\Node\ -text\In this theory, we introduce the typed pointers for the class Node.\ -theory NodePointer - imports - ObjectPointer -begin - -datatype 'node_ptr node_ptr = Ext 'node_ptr -register_default_tvars "'node_ptr node_ptr" - -type_synonym ('object_ptr, 'node_ptr) object_ptr = "('node_ptr node_ptr + 'object_ptr) object_ptr" -register_default_tvars "('object_ptr, 'node_ptr) object_ptr" - -definition cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) node_ptr \ (_) object_ptr" - where - "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr = object_ptr.Ext (Inl ptr)" - -definition cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) object_ptr \ (_) node_ptr option" - where - "cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r object_ptr = (case object_ptr of object_ptr.Ext (Inl node_ptr) - \ Some node_ptr | _ \ None)" - -adhoc_overloading cast cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r - -definition is_node_ptr_kind :: "(_) object_ptr \ bool" - where - "is_node_ptr_kind ptr = (cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr \ None)" - -instantiation node_ptr :: (linorder) linorder -begin -definition less_eq_node_ptr :: "(_::linorder) node_ptr \ (_) node_ptr \ bool" - where "less_eq_node_ptr x y \ (case x of Ext i \ (case y of Ext j \ i \ j))" -definition less_node_ptr :: "(_::linorder) node_ptr \ (_) node_ptr \ bool" - where "less_node_ptr x y \ x \ y \ \ y \ x" -instance - apply(standard) - by(auto simp add: less_eq_node_ptr_def less_node_ptr_def split: node_ptr.splits) -end - -lemma node_ptr_casts_commute [simp]: - "cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr = Some node_ptr \ cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr = ptr" - unfolding cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def - by(auto split: object_ptr.splits sum.splits) - -lemma node_ptr_casts_commute2 [simp]: - "cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr) = Some node_ptr" - by simp - -lemma node_ptr_casts_commute3 [simp]: - assumes "is_node_ptr_kind ptr" - shows "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r (the (cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr)) = ptr" - using assms - by(auto simp add: is_node_ptr_kind_def cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def - split: object_ptr.splits sum.splits) - -lemma is_node_ptr_kind_obtains: - assumes "is_node_ptr_kind ptr" - obtains node_ptr where "cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr = Some node_ptr" - using assms is_node_ptr_kind_def by auto - -lemma is_node_ptr_kind_none: - assumes "\is_node_ptr_kind ptr" - shows "cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr = None" - using assms - unfolding is_node_ptr_kind_def cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def - by auto - -lemma is_node_ptr_kind_cast [simp]: "is_node_ptr_kind (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr)" - unfolding is_node_ptr_kind_def by simp - -lemma cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_inject [simp]: - "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r x = cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r y \ x = y" - by(simp add: cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def) - -lemma cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_ext_none [simp]: - "cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r (object_ptr.Ext (Inr (Inr (Inr object_ext_ptr)))) = None" - by(simp add: cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def) - -lemma node_ptr_inclusion [simp]: - "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr \ cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ` node_ptrs \ node_ptr \ node_ptrs" - by auto -end diff --git a/Core_DOM/Core_SC_DOM/common/pointers/NodePointer.thy b/Core_DOM/Core_SC_DOM/common/pointers/NodePointer.thy new file mode 120000 index 0000000..475be01 --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/pointers/NodePointer.thy @@ -0,0 +1 @@ +../../../Core_DOM/common/pointers/NodePointer.thy \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/pointers/ObjectPointer.thy b/Core_DOM/Core_SC_DOM/common/pointers/ObjectPointer.thy deleted file mode 100644 index c4168c2..0000000 --- a/Core_DOM/Core_SC_DOM/common/pointers/ObjectPointer.thy +++ /dev/null @@ -1,51 +0,0 @@ -(*********************************************************************************** - * Copyright (c) 2016-2018 The University of Sheffield, UK - * - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * * Redistributions of source code must retain the above copyright notice, this - * list of conditions and the following disclaimer. - * - * * Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - * SPDX-License-Identifier: BSD-2-Clause - ***********************************************************************************) - -section\Object\ -text\In this theory, we introduce the typed pointer for the class Object. This class is the -common superclass of our class model.\ -theory ObjectPointer - imports - Ref -begin - -datatype 'object_ptr object_ptr = Ext 'object_ptr -register_default_tvars "'object_ptr object_ptr" - -instantiation object_ptr :: (linorder) linorder -begin -definition less_eq_object_ptr :: "'object_ptr::linorder object_ptr \ 'object_ptr object_ptr \ bool" - where "less_eq_object_ptr x y \ (case x of Ext i \ (case y of Ext j \ i \ j))" -definition less_object_ptr :: "'object_ptr::linorder object_ptr \ 'object_ptr object_ptr \ bool" - where "less_object_ptr x y \ x \ y \ \ y \ x" -instance by(standard, auto simp add: less_eq_object_ptr_def less_object_ptr_def - split: object_ptr.splits) -end - -end diff --git a/Core_DOM/Core_SC_DOM/common/pointers/ObjectPointer.thy b/Core_DOM/Core_SC_DOM/common/pointers/ObjectPointer.thy new file mode 120000 index 0000000..177b3de --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/pointers/ObjectPointer.thy @@ -0,0 +1 @@ +../../../Core_DOM/common/pointers/ObjectPointer.thy \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/pointers/Ref.thy b/Core_DOM/Core_SC_DOM/common/pointers/Ref.thy deleted file mode 100644 index fd29f5e..0000000 --- a/Core_DOM/Core_SC_DOM/common/pointers/Ref.thy +++ /dev/null @@ -1,62 +0,0 @@ -(*********************************************************************************** - * Copyright (c) 2016-2018 The University of Sheffield, UK - * - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * * Redistributions of source code must retain the above copyright notice, this - * list of conditions and the following disclaimer. - * - * * Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - * SPDX-License-Identifier: BSD-2-Clause - ***********************************************************************************) - -section\References\ -text\ - This theory, we introduce a generic reference. All our typed pointers include such - a reference, which allows us to distinguish pointers of the same type, but also to - iterate over all pointers in a set.\ -theory - Ref - imports - "HOL-Library.Adhoc_Overloading" - "../preliminaries/Hiding_Type_Variables" -begin - -instantiation sum :: (linorder, linorder) linorder -begin -definition less_eq_sum :: "'a + 'b \ 'a + 'b \ bool" - where - "less_eq_sum t t' = (case t of - Inl l \ (case t' of - Inl l' \ l \ l' - | Inr r' \ True) - | Inr r \ (case t' of - Inl l' \ False - | Inr r' \ r \ r'))" -definition less_sum :: "'a + 'b \ 'a + 'b \ bool" - where - "less_sum t t' \ t \ t' \ \ t' \ t" -instance by(standard) (auto simp add: less_eq_sum_def less_sum_def split: sum.splits) -end - -type_synonym ref = nat -consts cast :: 'a - -end diff --git a/Core_DOM/Core_SC_DOM/common/pointers/Ref.thy b/Core_DOM/Core_SC_DOM/common/pointers/Ref.thy new file mode 120000 index 0000000..ffeb1d5 --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/pointers/Ref.thy @@ -0,0 +1 @@ +../../../Core_DOM/common/pointers/Ref.thy \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/preliminaries/Heap_Error_Monad.thy b/Core_DOM/Core_SC_DOM/common/preliminaries/Heap_Error_Monad.thy deleted file mode 100644 index 5a4a0b4..0000000 --- a/Core_DOM/Core_SC_DOM/common/preliminaries/Heap_Error_Monad.thy +++ /dev/null @@ -1,930 +0,0 @@ -(*********************************************************************************** - * Copyright (c) 2016-2018 The University of Sheffield, UK - * - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * * Redistributions of source code must retain the above copyright notice, this - * list of conditions and the following disclaimer. - * - * * Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - * SPDX-License-Identifier: BSD-2-Clause - ***********************************************************************************) - -section\The Heap Error Monad\ -text \In this theory, we define a heap and error monad for modeling exceptions. -This allows us to define composite methods similar to stateful programming in Haskell, -but also to stay close to the official DOM specification.\ -theory - Heap_Error_Monad - imports - Hiding_Type_Variables - "HOL-Library.Monad_Syntax" -begin - -subsection \The Program Data Type\ - -datatype ('heap, 'e, 'result) prog = Prog (the_prog: "'heap \ 'e + 'result \ 'heap") -register_default_tvars "('heap, 'e, 'result) prog" (print, parse) - -subsection \Basic Functions\ - -definition - bind :: "(_, 'result) prog \ ('result \ (_, 'result2) prog) \ (_, 'result2) prog" - where - "bind f g = Prog (\h. (case (the_prog f) h of Inr (x, h') \ (the_prog (g x)) h' - | Inl exception \ Inl exception))" - -adhoc_overloading Monad_Syntax.bind bind - -definition - execute :: "'heap \ ('heap, 'e, 'result) prog \ ('e + 'result \ 'heap)" - ("((_)/ \ (_))" [51, 52] 55) - where - "execute h p = (the_prog p) h" - -definition - returns_result :: "'heap \ ('heap, 'e, 'result) prog \ 'result \ bool" - ("((_)/ \ (_)/ \\<^sub>r (_))" [60, 35, 61] 65) - where - "returns_result h p r \ (case h \ p of Inr (r', _) \ r = r' | Inl _ \ False)" - -fun select_result ("|(_)|\<^sub>r") - where - "select_result (Inr (r, _)) = r" - | "select_result (Inl _) = undefined" - -lemma returns_result_eq [elim]: "h \ f \\<^sub>r y \ h \ f \\<^sub>r y' \ y = y'" - by(auto simp add: returns_result_def split: sum.splits) - -definition - returns_heap :: "'heap \ ('heap, 'e, 'result) prog \ 'heap \ bool" - ("((_)/ \ (_)/ \\<^sub>h (_))" [60, 35, 61] 65) - where - "returns_heap h p h' \ (case h \ p of Inr (_ , h'') \ h' = h'' | Inl _ \ False)" - -fun select_heap ("|(_)|\<^sub>h") - where - "select_heap (Inr ( _, h)) = h" - | "select_heap (Inl _) = undefined" - -lemma returns_heap_eq [elim]: "h \ f \\<^sub>h h' \ h \ f \\<^sub>h h'' \ h' = h''" - by(auto simp add: returns_heap_def split: sum.splits) - -definition - returns_result_heap :: "'heap \ ('heap, 'e, 'result) prog \ 'result \ 'heap \ bool" - ("((_)/ \ (_)/ \\<^sub>r (_) \\<^sub>h (_))" [60, 35, 61, 62] 65) - where - "returns_result_heap h p r h' \ h \ p \\<^sub>r r \ h \ p \\<^sub>h h'" - -lemma return_result_heap_code [code]: "returns_result_heap h p r h' \ (case h \ p of Inr (r', h'') \ r = r' \ h' = h'' | Inl _ \ False)" - by(auto simp add: returns_result_heap_def returns_result_def returns_heap_def split: sum.splits) - -fun select_result_heap ("|(_)|\<^sub>r\<^sub>h") - where - "select_result_heap (Inr (r, h)) = (r, h)" - | "select_result_heap (Inl _) = undefined" - -definition - returns_error :: "'heap \ ('heap, 'e, 'result) prog \ 'e \ bool" - ("((_)/ \ (_)/ \\<^sub>e (_))" [60, 35, 61] 65) - where - "returns_error h p e = (case h \ p of Inr _ \ False | Inl e' \ e = e')" - -definition is_OK :: "'heap \ ('heap, 'e, 'result) prog \ bool" ("((_)/ \ ok (_))" [75, 75]) - where - "is_OK h p = (case h \ p of Inr _ \ True | Inl _ \ False)" - -lemma is_OK_returns_result_I [intro]: "h \ f \\<^sub>r y \ h \ ok f" - by(auto simp add: is_OK_def returns_result_def split: sum.splits) - -lemma is_OK_returns_result_E [elim]: - assumes "h \ ok f" - obtains x where "h \ f \\<^sub>r x" - using assms by(auto simp add: is_OK_def returns_result_def split: sum.splits) - -lemma is_OK_returns_heap_I [intro]: "h \ f \\<^sub>h h' \ h \ ok f" - by(auto simp add: is_OK_def returns_heap_def split: sum.splits) - -lemma is_OK_returns_heap_E [elim]: - assumes "h \ ok f" - obtains h' where "h \ f \\<^sub>h h'" - using assms by(auto simp add: is_OK_def returns_heap_def split: sum.splits) - -lemma select_result_I: - assumes "h \ ok f" - and "\x. h \ f \\<^sub>r x \ P x" - shows "P |h \ f|\<^sub>r" - using assms - by(auto simp add: is_OK_def returns_result_def split: sum.splits) - -lemma select_result_I2 [simp]: - assumes "h \ f \\<^sub>r x" - shows "|h \ f|\<^sub>r = x" - using assms - by(auto simp add: is_OK_def returns_result_def split: sum.splits) - -lemma returns_result_select_result [simp]: - assumes "h \ ok f" - shows "h \ f \\<^sub>r |h \ f|\<^sub>r" - using assms - by (simp add: select_result_I) - -lemma select_result_E: - assumes "P |h \ f|\<^sub>r" and "h \ ok f" - obtains x where "h \ f \\<^sub>r x" and "P x" - using assms - by(auto simp add: is_OK_def returns_result_def split: sum.splits) - -lemma select_result_eq: "(\x .h \ f \\<^sub>r x = h' \ f \\<^sub>r x) \ |h \ f|\<^sub>r = |h' \ f|\<^sub>r" - by (metis (no_types, lifting) is_OK_def old.sum.simps(6) select_result.elims - select_result_I select_result_I2) - -definition error :: "'e \ ('heap, 'e, 'result) prog" - where - "error exception = Prog (\h. Inl exception)" - -lemma error_bind [iff]: "(error e \ g) = error e" - unfolding error_def bind_def by auto - -lemma error_returns_result [simp]: "\ (h \ error e \\<^sub>r y)" - unfolding returns_result_def error_def execute_def by auto - -lemma error_returns_heap [simp]: "\ (h \ error e \\<^sub>h h')" - unfolding returns_heap_def error_def execute_def by auto - -lemma error_returns_error [simp]: "h \ error e \\<^sub>e e" - unfolding returns_error_def error_def execute_def by auto - -definition return :: "'result \ ('heap, 'e, 'result) prog" - where - "return result = Prog (\h. Inr (result, h))" - -lemma return_ok [simp]: "h \ ok (return x)" - by(simp add: return_def is_OK_def execute_def) - -lemma return_bind [iff]: "(return x \ g) = g x" - unfolding return_def bind_def by auto - -lemma return_id [simp]: "f \ return = f" - by (induct f) (auto simp add: return_def bind_def split: sum.splits prod.splits) - -lemma return_returns_result [iff]: "(h \ return x \\<^sub>r y) = (x = y)" - unfolding returns_result_def return_def execute_def by auto - -lemma return_returns_heap [iff]: "(h \ return x \\<^sub>h h') = (h = h')" - unfolding returns_heap_def return_def execute_def by auto - -lemma return_returns_error [iff]: "\ h \ return x \\<^sub>e e" - unfolding returns_error_def execute_def return_def by auto - -definition noop :: "('heap, 'e, unit) prog" - where - "noop = return ()" - -lemma noop_returns_heap [simp]: "h \ noop \\<^sub>h h' \ h = h'" - by(simp add: noop_def) - -definition get_heap :: "('heap, 'e, 'heap) prog" - where - "get_heap = Prog (\h. h \ return h)" - -lemma get_heap_ok [simp]: "h \ ok (get_heap)" - by (simp add: get_heap_def execute_def is_OK_def return_def) - -lemma get_heap_returns_result [simp]: "(h \ get_heap \ (\h'. f h') \\<^sub>r x) = (h \ f h \\<^sub>r x)" - by(simp add: get_heap_def returns_result_def bind_def return_def execute_def) - -lemma get_heap_returns_heap [simp]: "(h \ get_heap \ (\h'. f h') \\<^sub>h h'') = (h \ f h \\<^sub>h h'')" - by(simp add: get_heap_def returns_heap_def bind_def return_def execute_def) - -lemma get_heap_is_OK [simp]: "(h \ ok (get_heap \ (\h'. f h'))) = (h \ ok (f h))" - by(auto simp add: get_heap_def is_OK_def bind_def return_def execute_def) - -lemma get_heap_E [elim]: "(h \ get_heap \\<^sub>r x) \ x = h" - by(simp add: get_heap_def returns_result_def return_def execute_def) - -definition return_heap :: "'heap \ ('heap, 'e, unit) prog" - where - "return_heap h = Prog (\_. h \ return ())" - -lemma return_heap_E [iff]: "(h \ return_heap h' \\<^sub>h h'') = (h'' = h')" - by(simp add: return_heap_def returns_heap_def return_def execute_def) - -lemma return_heap_returns_result [simp]: "h \ return_heap h' \\<^sub>r ()" - by(simp add: return_heap_def execute_def returns_result_def return_def) - - -subsection \Pure Heaps\ - -definition pure :: "('heap, 'e, 'result) prog \ 'heap \ bool" - where "pure f h \ h \ ok f \ h \ f \\<^sub>h h" - -lemma return_pure [simp]: "pure (return x) h" - by(simp add: pure_def return_def is_OK_def returns_heap_def execute_def) - -lemma error_pure [simp]: "pure (error e) h" - by(simp add: pure_def error_def is_OK_def returns_heap_def execute_def) - -lemma noop_pure [simp]: "pure (noop) h" - by (simp add: noop_def) - -lemma get_pure [simp]: "pure get_heap h" - by(simp add: pure_def get_heap_def is_OK_def returns_heap_def return_def execute_def) - -lemma pure_returns_heap_eq: - "h \ f \\<^sub>h h' \ pure f h \ h = h'" - by (meson pure_def is_OK_returns_heap_I returns_heap_eq) - -lemma pure_eq_iff: - "(\h' x. h \ f \\<^sub>r x \ h \ f \\<^sub>h h' \ h = h') \ pure f h" - by(auto simp add: pure_def) - -subsection \Bind\ - -lemma bind_assoc [simp]: - "((bind f g) \ h) = (f \ (\x. (g x \ h)))" - by(auto simp add: bind_def split: sum.splits) - -lemma bind_returns_result_E: - assumes "h \ f \ g \\<^sub>r y" - obtains x h' where "h \ f \\<^sub>r x" and "h \ f \\<^sub>h h'" and "h' \ g x \\<^sub>r y" - using assms by(auto simp add: bind_def returns_result_def returns_heap_def execute_def - split: sum.splits) - -lemma bind_returns_result_E2: - assumes "h \ f \ g \\<^sub>r y" and "pure f h" - obtains x where "h \ f \\<^sub>r x" and "h \ g x \\<^sub>r y" - using assms pure_returns_heap_eq bind_returns_result_E by metis - -lemma bind_returns_result_E3: - assumes "h \ f \ g \\<^sub>r y" and "h \ f \\<^sub>r x" and "pure f h" - shows "h \ g x \\<^sub>r y" - using assms returns_result_eq bind_returns_result_E2 by metis - -lemma bind_returns_result_E4: - assumes "h \ f \ g \\<^sub>r y" and "h \ f \\<^sub>r x" - obtains h' where "h \ f \\<^sub>h h'" and "h' \ g x \\<^sub>r y" - using assms returns_result_eq bind_returns_result_E by metis - -lemma bind_returns_heap_E: - assumes "h \ f \ g \\<^sub>h h''" - obtains x h' where "h \ f \\<^sub>r x" and "h \ f \\<^sub>h h'" and "h' \ g x \\<^sub>h h''" - using assms by(auto simp add: bind_def returns_result_def returns_heap_def execute_def - split: sum.splits) - -lemma bind_returns_heap_E2 [elim]: - assumes "h \ f \ g \\<^sub>h h'" and "pure f h" - obtains x where "h \ f \\<^sub>r x" and "h \ g x \\<^sub>h h'" - using assms pure_returns_heap_eq by (fastforce elim: bind_returns_heap_E) - -lemma bind_returns_heap_E3 [elim]: - assumes "h \ f \ g \\<^sub>h h'" and "h \ f \\<^sub>r x" and "pure f h" - shows "h \ g x \\<^sub>h h'" - using assms pure_returns_heap_eq returns_result_eq by (fastforce elim: bind_returns_heap_E) - -lemma bind_returns_heap_E4: - assumes "h \ f \ g \\<^sub>h h''" and "h \ f \\<^sub>h h'" - obtains x where "h \ f \\<^sub>r x" and "h' \ g x \\<^sub>h h''" - using assms - by (metis bind_returns_heap_E returns_heap_eq) - -lemma bind_returns_error_I [intro]: - assumes "h \ f \\<^sub>e e" - shows "h \ f \ g \\<^sub>e e" - using assms - by(auto simp add: returns_error_def bind_def execute_def split: sum.splits) - -lemma bind_returns_error_I3: - assumes "h \ f \\<^sub>r x" and "h \ f \\<^sub>h h'" and "h' \ g x \\<^sub>e e" - shows "h \ f \ g \\<^sub>e e" - using assms - by(auto simp add: returns_error_def bind_def execute_def returns_heap_def returns_result_def - split: sum.splits) - -lemma bind_returns_error_I2 [intro]: - assumes "pure f h" and "h \ f \\<^sub>r x" and "h \ g x \\<^sub>e e" - shows "h \ f \ g \\<^sub>e e" - using assms - by (meson bind_returns_error_I3 is_OK_returns_result_I pure_def) - -lemma bind_is_OK_E [elim]: - assumes "h \ ok (f \ g)" - obtains x h' where "h \ f \\<^sub>r x" and "h \ f \\<^sub>h h'" and "h' \ ok (g x)" - using assms - by(auto simp add: bind_def returns_result_def returns_heap_def is_OK_def execute_def - split: sum.splits) - -lemma bind_is_OK_E2: - assumes "h \ ok (f \ g)" and "h \ f \\<^sub>r x" - obtains h' where "h \ f \\<^sub>h h'" and "h' \ ok (g x)" - using assms - by(auto simp add: bind_def returns_result_def returns_heap_def is_OK_def execute_def - split: sum.splits) - -lemma bind_returns_result_I [intro]: - assumes "h \ f \\<^sub>r x" and "h \ f \\<^sub>h h'" and "h' \ g x \\<^sub>r y" - shows "h \ f \ g \\<^sub>r y" - using assms - by(auto simp add: bind_def returns_result_def returns_heap_def execute_def - split: sum.splits) - -lemma bind_pure_returns_result_I [intro]: - assumes "pure f h" and "h \ f \\<^sub>r x" and "h \ g x \\<^sub>r y" - shows "h \ f \ g \\<^sub>r y" - using assms - by (meson bind_returns_result_I pure_def is_OK_returns_result_I) - -lemma bind_pure_returns_result_I2 [intro]: - assumes "pure f h" and "h \ ok f" and "\x. h \ f \\<^sub>r x \ h \ g x \\<^sub>r y" - shows "h \ f \ g \\<^sub>r y" - using assms by auto - -lemma bind_returns_heap_I [intro]: - assumes "h \ f \\<^sub>r x" and "h \ f \\<^sub>h h'" and "h' \ g x \\<^sub>h h''" - shows "h \ f \ g \\<^sub>h h''" - using assms - by(auto simp add: bind_def returns_result_def returns_heap_def execute_def - split: sum.splits) - -lemma bind_returns_heap_I2 [intro]: - assumes "h \ f \\<^sub>h h'" and "\x. h \ f \\<^sub>r x \ h' \ g x \\<^sub>h h''" - shows "h \ f \ g \\<^sub>h h''" - using assms - by (meson bind_returns_heap_I is_OK_returns_heap_I is_OK_returns_result_E) - -lemma bind_is_OK_I [intro]: - assumes "h \ f \\<^sub>r x" and "h \ f \\<^sub>h h'" and "h' \ ok (g x)" - shows "h \ ok (f \ g)" - by (meson assms(1) assms(2) assms(3) bind_returns_heap_I is_OK_returns_heap_E - is_OK_returns_heap_I) - -lemma bind_is_OK_I2 [intro]: - assumes "h \ ok f" and "\x h'. h \ f \\<^sub>r x \ h \ f \\<^sub>h h' \ h' \ ok (g x)" - shows "h \ ok (f \ g)" - using assms by blast - -lemma bind_is_OK_pure_I [intro]: - assumes "pure f h" and "h \ ok f" and "\x. h \ f \\<^sub>r x \ h \ ok (g x)" - shows "h \ ok (f \ g)" - using assms by blast - -lemma bind_pure_I: - assumes "pure f h" and "\x. h \ f \\<^sub>r x \ pure (g x) h" - shows "pure (f \ g) h" - using assms - by (metis bind_returns_heap_E2 pure_def pure_returns_heap_eq is_OK_returns_heap_E) - -lemma pure_pure: - assumes "h \ ok f" and "pure f h" - shows "h \ f \\<^sub>h h" - using assms returns_heap_eq - unfolding pure_def - by auto - -lemma bind_returns_error_eq: - assumes "h \ f \\<^sub>e e" - and "h \ g \\<^sub>e e" - shows "h \ f = h \ g" - using assms - by(auto simp add: returns_error_def split: sum.splits) - -subsection \Map\ - -fun map_M :: "('x \ ('heap, 'e, 'result) prog) \ 'x list \ ('heap, 'e, 'result list) prog" - where - "map_M f [] = return []" - | "map_M f (x#xs) = do { - y \ f x; - ys \ map_M f xs; - return (y # ys) - }" - -lemma map_M_ok_I [intro]: - "(\x. x \ set xs \ h \ ok (f x)) \ (\x. x \ set xs \ pure (f x) h) \ h \ ok (map_M f xs)" - apply(induct xs) - by (simp_all add: bind_is_OK_I2 bind_is_OK_pure_I) - -lemma map_M_pure_I : "\h. (\x. x \ set xs \ pure (f x) h) \ pure (map_M f xs) h" - apply(induct xs) - apply(simp) - by(auto intro!: bind_pure_I) - -lemma map_M_pure_E : - assumes "h \ map_M g xs \\<^sub>r ys" and "x \ set xs" and "\x h. x \ set xs \ pure (g x) h" - obtains y where "h \ g x \\<^sub>r y" and "y \ set ys" - apply(insert assms, induct xs arbitrary: ys) - apply(simp) - apply(auto elim!: bind_returns_result_E)[1] - by (metis (full_types) pure_returns_heap_eq) - -lemma map_M_pure_E2: - assumes "h \ map_M g xs \\<^sub>r ys" and "y \ set ys" and "\x h. x \ set xs \ pure (g x) h" - obtains x where "h \ g x \\<^sub>r y" and "x \ set xs" - apply(insert assms, induct xs arbitrary: ys) - apply(simp) - apply(auto elim!: bind_returns_result_E)[1] - by (metis (full_types) pure_returns_heap_eq) - - -subsection \Forall\ - -fun forall_M :: "('y \ ('heap, 'e, 'result) prog) \ 'y list \ ('heap, 'e, unit) prog" - where - "forall_M P [] = return ()" - | "forall_M P (x # xs) = do { - P x; - forall_M P xs - }" - (* -lemma forall_M_elim: - assumes "h \ forall_M P xs \\<^sub>r True" and "\x h. x \ set xs \ pure (P x) h" - shows "\x \ set xs. h \ P x \\<^sub>r True" - apply(insert assms, induct xs) - apply(simp) - apply(auto elim!: bind_returns_result_E)[1] - by (metis (full_types) pure_returns_heap_eq) *) - -lemma pure_forall_M_I: "(\x. x \ set xs \ pure (P x) h) \ pure (forall_M P xs) h" - apply(induct xs) - by(auto intro!: bind_pure_I) - (* -lemma forall_M_pure_I: - assumes "\x. x \ set xs \ h \ P x \\<^sub>r True" and "\x h. x \ set xs \ pure (P x)h" - shows "h \ forall_M P xs \\<^sub>r True" - apply(insert assms, induct xs) - apply(simp) - by(fastforce) - -lemma forall_M_pure_eq: - assumes "\x. x \ set xs \ h \ P x \\<^sub>r True \ h' \ P x \\<^sub>r True" - and "\x h. x \ set xs \ pure (P x) h" - shows "(h \ forall_M P xs \\<^sub>r True) \ h' \ forall_M P xs \\<^sub>r True" - using assms - by(auto intro!: forall_M_pure_I dest!: forall_M_elim) *) - -subsection \Fold\ - -fun fold_M :: "('result \ 'y \ ('heap, 'e, 'result) prog) \ 'result \ 'y list - \ ('heap, 'e, 'result) prog" - where - "fold_M f d [] = return d" | - "fold_M f d (x # xs) = do { y \ f d x; fold_M f y xs }" - -lemma fold_M_pure_I : "(\d x. pure (f d x) h) \ (\d. pure (fold_M f d xs) h)" - apply(induct xs) - by(auto intro: bind_pure_I) - -subsection \Filter\ - -fun filter_M :: "('x \ ('heap, 'e, bool) prog) \ 'x list \ ('heap, 'e, 'x list) prog" - where - "filter_M P [] = return []" - | "filter_M P (x#xs) = do { - p \ P x; - ys \ filter_M P xs; - return (if p then x # ys else ys) - }" - -lemma filter_M_pure_I [intro]: "(\x. x \ set xs \ pure (P x) h) \ pure (filter_M P xs)h" - apply(induct xs) - by(auto intro!: bind_pure_I) - -lemma filter_M_is_OK_I [intro]: "(\x. x \ set xs \ h \ ok (P x)) \ (\x. x \ set xs \ pure (P x) h) \ h \ ok (filter_M P xs)" - apply(induct xs) - apply(simp) - by(auto intro!: bind_is_OK_pure_I) - -lemma filter_M_not_more_elements: - assumes "h \ filter_M P xs \\<^sub>r ys" and "\x. x \ set xs \ pure (P x) h" and "x \ set ys" - shows "x \ set xs" - apply(insert assms, induct xs arbitrary: ys) - by(auto elim!: bind_returns_result_E2 split: if_splits intro!: set_ConsD) - -lemma filter_M_in_result_if_ok: - assumes "h \ filter_M P xs \\<^sub>r ys" and "\h x. x \ set xs \ pure (P x) h" and "x \ set xs" and "h \ P x \\<^sub>r True" - shows "x \ set ys" - apply(insert assms, induct xs arbitrary: ys) - apply(simp) - apply(auto elim!: bind_returns_result_E2)[1] - by (metis returns_result_eq) - -lemma filter_M_holds_for_result: - assumes "h \ filter_M P xs \\<^sub>r ys" and "x \ set ys" and "\x h. x \ set xs \ pure (P x) h" - shows "h \ P x \\<^sub>r True" - apply(insert assms, induct xs arbitrary: ys) - by(auto elim!: bind_returns_result_E2 split: if_splits intro!: set_ConsD) - -lemma filter_M_empty_I: - assumes "\x. pure (P x) h" - and "\x \ set xs. h \ P x \\<^sub>r False" - shows "h \ filter_M P xs \\<^sub>r []" - using assms - apply(induct xs) - by(auto intro!: bind_pure_returns_result_I) - -lemma filter_M_subset_2: "h \ filter_M P xs \\<^sub>r ys \ h' \ filter_M P xs \\<^sub>r ys' - \ (\x. pure (P x) h) \ (\x. pure (P x) h') - \ (\b. \x \ set xs. h \ P x \\<^sub>r True \ h' \ P x \\<^sub>r b \ b) - \ set ys \ set ys'" -proof - - assume 1: "h \ filter_M P xs \\<^sub>r ys" and 2: "h' \ filter_M P xs \\<^sub>r ys'" - and 3: "(\x. pure (P x) h)" and "(\x. pure (P x) h')" - and 4: "\b. \x\set xs. h \ P x \\<^sub>r True \ h' \ P x \\<^sub>r b \ b" - have h1: "\x \ set xs. h' \ ok (P x)" - using 2 3 \(\x. pure (P x) h')\ - apply(induct xs arbitrary: ys') - by(auto elim!: bind_returns_result_E2) - then have 5: "\x\set xs. h \ P x \\<^sub>r True \ h' \ P x \\<^sub>r True" - using 4 - apply(auto)[1] - by (metis is_OK_returns_result_E) - show ?thesis - using 1 2 3 5 \(\x. pure (P x) h')\ - apply(induct xs arbitrary: ys ys') - apply(auto)[1] - apply(auto elim!: bind_returns_result_E2 split: if_splits)[1] - apply auto[1] - apply auto[1] - apply(metis returns_result_eq) - apply auto[1] - apply auto[1] - apply auto[1] - by(auto) -qed - -lemma filter_M_subset: "h \ filter_M P xs \\<^sub>r ys \ set ys \ set xs" - apply(induct xs arbitrary: h ys) - apply(auto)[1] - apply(auto elim!: bind_returns_result_E split: if_splits)[1] - apply blast - by blast - -lemma filter_M_distinct: "h \ filter_M P xs \\<^sub>r ys \ distinct xs \ distinct ys" - apply(induct xs arbitrary: h ys) - apply(auto)[1] - using filter_M_subset - apply(auto elim!: bind_returns_result_E)[1] - by fastforce - -lemma filter_M_filter: "h \ filter_M P xs \\<^sub>r ys \ (\x. x \ set xs \ pure (P x) h) - \ (\x \ set xs. h \ ok P x) \ ys = filter (\x. |h \ P x|\<^sub>r) xs" - apply(induct xs arbitrary: ys) - by(auto elim!: bind_returns_result_E2) - -lemma filter_M_filter2: "(\x. x \ set xs \ pure (P x) h \ h \ ok P x) - \ filter (\x. |h \ P x|\<^sub>r) xs = ys \ h \ filter_M P xs \\<^sub>r ys" - apply(induct xs arbitrary: ys) - by(auto elim!: bind_returns_result_E2 intro!: bind_pure_returns_result_I) - -lemma filter_ex1: "\!x \ set xs. P x \ P x \ x \ set xs \ distinct xs - \ filter P xs = [x]" - apply(auto)[1] - apply(induct xs) - apply(auto)[1] - apply(auto)[1] - using filter_empty_conv by fastforce - -lemma filter_M_ex1: - assumes "h \ filter_M P xs \\<^sub>r ys" - and "x \ set xs" - and "\!x \ set xs. h \ P x \\<^sub>r True" - and "\x. x \ set xs \ pure (P x) h" - and "distinct xs" - and "h \ P x \\<^sub>r True" - shows "ys = [x]" -proof - - have *: "\!x \ set xs. |h \ P x|\<^sub>r" - apply(insert assms(1) assms(3) assms(4)) - apply(drule filter_M_filter) - apply(simp) - apply(auto simp add: select_result_I2)[1] - by (metis (full_types) is_OK_returns_result_E select_result_I2) - then show ?thesis - apply(insert assms(1) assms(4)) - apply(drule filter_M_filter) - apply(auto)[1] - by (metis * assms(2) assms(5) assms(6) distinct_filter - distinct_length_2_or_more filter_empty_conv filter_set list.exhaust - list.set_intros(1) list.set_intros(2) member_filter select_result_I2) -qed - -lemma filter_M_eq: - assumes "\x. pure (P x) h" and "\x. pure (P x) h'" - and "\b x. x \ set xs \ h \ P x \\<^sub>r b = h' \ P x \\<^sub>r b" - shows "h \ filter_M P xs \\<^sub>r ys \ h' \ filter_M P xs \\<^sub>r ys" - using assms - apply (induct xs arbitrary: ys) - by(auto elim!: bind_returns_result_E2 intro!: bind_pure_returns_result_I - dest: returns_result_eq) - - -subsection \Map Filter\ - -definition map_filter_M :: "('x \ ('heap, 'e, 'y option) prog) \ 'x list - \ ('heap, 'e, 'y list) prog" - where - "map_filter_M f xs = do { - ys_opts \ map_M f xs; - ys_no_opts \ filter_M (\x. return (x \ None)) ys_opts; - map_M (\x. return (the x)) ys_no_opts - }" - -lemma map_filter_M_pure: "(\x h. x \ set xs \ pure (f x) h) \ pure (map_filter_M f xs) h" - by(auto simp add: map_filter_M_def map_M_pure_I intro!: bind_pure_I) - -lemma map_filter_M_pure_E: - assumes "h \ (map_filter_M::('x \ ('heap, 'e, 'y option) prog) \ 'x list - \ ('heap, 'e, 'y list) prog) f xs \\<^sub>r ys" and "y \ set ys" and "\x h. x \ set xs \ pure (f x) h" - obtains x where "h \ f x \\<^sub>r Some y" and "x \ set xs" -proof - - obtain ys_opts ys_no_opts where - ys_opts: "h \ map_M f xs \\<^sub>r ys_opts" and - ys_no_opts: "h \ filter_M (\x. (return (x \ None)::('heap, 'e, bool) prog)) ys_opts \\<^sub>r ys_no_opts" and - ys: "h \ map_M (\x. (return (the x)::('heap, 'e, 'y) prog)) ys_no_opts \\<^sub>r ys" - using assms - by(auto simp add: map_filter_M_def map_M_pure_I elim!: bind_returns_result_E2) - have "\y \ set ys_no_opts. y \ None" - using ys_no_opts filter_M_holds_for_result - by fastforce - then have "Some y \ set ys_no_opts" - using map_M_pure_E2 ys \y \ set ys\ - by (metis (no_types, lifting) option.collapse return_pure return_returns_result) - then have "Some y \ set ys_opts" - using filter_M_subset ys_no_opts by fastforce - then show "(\x. h \ f x \\<^sub>r Some y \ x \ set xs \ thesis) \ thesis" - by (metis assms(3) map_M_pure_E2 ys_opts) -qed - - -subsection \Iterate\ - -fun iterate_M :: "('heap, 'e, 'result) prog list \ ('heap, 'e, 'result) prog" - where - "iterate_M [] = return undefined" - | "iterate_M (x # xs) = x \ (\_. iterate_M xs)" - - -lemma iterate_M_concat: - assumes "h \ iterate_M xs \\<^sub>h h'" - and "h' \ iterate_M ys \\<^sub>h h''" - shows "h \ iterate_M (xs @ ys) \\<^sub>h h''" - using assms - apply(induct "xs" arbitrary: h h'') - apply(simp) - apply(auto)[1] - by (meson bind_returns_heap_E bind_returns_heap_I) - -subsection\Miscellaneous Rules\ - -lemma execute_bind_simp: - assumes "h \ f \\<^sub>r x" and "h \ f \\<^sub>h h'" - shows "h \ f \ g = h' \ g x" - using assms - by(auto simp add: returns_result_def returns_heap_def bind_def execute_def - split: sum.splits) - -lemma bind_cong [fundef_cong]: - fixes f1 f2 :: "('heap, 'e, 'result) prog" - and g1 g2 :: "'result \ ('heap, 'e, 'result2) prog" - assumes "h \ f1 = h \ f2" - and "\y h'. h \ f1 \\<^sub>r y \ h \ f1 \\<^sub>h h' \ h' \ g1 y = h' \ g2 y" - shows "h \ (f1 \ g1) = h \ (f2 \ g2)" - apply(insert assms, cases "h \ f1") - by(auto simp add: bind_def returns_result_def returns_heap_def execute_def - split: sum.splits) - -lemma bind_cong_2: - assumes "pure f h" and "pure f h'" - and "\x. h \ f \\<^sub>r x = h' \ f \\<^sub>r x" - and "\x. h \ f \\<^sub>r x \ h \ g x \\<^sub>r y = h' \ g x \\<^sub>r y'" - shows "h \ f \ g \\<^sub>r y = h' \ f \ g \\<^sub>r y'" - using assms - by(auto intro!: bind_pure_returns_result_I elim!: bind_returns_result_E2) - -lemma bind_case_cong [fundef_cong]: - assumes "x = x'" and "\a. x = Some a \ f a h = f' a h" - shows "(case x of Some a \ f a | None \ g) h = (case x' of Some a \ f' a | None \ g) h" - by (insert assms, simp add: option.case_eq_if) - - -subsection \Reasoning About Reads and Writes\ - -definition preserved :: "('heap, 'e, 'result) prog \ 'heap \ 'heap \ bool" - where - "preserved f h h' \ (\x. h \ f \\<^sub>r x \ h' \ f \\<^sub>r x)" - -lemma preserved_code [code]: "preserved f h h' = (((h \ ok f) \ (h' \ ok f) \ |h \ f|\<^sub>r = |h' \ f|\<^sub>r) \ ((\h \ ok f) \ (\h' \ ok f)))" - apply(auto simp add: preserved_def)[1] - apply (meson is_OK_returns_result_E is_OK_returns_result_I)+ - done - -lemma reflp_preserved_f [simp]: "reflp (preserved f)" - by(auto simp add: preserved_def reflp_def) -lemma transp_preserved_f [simp]: "transp (preserved f)" - by(auto simp add: preserved_def transp_def) - - -definition - all_args :: "('a \ ('heap, 'e, 'result) prog) \ ('heap, 'e, 'result) prog set" - where - "all_args f = (\arg. {f arg})" - - -definition - reads :: "('heap \ 'heap \ bool) set \ ('heap, 'e, 'result) prog \ 'heap - \ 'heap \ bool" - where - "reads S getter h h' \ (\P \ S. reflp P \ transp P) \ ((\P \ S. P h h') - \ preserved getter h h')" - -lemma reads_singleton [simp]: "reads {preserved f} f h h'" - by(auto simp add: reads_def) - -lemma reads_bind_pure: - assumes "pure f h" and "pure f h'" - and "reads S f h h'" - and "\x. h \ f \\<^sub>r x \ reads S (g x) h h'" - shows "reads S (f \ g) h h'" - using assms - by(auto simp add: reads_def pure_pure preserved_def - intro!: bind_pure_returns_result_I is_OK_returns_result_I - dest: pure_returns_heap_eq - elim!: bind_returns_result_E) - -lemma reads_insert_writes_set_left: "\P \ S. reflp P \ transp P \ reads {getter} f h h' \ reads (insert getter S) f h h'" - unfolding reads_def by simp - -lemma reads_insert_writes_set_right: "reflp getter \ transp getter \ reads S f h h' \ reads (insert getter S) f h h'" - unfolding reads_def by blast - -lemma reads_subset: "reads S f h h' \ \P \ S' - S. reflp P \ transp P \ S \ S' \ reads S' f h h'" - by(auto simp add: reads_def) - -lemma return_reads [simp]: "reads {} (return x) h h'" - by(simp add: reads_def preserved_def) - -lemma error_reads [simp]: "reads {} (error e) h h'" - by(simp add: reads_def preserved_def) - -lemma noop_reads [simp]: "reads {} noop h h'" - by(simp add: reads_def noop_def preserved_def) - -lemma filter_M_reads: - assumes "\x. x \ set xs \ pure (P x) h" and "\x. x \ set xs \ pure (P x) h'" - and "\x. x \ set xs \ reads S (P x) h h'" - and "\P \ S. reflp P \ transp P" - shows "reads S (filter_M P xs) h h'" - using assms - apply(induct xs) - by(auto intro: reads_subset[OF return_reads] intro!: reads_bind_pure) - -definition writes :: - "('heap, 'e, 'result) prog set \ ('heap, 'e, 'result2) prog \ 'heap \ 'heap \ bool" - where - "writes S setter h h' - \ (h \ setter \\<^sub>h h' \ (\progs. set progs \ S \ h \ iterate_M progs \\<^sub>h h'))" - -lemma writes_singleton [simp]: "writes (all_args f) (f a) h h'" - apply(auto simp add: writes_def all_args_def)[1] - apply(rule exI[where x="[f a]"]) - by(auto) - -lemma writes_singleton2 [simp]: "writes {f} f h h'" - apply(auto simp add: writes_def all_args_def)[1] - apply(rule exI[where x="[f]"]) - by(auto) - -lemma writes_union_left_I: - assumes "writes S f h h'" - shows "writes (S \ S') f h h'" - using assms - by(auto simp add: writes_def) - -lemma writes_union_right_I: - assumes "writes S' f h h'" - shows "writes (S \ S') f h h'" - using assms - by(auto simp add: writes_def) - -lemma writes_union_minus_split: - assumes "writes (S - S2) f h h'" - and "writes (S' - S2) f h h'" - shows "writes ((S \ S') - S2) f h h'" - using assms - by(auto simp add: writes_def) - -lemma writes_subset: "writes S f h h' \ S \ S' \ writes S' f h h'" - by(auto simp add: writes_def) - -lemma writes_error [simp]: "writes S (error e) h h'" - by(simp add: writes_def) - -lemma writes_not_ok [simp]: "\h \ ok f \ writes S f h h'" - by(auto simp add: writes_def) - -lemma writes_pure [simp]: - assumes "pure f h" - shows "writes S f h h'" - using assms - apply(auto simp add: writes_def)[1] - by (metis bot.extremum iterate_M.simps(1) list.set(1) pure_returns_heap_eq return_returns_heap) - -lemma writes_bind: - assumes "\h2. writes S f h h2" - assumes "\x h2. h \ f \\<^sub>r x \ h \ f \\<^sub>h h2 \ writes S (g x) h2 h'" - shows "writes S (f \ g) h h'" - using assms - apply(auto simp add: writes_def elim!: bind_returns_heap_E)[1] - by (metis iterate_M_concat le_supI set_append) - -lemma writes_bind_pure: - assumes "pure f h" - assumes "\x. h \ f \\<^sub>r x \ writes S (g x) h h'" - shows "writes S (f \ g) h h'" - using assms - by(auto simp add: writes_def elim!: bind_returns_heap_E2) - -lemma writes_small_big: - assumes "writes SW setter h h'" - assumes "h \ setter \\<^sub>h h'" - assumes "\h h' w. w \ SW \ h \ w \\<^sub>h h' \ P h h'" - assumes "reflp P" - assumes "transp P" - shows "P h h'" -proof - - obtain progs where "set progs \ SW" and iterate: "h \ iterate_M progs \\<^sub>h h'" - by (meson assms(1) assms(2) writes_def) - then have "\h h'. \prog \ set progs. h \ prog \\<^sub>h h' \ P h h'" - using assms(3) by auto - with iterate assms(4) assms(5) have "h \ iterate_M progs \\<^sub>h h' \ P h h'" - proof(induct progs arbitrary: h) - case Nil - then show ?case - using reflpE by force - next - case (Cons a progs) - then show ?case - apply(auto elim!: bind_returns_heap_E)[1] - by (metis (full_types) transpD) - qed - then show ?thesis - using assms(1) iterate by blast -qed - -lemma reads_writes_preserved: - assumes "reads SR getter h h'" - assumes "writes SW setter h h'" - assumes "h \ setter \\<^sub>h h'" - assumes "\h h'. \w \ SW. h \ w \\<^sub>h h' \ (\r \ SR. r h h')" - shows "h \ getter \\<^sub>r x \ h' \ getter \\<^sub>r x" -proof - - obtain progs where "set progs \ SW" and iterate: "h \ iterate_M progs \\<^sub>h h'" - by (meson assms(2) assms(3) writes_def) - then have "\h h'. \prog \ set progs. h \ prog \\<^sub>h h' \ (\r \ SR. r h h')" - using assms(4) by blast - with iterate have "\r \ SR. r h h'" - using writes_small_big assms(1) unfolding reads_def - by (metis assms(2) assms(3) assms(4)) - then show ?thesis - using assms(1) - by (simp add: preserved_def reads_def) -qed - -lemma reads_writes_separate_forwards: - assumes "reads SR getter h h'" - assumes "writes SW setter h h'" - assumes "h \ setter \\<^sub>h h'" - assumes "h \ getter \\<^sub>r x" - assumes "\h h'. \w \ SW. h \ w \\<^sub>h h' \ (\r \ SR. r h h')" - shows "h' \ getter \\<^sub>r x" - using reads_writes_preserved[OF assms(1) assms(2) assms(3) assms(5)] assms(4) - by(auto simp add: preserved_def) - -lemma reads_writes_separate_backwards: - assumes "reads SR getter h h'" - assumes "writes SW setter h h'" - assumes "h \ setter \\<^sub>h h'" - assumes "h' \ getter \\<^sub>r x" - assumes "\h h'. \w \ SW. h \ w \\<^sub>h h' \ (\r \ SR. r h h')" - shows "h \ getter \\<^sub>r x" - using reads_writes_preserved[OF assms(1) assms(2) assms(3) assms(5)] assms(4) - by(auto simp add: preserved_def) - -end diff --git a/Core_DOM/Core_SC_DOM/common/preliminaries/Heap_Error_Monad.thy b/Core_DOM/Core_SC_DOM/common/preliminaries/Heap_Error_Monad.thy new file mode 120000 index 0000000..256298b --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/preliminaries/Heap_Error_Monad.thy @@ -0,0 +1 @@ +../../../Core_DOM/common/preliminaries/Heap_Error_Monad.thy \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/preliminaries/Hiding_Type_Variables.thy b/Core_DOM/Core_SC_DOM/common/preliminaries/Hiding_Type_Variables.thy deleted file mode 100644 index 9c6c783..0000000 --- a/Core_DOM/Core_SC_DOM/common/preliminaries/Hiding_Type_Variables.thy +++ /dev/null @@ -1,584 +0,0 @@ -(*********************************************************************************** - * Copyright (c) 2018 Achim D. Brucker - * - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * * Redistributions of source code must retain the above copyright notice, this - * list of conditions and the following disclaimer. - * - * * Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - * SPDX-License-Identifier: BSD-2-Clause - * Repository: https://git.logicalhacking.com/adbrucker/isabelle-hacks/ - * Dependencies: None (assert.thy is used for testing the theory but it is - * not required for providing the functionality of this hack) - ***********************************************************************************) - -(* - This file is based on commit 8a5e95421521c36ab71ab2711435a9bc0fa2c5cc from upstream - (https://git.logicalhacking.com/adbrucker/isabelle-hacks/). Merely the dependency to - Assert.thy has been removed by disabling the example section (which include assert - checks). -*) - -section\Hiding Type Variables\ -text\ This theory\footnote{This theory can be used ``stand-alone,'' i.e., this theory is - not specific to the DOM formalization. The latest version is part of the ``Isabelle Hacks'' - repository: \url{https://git.logicalhacking.com/adbrucker/isabelle-hacks/}.} implements - a mechanism for declaring default type variables for data types. This comes handy for complex - data types with many type variables.\ -theory - "Hiding_Type_Variables" -imports - Main -keywords - "register_default_tvars" - "update_default_tvars_mode"::thy_decl -begin -(*<*) -section\Implementation\ -subsection\Theory Managed Data Structure\ -ML\ -signature HIDE_TVAR = sig - datatype print_mode = print_all | print | noprint - datatype tvar_subst = right | left - datatype parse_mode = parse | noparse - type hide_varT = { - name: string, - tvars: typ list, - typ_syn_tab : (string * typ list*string) Symtab.table, - print_mode: print_mode, - parse_mode: parse_mode - } - val parse_print_mode : string -> print_mode - val parse_parse_mode : string -> parse_mode - val register : string -> print_mode option -> parse_mode option -> - theory -> theory - val update_mode : string -> print_mode option -> parse_mode option -> - theory -> theory - val lookup : theory -> string -> hide_varT option - val hide_tvar_tr' : string -> Proof.context -> term list -> term - val hide_tvar_ast_tr : Proof.context -> Ast.ast list -> Ast.ast - val hide_tvar_subst_ast_tr : tvar_subst -> Proof.context -> Ast.ast list - -> Ast.ast - val hide_tvar_subst_return_ast_tr : tvar_subst -> Proof.context - -> Ast.ast list -> Ast.ast -end - -structure Hide_Tvar : HIDE_TVAR = struct - datatype print_mode = print_all | print | noprint - datatype tvar_subst = right | left - datatype parse_mode = parse | noparse - type hide_varT = { - name: string, - tvars: typ list, - typ_syn_tab : (string * typ list*string) Symtab.table, - print_mode: print_mode, - parse_mode: parse_mode - } - type hide_tvar_tab = (hide_varT) Symtab.table - fun hide_tvar_eq (a, a') = (#name a) = (#name a') - fun merge_tvar_tab (tab,tab') = Symtab.merge hide_tvar_eq (tab,tab') - - structure Data = Generic_Data - ( - type T = hide_tvar_tab - val empty = Symtab.empty:hide_tvar_tab - val extend = I - fun merge(t1,t2) = merge_tvar_tab (t1, t2) - ); - - - fun parse_print_mode "print_all" = print_all - | parse_print_mode "print" = print - | parse_print_mode "noprint" = noprint - | parse_print_mode s = error("Print mode not supported: "^s) - - fun parse_parse_mode "parse" = parse - | parse_parse_mode "noparse" = noparse - | parse_parse_mode s = error("Parse mode not supported: "^s) - - fun update_mode typ_str print_mode parse_mode thy = - let - val ctx = Toplevel.context_of(Toplevel.theory_toplevel thy) - val typ = Syntax.parse_typ ctx typ_str (* no type checking *) - val name = case typ of - Type(name,_) => name - | _ => error("Complex type not (yet) supported.") - fun update tab = - let - val old_entry = (case Symtab.lookup tab name of - SOME t => t - | NONE => error ("Type shorthand not registered: "^name)) - val print_m = case print_mode of - SOME m => m - | NONE => #print_mode old_entry - val parse_m = case parse_mode of - SOME m => m - | NONE => #parse_mode old_entry - val entry = { - name = name, - tvars = #tvars old_entry, - typ_syn_tab = #typ_syn_tab old_entry, - print_mode = print_m, - parse_mode = parse_m - } - in - Symtab.update (name,entry) tab - end - in - Context.theory_of ( (Data.map update) (Context.Theory thy)) - end - - fun lookup thy name = - let - val tab = (Data.get o Context.Theory) thy - in - Symtab.lookup tab name - end - - fun obtain_normalized_vname lookup_table vname = - case List.find (fn e => fst e = vname) lookup_table of - SOME (_,idx) => (lookup_table, Int.toString idx) - | NONE => let - fun max_idx [] = 0 - | max_idx ((_,idx)::lt) = Int.max(idx,max_idx lt) - - val idx = (max_idx lookup_table ) + 1 - in - ((vname,idx)::lookup_table, Int.toString idx) end - - fun normalize_typvar_type lt (Type (a, Ts)) = - let - fun switch (a,b) = (b,a) - val (Ts', lt') = fold_map (fn t => fn lt => switch (normalize_typvar_type lt t)) Ts lt - in - (lt', Type (a, Ts')) - end - | normalize_typvar_type lt (TFree (vname, S)) = - let - val (lt, vname) = obtain_normalized_vname lt (vname) - in - (lt, TFree( vname, S)) - end - | normalize_typvar_type lt (TVar (xi, S)) = - let - val (lt, vname) = obtain_normalized_vname lt (Term.string_of_vname xi) - in - (lt, TFree( vname, S)) - end - - fun normalize_typvar_type' t = snd ( normalize_typvar_type [] t) - - fun mk_p s = s (* "("^s^")" *) - - fun key_of_type (Type(a, TS)) = mk_p (a^String.concat(map key_of_type TS)) - | key_of_type (TFree (vname, _)) = mk_p vname - | key_of_type (TVar (xi, _ )) = mk_p (Term.string_of_vname xi) - val key_of_type' = key_of_type o normalize_typvar_type' - - - fun normalize_typvar_term lt (Const (a, t)) = (lt, Const(a, t)) - | normalize_typvar_term lt (Free (a, t)) = let - val (lt, vname) = obtain_normalized_vname lt a - in - (lt, Free(vname,t)) - end - | normalize_typvar_term lt (Var (xi, t)) = - let - val (lt, vname) = obtain_normalized_vname lt (Term.string_of_vname xi) - in - (lt, Free(vname,t)) - end - | normalize_typvar_term lt (Bound (i)) = (lt, Bound(i)) - | normalize_typvar_term lt (Abs(s,ty,tr)) = - let - val (lt,tr) = normalize_typvar_term lt tr - in - (lt, Abs(s,ty,tr)) - end - | normalize_typvar_term lt (t1$t2) = - let - val (lt,t1) = normalize_typvar_term lt t1 - val (lt,t2) = normalize_typvar_term lt t2 - in - (lt, t1$t2) - end - - - fun normalize_typvar_term' t = snd(normalize_typvar_term [] t) - - fun key_of_term (Const(s,_)) = if String.isPrefix "\<^type>" s - then Lexicon.unmark_type s - else "" - | key_of_term (Free(s,_)) = s - | key_of_term (Var(xi,_)) = Term.string_of_vname xi - | key_of_term (Bound(_)) = error("Bound() not supported in key_of_term") - | key_of_term (Abs(_,_,_)) = error("Abs() not supported in key_of_term") - | key_of_term (t1$t2) = (key_of_term t1)^(key_of_term t2) - - val key_of_term' = key_of_term o normalize_typvar_term' - - - fun hide_tvar_tr' tname ctx terms = - let - - val mtyp = Syntax.parse_typ ctx tname (* no type checking *) - - val (fq_name, _) = case mtyp of - Type(s,ts) => (s,ts) - | _ => error("Complex type not (yet) supported.") - - val local_name_of = hd o rev o String.fields (fn c => c = #".") - - fun hide_type tname = Syntax.const("(_) "^tname) - - val reg_type_as_term = Term.list_comb(Const(Lexicon.mark_type tname,dummyT),terms) - val key = key_of_term' reg_type_as_term - val actual_tvars_key = key_of_term reg_type_as_term - - in - case lookup (Proof_Context.theory_of ctx) fq_name of - NONE => raise Match - | SOME e => let - val (tname,default_tvars_key) = - case Symtab.lookup (#typ_syn_tab e) key of - NONE => (local_name_of tname, "") - | SOME (s,_,tv) => (local_name_of s,tv) - in - case (#print_mode e) of - print_all => hide_type tname - | print => if default_tvars_key=actual_tvars_key - then hide_type tname - else raise Match - | noprint => raise Match - end - end - - fun hide_tvar_ast_tr ctx ast= - let - val thy = Proof_Context.theory_of ctx - - fun parse_ast ((Ast.Constant const)::[]) = (const,NONE) - | parse_ast ((Ast.Constant sort)::(Ast.Constant const)::[]) - = (const,SOME sort) - | parse_ast _ = error("AST type not supported.") - - val (decorated_name, decorated_sort) = parse_ast ast - - val name = Lexicon.unmark_type decorated_name - val default_info = case lookup thy name of - NONE => error("No default type vars registered: "^name) - | SOME e => e - val _ = if #parse_mode default_info = noparse - then error("Default type vars disabled (option noparse): "^name) - else () - fun name_of_tvar tvar = case tvar of (TFree(n,_)) => n - | _ => error("Unsupported type structure.") - val type_vars_ast = - let fun mk_tvar n = - case decorated_sort of - NONE => Ast.Variable(name_of_tvar n) - | SOME sort => Ast.Appl([Ast.Constant("_ofsort"), - Ast.Variable(name_of_tvar n), - Ast.Constant(sort)]) - in - map mk_tvar (#tvars default_info) - end - in - Ast.Appl ((Ast.Constant decorated_name)::type_vars_ast) - end - - fun register typ_str print_mode parse_mode thy = - let - val ctx = Toplevel.context_of(Toplevel.theory_toplevel thy) - val typ = Syntax.parse_typ ctx typ_str - val (name,tvars) = case typ of Type(name,tvars) => (name,tvars) - | _ => error("Unsupported type structure.") - - val base_typ = Syntax.read_typ ctx typ_str - val (base_name,base_tvars) = case base_typ of Type(name,tvars) => (name,tvars) - | _ => error("Unsupported type structure.") - - val base_key = key_of_type' base_typ - val base_tvar_key = key_of_type base_typ - - val print_m = case print_mode of - SOME m => m - | NONE => print_all - val parse_m = case parse_mode of - SOME m => m - | NONE => parse - val entry = { - name = name, - tvars = tvars, - typ_syn_tab = Symtab.empty:((string * typ list * string) Symtab.table), - print_mode = print_m, - parse_mode = parse_m - } - - val base_entry = if name = base_name - then - { - name = "", - tvars = [], - typ_syn_tab = Symtab.empty:((string * typ list * string) Symtab.table), - print_mode = noprint, - parse_mode = noparse - } - else case lookup thy base_name of - SOME e => e - | NONE => error ("No entry found for "^base_name^ - " (via "^name^")") - - val base_entry = { - name = #name base_entry, - tvars = #tvars base_entry, - typ_syn_tab = Symtab.update (base_key, (name, base_tvars, base_tvar_key)) - (#typ_syn_tab (base_entry)), - print_mode = #print_mode base_entry, - parse_mode = #parse_mode base_entry - } - - fun reg tab = let - val tab = Symtab.update_new(name, entry) tab - val tab = if name = base_name - then tab - else Symtab.update(base_name, base_entry) tab - in - tab - end - - val thy = Sign.print_translation - [(Lexicon.mark_type name, hide_tvar_tr' name)] thy - - in - Context.theory_of ( (Data.map reg) (Context.Theory thy)) - handle Symtab.DUP _ => error("Type shorthand already registered: "^name) - end - - fun hide_tvar_subst_ast_tr hole ctx (ast::[]) = - let - - val thy = Proof_Context.theory_of ctx - val (decorated_name, args) = case ast - of (Ast.Appl ((Ast.Constant s)::args)) => (s, args) - | _ => error "Error in obtaining type constructor." - - val name = Lexicon.unmark_type decorated_name - val default_info = case lookup thy name of - NONE => error("No default type vars registered: "^name) - | SOME e => e - val _ = if #parse_mode default_info = noparse - then error("Default type vars disabled (option noparse): "^name) - else () - fun name_of_tvar tvar = case tvar of (TFree(n,_)) => n - | _ => error("Unsupported type structure.") - val type_vars_ast = map (fn n => Ast.Variable(name_of_tvar n)) (#tvars default_info) - val type_vars_ast = case hole of - right => (List.rev(List.drop(List.rev type_vars_ast, List.length args)))@args - | left => args@List.drop(type_vars_ast, List.length args) - in - Ast.Appl ((Ast.Constant decorated_name)::type_vars_ast) - end - | hide_tvar_subst_ast_tr _ _ _ = error("hide_tvar_subst_ast_tr: empty AST.") - - fun hide_tvar_subst_return_ast_tr hole ctx (retval::constructor::[]) = - hide_tvar_subst_ast_tr hole ctx [Ast.Appl (constructor::retval::[])] - | hide_tvar_subst_return_ast_tr _ _ _ = - error("hide_tvar_subst_return_ast_tr: error in parsing AST") - - -end -\ - - - -subsection\Register Parse Translations\ -syntax "_tvars_wildcard" :: "type \ type" ("'('_') _") -syntax "_tvars_wildcard_retval" :: "type \ type \ type" ("'('_, _') _") -syntax "_tvars_wildcard_sort" :: "sort \ type \ type" ("'('_::_') _") -syntax "_tvars_wildcard_right" :: "type \ type" ("_ '_..") -syntax "_tvars_wildcard_left" :: "type \ type" ("_ ..'_") - -parse_ast_translation\ - [ - (@{syntax_const "_tvars_wildcard_sort"}, Hide_Tvar.hide_tvar_ast_tr), - (@{syntax_const "_tvars_wildcard"}, Hide_Tvar.hide_tvar_ast_tr), - (@{syntax_const "_tvars_wildcard_retval"}, Hide_Tvar.hide_tvar_subst_return_ast_tr Hide_Tvar.right), - (@{syntax_const "_tvars_wildcard_right"}, Hide_Tvar.hide_tvar_subst_ast_tr Hide_Tvar.right), - (@{syntax_const "_tvars_wildcard_left"}, Hide_Tvar.hide_tvar_subst_ast_tr Hide_Tvar.left) - ] -\ - -subsection\Register Top-Level Isar Commands\ -ML\ - val modeP = (Parse.$$$ "(" - |-- (Parse.name --| Parse.$$$ "," - -- Parse.name --| - Parse.$$$ ")")) - val typ_modeP = Parse.typ -- (Scan.optional modeP ("print_all","parse")) - - val _ = Outer_Syntax.command @{command_keyword "register_default_tvars"} - "Register default variables (and hiding mechanims) for a type." - (typ_modeP >> (fn (typ,(print_m,parse_m)) => - (Toplevel.theory - (Hide_Tvar.register typ - (SOME (Hide_Tvar.parse_print_mode print_m)) - (SOME (Hide_Tvar.parse_parse_mode parse_m)))))); - - val _ = Outer_Syntax.command @{command_keyword "update_default_tvars_mode"} - "Update print and/or parse mode or the default type variables for a certain type." - (typ_modeP >> (fn (typ,(print_m,parse_m)) => - (Toplevel.theory - (Hide_Tvar.update_mode typ - (SOME (Hide_Tvar.parse_print_mode print_m)) - (SOME (Hide_Tvar.parse_parse_mode parse_m)))))); -\ -(* -section\Examples\ -subsection\Print Translation\ -datatype ('a, 'b) hide_tvar_foobar = hide_tvar_foo 'a | hide_tvar_bar 'b -type_synonym ('a, 'b, 'c, 'd) hide_tvar_baz = "('a+'b, 'a \ 'b) hide_tvar_foobar" - -definition hide_tvar_f::"('a, 'b) hide_tvar_foobar \ ('a, 'b) hide_tvar_foobar \ ('a, 'b) hide_tvar_foobar" - where "hide_tvar_f a b = a" -definition hide_tvar_g::"('a, 'b, 'c, 'd) hide_tvar_baz \ ('a, 'b, 'c, 'd) hide_tvar_baz \ ('a, 'b, 'c, 'd) hide_tvar_baz" - where "hide_tvar_g a b = a" - -assert[string_of_thm_equal, - thm_def="hide_tvar_f_def", - str="hide_tvar_f (a::('a, 'b) hide_tvar_foobar) (b::('a, 'b) hide_tvar_foobar) = a"] -assert[string_of_thm_equal, - thm_def="hide_tvar_g_def", - str="hide_tvar_g (a::('a + 'b, 'a \ 'b) hide_tvar_foobar) (b::('a + 'b, 'a \ 'b) hide_tvar_foobar) = a"] - -register_default_tvars "('alpha, 'beta) hide_tvar_foobar" (print_all,parse) -register_default_tvars "('alpha, 'beta, 'gamma, 'delta) hide_tvar_baz" (print_all,parse) - -update_default_tvars_mode "_ hide_tvar_foobar" (noprint,noparse) -assert[string_of_thm_equal, - thm_def="hide_tvar_f_def", - str="hide_tvar_f (a::('a, 'b) hide_tvar_foobar) (b::('a, 'b) hide_tvar_foobar) = a"] -assert[string_of_thm_equal, - thm_def="hide_tvar_g_def", - str="hide_tvar_g (a::('a + 'b, 'a \ 'b) hide_tvar_foobar) (b::('a + 'b, 'a \ 'b) hide_tvar_foobar) = a"] - -update_default_tvars_mode "_ hide_tvar_foobar" (print_all,noparse) - -assert[string_of_thm_equal, - thm_def="hide_tvar_f_def", str="hide_tvar_f (a::(_) hide_tvar_foobar) (b::(_) hide_tvar_foobar) = a"] -assert[string_of_thm_equal, - thm_def="hide_tvar_g_def", str="hide_tvar_g (a::(_) hide_tvar_baz) (b::(_) hide_tvar_baz) = a"] - -subsection\Parse Translation\ -update_default_tvars_mode "_ hide_tvar_foobar" (print_all,parse) - -declare [[show_types]] -definition hide_tvar_A :: "'x \ (('x::linorder) hide_tvar_foobar) .._" - where "hide_tvar_A x = hide_tvar_foo x" -assert[string_of_thm_equal, - thm_def="hide_tvar_A_def", str="hide_tvar_A (x::'x) = hide_tvar_foo x"] - -definition hide_tvar_A' :: "'x \ (('x,'b) hide_tvar_foobar) .._" - where "hide_tvar_A' x = hide_tvar_foo x" -assert[string_of_thm_equal, - thm_def="hide_tvar_A'_def", str="hide_tvar_A' (x::'x) = hide_tvar_foo x"] - -definition hide_tvar_B' :: "(_) hide_tvar_foobar \ (_) hide_tvar_foobar \ (_) hide_tvar_foobar" - where "hide_tvar_B' x y = x" -assert[string_of_thm_equal, - thm_def="hide_tvar_A'_def", str="hide_tvar_A' (x::'x) = hide_tvar_foo x"] - - -definition hide_tvar_B :: "(_) hide_tvar_foobar \ (_) hide_tvar_foobar \ (_) hide_tvar_foobar" - where "hide_tvar_B x y = x" -assert[string_of_thm_equal, - thm_def="hide_tvar_B_def", str="hide_tvar_B (x::(_) hide_tvar_foobar) (y::(_) hide_tvar_foobar) = x"] - -definition hide_tvar_C :: "(_) hide_tvar_baz \ (_) hide_tvar_foobar \ (_) hide_tvar_baz" - where "hide_tvar_C x y = x" -assert[string_of_thm_equal, - thm_def="hide_tvar_C_def", str="hide_tvar_C (x::(_) hide_tvar_baz) (y::(_) hide_tvar_foobar) = x"] - -definition hide_tvar_E :: "(_::linorder) hide_tvar_baz \ (_::linorder) hide_tvar_foobar \ (_::linorder) hide_tvar_baz" - where "hide_tvar_E x y = x" -assert[string_of_thm_equal, - thm_def="hide_tvar_C_def", str="hide_tvar_C (x::(_) hide_tvar_baz) (y::(_) hide_tvar_foobar) = x"] - -definition hide_tvar_X :: "(_, 'retval::linorder) hide_tvar_baz - \ (_,'retval) hide_tvar_foobar - \ (_,'retval) hide_tvar_baz" - where "hide_tvar_X x y = x" -*) -(*>*) - -subsection\Introduction\ -text\ - When modelling object-oriented data models in HOL with the goal of preserving \<^emph>\extensibility\ - (e.g., as described in~\cite{brucker.ea:extensible:2008-b,brucker:interactive:2007}) one needs - to define type constructors with a large number of type variables. This can reduce the readability - of the overall formalization. Thus, we use a short-hand notation in cases were the names of - the type variables are known from the context. In more detail, this theory sets up both - configurable print and parse translations that allows for replacing @{emph \all\} type variables - by \(_)\, e.g., a five-ary constructor \('a, 'b, 'c, 'd, 'e) hide_tvar_foo\ can - be shorted to \(_) hide_tvar_foo\. The use of this shorthand in output (printing) and - input (parsing) is, on a per-type basis, user-configurable using the top-level commands - \register_default_tvars\ (for registering the names of the default type variables and - the print/parse mode) and \update_default_tvars_mode\ (for changing the print/parse mode - dynamically). - - The input also supports short-hands for declaring default sorts (e.g., \(_::linorder)\ - specifies that all default variables need to be instances of the sort (type class) - @{class \linorder\} and short-hands of overriding a suffice (or prefix) of the default type - variables. For example, \('state) hide_tvar_foo _.\ is a short-hand for - \('a, 'b, 'c, 'd, 'state) hide_tvar_foo\. In this document, we omit the implementation - details (we refer the interested reader to theory file) and continue directly with a few - examples. -\ - -subsection\Example\ -text\Given the following type definition:\ -datatype ('a, 'b) hide_tvar_foobar = hide_tvar_foo 'a | hide_tvar_bar 'b -type_synonym ('a, 'b, 'c, 'd) hide_tvar_baz = "('a+'b, 'a \ 'b) hide_tvar_foobar" -text\We can register default values for the type variables for the abstract -data type as well as the type synonym:\ -register_default_tvars "('alpha, 'beta) hide_tvar_foobar" (print_all,parse) -register_default_tvars "('alpha, 'beta, 'gamma, 'delta) hide_tvar_baz" (print_all,parse) -text\This allows us to write\ -definition hide_tvar_f::"(_) hide_tvar_foobar \ (_) hide_tvar_foobar \ (_) hide_tvar_foobar" - where "hide_tvar_f a b = a" -definition hide_tvar_g::"(_) hide_tvar_baz \ (_) hide_tvar_baz \ (_) hide_tvar_baz" - where "hide_tvar_g a b = a" - -text\Instead of specifying the type variables explicitely. This makes, in particular -for type constructors with a large number of type variables, definitions much -more concise. This syntax is also used in the output of antiquotations, e.g., -@{term[show_types] "x = hide_tvar_g"}. Both the print translation and the parse -translation can be disabled for each type individually:\ - -update_default_tvars_mode "_ hide_tvar_foobar" (noprint,noparse) -update_default_tvars_mode "_ hide_tvar_foobar" (noprint,noparse) - -text\ Now, Isabelle's interactive output and the antiquotations will show -all type variables, e.g., @{term[show_types] "x = hide_tvar_g"}.\ - - - -end diff --git a/Core_DOM/Core_SC_DOM/common/preliminaries/Hiding_Type_Variables.thy b/Core_DOM/Core_SC_DOM/common/preliminaries/Hiding_Type_Variables.thy new file mode 120000 index 0000000..f54beb3 --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/preliminaries/Hiding_Type_Variables.thy @@ -0,0 +1 @@ +../../../Core_DOM/common/preliminaries/Hiding_Type_Variables.thy \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/preliminaries/Testing_Utils.thy b/Core_DOM/Core_SC_DOM/common/preliminaries/Testing_Utils.thy deleted file mode 100644 index a8811e7..0000000 --- a/Core_DOM/Core_SC_DOM/common/preliminaries/Testing_Utils.thy +++ /dev/null @@ -1,92 +0,0 @@ -(*********************************************************************************** - * Copyright (c) 2016-2018 The University of Sheffield, UK - * - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * * Redistributions of source code must retain the above copyright notice, this - * list of conditions and the following disclaimer. - * - * * Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - * SPDX-License-Identifier: BSD-2-Clause - ***********************************************************************************) - -theory Testing_Utils - imports Main -begin -ML \ -val _ = Theory.setup - (Method.setup @{binding timed_code_simp} - (Scan.succeed (SIMPLE_METHOD' o (CHANGED_PROP oo (fn a => fn b => fn tac => - let - val start = Time.now (); - val result = Code_Simp.dynamic_tac a b tac; - val t = Time.now() - start; - in - (if length (Seq.list_of result) > 0 then Output.information ("Took " ^ (Time.toString t)) else ()); - result - end)))) - "timed simplification with code equations"); - -val _ = Theory.setup - (Method.setup @{binding timed_eval} - (Scan.succeed (SIMPLE_METHOD' o (fn a => fn b => fn tac => - let - val eval = CONVERSION (Conv.params_conv ~1 (K (Conv.concl_conv ~1 (Code_Runtime.dynamic_holds_conv a))) a) THEN' - resolve_tac a [TrueI]; - val start = Time.now (); - val result = eval b tac - val t = Time.now() - start; - in - (if length (Seq.list_of result) > 0 then Output.information ("Took " ^ (Time.toString t)) else ()); - result - end))) - "timed evaluation"); - -val _ = Theory.setup - (Method.setup @{binding timed_eval_and_code_simp} - (Scan.succeed (SIMPLE_METHOD' o (fn a => fn b => fn tac => - let - val eval = CONVERSION (Conv.params_conv ~1 (K (Conv.concl_conv ~1 (Code_Runtime.dynamic_holds_conv a))) a) THEN' - resolve_tac a [TrueI]; - val start = Time.now (); - val result = eval b tac - val t = Time.now() - start; - - val start2 = Time.now (); - val result2_opt = - Timeout.apply (seconds 600.0) (fn _ => SOME (Code_Simp.dynamic_tac a b tac)) () - handle Timeout.TIMEOUT _ => NONE; - val t2 = Time.now() - start2; - in - if length (Seq.list_of result) > 0 then (Output.information ("eval took " ^ (Time.toString t)); File.append (Path.explode "/tmp/isabellebench") (Time.toString t ^ ",")) else (); - (case result2_opt of - SOME result2 => - (if length (Seq.list_of result2) > 0 then (Output.information ("code_simp took " ^ (Time.toString t2)); File.append (Path.explode "/tmp/isabellebench") (Time.toString t2 ^ "\n")) else ()) - | NONE => (Output.information "code_simp timed out after 600s"; File.append (Path.explode "/tmp/isabellebench") (">600.000\n"))); - result - end))) - "timed evaluation and simplification with code equations with file output"); -\ - -(* To run the DOM test cases with timing information output, simply replace the use *) -(* of "eval" with either "timed_code_simp", "timed_eval", or, to run both and write the results *) -(* to /tmp/isabellebench, "timed_eval_and_code_simp". *) - -end diff --git a/Core_DOM/Core_SC_DOM/common/preliminaries/Testing_Utils.thy b/Core_DOM/Core_SC_DOM/common/preliminaries/Testing_Utils.thy new file mode 120000 index 0000000..283ab52 --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/preliminaries/Testing_Utils.thy @@ -0,0 +1 @@ +../../../Core_DOM/common/preliminaries/Testing_Utils.thy \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/tests/Core_DOM_BaseTest.thy b/Core_DOM/Core_SC_DOM/common/tests/Core_DOM_BaseTest.thy deleted file mode 100644 index 62f5703..0000000 --- a/Core_DOM/Core_SC_DOM/common/tests/Core_DOM_BaseTest.thy +++ /dev/null @@ -1,273 +0,0 @@ -(*********************************************************************************** - * Copyright (c) 2016-2018 The University of Sheffield, UK - * - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * * Redistributions of source code must retain the above copyright notice, this - * list of conditions and the following disclaimer. - * - * * Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - * SPDX-License-Identifier: BSD-2-Clause - ***********************************************************************************) - -section\Common Test Setup\ -text\This theory provides the common test setup that is used by all formalized test cases.\ - -theory Core_DOM_BaseTest - imports - (*<*) - "../preliminaries/Testing_Utils" - (*>*) - "../Core_DOM" -begin - -definition "assert_throws e p = do { - h \ get_heap; - (if (h \ p \\<^sub>e e) then return () else error AssertException) -}" -notation assert_throws ("assert'_throws'(_, _')") - -definition "test p h \ h \ ok p" - - -definition field_access :: "(string \ (_, (_) object_ptr option) dom_prog) \ string - \ (_, (_) object_ptr option) dom_prog" (infix "." 80) - where - "field_access m field = m field" - -definition assert_equals :: "'a \ 'a \ (_, unit) dom_prog" - where - "assert_equals l r = (if l = r then return () else error AssertException)" -definition assert_equals_with_message :: "'a \ 'a \ 'b \ (_, unit) dom_prog" - where - "assert_equals_with_message l r _ = (if l = r then return () else error AssertException)" -notation assert_equals ("assert'_equals'(_, _')") -notation assert_equals_with_message ("assert'_equals'(_, _, _')") -notation assert_equals ("assert'_array'_equals'(_, _')") -notation assert_equals_with_message ("assert'_array'_equals'(_, _, _')") - -definition assert_not_equals :: "'a \ 'a \ (_, unit) dom_prog" - where - "assert_not_equals l r = (if l \ r then return () else error AssertException)" -definition assert_not_equals_with_message :: "'a \ 'a \ 'b \ (_, unit) dom_prog" - where - "assert_not_equals_with_message l r _ = (if l \ r then return () else error AssertException)" -notation assert_not_equals ("assert'_not'_equals'(_, _')") -notation assert_not_equals_with_message ("assert'_not'_equals'(_, _, _')") -notation assert_not_equals ("assert'_array'_not'_equals'(_, _')") -notation assert_not_equals_with_message ("assert'_array'_not'_equals'(_, _, _')") - -definition removeWhiteSpaceOnlyTextNodes :: "((_) object_ptr option) \ (_, unit) dom_prog" - where - "removeWhiteSpaceOnlyTextNodes _ = return ()" - - -subsection \Making the functions under test compatible with untyped languages such as JavaScript\ - -fun set_attribute_with_null :: "((_) object_ptr option) \ attr_key \ attr_value \ (_, unit) dom_prog" - where - "set_attribute_with_null (Some ptr) k v = (case cast ptr of - Some element_ptr \ set_attribute element_ptr k (Some v))" -fun set_attribute_with_null2 :: "((_) object_ptr option) \ attr_key \ attr_value option \ (_, unit) dom_prog" - where - "set_attribute_with_null2 (Some ptr) k v = (case cast ptr of - Some element_ptr \ set_attribute element_ptr k v)" -notation set_attribute_with_null ("_ . setAttribute'(_, _')") -notation set_attribute_with_null2 ("_ . setAttribute'(_, _')") - -fun get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_with_null :: "((_) object_ptr option) \ (_, (_) object_ptr option list) dom_prog" - where - "get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_with_null (Some ptr) = do { - children \ get_child_nodes ptr; - return (map (Some \ cast) children) - }" -notation get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_with_null ("_ . childNodes") - -fun create_element_with_null :: "((_) object_ptr option) \ string \ (_, ((_) object_ptr option)) dom_prog" - where - "create_element_with_null (Some owner_document_obj) tag = (case cast owner_document_obj of - Some owner_document \ do { - element_ptr \ create_element owner_document tag; - return (Some (cast element_ptr))})" -notation create_element_with_null ("_ . createElement'(_')") - -fun create_character_data_with_null :: "((_) object_ptr option) \ string \ (_, ((_) object_ptr option)) dom_prog" - where - "create_character_data_with_null (Some owner_document_obj) tag = (case cast owner_document_obj of - Some owner_document \ do { - character_data_ptr \ create_character_data owner_document tag; - return (Some (cast character_data_ptr))})" -notation create_character_data_with_null ("_ . createTextNode'(_')") - -definition create_document_with_null :: "string \ (_, ((_::linorder) object_ptr option)) dom_prog" - where - "create_document_with_null title = do { - new_document_ptr \ create_document; - html \ create_element new_document_ptr ''html''; - append_child (cast new_document_ptr) (cast html); - heap \ create_element new_document_ptr ''heap''; - append_child (cast html) (cast heap); - body \ create_element new_document_ptr ''body''; - append_child (cast html) (cast body); - return (Some (cast new_document_ptr)) - }" -abbreviation "create_document_with_null2 _ _ _ \ create_document_with_null ''''" -notation create_document_with_null ("createDocument'(_')") -notation create_document_with_null2 ("createDocument'(_, _, _')") - -fun get_element_by_id_with_null :: "((_::linorder) object_ptr option) \ string \ (_, ((_) object_ptr option)) dom_prog" - where - "get_element_by_id_with_null (Some ptr) id' = do { - element_ptr_opt \ get_element_by_id ptr id'; - (case element_ptr_opt of - Some element_ptr \ return (Some (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r element_ptr)) - | None \ return None)}" - | "get_element_by_id_with_null _ _ = error SegmentationFault" -notation get_element_by_id_with_null ("_ . getElementById'(_')") - -fun get_elements_by_class_name_with_null :: "((_::linorder) object_ptr option) \ string \ (_, ((_) object_ptr option) list) dom_prog" - where - "get_elements_by_class_name_with_null (Some ptr) class_name = - get_elements_by_class_name ptr class_name \ map_M (return \ Some \ cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r)" -notation get_elements_by_class_name_with_null ("_ . getElementsByClassName'(_')") - -fun get_elements_by_tag_name_with_null :: "((_::linorder) object_ptr option) \ string \ (_, ((_) object_ptr option) list) dom_prog" - where - "get_elements_by_tag_name_with_null (Some ptr) tag_name = - get_elements_by_tag_name ptr tag_name \ map_M (return \ Some \ cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r)" -notation get_elements_by_tag_name_with_null ("_ . getElementsByTagName'(_')") - -fun insert_before_with_null :: "((_::linorder) object_ptr option) \ ((_) object_ptr option) \ ((_) object_ptr option) \ (_, ((_) object_ptr option)) dom_prog" - where - "insert_before_with_null (Some ptr) (Some child_obj) ref_child_obj_opt = (case cast child_obj of - Some child \ do { - (case ref_child_obj_opt of - Some ref_child_obj \ insert_before ptr child (cast ref_child_obj) - | None \ insert_before ptr child None); - return (Some child_obj)} - | None \ error HierarchyRequestError)" -notation insert_before_with_null ("_ . insertBefore'(_, _')") - -fun append_child_with_null :: "((_::linorder) object_ptr option) \ ((_) object_ptr option) \ (_, unit) dom_prog" - where - "append_child_with_null (Some ptr) (Some child_obj) = (case cast child_obj of - Some child \ append_child ptr child - | None \ error SegmentationFault)" -notation append_child_with_null ("_ . appendChild'(_')") - -fun get_body :: "((_::linorder) object_ptr option) \ (_, ((_) object_ptr option)) dom_prog" - where - "get_body ptr = do { - ptrs \ ptr . getElementsByTagName(''body''); - return (hd ptrs) - }" -notation get_body ("_ . body") - -fun get_document_element_with_null :: "((_::linorder) object_ptr option) \ (_, ((_) object_ptr option)) dom_prog" - where - "get_document_element_with_null (Some ptr) = (case cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr of - Some document_ptr \ do { - element_ptr_opt \ get_M document_ptr document_element; - return (case element_ptr_opt of - Some element_ptr \ Some (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r element_ptr) - | None \ None)})" -notation get_document_element_with_null ("_ . documentElement") - -fun get_owner_document_with_null :: "((_::linorder) object_ptr option) \ (_, ((_) object_ptr option)) dom_prog" - where - "get_owner_document_with_null (Some ptr) = (do { - document_ptr \ get_owner_document ptr; - return (Some (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr))})" -notation get_owner_document_with_null ("_ . ownerDocument") - -fun remove_with_null :: "((_::linorder) object_ptr option) \ ((_) object_ptr option) \ (_, ((_) object_ptr option)) dom_prog" - where - "remove_with_null (Some ptr) (Some child) = (case cast child of - Some child_node \ do { - remove child_node; - return (Some child)} - | None \ error NotFoundError)" - | "remove_with_null None _ = error TypeError" - | "remove_with_null _ None = error TypeError" -notation remove_with_null ("_ . remove'(')") - -fun remove_child_with_null :: "((_::linorder) object_ptr option) \ ((_) object_ptr option) \ (_, ((_) object_ptr option)) dom_prog" - where - "remove_child_with_null (Some ptr) (Some child) = (case cast child of - Some child_node \ do { - remove_child ptr child_node; - return (Some child)} - | None \ error NotFoundError)" - | "remove_child_with_null None _ = error TypeError" - | "remove_child_with_null _ None = error TypeError" -notation remove_child_with_null ("_ . removeChild") - -fun get_tag_name_with_null :: "((_) object_ptr option) \ (_, attr_value) dom_prog" - where - "get_tag_name_with_null (Some ptr) = (case cast ptr of - Some element_ptr \ get_M element_ptr tag_type)" -notation get_tag_name_with_null ("_ . tagName") - -abbreviation "remove_attribute_with_null ptr k \ set_attribute_with_null2 ptr k None" -notation remove_attribute_with_null ("_ . removeAttribute'(_')") - -fun get_attribute_with_null :: "((_) object_ptr option) \ attr_key \ (_, attr_value option) dom_prog" - where - "get_attribute_with_null (Some ptr) k = (case cast ptr of - Some element_ptr \ get_attribute element_ptr k)" -fun get_attribute_with_null2 :: "((_) object_ptr option) \ attr_key \ (_, attr_value) dom_prog" - where - "get_attribute_with_null2 (Some ptr) k = (case cast ptr of - Some element_ptr \ do { - a \ get_attribute element_ptr k; - return (the a)})" -notation get_attribute_with_null ("_ . getAttribute'(_')") -notation get_attribute_with_null2 ("_ . getAttribute'(_')") - -fun get_parent_with_null :: "((_::linorder) object_ptr option) \ (_, (_) object_ptr option) dom_prog" - where - "get_parent_with_null (Some ptr) = (case cast ptr of - Some node_ptr \ get_parent node_ptr)" -notation get_parent_with_null ("_ . parentNode") - -fun first_child_with_null :: "((_) object_ptr option) \ (_, ((_) object_ptr option)) dom_prog" - where - "first_child_with_null (Some ptr) = do { - child_opt \ first_child ptr; - return (case child_opt of - Some child \ Some (cast child) - | None \ None)}" -notation first_child_with_null ("_ . firstChild") - -fun adopt_node_with_null :: "((_::linorder) object_ptr option) \ ((_) object_ptr option) \ (_, ((_) object_ptr option)) dom_prog" - where - "adopt_node_with_null (Some ptr) (Some child) = (case cast ptr of - Some document_ptr \ (case cast child of - Some child_node \ do { - adopt_node document_ptr child_node; - return (Some child)}))" -notation adopt_node_with_null ("_ . adoptNode'(_')") - - -definition createTestTree :: "((_::linorder) object_ptr option) \ (_, (string \ (_, ((_) object_ptr option)) dom_prog)) dom_prog" - where - "createTestTree ref = return (\id. get_element_by_id_with_null ref id)" - -end diff --git a/Core_DOM/Core_SC_DOM/common/tests/Core_DOM_BaseTest.thy b/Core_DOM/Core_SC_DOM/common/tests/Core_DOM_BaseTest.thy new file mode 120000 index 0000000..4653aa2 --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/tests/Core_DOM_BaseTest.thy @@ -0,0 +1 @@ +../../../Core_DOM/common/tests/Core_DOM_BaseTest.thy \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/tests/Document-adoptNode.html b/Core_DOM/Core_SC_DOM/common/tests/Document-adoptNode.html deleted file mode 100644 index 75d4531..0000000 --- a/Core_DOM/Core_SC_DOM/common/tests/Document-adoptNode.html +++ /dev/null @@ -1,36 +0,0 @@ - - -Document.adoptNode - - - -
-x - diff --git a/Core_DOM/Core_SC_DOM/common/tests/Document-adoptNode.html b/Core_DOM/Core_SC_DOM/common/tests/Document-adoptNode.html new file mode 120000 index 0000000..a0c2b71 --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/tests/Document-adoptNode.html @@ -0,0 +1 @@ +../../../Core_DOM/common/tests/Document-adoptNode.html \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/tests/Document-adoptNode.html.orig b/Core_DOM/Core_SC_DOM/common/tests/Document-adoptNode.html.orig deleted file mode 100644 index 584d5d9..0000000 --- a/Core_DOM/Core_SC_DOM/common/tests/Document-adoptNode.html.orig +++ /dev/null @@ -1,50 +0,0 @@ - - -Document.adoptNode - - - -
-x - diff --git a/Core_DOM/Core_SC_DOM/common/tests/Document-adoptNode.html.orig b/Core_DOM/Core_SC_DOM/common/tests/Document-adoptNode.html.orig new file mode 120000 index 0000000..322f2d4 --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/tests/Document-adoptNode.html.orig @@ -0,0 +1 @@ +../../../Core_DOM/common/tests/Document-adoptNode.html.orig \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/tests/Document-getElementById.html b/Core_DOM/Core_SC_DOM/common/tests/Document-getElementById.html deleted file mode 100644 index d565ef0..0000000 --- a/Core_DOM/Core_SC_DOM/common/tests/Document-getElementById.html +++ /dev/null @@ -1,251 +0,0 @@ - - -Document.getElementById - - - - - -
- -
- -
- -
-

P

- -
- -
-
-
-
-
- - - - diff --git a/Core_DOM/Core_SC_DOM/common/tests/Document-getElementById.html b/Core_DOM/Core_SC_DOM/common/tests/Document-getElementById.html new file mode 120000 index 0000000..888680c --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/tests/Document-getElementById.html @@ -0,0 +1 @@ +../../../Core_DOM/common/tests/Document-getElementById.html \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/tests/Document-getElementById.html.orig b/Core_DOM/Core_SC_DOM/common/tests/Document-getElementById.html.orig deleted file mode 100644 index 1dec4c0..0000000 --- a/Core_DOM/Core_SC_DOM/common/tests/Document-getElementById.html.orig +++ /dev/null @@ -1,350 +0,0 @@ - - -Document.getElementById - - - - - -
- - -
- - -
- - -
-

P

- -
- - -
-
-
-
-
- - - - diff --git a/Core_DOM/Core_SC_DOM/common/tests/Document-getElementById.html.orig b/Core_DOM/Core_SC_DOM/common/tests/Document-getElementById.html.orig new file mode 120000 index 0000000..44489c3 --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/tests/Document-getElementById.html.orig @@ -0,0 +1 @@ +../../../Core_DOM/common/tests/Document-getElementById.html.orig \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/tests/Document_adoptNode.thy b/Core_DOM/Core_SC_DOM/common/tests/Document_adoptNode.thy deleted file mode 100644 index 652dccb..0000000 --- a/Core_DOM/Core_SC_DOM/common/tests/Document_adoptNode.thy +++ /dev/null @@ -1,113 +0,0 @@ -(*********************************************************************************** - * Copyright (c) 2016-2019 The University of Sheffield, UK - * - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * * Redistributions of source code must retain the above copyright notice, this - * list of conditions and the following disclaimer. - * - * * Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - * SPDX-License-Identifier: BSD-2-Clause - ***********************************************************************************) - -(* This file is automatically generated, please do not modify! *) - -section\Testing Document\_adoptNode\ -text\This theory contains the test cases for Document\_adoptNode.\ - -theory Document_adoptNode -imports - "Core_DOM_BaseTest" -begin - -definition Document_adoptNode_heap :: heap\<^sub>f\<^sub>i\<^sub>n\<^sub>a\<^sub>l where - "Document_adoptNode_heap = create_heap [(cast (document_ptr.Ref 1), cast (create_document_obj html (Some (cast (element_ptr.Ref 1))) [])), - (cast (element_ptr.Ref 1), cast (create_element_obj ''html'' [cast (element_ptr.Ref 2), cast (element_ptr.Ref 8)] fmempty None)), - (cast (element_ptr.Ref 2), cast (create_element_obj ''head'' [cast (element_ptr.Ref 3), cast (element_ptr.Ref 4), cast (element_ptr.Ref 5), cast (element_ptr.Ref 6), cast (element_ptr.Ref 7)] fmempty None)), - (cast (element_ptr.Ref 3), cast (create_element_obj ''meta'' [] (fmap_of_list [(''charset'', ''utf-8'')]) None)), - (cast (element_ptr.Ref 4), cast (create_element_obj ''title'' [cast (character_data_ptr.Ref 1)] fmempty None)), - (cast (character_data_ptr.Ref 1), cast (create_character_data_obj ''Document.adoptNode'')), - (cast (element_ptr.Ref 5), cast (create_element_obj ''link'' [] (fmap_of_list [(''rel'', ''help''), (''href'', ''https://dom.spec.whatwg.org/#dom-document-adoptnode'')]) None)), - (cast (element_ptr.Ref 6), cast (create_element_obj ''script'' [] (fmap_of_list [(''src'', ''/resources/testharness.js'')]) None)), - (cast (element_ptr.Ref 7), cast (create_element_obj ''script'' [] (fmap_of_list [(''src'', ''/resources/testharnessreport.js'')]) None)), - (cast (element_ptr.Ref 8), cast (create_element_obj ''body'' [cast (element_ptr.Ref 9), cast (element_ptr.Ref 10), cast (element_ptr.Ref 11)] fmempty None)), - (cast (element_ptr.Ref 9), cast (create_element_obj ''div'' [] (fmap_of_list [(''id'', ''log'')]) None)), - (cast (element_ptr.Ref 10), cast (create_element_obj ''x<'' [cast (character_data_ptr.Ref 2)] fmempty None)), - (cast (character_data_ptr.Ref 2), cast (create_character_data_obj ''x'')), - (cast (element_ptr.Ref 11), cast (create_element_obj ''script'' [cast (character_data_ptr.Ref 3)] fmempty None)), - (cast (character_data_ptr.Ref 3), cast (create_character_data_obj ''%3C%3Cscript%3E%3E''))]" - -definition Document_adoptNode_document :: "(unit, unit, unit, unit, unit, unit) object_ptr option" where "Document_adoptNode_document = Some (cast (document_ptr.Ref 1))" - - -text \"Adopting an Element called 'x<' should work."\ - -lemma "test (do { - tmp0 \ Document_adoptNode_document . getElementsByTagName(''x<''); - y \ return (tmp0 ! 0); - child \ y . firstChild; - tmp1 \ y . parentNode; - tmp2 \ Document_adoptNode_document . body; - assert_equals(tmp1, tmp2); - tmp3 \ y . ownerDocument; - assert_equals(tmp3, Document_adoptNode_document); - tmp4 \ Document_adoptNode_document . adoptNode(y); - assert_equals(tmp4, y); - tmp5 \ y . parentNode; - assert_equals(tmp5, None); - tmp6 \ y . firstChild; - assert_equals(tmp6, child); - tmp7 \ y . ownerDocument; - assert_equals(tmp7, Document_adoptNode_document); - tmp8 \ child . ownerDocument; - assert_equals(tmp8, Document_adoptNode_document); - doc \ createDocument(None, None, None); - tmp9 \ doc . adoptNode(y); - assert_equals(tmp9, y); - tmp10 \ y . parentNode; - assert_equals(tmp10, None); - tmp11 \ y . firstChild; - assert_equals(tmp11, child); - tmp12 \ y . ownerDocument; - assert_equals(tmp12, doc); - tmp13 \ child . ownerDocument; - assert_equals(tmp13, doc) -}) Document_adoptNode_heap" - by eval - - -text \"Adopting an Element called ':good:times:' should work."\ - -lemma "test (do { - x \ Document_adoptNode_document . createElement('':good:times:''); - tmp0 \ Document_adoptNode_document . adoptNode(x); - assert_equals(tmp0, x); - doc \ createDocument(None, None, None); - tmp1 \ doc . adoptNode(x); - assert_equals(tmp1, x); - tmp2 \ x . parentNode; - assert_equals(tmp2, None); - tmp3 \ x . ownerDocument; - assert_equals(tmp3, doc) -}) Document_adoptNode_heap" - by eval - - -end diff --git a/Core_DOM/Core_SC_DOM/common/tests/Document_adoptNode.thy b/Core_DOM/Core_SC_DOM/common/tests/Document_adoptNode.thy new file mode 120000 index 0000000..e075341 --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/tests/Document_adoptNode.thy @@ -0,0 +1 @@ +../../../Core_DOM/common/tests/Document_adoptNode.thy \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/tests/Document_getElementById.thy b/Core_DOM/Core_SC_DOM/common/tests/Document_getElementById.thy deleted file mode 100644 index 6c5b481..0000000 --- a/Core_DOM/Core_SC_DOM/common/tests/Document_getElementById.thy +++ /dev/null @@ -1,277 +0,0 @@ -(*********************************************************************************** - * Copyright (c) 2016-2019 The University of Sheffield, UK - * - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * * Redistributions of source code must retain the above copyright notice, this - * list of conditions and the following disclaimer. - * - * * Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - * SPDX-License-Identifier: BSD-2-Clause - ***********************************************************************************) - -(* This file is automatically generated, please do not modify! *) - -section\Testing Document\_getElementById\ -text\This theory contains the test cases for Document\_getElementById.\ - -theory Document_getElementById -imports - "Core_DOM_BaseTest" -begin - -definition Document_getElementById_heap :: heap\<^sub>f\<^sub>i\<^sub>n\<^sub>a\<^sub>l where - "Document_getElementById_heap = create_heap [(cast (document_ptr.Ref 1), cast (create_document_obj html (Some (cast (element_ptr.Ref 1))) [])), - (cast (element_ptr.Ref 1), cast (create_element_obj ''html'' [cast (element_ptr.Ref 2), cast (element_ptr.Ref 9)] fmempty None)), - (cast (element_ptr.Ref 2), cast (create_element_obj ''head'' [cast (element_ptr.Ref 3), cast (element_ptr.Ref 4), cast (element_ptr.Ref 5), cast (element_ptr.Ref 6), cast (element_ptr.Ref 7), cast (element_ptr.Ref 8)] fmempty None)), - (cast (element_ptr.Ref 3), cast (create_element_obj ''meta'' [] (fmap_of_list [(''charset'', ''utf-8'')]) None)), - (cast (element_ptr.Ref 4), cast (create_element_obj ''title'' [cast (character_data_ptr.Ref 1)] fmempty None)), - (cast (character_data_ptr.Ref 1), cast (create_character_data_obj ''Document.getElementById'')), - (cast (element_ptr.Ref 5), cast (create_element_obj ''link'' [] (fmap_of_list [(''rel'', ''author''), (''title'', ''Tetsuharu OHZEKI''), (''href'', ''mailto:saneyuki.snyk@gmail.com'')]) None)), - (cast (element_ptr.Ref 6), cast (create_element_obj ''link'' [] (fmap_of_list [(''rel'', ''help''), (''href'', ''https://dom.spec.whatwg.org/#dom-document-getelementbyid'')]) None)), - (cast (element_ptr.Ref 7), cast (create_element_obj ''script'' [] (fmap_of_list [(''src'', ''/resources/testharness.js'')]) None)), - (cast (element_ptr.Ref 8), cast (create_element_obj ''script'' [] (fmap_of_list [(''src'', ''/resources/testharnessreport.js'')]) None)), - (cast (element_ptr.Ref 9), cast (create_element_obj ''body'' [cast (element_ptr.Ref 10), cast (element_ptr.Ref 11), cast (element_ptr.Ref 12), cast (element_ptr.Ref 13), cast (element_ptr.Ref 16), cast (element_ptr.Ref 19)] fmempty None)), - (cast (element_ptr.Ref 10), cast (create_element_obj ''div'' [] (fmap_of_list [(''id'', ''log'')]) None)), - (cast (element_ptr.Ref 11), cast (create_element_obj ''div'' [] (fmap_of_list [(''id'', '''')]) None)), - (cast (element_ptr.Ref 12), cast (create_element_obj ''div'' [] (fmap_of_list [(''id'', ''test1'')]) None)), - (cast (element_ptr.Ref 13), cast (create_element_obj ''div'' [cast (element_ptr.Ref 14), cast (element_ptr.Ref 15)] (fmap_of_list [(''id'', ''test5''), (''data-name'', ''1st'')]) None)), - (cast (element_ptr.Ref 14), cast (create_element_obj ''p'' [cast (character_data_ptr.Ref 2)] (fmap_of_list [(''id'', ''test5''), (''data-name'', ''2nd'')]) None)), - (cast (character_data_ptr.Ref 2), cast (create_character_data_obj ''P'')), - (cast (element_ptr.Ref 15), cast (create_element_obj ''input'' [] (fmap_of_list [(''id'', ''test5''), (''type'', ''submit''), (''value'', ''Submit''), (''data-name'', ''3rd'')]) None)), - (cast (element_ptr.Ref 16), cast (create_element_obj ''div'' [cast (element_ptr.Ref 17)] (fmap_of_list [(''id'', ''outer'')]) None)), - (cast (element_ptr.Ref 17), cast (create_element_obj ''div'' [cast (element_ptr.Ref 18)] (fmap_of_list [(''id'', ''middle'')]) None)), - (cast (element_ptr.Ref 18), cast (create_element_obj ''div'' [] (fmap_of_list [(''id'', ''inner'')]) None)), - (cast (element_ptr.Ref 19), cast (create_element_obj ''script'' [cast (character_data_ptr.Ref 3)] fmempty None)), - (cast (character_data_ptr.Ref 3), cast (create_character_data_obj ''%3C%3Cscript%3E%3E''))]" - -definition Document_getElementById_document :: "(unit, unit, unit, unit, unit, unit) object_ptr option" where "Document_getElementById_document = Some (cast (document_ptr.Ref 1))" - - -text \"Document.getElementById with a script-inserted element"\ - -lemma "test (do { - gBody \ Document_getElementById_document . body; - TEST_ID \ return ''test2''; - test \ Document_getElementById_document . createElement(''div''); - test . setAttribute(''id'', TEST_ID); - gBody . appendChild(test); - result \ Document_getElementById_document . getElementById(TEST_ID); - assert_not_equals(result, None, ''should not be null.''); - tmp0 \ result . tagName; - assert_equals(tmp0, ''div'', ''should have appended element's tag name''); - gBody . removeChild(test); - removed \ Document_getElementById_document . getElementById(TEST_ID); - assert_equals(removed, None, ''should not get removed element.'') -}) Document_getElementById_heap" - by eval - - -text \"update `id` attribute via setAttribute/removeAttribute"\ - -lemma "test (do { - gBody \ Document_getElementById_document . body; - TEST_ID \ return ''test3''; - test \ Document_getElementById_document . createElement(''div''); - test . setAttribute(''id'', TEST_ID); - gBody . appendChild(test); - UPDATED_ID \ return ''test3-updated''; - test . setAttribute(''id'', UPDATED_ID); - e \ Document_getElementById_document . getElementById(UPDATED_ID); - assert_equals(e, test, ''should get the element with id.''); - old \ Document_getElementById_document . getElementById(TEST_ID); - assert_equals(old, None, ''shouldn't get the element by the old id.''); - test . removeAttribute(''id''); - e2 \ Document_getElementById_document . getElementById(UPDATED_ID); - assert_equals(e2, None, ''should return null when the passed id is none in document.'') -}) Document_getElementById_heap" - by eval - - -text \"Ensure that the id attribute only affects elements present in a document"\ - -lemma "test (do { - TEST_ID \ return ''test4-should-not-exist''; - e \ Document_getElementById_document . createElement(''div''); - e . setAttribute(''id'', TEST_ID); - tmp0 \ Document_getElementById_document . getElementById(TEST_ID); - assert_equals(tmp0, None, ''should be null''); - tmp1 \ Document_getElementById_document . body; - tmp1 . appendChild(e); - tmp2 \ Document_getElementById_document . getElementById(TEST_ID); - assert_equals(tmp2, e, ''should be the appended element'') -}) Document_getElementById_heap" - by eval - - -text \"in tree order, within the context object's tree"\ - -lemma "test (do { - gBody \ Document_getElementById_document . body; - TEST_ID \ return ''test5''; - target \ Document_getElementById_document . getElementById(TEST_ID); - assert_not_equals(target, None, ''should not be null''); - tmp0 \ target . getAttribute(''data-name''); - assert_equals(tmp0, ''1st'', ''should return the 1st''); - element4 \ Document_getElementById_document . createElement(''div''); - element4 . setAttribute(''id'', TEST_ID); - element4 . setAttribute(''data-name'', ''4th''); - gBody . appendChild(element4); - target2 \ Document_getElementById_document . getElementById(TEST_ID); - assert_not_equals(target2, None, ''should not be null''); - tmp1 \ target2 . getAttribute(''data-name''); - assert_equals(tmp1, ''1st'', ''should be the 1st''); - tmp2 \ target2 . parentNode; - tmp2 . removeChild(target2); - target3 \ Document_getElementById_document . getElementById(TEST_ID); - assert_not_equals(target3, None, ''should not be null''); - tmp3 \ target3 . getAttribute(''data-name''); - assert_equals(tmp3, ''4th'', ''should be the 4th'') -}) Document_getElementById_heap" - by eval - - -text \"Modern browsers optimize this method with using internal id cache. This test checks that their optimization should effect only append to `Document`, not append to `Node`."\ - -lemma "test (do { - TEST_ID \ return ''test6''; - s \ Document_getElementById_document . createElement(''div''); - s . setAttribute(''id'', TEST_ID); - tmp0 \ Document_getElementById_document . createElement(''div''); - tmp0 . appendChild(s); - tmp1 \ Document_getElementById_document . getElementById(TEST_ID); - assert_equals(tmp1, None, ''should be null'') -}) Document_getElementById_heap" - by eval - - -text \"changing attribute's value via `Attr` gotten from `Element.attribute`."\ - -lemma "test (do { - gBody \ Document_getElementById_document . body; - TEST_ID \ return ''test7''; - element \ Document_getElementById_document . createElement(''div''); - element . setAttribute(''id'', TEST_ID); - gBody . appendChild(element); - target \ Document_getElementById_document . getElementById(TEST_ID); - assert_equals(target, element, ''should return the element before changing the value''); - element . setAttribute(''id'', (TEST_ID @ ''-updated'')); - target2 \ Document_getElementById_document . getElementById(TEST_ID); - assert_equals(target2, None, ''should return null after updated id via Attr.value''); - target3 \ Document_getElementById_document . getElementById((TEST_ID @ ''-updated'')); - assert_equals(target3, element, ''should be equal to the updated element.'') -}) Document_getElementById_heap" - by eval - - -text \"update `id` attribute via element.id"\ - -lemma "test (do { - gBody \ Document_getElementById_document . body; - TEST_ID \ return ''test12''; - test \ Document_getElementById_document . createElement(''div''); - test . setAttribute(''id'', TEST_ID); - gBody . appendChild(test); - UPDATED_ID \ return (TEST_ID @ ''-updated''); - test . setAttribute(''id'', UPDATED_ID); - e \ Document_getElementById_document . getElementById(UPDATED_ID); - assert_equals(e, test, ''should get the element with id.''); - old \ Document_getElementById_document . getElementById(TEST_ID); - assert_equals(old, None, ''shouldn't get the element by the old id.''); - test . setAttribute(''id'', ''''); - e2 \ Document_getElementById_document . getElementById(UPDATED_ID); - assert_equals(e2, None, ''should return null when the passed id is none in document.'') -}) Document_getElementById_heap" - by eval - - -text \"where insertion order and tree order don't match"\ - -lemma "test (do { - gBody \ Document_getElementById_document . body; - TEST_ID \ return ''test13''; - container \ Document_getElementById_document . createElement(''div''); - container . setAttribute(''id'', (TEST_ID @ ''-fixture'')); - gBody . appendChild(container); - element1 \ Document_getElementById_document . createElement(''div''); - element1 . setAttribute(''id'', TEST_ID); - element2 \ Document_getElementById_document . createElement(''div''); - element2 . setAttribute(''id'', TEST_ID); - element3 \ Document_getElementById_document . createElement(''div''); - element3 . setAttribute(''id'', TEST_ID); - element4 \ Document_getElementById_document . createElement(''div''); - element4 . setAttribute(''id'', TEST_ID); - container . appendChild(element2); - container . appendChild(element4); - container . insertBefore(element3, element4); - container . insertBefore(element1, element2); - test \ Document_getElementById_document . getElementById(TEST_ID); - assert_equals(test, element1, ''should return 1st element''); - container . removeChild(element1); - test \ Document_getElementById_document . getElementById(TEST_ID); - assert_equals(test, element2, ''should return 2nd element''); - container . removeChild(element2); - test \ Document_getElementById_document . getElementById(TEST_ID); - assert_equals(test, element3, ''should return 3rd element''); - container . removeChild(element3); - test \ Document_getElementById_document . getElementById(TEST_ID); - assert_equals(test, element4, ''should return 4th element''); - container . removeChild(element4) -}) Document_getElementById_heap" - by eval - - -text \"Inserting an id by inserting its parent node"\ - -lemma "test (do { - gBody \ Document_getElementById_document . body; - TEST_ID \ return ''test14''; - a \ Document_getElementById_document . createElement(''a''); - b \ Document_getElementById_document . createElement(''b''); - a . appendChild(b); - b . setAttribute(''id'', TEST_ID); - tmp0 \ Document_getElementById_document . getElementById(TEST_ID); - assert_equals(tmp0, None); - gBody . appendChild(a); - tmp1 \ Document_getElementById_document . getElementById(TEST_ID); - assert_equals(tmp1, b) -}) Document_getElementById_heap" - by eval - - -text \"Document.getElementById must not return nodes not present in document"\ - -lemma "test (do { - TEST_ID \ return ''test15''; - outer \ Document_getElementById_document . getElementById(''outer''); - middle \ Document_getElementById_document . getElementById(''middle''); - inner \ Document_getElementById_document . getElementById(''inner''); - tmp0 \ Document_getElementById_document . getElementById(''middle''); - outer . removeChild(tmp0); - new_el \ Document_getElementById_document . createElement(''h1''); - new_el . setAttribute(''id'', ''heading''); - inner . appendChild(new_el); - tmp1 \ Document_getElementById_document . getElementById(''heading''); - assert_equals(tmp1, None) -}) Document_getElementById_heap" - by eval - - -end diff --git a/Core_DOM/Core_SC_DOM/common/tests/Document_getElementById.thy b/Core_DOM/Core_SC_DOM/common/tests/Document_getElementById.thy new file mode 120000 index 0000000..9fcde09 --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/tests/Document_getElementById.thy @@ -0,0 +1 @@ +../../../Core_DOM/common/tests/Document_getElementById.thy \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/tests/Node-insertBefore.html b/Core_DOM/Core_SC_DOM/common/tests/Node-insertBefore.html deleted file mode 100644 index db2675b..0000000 --- a/Core_DOM/Core_SC_DOM/common/tests/Node-insertBefore.html +++ /dev/null @@ -1,288 +0,0 @@ - -Node.insertBefore - - - -
- - diff --git a/Core_DOM/Core_SC_DOM/common/tests/Node-insertBefore.html b/Core_DOM/Core_SC_DOM/common/tests/Node-insertBefore.html new file mode 120000 index 0000000..76efc47 --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/tests/Node-insertBefore.html @@ -0,0 +1 @@ +../../../Core_DOM/common/tests/Node-insertBefore.html \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/tests/Node-insertBefore.html.orig b/Core_DOM/Core_SC_DOM/common/tests/Node-insertBefore.html.orig deleted file mode 100644 index a9fc83b..0000000 --- a/Core_DOM/Core_SC_DOM/common/tests/Node-insertBefore.html.orig +++ /dev/null @@ -1,306 +0,0 @@ - -Node.insertBefore - - -
- diff --git a/Core_DOM/Core_SC_DOM/common/tests/Node-insertBefore.html.orig b/Core_DOM/Core_SC_DOM/common/tests/Node-insertBefore.html.orig new file mode 120000 index 0000000..db008de --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/tests/Node-insertBefore.html.orig @@ -0,0 +1 @@ +../../../Core_DOM/common/tests/Node-insertBefore.html.orig \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/tests/Node-removeChild.html b/Core_DOM/Core_SC_DOM/common/tests/Node-removeChild.html deleted file mode 100644 index 83c4c3d..0000000 --- a/Core_DOM/Core_SC_DOM/common/tests/Node-removeChild.html +++ /dev/null @@ -1,66 +0,0 @@ - -Node.removeChild - - - - -
- - - diff --git a/Core_DOM/Core_SC_DOM/common/tests/Node-removeChild.html b/Core_DOM/Core_SC_DOM/common/tests/Node-removeChild.html new file mode 120000 index 0000000..d7e22a4 --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/tests/Node-removeChild.html @@ -0,0 +1 @@ +../../../Core_DOM/common/tests/Node-removeChild.html \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/tests/Node-removeChild.html.orig b/Core_DOM/Core_SC_DOM/common/tests/Node-removeChild.html.orig deleted file mode 100644 index fb22583..0000000 --- a/Core_DOM/Core_SC_DOM/common/tests/Node-removeChild.html.orig +++ /dev/null @@ -1,54 +0,0 @@ - -Node.removeChild - - - -
- - diff --git a/Core_DOM/Core_SC_DOM/common/tests/Node-removeChild.html.orig b/Core_DOM/Core_SC_DOM/common/tests/Node-removeChild.html.orig new file mode 120000 index 0000000..15a20f8 --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/tests/Node-removeChild.html.orig @@ -0,0 +1 @@ +../../../Core_DOM/common/tests/Node-removeChild.html.orig \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/tests/Node_insertBefore.thy b/Core_DOM/Core_SC_DOM/common/tests/Node_insertBefore.thy deleted file mode 100644 index 5ebf2a7..0000000 --- a/Core_DOM/Core_SC_DOM/common/tests/Node_insertBefore.thy +++ /dev/null @@ -1,128 +0,0 @@ -(*********************************************************************************** - * Copyright (c) 2016-2019 The University of Sheffield, UK - * - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * * Redistributions of source code must retain the above copyright notice, this - * list of conditions and the following disclaimer. - * - * * Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - * SPDX-License-Identifier: BSD-2-Clause - ***********************************************************************************) - -(* This file is automatically generated, please do not modify! *) - -section\Testing Node\_insertBefore\ -text\This theory contains the test cases for Node\_insertBefore.\ - -theory Node_insertBefore -imports - "Core_DOM_BaseTest" -begin - -definition Node_insertBefore_heap :: heap\<^sub>f\<^sub>i\<^sub>n\<^sub>a\<^sub>l where - "Node_insertBefore_heap = create_heap [(cast (document_ptr.Ref 1), cast (create_document_obj html (Some (cast (element_ptr.Ref 1))) [])), - (cast (element_ptr.Ref 1), cast (create_element_obj ''html'' [cast (element_ptr.Ref 2), cast (element_ptr.Ref 6)] fmempty None)), - (cast (element_ptr.Ref 2), cast (create_element_obj ''head'' [cast (element_ptr.Ref 3), cast (element_ptr.Ref 4), cast (element_ptr.Ref 5)] fmempty None)), - (cast (element_ptr.Ref 3), cast (create_element_obj ''title'' [cast (character_data_ptr.Ref 1)] fmempty None)), - (cast (character_data_ptr.Ref 1), cast (create_character_data_obj ''Node.insertBefore'')), - (cast (element_ptr.Ref 4), cast (create_element_obj ''script'' [] (fmap_of_list [(''src'', ''/resources/testharness.js'')]) None)), - (cast (element_ptr.Ref 5), cast (create_element_obj ''script'' [] (fmap_of_list [(''src'', ''/resources/testharnessreport.js'')]) None)), - (cast (element_ptr.Ref 6), cast (create_element_obj ''body'' [cast (element_ptr.Ref 7), cast (element_ptr.Ref 8)] fmempty None)), - (cast (element_ptr.Ref 7), cast (create_element_obj ''div'' [] (fmap_of_list [(''id'', ''log'')]) None)), - (cast (element_ptr.Ref 8), cast (create_element_obj ''script'' [cast (character_data_ptr.Ref 2)] fmempty None)), - (cast (character_data_ptr.Ref 2), cast (create_character_data_obj ''%3C%3Cscript%3E%3E''))]" - -definition Node_insertBefore_document :: "(unit, unit, unit, unit, unit, unit) object_ptr option" where "Node_insertBefore_document = Some (cast (document_ptr.Ref 1))" - - -text \"Calling insertBefore an a leaf node Text must throw HIERARCHY\_REQUEST\_ERR."\ - -lemma "test (do { - node \ Node_insertBefore_document . createTextNode(''Foo''); - tmp0 \ Node_insertBefore_document . createTextNode(''fail''); - assert_throws(HierarchyRequestError, node . insertBefore(tmp0, None)) -}) Node_insertBefore_heap" - by eval - - -text \"Calling insertBefore with an inclusive ancestor of the context object must throw HIERARCHY\_REQUEST\_ERR."\ - -lemma "test (do { - tmp1 \ Node_insertBefore_document . body; - tmp2 \ Node_insertBefore_document . getElementById(''log''); - tmp0 \ Node_insertBefore_document . body; - assert_throws(HierarchyRequestError, tmp0 . insertBefore(tmp1, tmp2)); - tmp4 \ Node_insertBefore_document . documentElement; - tmp5 \ Node_insertBefore_document . getElementById(''log''); - tmp3 \ Node_insertBefore_document . body; - assert_throws(HierarchyRequestError, tmp3 . insertBefore(tmp4, tmp5)) -}) Node_insertBefore_heap" - by eval - - -text \"Calling insertBefore with a reference child whose parent is not the context node must throw a NotFoundError."\ - -lemma "test (do { - a \ Node_insertBefore_document . createElement(''div''); - b \ Node_insertBefore_document . createElement(''div''); - c \ Node_insertBefore_document . createElement(''div''); - assert_throws(NotFoundError, a . insertBefore(b, c)) -}) Node_insertBefore_heap" - by eval - - -text \"If the context node is a document, inserting a document or text node should throw a HierarchyRequestError."\ - -lemma "test (do { - doc \ createDocument(''title''); - doc2 \ createDocument(''title2''); - tmp0 \ doc . documentElement; - assert_throws(HierarchyRequestError, doc . insertBefore(doc2, tmp0)); - tmp1 \ doc . createTextNode(''text''); - tmp2 \ doc . documentElement; - assert_throws(HierarchyRequestError, doc . insertBefore(tmp1, tmp2)) -}) Node_insertBefore_heap" - by eval - - -text \"Inserting a node before itself should not move the node"\ - -lemma "test (do { - a \ Node_insertBefore_document . createElement(''div''); - b \ Node_insertBefore_document . createElement(''div''); - c \ Node_insertBefore_document . createElement(''div''); - a . appendChild(b); - a . appendChild(c); - tmp0 \ a . childNodes; - assert_array_equals(tmp0, [b, c]); - tmp1 \ a . insertBefore(b, b); - assert_equals(tmp1, b); - tmp2 \ a . childNodes; - assert_array_equals(tmp2, [b, c]); - tmp3 \ a . insertBefore(c, c); - assert_equals(tmp3, c); - tmp4 \ a . childNodes; - assert_array_equals(tmp4, [b, c]) -}) Node_insertBefore_heap" - by eval - - -end diff --git a/Core_DOM/Core_SC_DOM/common/tests/Node_insertBefore.thy b/Core_DOM/Core_SC_DOM/common/tests/Node_insertBefore.thy new file mode 120000 index 0000000..9c2d302 --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/tests/Node_insertBefore.thy @@ -0,0 +1 @@ +../../../Core_DOM/common/tests/Node_insertBefore.thy \ No newline at end of file diff --git a/Core_DOM/Core_SC_DOM/common/tests/Node_removeChild.thy b/Core_DOM/Core_SC_DOM/common/tests/Node_removeChild.thy deleted file mode 100644 index 497db8e..0000000 --- a/Core_DOM/Core_SC_DOM/common/tests/Node_removeChild.thy +++ /dev/null @@ -1,159 +0,0 @@ -(*********************************************************************************** - * Copyright (c) 2016-2019 The University of Sheffield, UK - * - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * * Redistributions of source code must retain the above copyright notice, this - * list of conditions and the following disclaimer. - * - * * Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE - * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR - * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER - * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, - * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE - * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - * - * SPDX-License-Identifier: BSD-2-Clause - ***********************************************************************************) - -(* This file is automatically generated, please do not modify! *) - -section\Testing Node\_removeChild\ -text\This theory contains the test cases for Node\_removeChild.\ - -theory Node_removeChild -imports - "Core_DOM_BaseTest" -begin - -definition Node_removeChild_heap :: heap\<^sub>f\<^sub>i\<^sub>n\<^sub>a\<^sub>l where - "Node_removeChild_heap = create_heap [(cast (document_ptr.Ref 1), cast (create_document_obj html (Some (cast (element_ptr.Ref 1))) [])), - (cast (element_ptr.Ref 1), cast (create_element_obj ''html'' [cast (element_ptr.Ref 2), cast (element_ptr.Ref 7)] fmempty None)), - (cast (element_ptr.Ref 2), cast (create_element_obj ''head'' [cast (element_ptr.Ref 3), cast (element_ptr.Ref 4), cast (element_ptr.Ref 5), cast (element_ptr.Ref 6)] fmempty None)), - (cast (element_ptr.Ref 3), cast (create_element_obj ''title'' [cast (character_data_ptr.Ref 1)] fmempty None)), - (cast (character_data_ptr.Ref 1), cast (create_character_data_obj ''Node.removeChild'')), - (cast (element_ptr.Ref 4), cast (create_element_obj ''script'' [] (fmap_of_list [(''src'', ''/resources/testharness.js'')]) None)), - (cast (element_ptr.Ref 5), cast (create_element_obj ''script'' [] (fmap_of_list [(''src'', ''/resources/testharnessreport.js'')]) None)), - (cast (element_ptr.Ref 6), cast (create_element_obj ''script'' [] (fmap_of_list [(''src'', ''creators.js'')]) None)), - (cast (element_ptr.Ref 7), cast (create_element_obj ''body'' [cast (element_ptr.Ref 8), cast (element_ptr.Ref 9), cast (element_ptr.Ref 10)] fmempty None)), - (cast (element_ptr.Ref 8), cast (create_element_obj ''div'' [] (fmap_of_list [(''id'', ''log'')]) None)), - (cast (element_ptr.Ref 9), cast (create_element_obj ''iframe'' [] (fmap_of_list [(''src'', ''about:blank'')]) None)), - (cast (element_ptr.Ref 10), cast (create_element_obj ''script'' [cast (character_data_ptr.Ref 2)] fmempty None)), - (cast (character_data_ptr.Ref 2), cast (create_character_data_obj ''%3C%3Cscript%3E%3E''))]" - -definition Node_removeChild_document :: "(unit, unit, unit, unit, unit, unit) object_ptr option" where "Node_removeChild_document = Some (cast (document_ptr.Ref 1))" - - -text \"Passing a detached Element to removeChild should not affect it."\ - -lemma "test (do { - doc \ return Node_removeChild_document; - s \ doc . createElement(''div''); - tmp0 \ s . ownerDocument; - assert_equals(tmp0, doc); - tmp1 \ Node_removeChild_document . body; - assert_throws(NotFoundError, tmp1 . removeChild(s)); - tmp2 \ s . ownerDocument; - assert_equals(tmp2, doc) -}) Node_removeChild_heap" - by eval - - -text \"Passing a non-detached Element to removeChild should not affect it."\ - -lemma "test (do { - doc \ return Node_removeChild_document; - s \ doc . createElement(''div''); - tmp0 \ doc . documentElement; - tmp0 . appendChild(s); - tmp1 \ s . ownerDocument; - assert_equals(tmp1, doc); - tmp2 \ Node_removeChild_document . body; - assert_throws(NotFoundError, tmp2 . removeChild(s)); - tmp3 \ s . ownerDocument; - assert_equals(tmp3, doc) -}) Node_removeChild_heap" - by eval - - -text \"Calling removeChild on an Element with no children should throw NOT\_FOUND\_ERR."\ - -lemma "test (do { - doc \ return Node_removeChild_document; - s \ doc . createElement(''div''); - tmp0 \ doc . body; - tmp0 . appendChild(s); - tmp1 \ s . ownerDocument; - assert_equals(tmp1, doc); - assert_throws(NotFoundError, s . removeChild(doc)) -}) Node_removeChild_heap" - by eval - - -text \"Passing a detached Element to removeChild should not affect it."\ - -lemma "test (do { - doc \ createDocument(''''); - s \ doc . createElement(''div''); - tmp0 \ s . ownerDocument; - assert_equals(tmp0, doc); - tmp1 \ Node_removeChild_document . body; - assert_throws(NotFoundError, tmp1 . removeChild(s)); - tmp2 \ s . ownerDocument; - assert_equals(tmp2, doc) -}) Node_removeChild_heap" - by eval - - -text \"Passing a non-detached Element to removeChild should not affect it."\ - -lemma "test (do { - doc \ createDocument(''''); - s \ doc . createElement(''div''); - tmp0 \ doc . documentElement; - tmp0 . appendChild(s); - tmp1 \ s . ownerDocument; - assert_equals(tmp1, doc); - tmp2 \ Node_removeChild_document . body; - assert_throws(NotFoundError, tmp2 . removeChild(s)); - tmp3 \ s . ownerDocument; - assert_equals(tmp3, doc) -}) Node_removeChild_heap" - by eval - - -text \"Calling removeChild on an Element with no children should throw NOT\_FOUND\_ERR."\ - -lemma "test (do { - doc \ createDocument(''''); - s \ doc . createElement(''div''); - tmp0 \ doc . body; - tmp0 . appendChild(s); - tmp1 \ s . ownerDocument; - assert_equals(tmp1, doc); - assert_throws(NotFoundError, s . removeChild(doc)) -}) Node_removeChild_heap" - by eval - - -text \"Passing a value that is not a Node reference to removeChild should throw TypeError."\ - -lemma "test (do { - tmp0 \ Node_removeChild_document . body; - assert_throws(TypeError, tmp0 . removeChild(None)) -}) Node_removeChild_heap" - by eval - - -end diff --git a/Core_DOM/Core_SC_DOM/common/tests/Node_removeChild.thy b/Core_DOM/Core_SC_DOM/common/tests/Node_removeChild.thy new file mode 120000 index 0000000..69be776 --- /dev/null +++ b/Core_DOM/Core_SC_DOM/common/tests/Node_removeChild.thy @@ -0,0 +1 @@ +../../../Core_DOM/common/tests/Node_removeChild.thy \ No newline at end of file