From 2f6199408db49748ce54e74b078ccab0ef5243cb Mon Sep 17 00:00:00 2001 From: Gerwin Klein Date: Sun, 18 Feb 2024 14:46:20 +1100 Subject: [PATCH] c-parser: update Simpl from AFP; update license Pull in Simpl update from AFP-2023 and the associated license change to BSD-3-Clause. Signed-off-by: Gerwin Klein --- .reuse/dep5 | 2 +- tools/c-parser/Simpl/AlternativeSmallStep.thy | 21 - tools/c-parser/Simpl/COPYRIGHT | 423 ------- tools/c-parser/Simpl/DPC0Expressions.thy | 3 +- tools/c-parser/Simpl/DPC0Library.thy | 3 +- tools/c-parser/Simpl/Generalise.thy | 23 +- tools/c-parser/Simpl/HeapList.thy | 23 +- tools/c-parser/Simpl/Hoare.thy | 23 +- tools/c-parser/Simpl/HoarePartial.thy | 416 +++++-- tools/c-parser/Simpl/HoarePartialDef.thy | 23 +- tools/c-parser/Simpl/HoarePartialProps.thy | 725 +++++++----- tools/c-parser/Simpl/HoareTotal.thy | 403 +++++-- tools/c-parser/Simpl/HoareTotalDef.thy | 23 +- tools/c-parser/Simpl/HoareTotalProps.thy | 856 ++++++++------ tools/c-parser/Simpl/Language.thy | 174 ++- tools/c-parser/Simpl/Semantic.thy | 759 +++++++++++-- tools/c-parser/Simpl/Simpl.thy | 23 +- tools/c-parser/Simpl/Simpl_Heap.thy | 23 +- tools/c-parser/Simpl/SmallStep.thy | 21 - tools/c-parser/Simpl/StateSpace.thy | 38 +- tools/c-parser/Simpl/SyntaxTest.thy | 22 +- tools/c-parser/Simpl/Termination.thy | 141 ++- tools/c-parser/Simpl/UserGuide.thy | 35 +- tools/c-parser/Simpl/Vcg.thy | 51 +- tools/c-parser/Simpl/XVcg.thy | 21 - tools/c-parser/Simpl/ex/Closure.thy | 21 - tools/c-parser/Simpl/ex/ClosureEx.thy | 28 +- tools/c-parser/Simpl/ex/Compose.thy | 25 +- tools/c-parser/Simpl/ex/ComposeEx.thy | 21 - tools/c-parser/Simpl/ex/ProcParEx.thy | 21 - tools/c-parser/Simpl/ex/ProcParExSP.thy | 23 +- tools/c-parser/Simpl/ex/Quicksort.thy | 23 +- tools/c-parser/Simpl/ex/VcgEx.thy | 23 +- tools/c-parser/Simpl/ex/VcgExSP.thy | 23 +- tools/c-parser/Simpl/ex/VcgExTotal.thy | 50 +- tools/c-parser/Simpl/ex/XVcgEx.thy | 21 - tools/c-parser/Simpl/generalise_state.ML | 81 +- tools/c-parser/Simpl/hoare.ML | 1012 ++++++++++------- tools/c-parser/Simpl/hoare_syntax.ML | 576 ++++++---- 39 files changed, 3501 insertions(+), 2722 deletions(-) delete mode 100644 tools/c-parser/Simpl/COPYRIGHT diff --git a/.reuse/dep5 b/.reuse/dep5 index b08bbf633..5db68fae1 100644 --- a/.reuse/dep5 +++ b/.reuse/dep5 @@ -6,7 +6,7 @@ Source: https://github.com/seL4/l4v/ # AFP entry https://www.isa-afp.org/entries/Simpl.html Files: tools/c-parser/Simpl/* Copyright: 2008, Norbert Schirmer, TU Muenchen -License: LGPL-2.1-only +License: BSD-3-Clause # AFP entry Word_Lib Files: lib/Word_Lib/Word_Next.thy diff --git a/tools/c-parser/Simpl/AlternativeSmallStep.thy b/tools/c-parser/Simpl/AlternativeSmallStep.thy index c06998995..f3181a49e 100644 --- a/tools/c-parser/Simpl/AlternativeSmallStep.thy +++ b/tools/c-parser/Simpl/AlternativeSmallStep.thy @@ -1,29 +1,8 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL -*) - -(* Title: AlternativeSmallStep.thy - Author: Norbert Schirmer, TU Muenchen Copyright (C) 2006-2008 Norbert Schirmer -Some rights reserved, TU Muenchen - -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA *) section \Alternative Small Step Semantics\ diff --git a/tools/c-parser/Simpl/COPYRIGHT b/tools/c-parser/Simpl/COPYRIGHT deleted file mode 100644 index af7215f52..000000000 --- a/tools/c-parser/Simpl/COPYRIGHT +++ /dev/null @@ -1,423 +0,0 @@ -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - - - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - - - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA - - -TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION - - - -0. This License Agreement applies to any software library or other -program which contains a notice placed by the copyright holder or -other authorized party saying it may be distributed under the terms of -this Lesser General Public License (also called "this License"). Each -licensee is addressed as "you". - - - -A "library" means a collection of software functions and/or data -prepared so as to be conveniently linked with application programs -(which use some of those functions and data) to form executables. - - -The "Library", below, refers to any such software library or work -which has been distributed under these terms. A "work based on the -Library" means either the Library or any derivative work under -copyright law: that is to say, a work containing the Library or a -portion of it, either verbatim or with modifications and/or translated -straightforwardly into another language. (Hereinafter, translation is -included without limitation in the term "modification".) - - -"Source code" for a work means the preferred form of the work for -making modifications to it. For a library, complete source code means -all the source code for all modules it contains, plus any associated -interface definition files, plus the scripts used to control -compilation and installation of the library. - - - -Activities other than copying, distribution and modification are not -covered by this License; they are outside its scope. The act of -running a program using the Library is not restricted, and output from -such a program is covered only if its contents constitute a work based -on the Library (independent of the use of the Library in a tool for -writing it). Whether that is true depends on what the Library does and -what the program that uses the Library does. - - -1. You may copy and distribute verbatim copies of the Library's -complete source code as you receive it, in any medium, provided that -you conspicuously and appropriately publish on each copy an -appropriate copyright notice and disclaimer of warranty; keep intact -all the notices that refer to this License and to the absence of any -warranty; and distribute a copy of this License along with the -Library. - - -You may charge a fee for the physical act of transferring a copy, and -you may at your option offer warranty protection in exchange for a -fee. - - -2. You may modify your copy or copies of the Library or any portion of -it, thus forming a work based on the Library, and copy and distribute -such modifications or work under the terms of Section 1 above, -provided that you also meet all of these conditions: - - -a) The modified work must itself be a software library. - - -b) You must cause the files modified to carry prominent notices -stating that you changed the files and the date of any change. - - - -c) You must cause the whole of the work to be licensed at no charge to -all third parties under the terms of this License. - - -d) If a facility in the modified Library refers to a function or a -table of data to be supplied by an application program that uses the -facility, other than as an argument passed when the facility is -invoked, then you must make a good faith effort to ensure that, in the -event an application does not supply such function or table, the -facility still operates, and performs whatever part of its purpose -remains meaningful. - - -(For example, a function in a library to compute square roots has a -purpose that is entirely well-defined independent of the -application. Therefore, Subsection 2d requires that any -application-supplied function or table used by this function must be -optional: if the application does not supply it, the square root -function must still compute square roots.) - - -These requirements apply to the modified work as a whole. If -identifiable sections of that work are not derived from the Library, -and can be reasonably considered independent and separate works in -themselves, then this License, and its terms, do not apply to those -sections when you distribute them as separate works. But when you -distribute the same sections as part of a whole which is a work based -on the Library, the distribution of the whole must be on the terms of -this License, whose permissions for other licensees extend to the -entire whole, and thus to each and every part regardless of who wrote -it. - - -Thus, it is not the intent of this section to claim rights or contest -your rights to work written entirely by you; rather, the intent is to -exercise the right to control the distribution of derivative or -collective works based on the Library. - - -In addition, mere aggregation of another work not based on the Library -with the Library (or with a work based on the Library) on a volume of -a storage or distribution medium does not bring the other work under -the scope of this License. - - -3. You may opt to apply the terms of the ordinary GNU General Public -License instead of this License to a given copy of the Library. To do -this, you must alter all the notices that refer to this License, so -that they refer to the ordinary GNU General Public License, version 2, -instead of to this License. (If a newer version than version 2 of the -ordinary GNU General Public License has appeared, then you can specify -that version instead if you wish.) Do not make any other change in -these notices. - - -Once this change is made in a given copy, it is irreversible for that -copy, so the ordinary GNU General Public License applies to all -subsequent copies and derivative works made from that copy. - - -This option is useful when you wish to copy part of the code of the -Library into a program that is not a library. - - -4. You may copy and distribute the Library (or a portion or derivative -of it, under Section 2) in object code or executable form under the -terms of Sections 1 and 2 above provided that you accompany it with -the complete corresponding machine-readable source code, which must be -distributed under the terms of Sections 1 and 2 above on a medium -customarily used for software interchange. - - -If distribution of object code is made by offering access to copy from -a designated place, then offering equivalent access to copy the source -code from the same place satisfies the requirement to distribute the -source code, even though third parties are not compelled to copy the -source along with the object code. - - - -5. A program that contains no derivative of any portion of the -Library, but is designed to work with the Library by being compiled or -linked with it, is called a "work that uses the Library". Such a work, -in isolation, is not a derivative work of the Library, and therefore -falls outside the scope of this License. - - -However, linking a "work that uses the Library" with the Library -creates an executable that is a derivative of the Library (because it -contains portions of the Library), rather than a "work that uses the -library". The executable is therefore covered by this License. Section -6 states terms for distribution of such executables. - - -When a "work that uses the Library" uses material from a header file -that is part of the Library, the object code for the work may be a -derivative work of the Library even though the source code is -not. Whether this is true is especially significant if the work can be -linked without the Library, or if the work is itself a library. The -threshold for this to be true is not precisely defined by law. - - -If such an object file uses only numerical parameters, data structure -layouts and accessors, and small macros and small inline functions -(ten lines or less in length), then the use of the object file is -unrestricted, regardless of whether it is legally a derivative -work. (Executables containing this object code plus portions of the -Library will still fall under Section 6.) - - -Otherwise, if the work is a derivative of the Library, you may -distribute the object code for the work under the terms of Section -6. Any executables containing that work also fall under Section 6, -whether or not they are linked directly with the Library itself. - - -6. As an exception to the Sections above, you may also combine or link -a "work that uses the Library" with the Library to produce a work -containing portions of the Library, and distribute that work under -terms of your choice, provided that the terms permit modification of -the work for the customer's own use and reverse engineering for -debugging such modifications. - - -You must give prominent notice with each copy of the work that the -Library is used in it and that the Library and its use are covered by -this License. You must supply a copy of this License. If the work -during execution displays copyright notices, you must include the -copyright notice for the Library among them, as well as a reference -directing the user to the copy of this License. Also, you must do one -of these things: - - -a) Accompany the work with the complete corresponding machine-readable -source code for the Library including whatever changes were used in -the work (which must be distributed under Sections 1 and 2 above); -and, if the work is an executable linked with the Library, with the -complete machine-readable "work that uses the Library", as object code -and/or source code, so that the user can modify the Library and then -relink to produce a modified executable containing the modified -Library. (It is understood that the user who changes the contents of -definitions files in the Library will not necessarily be able to -recompile the application to use the modified definitions.) - - -b) Use a suitable shared library mechanism for linking with the -Library. A suitable mechanism is one that (1) uses at run time a copy -of the library already present on the user's computer system, rather -than copying library functions into the executable, and (2) will -operate properly with a modified version of the library, if the user -installs one, as long as the modified version is interface-compatible -with the version that the work was made with. - - -c) Accompany the work with a written offer, valid for at least three -years, to give the same user the materials specified in Subsection 6a, -above, for a charge no more than the cost of performing this -distribution. - - -d) If distribution of the work is made by offering access to copy from -a designated place, offer equivalent access to copy the above -specified materials from the same place. - - -e) Verify that the user has already received a copy of these materials -or that you have already sent this user a copy. - - - -For an executable, the required form of the "work that uses the -Library" must include any data and utility programs needed for -reproducing the executable from it. However, as a special exception, -the materials to be distributed need not include anything that is -normally distributed (in either source or binary form) with the major -components (compiler, kernel, and so on) of the operating system on -which the executable runs, unless that component itself accompanies -the executable. - - -It may happen that this requirement contradicts the license -restrictions of other proprietary libraries that do not normally -accompany the operating system. Such a contradiction means you cannot -use both them and the Library together in an executable that you -distribute. - - -7. You may place library facilities that are a work based on the -Library side-by-side in a single library together with other library -facilities not covered by this License, and distribute such a combined -library, provided that the separate distribution of the work based on -the Library and of the other library facilities is otherwise -permitted, and provided that you do these two things: - - -a) Accompany the combined library with a copy of the same work based -on the Library, uncombined with any other library facilities. This -must be distributed under the terms of the Sections above. - - -b) Give prominent notice with the combined library of the fact that -part of it is a work based on the Library, and explaining where to -find the accompanying uncombined form of the same work. - - - -8. You may not copy, modify, sublicense, link with, or distribute the -Library except as expressly provided under this License. Any attempt -otherwise to copy, modify, sublicense, link with, or distribute the -Library is void, and will automatically terminate your rights under -this License. However, parties who have received copies, or rights, -from you under this License will not have their licenses terminated so -long as such parties remain in full compliance. - - -9. You are not required to accept this License, since you have not -signed it. However, nothing else grants you permission to modify or -distribute the Library or its derivative works. These actions are -prohibited by law if you do not accept this License. Therefore, by -modifying or distributing the Library (or any work based on the -Library), you indicate your acceptance of this License to do so, and -all its terms and conditions for copying, distributing or modifying -the Library or works based on it. - - -10. Each time you redistribute the Library (or any work based on the -Library), the recipient automatically receives a license from the -original licensor to copy, distribute, link with or modify the Library -subject to these terms and conditions. You may not impose any further -restrictions on the recipients' exercise of the rights granted -herein. You are not responsible for enforcing compliance by third -parties with this License. - - -11. If, as a consequence of a court judgment or allegation of patent -infringement or for any other reason (not limited to patent issues), -conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot -distribute so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you -may not distribute the Library at all. For example, if a patent -license would not permit royalty-free redistribution of the Library by -all those who receive copies directly or indirectly through you, then -the only way you could satisfy both it and this License would be to -refrain entirely from distribution of the Library. - - -If any portion of this section is held invalid or unenforceable under -any particular circumstance, the balance of the section is intended to -apply, and the section as a whole is intended to apply in other -circumstances. - - -It is not the purpose of this section to induce you to infringe any -patents or other property right claims or to contest validity of any -such claims; this section has the sole purpose of protecting the -integrity of the free software distribution system which is -implemented by public license practices. Many people have made -generous contributions to the wide range of software distributed -through that system in reliance on consistent application of that -system; it is up to the author/donor to decide if he or she is willing -to distribute software through any other system and a licensee cannot -impose that choice. - - -This section is intended to make thoroughly clear what is believed to -be a consequence of the rest of this License. - - -12. If the distribution and/or use of the Library is restricted in -certain countries either by patents or by copyrighted interfaces, the -original copyright holder who places the Library under this License -may add an explicit geographical distribution limitation excluding -those countries, so that distribution is permitted only in or among -countries not thus excluded. In such case, this License incorporates -the limitation as if written in the body of this License. - - -13. The Free Software Foundation may publish revised and/or new -versions of the Lesser General Public License from time to time. Such -new versions will be similar in spirit to the present version, but may -differ in detail to address new problems or concerns. - - - -Each version is given a distinguishing version number. If the Library -specifies a version number of this License which applies to it and -"any later version", you have the option of following the terms and -conditions either of that version or of any later version published by -the Free Software Foundation. If the Library does not specify a -license version number, you may choose any version ever published by -the Free Software Foundation. - - -14. If you wish to incorporate parts of the Library into other free -programs whose distribution conditions are incompatible with these, -write to the author to ask for permission. For software which is -copyrighted by the Free Software Foundation, write to the Free -Software Foundation; we sometimes make exceptions for this. Our -decision will be guided by the two goals of preserving the free status -of all derivatives of our free software and of promoting the sharing -and reuse of software generally. - - -NO WARRANTY - - -15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO -WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE -LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS -AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF -ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, -THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE -LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME -THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. - - -16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN -WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY -AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU -FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR -CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE -LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING -RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A -FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF -SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH -DAMAGES. - - -END OF TERMS AND CONDITIONS \ No newline at end of file diff --git a/tools/c-parser/Simpl/DPC0Expressions.thy b/tools/c-parser/Simpl/DPC0Expressions.thy index a02d30f2b..fc5dc31a6 100644 --- a/tools/c-parser/Simpl/DPC0Expressions.thy +++ b/tools/c-parser/Simpl/DPC0Expressions.thy @@ -1,7 +1,8 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL + +Copyright (C) 2006-2008 Norbert Schirmer *) section \SHORTENED! Parallel expressions in DPC/Hoare.\ diff --git a/tools/c-parser/Simpl/DPC0Library.thy b/tools/c-parser/Simpl/DPC0Library.thy index 016f246c3..0d39d42ba 100644 --- a/tools/c-parser/Simpl/DPC0Library.thy +++ b/tools/c-parser/Simpl/DPC0Library.thy @@ -1,7 +1,8 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL + +Copyright (C) 2006-2008 Norbert Schirmer *) section \DPC0 standard library\ diff --git a/tools/c-parser/Simpl/Generalise.thy b/tools/c-parser/Simpl/Generalise.thy index 5fe88f1f2..eff941a5a 100644 --- a/tools/c-parser/Simpl/Generalise.thy +++ b/tools/c-parser/Simpl/Generalise.thy @@ -1,29 +1,8 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL -*) -(* Title: Generalise.thy - Author: Norbert Schirmer, TU Muenchen - -Copyright (C) 2005-2008 Norbert Schirmer -Some rights reserved, TU Muenchen - -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA +Copyright (C) 2006-2008 Norbert Schirmer *) theory Generalise imports "HOL-Statespace.DistinctTreeProver" diff --git a/tools/c-parser/Simpl/HeapList.thy b/tools/c-parser/Simpl/HeapList.thy index 7c65a1f10..5ca32c263 100644 --- a/tools/c-parser/Simpl/HeapList.thy +++ b/tools/c-parser/Simpl/HeapList.thy @@ -1,28 +1,7 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL -*) -(* Title: HeapList.thy - Author: Norbert Schirmer, TU Muenchen - -Copyright (C) 2004-2008 Norbert Schirmer -Some rights reserved, TU Muenchen - -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA +Copyright (C) 2006-2008 Norbert Schirmer *) section \Paths and Lists in the Heap\ diff --git a/tools/c-parser/Simpl/Hoare.thy b/tools/c-parser/Simpl/Hoare.thy index 7ebe753ca..a90b05f09 100644 --- a/tools/c-parser/Simpl/Hoare.thy +++ b/tools/c-parser/Simpl/Hoare.thy @@ -1,29 +1,8 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL -*) -(* Title: Hoare.thy - Author: Norbert Schirmer, TU Muenchen - -Copyright (C) 2004-2008 Norbert Schirmer -Some rights reserved, TU Muenchen - -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA +Copyright (C) 2006-2008 Norbert Schirmer *) section \Auxiliary Definitions/Lemmas to Facilitate Hoare Logic\ diff --git a/tools/c-parser/Simpl/HoarePartial.thy b/tools/c-parser/Simpl/HoarePartial.thy index 786d7e5ff..cfd15cd9f 100644 --- a/tools/c-parser/Simpl/HoarePartial.thy +++ b/tools/c-parser/Simpl/HoarePartial.thy @@ -1,29 +1,10 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL -*) - -(* Title: HoarePartial.thy - Author: Norbert Schirmer, TU Muenchen Copyright (C) 2004-2008 Norbert Schirmer -Some rights reserved, TU Muenchen +Copyright (c) 2022 Apple Inc. All rights reserved. -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA *) section \Derived Hoare Rules for Partial Correctness\ @@ -199,6 +180,11 @@ lemma Seq [trans, intro?]: "\\,\\\<^bsub>/F\<^esub> P c\<^sub>1 R,A; \,\\\<^bsub>/F\<^esub> R c\<^sub>2 Q,A\ \ \,\\\<^bsub>/F\<^esub> P (Seq c\<^sub>1 c\<^sub>2) Q,A" by (rule hoarep.Seq) +lemma SeqSame: + "\\,\\\<^bsub>/F\<^esub> P c\<^sub>1 Q,A; \,\\\<^bsub>/F\<^esub> Q c\<^sub>2 Q,A\ \ \,\\\<^bsub>/F\<^esub> P (Seq c\<^sub>1 c\<^sub>2) Q,A" + by (rule hoarep.Seq) + + lemma SeqSwap: "\\,\\\<^bsub>/F\<^esub> R c2 Q,A; \,\\\<^bsub>/F\<^esub> P c1 R,A\ \ \,\\\<^bsub>/F\<^esub> P (Seq c1 c2) Q,A" by (rule Seq) @@ -207,6 +193,9 @@ lemma BSeq: "\\,\\\<^bsub>/F\<^esub> P c\<^sub>1 R,A; \,\\\<^bsub>/F\<^esub> R c\<^sub>2 Q,A\ \ \,\\\<^bsub>/F\<^esub> P (bseq c\<^sub>1 c\<^sub>2) Q,A" by (unfold bseq_def) (rule Seq) +lemma BSeqSame: + "\\,\\\<^bsub>/F\<^esub> P c\<^sub>1 Q,A; \,\\\<^bsub>/F\<^esub> Q c\<^sub>2 Q,A\ \ \,\\\<^bsub>/F\<^esub> P (bseq c\<^sub>1 c\<^sub>2) Q,A" + by (rule BSeq) lemma Cond: assumes wp: "P \ {s. (s\b \ s\P\<^sub>1) \ (s\b \ s\P\<^sub>2)}" @@ -312,6 +301,11 @@ apply (rule Guarantee [THEN conseqPre]) apply auto done +lemma GuardStripSame: + "\\,\\\<^bsub>/F\<^esub> P c Q,A; f \ F\ + \ \,\\\<^bsub>/F\<^esub> P (Guard f g c) Q,A" + by (rule GuardStrip [OF subset_refl]) + lemma GuardStripSwap: "\\,\\\<^bsub>/F\<^esub> R c Q,A; P \ R; f \ F\ \ \,\\\<^bsub>/F\<^esub> P (Guard f g c) Q,A" @@ -452,18 +446,18 @@ using adapt apply blast done -lemma Block: +lemma Block_exn: assumes adapt: "P \ {s. init s \ P' s}" -assumes bdy: "\s. \,\\\<^bsub>/F\<^esub> (P' s) bdy {t. return s t \ R s t},{t. return s t \ A}" +assumes bdy: "\s. \,\\\<^bsub>/F\<^esub> (P' s) bdy {t. return s t \ R s t},{t. result_exn (return s t) t \ A}" assumes c: "\s t. \,\\\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" -shows "\,\\\<^bsub>/F\<^esub> P (block init bdy return c) Q,A" +shows "\,\\\<^bsub>/F\<^esub> P (block_exn init bdy return result_exn c) Q,A" apply (rule conseq [where P'="\Z. {s. s=Z \ init s \ P' Z}" and Q'="\Z. Q" and A'="\Z. A"]) prefer 2 using adapt apply blast apply (rule allI) -apply (unfold block_def) +apply (unfold block_exn_def) apply (rule DynCom) apply (rule ballI) apply clarsimp @@ -478,7 +472,7 @@ apply (rule SeqSwap) apply (rule c [rule_format]) apply (rule Basic) apply clarsimp -apply (rule_tac R="{t. return Z t \ A}" in Catch) +apply (rule_tac R="{t. result_exn (return Z t) t \ A}" in Catch) apply (rule_tac R="{i. i \ P' Z}" in Seq) apply (rule Basic) apply clarsimp @@ -490,6 +484,14 @@ apply (rule Basic) apply simp done +lemma Block: +assumes adapt: "P \ {s. init s \ P' s}" +assumes bdy: "\s. \,\\\<^bsub>/F\<^esub> (P' s) bdy {t. return s t \ R s t},{t. return s t \ A}" +assumes c: "\s t. \,\\\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" +shows "\,\\\<^bsub>/F\<^esub> P (block init bdy return c) Q,A" + unfolding block_def + by (rule Block_exn [OF adapt bdy c]) + lemma BlockSwap: assumes c: "\s t. \,\\\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" @@ -500,22 +502,22 @@ using adapt bdy c by (rule Block) -lemma BlockSpec: +lemma Block_exnSpec: assumes adapt: "P \ {s. \Z. init s \ P' Z \ (\t. t \ Q' Z \ return s t \ R s t) \ - (\t. t \ A' Z \ return s t \ A)}" + (\t. t \ A' Z \ (result_exn (return s t) t) \ A)}" assumes c: "\s t. \,\\\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" assumes bdy: "\Z. \,\\\<^bsub>/F\<^esub> (P' Z) bdy (Q' Z),(A' Z)" - shows "\,\\\<^bsub>/F\<^esub> P (block init bdy return c) Q,A" + shows "\,\\\<^bsub>/F\<^esub> P (block_exn init bdy return result_exn c) Q,A" apply (rule conseq [where P'="\Z. {s. init s \ P' Z \ (\t. t \ Q' Z \ return s t \ R s t) \ - (\t. t \ A' Z \ return s t \ A)}" and Q'="\Z. Q" and + (\t. t \ A' Z \ (result_exn (return s t) t) \ A)}" and Q'="\Z. Q" and A'="\Z. A"]) prefer 2 using adapt apply blast apply (rule allI) -apply (unfold block_def) +apply (unfold block_exn_def) apply (rule DynCom) apply (rule ballI) apply clarsimp @@ -530,7 +532,7 @@ apply (rule SeqSwap) apply (rule c [rule_format]) apply (rule Basic) apply clarsimp -apply (rule_tac R="{t. return s t \ A}" in Catch) +apply (rule_tac R="{t. (result_exn (return s t) t) \ A}" in Catch) apply (rule_tac R="{i. i \ P' Z}" in Seq) apply (rule Basic) apply clarsimp @@ -542,7 +544,18 @@ apply (rule SeqSwap) apply (rule Throw) apply (rule Basic) apply simp -done + done + +lemma BlockSpec: + assumes adapt: "P \ {s. \Z. init s \ P' Z \ + (\t. t \ Q' Z \ return s t \ R s t) \ + (\t. t \ A' Z \ return s t \ A)}" + assumes c: "\s t. \,\\\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" + assumes bdy: "\Z. \,\\\<^bsub>/F\<^esub> (P' Z) bdy (Q' Z),(A' Z)" + shows "\,\\\<^bsub>/F\<^esub> P (block init bdy return c) Q,A" + unfolding block_def + by (rule Block_exnSpec [OF adapt c bdy]) + lemma Throw: "P \ A \ \,\\\<^bsub>/F\<^esub> P Throw Q,A" by (rule hoarep.Throw [THEN conseqPre]) @@ -551,6 +564,9 @@ lemmas Catch = hoarep.Catch lemma CatchSwap: "\\,\\\<^bsub>/F\<^esub> R c\<^sub>2 Q,A; \,\\\<^bsub>/F\<^esub> P c\<^sub>1 Q,R\ \ \,\\\<^bsub>/F\<^esub> P Catch c\<^sub>1 c\<^sub>2 Q,A" by (rule hoarep.Catch) +lemma CatchSame: "\\,\\\<^bsub>/F\<^esub> P c\<^sub>1 Q,A; \,\\\<^bsub>/F\<^esub> A c\<^sub>2 Q,A\ \ \,\\\<^bsub>/F\<^esub> P Catch c\<^sub>1 c\<^sub>2 Q,A" + by (rule hoarep.Catch) + lemma raise: "P \ {s. f s \ A} \ \,\\\<^bsub>/F\<^esub> P raise f Q,A" apply (simp add: raise_def) apply (rule Seq) @@ -575,6 +591,18 @@ lemma condCatchSwap: "\\,\\\<^bsub>/F\<^esub> R \ \,\\\<^bsub>/F\<^esub>P condCatch c\<^sub>1 b c\<^sub>2 Q,A" by (rule condCatch) +lemma condCatchSame: + assumes c1: "\,\\\<^bsub>/F\<^esub> P c\<^sub>1 Q,A" + assumes c2: "\,\\\<^bsub>/F\<^esub> A c\<^sub>2 Q,A" + shows "\,\\\<^bsub>/F\<^esub>P condCatch c\<^sub>1 b c\<^sub>2 Q,A" +proof - + have eq: "((b \ A) \ (-b \ A)) = A" by blast + show ?thesis + apply (rule condCatch [OF _ c2]) + apply (simp add: eq) + apply (rule c1) + done +qed lemma ProcSpec: assumes adapt: "P \ {s. \Z. init s \ P' Z \ @@ -587,6 +615,17 @@ using adapt c p apply (unfold call_def) by (rule BlockSpec) +lemma Proc_exnSpec: + assumes adapt: "P \ {s. \Z. init s \ P' Z \ + (\t. t \ Q' Z \ return s t \ R s t) \ + (\t. t \ A' Z \ result_exn (return s t) t \ A)}" + assumes c: "\s t. \,\\\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" + assumes p: "\Z. \,\\\<^bsub>/F\<^esub> (P' Z) Call p (Q' Z),(A' Z)" + shows "\,\\\<^bsub>/F\<^esub> P (call_exn init p return result_exn c) Q,A" +using adapt c p +apply (unfold call_exn_def) + by (rule Block_exnSpec) + lemma ProcSpec': assumes adapt: "P \ {s. \Z. init s \ P' Z \ (\t \ Q' Z. return s t \ R s t) \ @@ -603,6 +642,17 @@ apply (rule_tac x=Z in exI) apply blast done +lemma Proc_exnSpecNoAbrupt: + assumes adapt: "P \ {s. \Z. init s \ P' Z \ + (\t. t \ Q' Z \ return s t \ R s t)}" + assumes c: "\s t. \,\\\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" + assumes p: "\Z. \,\\\<^bsub>/F\<^esub> (P' Z) Call p (Q' Z),{}" + shows "\,\\\<^bsub>/F\<^esub> P (call_exn init p return result_exn c) Q,A" +apply (rule Proc_exnSpec [OF _ c p]) +using adapt +apply simp + done + lemma ProcSpecNoAbrupt: assumes adapt: "P \ {s. \Z. init s \ P' Z \ (\t. t \ Q' Z \ return s t \ R s t)}" @@ -719,8 +769,32 @@ apply (rule ProcBody [where \=\, OF _ bdy [rule_format] body]) apply simp done +lemma Call_exnBody: +assumes adapt: "P \ {s. init s \ P' s}" +assumes bdy: "\s. \,\\\<^bsub>/F\<^esub> (P' s) body {t. return s t \ R s t},{t. result_exn (return s t) t \ A}" +assumes c: "\s t. \,\\\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" +assumes body: "\ p = Some body" +shows "\,\\\<^bsub>/F\<^esub> P (call_exn init p return result_exn c) Q,A" +apply (unfold call_exn_def) +apply (rule Block_exn [OF adapt _ c]) +apply (rule allI) +apply (rule ProcBody [where \=\, OF _ bdy [rule_format] body]) +apply simp +done + lemmas ProcModifyReturn = HoarePartialProps.ProcModifyReturn lemmas ProcModifyReturnSameFaults = HoarePartialProps.ProcModifyReturnSameFaults +lemmas Proc_exnModifyReturn = HoarePartialProps.Proc_exnModifyReturn +lemmas Proc_exnModifyReturnSameFaults = HoarePartialProps.Proc_exnModifyReturnSameFaults + +lemma Proc_exnModifyReturnNoAbr: + assumes spec: "\,\\\<^bsub>/F\<^esub> P (call_exn init p return' result_exn c) Q,A" + assumes result_conform: + "\s t. t \ Modif (init s) \ (return' s t) = (return s t)" + assumes modifies_spec: + "\\. \,\\\<^bsub>/UNIV\<^esub> {\} Call p (Modif \),{}" + shows "\,\\\<^bsub>/F\<^esub> P (call_exn init p return result_exn c) Q,A" + by (rule Proc_exnModifyReturn [OF spec result_conform _ modifies_spec]) simp lemma ProcModifyReturnNoAbr: assumes spec: "\,\\\<^bsub>/F\<^esub> P (call init p return' c) Q,A" @@ -731,6 +805,15 @@ lemma ProcModifyReturnNoAbr: shows "\,\\\<^bsub>/F\<^esub> P (call init p return c) Q,A" by (rule ProcModifyReturn [OF spec result_conform _ modifies_spec]) simp +lemma Proc_exnModifyReturnNoAbrSameFaults: + assumes spec: "\,\\\<^bsub>/F\<^esub> P (call_exn init p return' result_exn c) Q,A" + assumes result_conform: + "\s t. t \ Modif (init s) \ (return' s t) = (return s t)" + assumes modifies_spec: + "\\. \,\\\<^bsub>/F\<^esub> {\} Call p (Modif \),{}" + shows "\,\\\<^bsub>/F\<^esub> P (call_exn init p return result_exn c) Q,A" + by (rule Proc_exnModifyReturnSameFaults [OF spec result_conform _ modifies_spec]) simp + lemma ProcModifyReturnNoAbrSameFaults: assumes spec: "\,\\\<^bsub>/F\<^esub> P (call init p return' c) Q,A" assumes result_conform: @@ -740,21 +823,20 @@ lemma ProcModifyReturnNoAbrSameFaults: shows "\,\\\<^bsub>/F\<^esub> P (call init p return c) Q,A" by (rule ProcModifyReturnSameFaults [OF spec result_conform _ modifies_spec]) simp - -lemma DynProc: +lemma DynProc_exn: assumes adapt: "P \ {s. \Z. init s \ P' s Z \ (\t. t \ Q' s Z \ return s t \ R s t) \ - (\t. t \ A' s Z \ return s t \ A)}" + (\t. t \ A' s Z \ result_exn (return s t) t \ A)}" assumes c: "\s t. \,\\\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" assumes p: "\s\ P. \Z. \,\\\<^bsub>/F\<^esub> (P' s Z) Call (p s) (Q' s Z),(A' s Z)" - shows "\,\\\<^bsub>/F\<^esub> P dynCall init p return c Q,A" + shows "\,\\\<^bsub>/F\<^esub> P dynCall_exn f UNIV init p return result_exn c Q,A" apply (rule conseq [where P'="\Z. {s. s=Z \ s \ P}" and Q'="\Z. Q" and A'="\Z. A"]) prefer 2 using adapt apply blast apply (rule allI) -apply (unfold dynCall_def call_def block_def) +apply (unfold dynCall_exn_def call_exn_def maybe_guard_UNIV block_exn_def guards.simps) apply (rule DynCom) apply clarsimp apply (rule DynCom) @@ -788,7 +870,41 @@ apply (rule SeqSwap) apply (rule c [rule_format]) apply (rule Basic) apply clarsimp -done + done + +lemma DynProc_exn_guards_cons: + assumes p: "\,\\\<^bsub>/F\<^esub> P dynCall_exn f UNIV init p return result_exn c Q,A" + shows "\,\\\<^bsub>/F\<^esub> (g \ P) dynCall_exn f g init p return result_exn c Q,A" + using p apply (clarsimp simp add: dynCall_exn_def maybe_guard_def) + apply (rule Guard) + apply (rule subset_refl) + apply assumption + done + +lemma DynProc: + assumes adapt: "P \ {s. \Z. init s \ P' s Z \ + (\t. t \ Q' s Z \ return s t \ R s t) \ + (\t. t \ A' s Z \ return s t \ A)}" + assumes c: "\s t. \,\\\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" + assumes p: "\s\ P. \Z. \,\\\<^bsub>/F\<^esub> (P' s Z) Call (p s) (Q' s Z),(A' s Z)" + shows "\,\\\<^bsub>/F\<^esub> P dynCall init p return c Q,A" + using adapt c p unfolding dynCall_dynCall_exn by (rule DynProc_exn) + +lemma DynProc_exn': + assumes adapt: "P \ {s. \Z. init s \ P' s Z \ + (\t \ Q' s Z. return s t \ R s t) \ + (\t \ A' s Z. result_exn (return s t) t \ A)}" + assumes c: "\s t. \,\\\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" + assumes p: "\s\ P. \Z. \,\\\<^bsub>/F\<^esub> (P' s Z) Call (p s) (Q' s Z),(A' s Z)" + shows "\,\\\<^bsub>/F\<^esub> P dynCall_exn f UNIV init p return result_exn c Q,A" +proof - + from adapt have "P \ {s. \Z. init s \ P' s Z \ + (\t. t \ Q' s Z \ return s t \ R s t) \ + (\t. t \ A' s Z \ result_exn (return s t) t \ A)}" + by blast + from this c p show ?thesis + by (rule DynProc_exn) +qed lemma DynProc': assumes adapt: "P \ {s. \Z. init s \ P' s Z \ @@ -797,28 +913,20 @@ lemma DynProc': assumes c: "\s t. \,\\\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" assumes p: "\s\ P. \Z. \,\\\<^bsub>/F\<^esub> (P' s Z) Call (p s) (Q' s Z),(A' s Z)" shows "\,\\\<^bsub>/F\<^esub> P dynCall init p return c Q,A" -proof - - from adapt have "P \ {s. \Z. init s \ P' s Z \ - (\t. t \ Q' s Z \ return s t \ R s t) \ - (\t. t \ A' s Z \ return s t \ A)}" - by blast - from this c p show ?thesis - by (rule DynProc) -qed + using adapt c p unfolding dynCall_dynCall_exn by (rule DynProc_exn') - -lemma DynProcStaticSpec: +lemma DynProc_exnStaticSpec: assumes adapt: "P \ {s. s \ S \ (\Z. init s \ P' Z \ (\\. \ \ Q' Z \ return s \ \ R s \) \ - (\\. \ \ A' Z \ return s \ \ A))}" + (\\. \ \ A' Z \ result_exn (return s \) \ \ A))}" assumes c: "\s t. \,\\\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" assumes spec: "\s\S. \Z. \,\\\<^bsub>/F\<^esub> (P' Z) Call (p s) (Q' Z),(A' Z)" -shows "\,\\\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" +shows "\,\\\<^bsub>/F\<^esub> P (dynCall_exn f UNIV init p return result_exn c) Q,A" proof - from adapt have P_S: "P \ S" by blast - have "\,\\\<^bsub>/F\<^esub> (P \ S) (dynCall init p return c) Q,A" - apply (rule DynProc [where P'="\s Z. P' Z" and Q'="\s Z. Q' Z" + have "\,\\\<^bsub>/F\<^esub> (P \ S) (dynCall_exn f UNIV init p return result_exn c) Q,A" + apply (rule DynProc_exn [where P'="\s Z. P' Z" and Q'="\s Z. Q' Z" and A'="\s Z. A' Z", OF _ c]) apply clarsimp apply (frule in_mono [rule_format, OF adapt]) @@ -830,6 +938,26 @@ proof - by (rule conseqPre) (insert P_S,blast) qed +lemma DynProcStaticSpec: +assumes adapt: "P \ {s. s \ S \ (\Z. init s \ P' Z \ + (\\. \ \ Q' Z \ return s \ \ R s \) \ + (\\. \ \ A' Z \ return s \ \ A))}" +assumes c: "\s t. \,\\\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" +assumes spec: "\s\S. \Z. \,\\\<^bsub>/F\<^esub> (P' Z) Call (p s) (Q' Z),(A' Z)" +shows "\,\\\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" + using adapt c spec unfolding dynCall_dynCall_exn by (rule DynProc_exnStaticSpec) + +lemma DynProc_exnProcPar: +assumes adapt: "P \ {s. p s = q \ (\Z. init s \ P' Z \ + (\\. \ \ Q' Z \ return s \ \ R s \) \ + (\\. \ \ A' Z \ result_exn (return s \) \ \ A))}" +assumes c: "\s t. \,\\\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" +assumes spec: "\Z. \,\\\<^bsub>/F\<^esub> (P' Z) Call q (Q' Z),(A' Z)" +shows "\,\\\<^bsub>/F\<^esub> P (dynCall_exn f UNIV init p return result_exn c) Q,A" + apply (rule DynProc_exnStaticSpec [where S="{s. p s = q}",simplified, OF adapt c]) + using spec + apply simp + done lemma DynProcProcPar: assumes adapt: "P \ {s. p s = q \ (\Z. init s \ P' Z \ @@ -843,17 +971,16 @@ shows "\,\\\<^bsub>/F\<^esub> P (dynCall init p return apply simp done - -lemma DynProcProcParNoAbrupt: +lemma DynProc_exnProcParNoAbrupt: assumes adapt: "P \ {s. p s = q \ (\Z. init s \ P' Z \ (\\. \ \ Q' Z \ return s \ \ R s \))}" assumes c: "\s t. \,\\\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" assumes spec: "\Z. \,\\\<^bsub>/F\<^esub> (P' Z) Call q (Q' Z),{}" -shows "\,\\\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" +shows "\,\\\<^bsub>/F\<^esub> P (dynCall_exn f UNIV init p return result_exn c) Q,A" proof - have "P \ {s. p s = q \ (\ Z. init s \ P' Z \ (\t. t \ Q' Z \ return s t \ R s t) \ - (\t. t \ {} \ return s t \ A))}" + (\t. t \ {} \ result_exn (return s t) t \ A))}" (is "P \ ?P'") proof fix s @@ -872,12 +999,42 @@ proof - note P = this show ?thesis apply - - apply (rule DynProcStaticSpec [where S="{s. p s = q}",simplified, OF P c]) + apply (rule DynProc_exnStaticSpec [where S="{s. p s = q}",simplified, OF P c]) apply (insert spec) apply auto done qed +lemma DynProcProcParNoAbrupt: +assumes adapt: "P \ {s. p s = q \ (\Z. init s \ P' Z \ + (\\. \ \ Q' Z \ return s \ \ R s \))}" +assumes c: "\s t. \,\\\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" +assumes spec: "\Z. \,\\\<^bsub>/F\<^esub> (P' Z) Call q (Q' Z),{}" +shows "\,\\\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" + using adapt c spec unfolding dynCall_dynCall_exn by (rule DynProc_exnProcParNoAbrupt) + +lemma DynProc_exnModifyReturnNoAbr: + assumes to_prove: "\,\\\<^bsub>/F\<^esub> P (dynCall_exn f g init p return' result_exn c) Q,A" + assumes ret_nrm_modif: "\s t. t \ (Modif (init s)) + \ return' s t = return s t" + assumes modif_clause: + "\s \ P. \\. \,\\\<^bsub>/UNIV\<^esub> {\} Call (p s) (Modif \),{}" + shows "\,\\\<^bsub>/F\<^esub> P (dynCall_exn f g init p return result_exn c) Q,A" +proof - + from ret_nrm_modif + have "\s t. t \ (Modif (init s)) + \ return' s t = return s t" + by iprover + then + have ret_nrm_modif': "\s t. t \ (Modif (init s)) + \ return' s t = return s t" + by simp + have ret_abr_modif': "\s t. t \ {} + \ result_exn (return' s t) t = result_exn (return s t) t" + by simp + from to_prove ret_nrm_modif' ret_abr_modif' modif_clause show ?thesis + by (rule dynProc_exnModifyReturn) +qed lemma DynProcModifyReturnNoAbr: assumes to_prove: "\,\\\<^bsub>/F\<^esub> P (dynCall init p return' c) Q,A" @@ -885,7 +1042,17 @@ lemma DynProcModifyReturnNoAbr: \ return' s t = return s t" assumes modif_clause: "\s \ P. \\. \,\\\<^bsub>/UNIV\<^esub> {\} Call (p s) (Modif \),{}" - shows "\,\\\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" + shows "\,\\\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" + using to_prove ret_nrm_modif modif_clause unfolding dynCall_dynCall_exn + by (rule DynProc_exnModifyReturnNoAbr) + +lemma ProcDyn_exnModifyReturnNoAbrSameFaults: + assumes to_prove: "\,\\\<^bsub>/F\<^esub> P (dynCall_exn f g init p return' result_exn c) Q,A" + assumes ret_nrm_modif: "\s t. t \ (Modif (init s)) + \ return' s t = return s t" + assumes modif_clause: + "\s \ P. \\. \,\\\<^bsub>/F\<^esub> {\} (Call (p s)) (Modif \),{}" + shows "\,\\\<^bsub>/F\<^esub> P (dynCall_exn f g init p return result_exn c) Q,A" proof - from ret_nrm_modif have "\s t. t \ (Modif (init s)) @@ -896,34 +1063,43 @@ proof - \ return' s t = return s t" by simp have ret_abr_modif': "\s t. t \ {} - \ return' s t = return s t" + \ result_exn (return' s t) t = result_exn (return s t) t" by simp - from to_prove ret_nrm_modif' ret_abr_modif' modif_clause show ?thesis - by (rule dynProcModifyReturn) + from to_prove ret_nrm_modif' ret_abr_modif' modif_clause show ?thesis + by (rule dynProc_exnModifyReturnSameFaults) qed - lemma ProcDynModifyReturnNoAbrSameFaults: assumes to_prove: "\,\\\<^bsub>/F\<^esub> P (dynCall init p return' c) Q,A" assumes ret_nrm_modif: "\s t. t \ (Modif (init s)) \ return' s t = return s t" assumes modif_clause: "\s \ P. \\. \,\\\<^bsub>/F\<^esub> {\} (Call (p s)) (Modif \),{}" - shows "\,\\\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" + shows "\,\\\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" + using to_prove ret_nrm_modif modif_clause unfolding dynCall_dynCall_exn + by (rule ProcDyn_exnModifyReturnNoAbrSameFaults) + +lemma Proc_exnProcParModifyReturn: + assumes q: "P \ {s. p s = q} \ P'" + \ \@{thm[source] DynProcProcPar} introduces the same constraint as first conjunction in + @{term P'}, so the vcg can simplify it.\ + assumes to_prove: "\,\\\<^bsub>/F\<^esub> P' (dynCall_exn f g init p return' result_exn c) Q,A" + assumes ret_nrm_modif: "\s t. t \ (Modif (init s)) + \ return' s t = return s t" + assumes ret_abr_modif: "\s t. t \ (ModifAbr (init s)) + \ result_exn (return' s t) t = result_exn (return s t) t" + assumes modif_clause: + "\\. \,\\\<^bsub>/UNIV\<^esub> {\} (Call q) (Modif \),(ModifAbr \)" + shows "\,\\\<^bsub>/F\<^esub> P (dynCall_exn f g init p return result_exn c) Q,A" proof - - from ret_nrm_modif - have "\s t. t \ (Modif (init s)) - \ return' s t = return s t" - by iprover - then - have ret_nrm_modif': "\s t. t \ (Modif (init s)) - \ return' s t = return s t" - by simp - have ret_abr_modif': "\s t. t \ {} - \ return' s t = return s t" - by simp - from to_prove ret_nrm_modif' ret_abr_modif' modif_clause show ?thesis - by (rule dynProcModifyReturnSameFaults) + from to_prove have "\,\\\<^bsub>/F\<^esub> ({s. p s = q} \ P') (dynCall_exn f g init p return' result_exn c) Q,A" + by (rule conseqPre) blast + from this ret_nrm_modif + ret_abr_modif + have "\,\\\<^bsub>/F\<^esub> ({s. p s = q} \ P') (dynCall_exn f g init p return result_exn c) Q,A" + by (rule dynProc_exnModifyReturn) (insert modif_clause,auto) + from this q show ?thesis + by (rule conseqPre) qed @@ -938,19 +1114,34 @@ lemma ProcProcParModifyReturn: \ return' s t = return s t" assumes modif_clause: "\\. \,\\\<^bsub>/UNIV\<^esub> {\} (Call q) (Modif \),(ModifAbr \)" - shows "\,\\\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" + shows "\,\\\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" + using q to_prove ret_nrm_modif ret_abr_modif modif_clause unfolding dynCall_dynCall_exn + by (rule Proc_exnProcParModifyReturn) + +lemma Proc_exnProcParModifyReturnSameFaults: + assumes q: "P \ {s. p s = q} \ P'" + \ \@{thm[source] DynProcProcPar} introduces the same constraint as first conjunction in + @{term P'}, so the vcg can simplify it.\ + assumes to_prove: "\,\\\<^bsub>/F\<^esub> P' (dynCall_exn f g init p return' result_exn c) Q,A" + assumes ret_nrm_modif: "\s t. t \ (Modif (init s)) + \ return' s t = return s t" + assumes ret_abr_modif: "\s t. t \ (ModifAbr (init s)) + \ result_exn (return' s t) t = result_exn (return s t) t" + assumes modif_clause: + "\\. \,\\\<^bsub>/F\<^esub> {\} Call q (Modif \),(ModifAbr \)" + shows "\,\\\<^bsub>/F\<^esub> P (dynCall_exn f g init p return result_exn c) Q,A" proof - - from to_prove have "\,\\\<^bsub>/F\<^esub> ({s. p s = q} \ P') (dynCall init p return' c) Q,A" + from to_prove + have "\,\\\<^bsub>/F\<^esub> ({s. p s = q} \ P') (dynCall_exn f g init p return' result_exn c) Q,A" by (rule conseqPre) blast from this ret_nrm_modif ret_abr_modif - have "\,\\\<^bsub>/F\<^esub> ({s. p s = q} \ P') (dynCall init p return c) Q,A" - by (rule dynProcModifyReturn) (insert modif_clause,auto) + have "\,\\\<^bsub>/F\<^esub> ({s. p s = q} \ P') (dynCall_exn f g init p return result_exn c) Q,A" + by (rule dynProc_exnModifyReturnSameFaults) (insert modif_clause,auto) from this q show ?thesis by (rule conseqPre) qed - lemma ProcProcParModifyReturnSameFaults: assumes q: "P \ {s. p s = q} \ P'" \ \@{thm[source] DynProcProcPar} introduces the same constraint as first conjunction in @@ -962,20 +1153,30 @@ lemma ProcProcParModifyReturnSameFaults: \ return' s t = return s t" assumes modif_clause: "\\. \,\\\<^bsub>/F\<^esub> {\} Call q (Modif \),(ModifAbr \)" - shows "\,\\\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" + shows "\,\\\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" + using q to_prove ret_nrm_modif ret_abr_modif modif_clause unfolding dynCall_dynCall_exn + by (rule Proc_exnProcParModifyReturnSameFaults) + +lemma Proc_exnProcParModifyReturnNoAbr: + assumes q: "P \ {s. p s = q} \ P'" + \ \@{thm[source] DynProcProcParNoAbrupt} introduces the same constraint as + first conjunction in @{term P'}, so the vcg can simplify it.\ + assumes to_prove: "\,\\\<^bsub>/F\<^esub> P' (dynCall_exn f g init p return' result_exn c) Q,A" + assumes ret_nrm_modif: "\s t. t \ (Modif (init s)) + \ return' s t = return s t" + assumes modif_clause: + "\\. \,\\\<^bsub>/UNIV\<^esub> {\} (Call q) (Modif \),{}" + shows "\,\\\<^bsub>/F\<^esub> P (dynCall_exn f g init p return result_exn c) Q,A" proof - - from to_prove - have "\,\\\<^bsub>/F\<^esub> ({s. p s = q} \ P') (dynCall init p return' c) Q,A" + from to_prove have "\,\\\<^bsub>/F\<^esub> ({s. p s = q} \ P') (dynCall_exn f g init p return' result_exn c) Q,A" by (rule conseqPre) blast from this ret_nrm_modif - ret_abr_modif - have "\,\\\<^bsub>/F\<^esub> ({s. p s = q} \ P') (dynCall init p return c) Q,A" - by (rule dynProcModifyReturnSameFaults) (insert modif_clause,auto) + have "\,\\\<^bsub>/F\<^esub> ({s. p s = q} \ P') (dynCall_exn f g init p return result_exn c) Q,A" + by (rule DynProc_exnModifyReturnNoAbr) (insert modif_clause,auto) from this q show ?thesis by (rule conseqPre) qed - lemma ProcProcParModifyReturnNoAbr: assumes q: "P \ {s. p s = q} \ P'" \ \@{thm[source] DynProcProcParNoAbrupt} introduces the same constraint as @@ -985,13 +1186,27 @@ lemma ProcProcParModifyReturnNoAbr: \ return' s t = return s t" assumes modif_clause: "\\. \,\\\<^bsub>/UNIV\<^esub> {\} (Call q) (Modif \),{}" - shows "\,\\\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" + shows "\,\\\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" + using q to_prove ret_nrm_modif modif_clause unfolding dynCall_dynCall_exn + by (rule Proc_exnProcParModifyReturnNoAbr) + +lemma Proc_exnProcParModifyReturnNoAbrSameFaults: + assumes q: "P \ {s. p s = q} \ P'" + \ \@{thm[source] DynProcProcParNoAbrupt} introduces the same constraint as + first conjunction in @{term P'}, so the vcg can simplify it.\ + assumes to_prove: "\,\\\<^bsub>/F\<^esub> P' (dynCall_exn f g init p return' result_exn c) Q,A" + assumes ret_nrm_modif: "\s t. t \ (Modif (init s)) + \ return' s t = return s t" + assumes modif_clause: + "\\. \,\\\<^bsub>/F\<^esub> {\} (Call q) (Modif \),{}" + shows "\,\\\<^bsub>/F\<^esub> P (dynCall_exn f g init p return result_exn c) Q,A" proof - - from to_prove have "\,\\\<^bsub>/F\<^esub> ({s. p s = q} \ P') (dynCall init p return' c) Q,A" + from to_prove have + "\,\\\<^bsub>/F\<^esub> ({s. p s = q} \ P') (dynCall_exn f g init p return' result_exn c) Q,A" by (rule conseqPre) blast from this ret_nrm_modif - have "\,\\\<^bsub>/F\<^esub> ({s. p s = q} \ P') (dynCall init p return c) Q,A" - by (rule DynProcModifyReturnNoAbr) (insert modif_clause,auto) + have "\,\\\<^bsub>/F\<^esub> ({s. p s = q} \ P') (dynCall_exn f g init p return result_exn c) Q,A" + by (rule ProcDyn_exnModifyReturnNoAbrSameFaults) (insert modif_clause,auto) from this q show ?thesis by (rule conseqPre) qed @@ -1005,17 +1220,10 @@ lemma ProcProcParModifyReturnNoAbrSameFaults: \ return' s t = return s t" assumes modif_clause: "\\. \,\\\<^bsub>/F\<^esub> {\} (Call q) (Modif \),{}" - shows "\,\\\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" -proof - - from to_prove have - "\,\\\<^bsub>/F\<^esub> ({s. p s = q} \ P') (dynCall init p return' c) Q,A" - by (rule conseqPre) blast - from this ret_nrm_modif - have "\,\\\<^bsub>/F\<^esub> ({s. p s = q} \ P') (dynCall init p return c) Q,A" - by (rule ProcDynModifyReturnNoAbrSameFaults) (insert modif_clause,auto) - from this q show ?thesis - by (rule conseqPre) -qed + shows "\,\\\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" + using q to_prove ret_nrm_modif modif_clause unfolding dynCall_dynCall_exn + by (rule Proc_exnProcParModifyReturnNoAbrSameFaults) + lemma MergeGuards_iff: "\,\\\<^bsub>/F\<^esub> P merge_guards c Q,A = \,\\\<^bsub>/F\<^esub> P c Q,A" by (auto intro: MergeGuardsI MergeGuardsD) @@ -1207,6 +1415,6 @@ lemma WhileConj [intro?]: (simp add: HoarePartialDef.While [THEN conseqPrePost] Collect_conj_eq Collect_neg_eq) -(* FIXME: Add rules for guarded while *) +(* fixme: Add rules for guarded while *) end diff --git a/tools/c-parser/Simpl/HoarePartialDef.thy b/tools/c-parser/Simpl/HoarePartialDef.thy index a846bca1e..84a719336 100644 --- a/tools/c-parser/Simpl/HoarePartialDef.thy +++ b/tools/c-parser/Simpl/HoarePartialDef.thy @@ -1,29 +1,8 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL -*) -(* Title: HoarePartialDef.thy - Author: Norbert Schirmer, TU Muenchen - -Copyright (C) 2004-2008 Norbert Schirmer -Some rights reserved, TU Muenchen - -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA +Copyright (C) 2006-2008 Norbert Schirmer *) section \Hoare Logic for Partial Correctness\ diff --git a/tools/c-parser/Simpl/HoarePartialProps.thy b/tools/c-parser/Simpl/HoarePartialProps.thy index de3b9dc28..43c2a536c 100644 --- a/tools/c-parser/Simpl/HoarePartialProps.thy +++ b/tools/c-parser/Simpl/HoarePartialProps.thy @@ -1,29 +1,10 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL -*) - -(* Title: HoarePartialProps.thy - Author: Norbert Schirmer, TU Muenchen Copyright (C) 2004-2008 Norbert Schirmer -Some rights reserved, TU Muenchen +Copyright (c) 2022 Apple Inc. All rights reserved. -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA *) section \Properties of Partial Correctness Hoare Logic\ @@ -1336,27 +1317,27 @@ done subsubsection \Modify Return\ -lemma ProcModifyReturn_sound: - assumes valid_call: "\n. \,\ \n:\<^bsub>/F\<^esub> P call init p return' c Q,A" +lemma Proc_exnModifyReturn_sound: + assumes valid_call: "\n. \,\ \n:\<^bsub>/F\<^esub> P call_exn init p return' result_exn c Q,A" assumes valid_modif: "\\. \n. \,\\n:\<^bsub>/UNIV\<^esub> {\} Call p (Modif \),(ModifAbr \)" assumes ret_modif: "\s t. t \ Modif (init s) \ return' s t = return s t" assumes ret_modifAbr: "\s t. t \ ModifAbr (init s) - \ return' s t = return s t" - shows "\,\ \n:\<^bsub>/F\<^esub> P (call init p return c) Q,A" + \ result_exn (return' s t) t = result_exn (return s t) t" + shows "\,\ \n:\<^bsub>/F\<^esub> P (call_exn init p return result_exn c) Q,A" proof (rule cnvalidI) fix s t assume ctxt: "\(P, p, Q, A)\\. \ \n:\<^bsub>/F\<^esub> P (Call p) Q,A" then have ctxt': "\(P, p, Q, A)\\. \ \n:\<^bsub>/UNIV\<^esub> P (Call p) Q,A" by (auto intro: nvalid_augment_Faults) - assume exec: "\\\call init p return c,Normal s\ =n\ t" + assume exec: "\\\call_exn init p return result_exn c,Normal s\ =n\ t" assume P: "s \ P" assume t_notin_F: "t \ Fault ` F" from exec show "t \ Normal ` Q \ Abrupt ` A" - proof (cases rule: execn_call_Normal_elim) + proof (cases rule: execn_call_exn_Normal_elim) fix bdy m t' assume bdy: "\ p = Some bdy" assume exec_body: "\\\bdy,Normal (init s)\ =m\ Normal t'" @@ -1372,8 +1353,8 @@ proof (rule cnvalidI) Normal (return s t')" by simp with exec_body exec_c bdy n - have "\\\call init p return' c,Normal s\ =n\ t" - by (auto intro: execn_call) + have "\\\call_exn init p return' result_exn c,Normal s\ =n\ t" + by (auto intro: execn_call_exn) from cnvalidD [OF valid_call [rule_format] ctxt this] P t_notin_F show ?thesis by simp @@ -1382,19 +1363,19 @@ proof (rule cnvalidI) assume bdy: "\ p = Some bdy" assume exec_body: "\\\bdy,Normal (init s)\ =m\ Abrupt t'" assume n: "n = Suc m" - assume t: "t = Abrupt (return s t')" + assume t: "t = Abrupt (result_exn (return s t') t')" also from exec_body n bdy have "\\\Call p,Normal (init s)\ =n\ Abrupt t'" by (auto simp add: intro: execn.intros) from cnvalidD [OF valid_modif [rule_format, of n "init s"] ctxt' this] P have "t' \ ModifAbr (init s)" by auto - with ret_modifAbr have "Abrupt (return s t') = Abrupt (return' s t')" + with ret_modifAbr have "Abrupt (result_exn (return s t') t') = Abrupt (result_exn (return' s t') t')" by simp - finally have "t = Abrupt (return' s t')" . + finally have "t = Abrupt (result_exn (return' s t') t')" . with exec_body bdy n - have "\\\call init p return' c,Normal s\ =n\ t" - by (auto intro: execn_callAbrupt) + have "\\\call_exn init p return' result_exn c,Normal s\ =n\ t" + by (auto intro: execn_call_exnAbrupt) from cnvalidD [OF valid_call [rule_format] ctxt this] P t_notin_F show ?thesis by simp @@ -1403,8 +1384,8 @@ proof (rule cnvalidI) assume bdy: "\ p = Some bdy" assume "\\\bdy,Normal (init s)\ =m\ Fault f" "n = Suc m" "t = Fault f" - with bdy have "\\\call init p return' c ,Normal s\ =n\ t" - by (auto intro: execn_callFault) + with bdy have "\\\call_exn init p return' result_exn c ,Normal s\ =n\ t" + by (auto intro: execn_call_exnFault) from valid_call [rule_format] ctxt this P t_notin_F show ?thesis by (rule cnvalidD) @@ -1413,8 +1394,8 @@ proof (rule cnvalidI) assume bdy: "\ p = Some bdy" assume "\\\bdy,Normal (init s)\ =m\ Stuck" "n = Suc m" "t = Stuck" - with bdy have "\\\call init p return' c ,Normal s\ =n\ t" - by (auto intro: execn_callStuck) + with bdy have "\\\call_exn init p return' result_exn c ,Normal s\ =n\ t" + by (auto intro: execn_call_exnStuck) from valid_call [rule_format] ctxt this P t_notin_F show ?thesis by (rule cnvalidD) @@ -1422,14 +1403,48 @@ proof (rule cnvalidI) fix m assume "\ p = None" and "n = Suc m" "t = Stuck" - then have "\\\call init p return' c ,Normal s\ =n\ t" - by (auto intro: execn_callUndefined) + then have "\\\call_exn init p return' result_exn c ,Normal s\ =n\ t" + by (auto intro: execn_call_exnUndefined) from valid_call [rule_format] ctxt this P t_notin_F show ?thesis by (rule cnvalidD) qed qed +lemma ProcModifyReturn_sound: + assumes valid_call: "\n. \,\ \n:\<^bsub>/F\<^esub> P call init p return' c Q,A" + assumes valid_modif: + "\\. \n. \,\\n:\<^bsub>/UNIV\<^esub> {\} Call p (Modif \),(ModifAbr \)" + assumes ret_modif: + "\s t. t \ Modif (init s) + \ return' s t = return s t" + assumes ret_modifAbr: "\s t. t \ ModifAbr (init s) + \ return' s t = return s t" + shows "\,\ \n:\<^bsub>/F\<^esub> P (call init p return c) Q,A" + using valid_call valid_modif ret_modif ret_modifAbr + unfolding call_call_exn + by (rule Proc_exnModifyReturn_sound) + +lemma Proc_exnModifyReturn: + assumes spec: "\,\\\<^bsub>/F\<^esub> P (call_exn init p return' result_exn c) Q,A" + assumes result_conform: + "\s t. t \ Modif (init s) \ (return' s t) = (return s t)" + assumes return_conform: + "\s t. t \ ModifAbr (init s) + \ (result_exn (return' s t) t) = (result_exn (return s t) t)" + assumes modifies_spec: + "\\. \,\\\<^bsub>/UNIV\<^esub> {\} Call p (Modif \),(ModifAbr \)" + shows "\,\\\<^bsub>/F\<^esub> P (call_exn init p return result_exn c) Q,A" +apply (rule hoare_complete') +apply (rule allI) +apply (rule Proc_exnModifyReturn_sound + [where Modif=Modif and ModifAbr=ModifAbr, + OF _ _ result_conform return_conform] ) +using spec +apply (blast intro: hoare_cnvalid) +using modifies_spec +apply (blast intro: hoare_cnvalid) +done lemma ProcModifyReturn: assumes spec: "\,\\\<^bsub>/F\<^esub> P (call init p return' c) Q,A" @@ -1440,37 +1455,30 @@ lemma ProcModifyReturn: \ (return' s t) = (return s t)" assumes modifies_spec: "\\. \,\\\<^bsub>/UNIV\<^esub> {\} Call p (Modif \),(ModifAbr \)" - shows "\,\\\<^bsub>/F\<^esub> P (call init p return c) Q,A" -apply (rule hoare_complete') -apply (rule allI) -apply (rule ProcModifyReturn_sound - [where Modif=Modif and ModifAbr=ModifAbr, - OF _ _ result_conform return_conform] ) -using spec -apply (blast intro: hoare_cnvalid) -using modifies_spec -apply (blast intro: hoare_cnvalid) -done +shows "\,\\\<^bsub>/F\<^esub> P (call init p return c) Q,A" + using spec result_conform return_conform modifies_spec + unfolding call_call_exn + by (rule Proc_exnModifyReturn) -lemma ProcModifyReturnSameFaults_sound: - assumes valid_call: "\n. \,\ \n:\<^bsub>/F\<^esub> P call init p return' c Q,A" +lemma Proc_exnModifyReturnSameFaults_sound: + assumes valid_call: "\n. \,\ \n:\<^bsub>/F\<^esub> P call_exn init p return' result_exn c Q,A" assumes valid_modif: "\\. \n. \,\\n:\<^bsub>/F\<^esub> {\} Call p (Modif \),(ModifAbr \)" assumes ret_modif: "\s t. t \ Modif (init s) \ return' s t = return s t" assumes ret_modifAbr: "\s t. t \ ModifAbr (init s) - \ return' s t = return s t" - shows "\,\ \n:\<^bsub>/F\<^esub> P (call init p return c) Q,A" + \ result_exn (return' s t) t = result_exn (return s t) t" + shows "\,\ \n:\<^bsub>/F\<^esub> P (call_exn init p return result_exn c) Q,A" proof (rule cnvalidI) fix s t assume ctxt: "\(P, p, Q, A)\\. \ \n:\<^bsub>/F\<^esub> P (Call p) Q,A" - assume exec: "\\\call init p return c,Normal s\ =n\ t" + assume exec: "\\\call_exn init p return result_exn c,Normal s\ =n\ t" assume P: "s \ P" assume t_notin_F: "t \ Fault ` F" from exec show "t \ Normal ` Q \ Abrupt ` A" - proof (cases rule: execn_call_Normal_elim) + proof (cases rule: execn_call_exn_Normal_elim) fix bdy m t' assume bdy: "\ p = Some bdy" assume exec_body: "\\\bdy,Normal (init s)\ =m\ Normal t'" @@ -1486,8 +1494,8 @@ proof (rule cnvalidI) Normal (return s t')" by simp with exec_body exec_c bdy n - have "\\\call init p return' c,Normal s\ =n\ t" - by (auto intro: execn_call) + have "\\\call_exn init p return' result_exn c,Normal s\ =n\ t" + by (auto intro: execn_call_exn) from cnvalidD [OF valid_call [rule_format] ctxt this] P t_notin_F show ?thesis by simp @@ -1496,7 +1504,7 @@ proof (rule cnvalidI) assume bdy: "\ p = Some bdy" assume exec_body: "\\\bdy,Normal (init s)\ =m\ Abrupt t'" assume n: "n = Suc m" - assume t: "t = Abrupt (return s t')" + assume t: "t = Abrupt (result_exn (return s t') t')" also from exec_body n bdy have "\\\Call p,Normal (init s)\ =n \ Abrupt t'" @@ -1504,12 +1512,12 @@ proof (rule cnvalidI) from cnvalidD [OF valid_modif [rule_format, of n "init s"] ctxt this] P have "t' \ ModifAbr (init s)" by auto - with ret_modifAbr have "Abrupt (return s t') = Abrupt (return' s t')" + with ret_modifAbr have "Abrupt (result_exn (return s t') t') = Abrupt (result_exn (return' s t') t')" by simp - finally have "t = Abrupt (return' s t')" . + finally have "t = Abrupt (result_exn (return' s t') t')" . with exec_body bdy n - have "\\\call init p return' c,Normal s\ =n\ t" - by (auto intro: execn_callAbrupt) + have "\\\call_exn init p return' result_exn c,Normal s\ =n\ t" + by (auto intro: execn_call_exnAbrupt) from cnvalidD [OF valid_call [rule_format] ctxt this] P t_notin_F show ?thesis by simp @@ -1518,8 +1526,8 @@ proof (rule cnvalidI) assume bdy: "\ p = Some bdy" assume "\\\bdy,Normal (init s)\ =m\ Fault f" "n = Suc m" and t: "t = Fault f" - with bdy have "\\\call init p return' c ,Normal s\ =n\ t" - by (auto intro: execn_callFault) + with bdy have "\\\call_exn init p return' result_exn c ,Normal s\ =n\ t" + by (auto intro: execn_call_exnFault) from cnvalidD [OF valid_call [rule_format] ctxt this P] t t_notin_F show ?thesis by simp @@ -1528,8 +1536,8 @@ proof (rule cnvalidI) assume bdy: "\ p = Some bdy" assume "\\\bdy,Normal (init s)\ =m\ Stuck" "n = Suc m" "t = Stuck" - with bdy have "\\\call init p return' c ,Normal s\ =n\ t" - by (auto intro: execn_callStuck) + with bdy have "\\\call_exn init p return' result_exn c ,Normal s\ =n\ t" + by (auto intro: execn_call_exnStuck) from valid_call [rule_format] ctxt this P t_notin_F show ?thesis by (rule cnvalidD) @@ -1537,14 +1545,49 @@ proof (rule cnvalidI) fix m assume "\ p = None" and "n = Suc m" "t = Stuck" - then have "\\\call init p return' c ,Normal s\ =n\ t" - by (auto intro: execn_callUndefined) + then have "\\\call_exn init p return' result_exn c ,Normal s\ =n\ t" + by (auto intro: execn_call_exnUndefined) from valid_call [rule_format] ctxt this P t_notin_F show ?thesis by (rule cnvalidD) qed qed +lemma ProcModifyReturnSameFaults_sound: + assumes valid_call: "\n. \,\ \n:\<^bsub>/F\<^esub> P call init p return' c Q,A" + assumes valid_modif: + "\\. \n. \,\\n:\<^bsub>/F\<^esub> {\} Call p (Modif \),(ModifAbr \)" + assumes ret_modif: + "\s t. t \ Modif (init s) + \ return' s t = return s t" + assumes ret_modifAbr: "\s t. t \ ModifAbr (init s) + \ return' s t = return s t" + shows "\,\ \n:\<^bsub>/F\<^esub> P (call init p return c) Q,A" + using valid_call valid_modif ret_modif ret_modifAbr + unfolding call_call_exn + by (rule Proc_exnModifyReturnSameFaults_sound) + + +lemma Proc_exnModifyReturnSameFaults: + assumes spec: "\,\\\<^bsub>/F\<^esub> P (call_exn init p return' result_exn c) Q,A" + assumes result_conform: + "\s t. t \ Modif (init s) \ (return' s t) = (return s t)" + assumes return_conform: + "\s t. t \ ModifAbr (init s) \ (result_exn (return' s t) t) = (result_exn (return s t) t)" + assumes modifies_spec: + "\\. \,\\\<^bsub>/F\<^esub> {\} Call p (Modif \),(ModifAbr \)" + shows "\,\\\<^bsub>/F\<^esub> P (call_exn init p return result_exn c) Q,A" +apply (rule hoare_complete') +apply (rule allI) +apply (rule Proc_exnModifyReturnSameFaults_sound + [where Modif=Modif and ModifAbr=ModifAbr, + OF _ _ result_conform return_conform]) +using spec +apply (blast intro: hoare_cnvalid) +using modifies_spec +apply (blast intro: hoare_cnvalid) +done + lemma ProcModifyReturnSameFaults: assumes spec: "\,\\\<^bsub>/F\<^esub> P (call init p return' c) Q,A" @@ -1554,20 +1597,146 @@ lemma ProcModifyReturnSameFaults: "\s t. t \ ModifAbr (init s) \ (return' s t) = (return s t)" assumes modifies_spec: "\\. \,\\\<^bsub>/F\<^esub> {\} Call p (Modif \),(ModifAbr \)" - shows "\,\\\<^bsub>/F\<^esub> P (call init p return c) Q,A" -apply (rule hoare_complete') -apply (rule allI) -apply (rule ProcModifyReturnSameFaults_sound - [where Modif=Modif and ModifAbr=ModifAbr, - OF _ _ result_conform return_conform]) -using spec -apply (blast intro: hoare_cnvalid) -using modifies_spec -apply (blast intro: hoare_cnvalid) -done +shows "\,\\\<^bsub>/F\<^esub> P (call init p return c) Q,A" + using spec result_conform return_conform modifies_spec + unfolding call_call_exn + by (rule Proc_exnModifyReturnSameFaults) + subsubsection \DynCall\ + + +lemma dynProc_exnModifyReturn_sound: +assumes valid_call: "\n. \,\ \n:\<^bsub>/F\<^esub> P dynCall_exn f g init p return' result_exn c Q,A" +assumes valid_modif: + "\s \ P. \\. \n. + \,\\n:\<^bsub>/UNIV\<^esub> {\} Call (p s) (Modif \),(ModifAbr \)" +assumes ret_modif: + "\s t. t \ Modif (init s) + \ return' s t = return s t" +assumes ret_modifAbr: "\s t. t \ ModifAbr (init s) + \ result_exn (return' s t) t = result_exn (return s t) t" +shows "\,\ \n:\<^bsub>/F\<^esub> P (dynCall_exn f g init p return result_exn c) Q,A" +proof (rule cnvalidI) + fix s t + assume ctxt: "\(P, p, Q, A)\\. \ \n:\<^bsub>/F\<^esub> P (Call p) Q,A" + then have ctxt': "\(P, p, Q, A)\\. \ \n:\<^bsub>/UNIV\<^esub> P (Call p) Q,A" + by (auto intro: nvalid_augment_Faults) + assume exec: "\\\dynCall_exn f g init p return result_exn c,Normal s\ =n\ t" + assume t_notin_F: "t \ Fault ` F" + assume P: "s \ P" + with valid_modif + have valid_modif': "\\. \n. + \,\\n:\<^bsub>/UNIV\<^esub> {\} Call (p s) (Modif \),(ModifAbr \)" + by blast + from exec thm execn_Normal_elim_cases + have exec_call: "\\\maybe_guard f g (call_exn init (p s) return result_exn c),Normal s\ =n\ t" + by (cases rule: execn_dynCall_exn_Normal_elim) + then show "t \ Normal ` Q \ Abrupt ` A" + proof (cases rule: execn_maybe_guard_Normal_elim_cases) + case noFault + from noFault have guards_ok: "s \ g" by simp + from noFault have "\\ \call_exn init (p s) return result_exn c,Normal s\ =n\ t" by simp + then show "t \ Normal ` Q \ Abrupt ` A" + proof (cases rule: execn_call_exn_Normal_elim) + fix bdy m t' + assume bdy: "\ (p s) = Some bdy" + assume exec_body: "\\\bdy,Normal (init s)\ =m\ Normal t'" + assume exec_c: "\\\c s t',Normal (return s t')\ =Suc m\ t" + assume n: "n = Suc m" + from exec_body n bdy + have "\\\Call (p s) ,Normal (init s)\ =n\ Normal t'" + by (auto simp add: intro: execn.intros) + from cnvalidD [OF valid_modif' [rule_format, of n "init s"] ctxt' this] P + have "t' \ Modif (init s)" + by auto + with ret_modif have "Normal (return' s t') = Normal (return s t')" + by simp + with exec_body exec_c bdy n + have "\\\call_exn init (p s) return' result_exn c,Normal s\ =n\ t" + by (auto intro: execn_call_exn) + from execn_maybe_guard_noFault [OF this guards_ok] + have "\\\dynCall_exn f g init p return' result_exn c,Normal s\ =n\ t" + by (simp add: dynCall_exn_def execn_maybe_guard_DynCom) + from cnvalidD [OF valid_call ctxt this] P t_notin_F + show ?thesis + by simp + next + fix bdy m t' + assume bdy: "\ (p s) = Some bdy" + assume exec_body: "\\\bdy,Normal (init s)\ =m\ Abrupt t'" + assume n: "n = Suc m" + assume t: "t = Abrupt (result_exn (return s t') t')" + also from exec_body n bdy + have "\\\Call (p s) ,Normal (init s)\ =n\ Abrupt t'" + by (auto simp add: intro: execn.intros) + from cnvalidD [OF valid_modif' [rule_format, of n "init s"] ctxt' this] P + have "t' \ ModifAbr (init s)" + by auto + with ret_modifAbr have "Abrupt (result_exn (return s t') t') = Abrupt (result_exn (return' s t') t')" + by simp + finally have "t = Abrupt (result_exn (return' s t') t')" . + with exec_body bdy n + have "\\\call_exn init (p s) return' result_exn c,Normal s\ =n\ t" + by (auto intro: execn_call_exnAbrupt) + from execn_maybe_guard_noFault [OF this guards_ok] + have "\\\dynCall_exn f g init p return' result_exn c,Normal s\ =n\ t" + by (simp add: dynCall_exn_def execn_maybe_guard_DynCom) + from cnvalidD [OF valid_call ctxt this] P t_notin_F + show ?thesis + by simp + next + fix bdy m f' + assume bdy: "\ (p s) = Some bdy" + assume "\\\bdy,Normal (init s)\ =m\ Fault f'" "n = Suc m" + "t = Fault f'" + with bdy have "\\\call_exn init (p s) return' result_exn c ,Normal s\ =n\ t" + by (auto intro: execn_call_exnFault) + from execn_maybe_guard_noFault [OF this guards_ok] + have "\\\dynCall_exn f g init p return' result_exn c,Normal s\ =n\ t" + by (simp add: dynCall_exn_def execn_maybe_guard_DynCom) + from valid_call ctxt this P t_notin_F + show ?thesis + by (rule cnvalidD) + next + fix bdy m + assume bdy: "\ (p s) = Some bdy" + assume "\\\bdy,Normal (init s)\ =m\ Stuck" "n = Suc m" + "t = Stuck" + with bdy have "\\\call_exn init (p s) return' result_exn c ,Normal s\ =n\ t" + by (auto intro: execn_call_exnStuck) + from execn_maybe_guard_noFault [OF this guards_ok] + have "\\\dynCall_exn f g init p return' result_exn c,Normal s\ =n\ t" + by (simp add: dynCall_exn_def execn_maybe_guard_DynCom) + from valid_call ctxt this P t_notin_F + show ?thesis + by (rule cnvalidD) + next + fix m + assume "\ (p s) = None" + and "n = Suc m" "t = Stuck" + hence "\\\call_exn init (p s) return' result_exn c ,Normal s\ =n\ t" + by (auto intro: execn_call_exnUndefined) + from execn_maybe_guard_noFault [OF this guards_ok] + have "\\\dynCall_exn f g init p return' result_exn c,Normal s\ =n\ t" + by (simp add: dynCall_exn_def execn_maybe_guard_DynCom) + from valid_call ctxt this P t_notin_F + show ?thesis + by (rule cnvalidD) + qed + next + case (someFault) + then obtain guards_fail:"s \ g" + and t: "t = Fault f" by simp + from execn_maybe_guard_Fault [OF guards_fail] t + have "\\\dynCall_exn f g init p return' result_exn c,Normal s\ =n\ t" + by (simp add: dynCall_exn_def execn_maybe_guard_DynCom) + from cnvalidD [OF valid_call ctxt this] P t_notin_F + show ?thesis by simp + qed +qed + lemma dynProcModifyReturn_sound: assumes valid_call: "\n. \,\ \n:\<^bsub>/F\<^esub> P dynCall init p return' c Q,A" assumes valid_modif: @@ -1579,104 +1748,30 @@ assumes ret_modif: assumes ret_modifAbr: "\s t. t \ ModifAbr (init s) \ return' s t = return s t" shows "\,\ \n:\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" -proof (rule cnvalidI) - fix s t - assume ctxt: "\(P, p, Q, A)\\. \ \n:\<^bsub>/F\<^esub> P (Call p) Q,A" - then have ctxt': "\(P, p, Q, A)\\. \ \n:\<^bsub>/UNIV\<^esub> P (Call p) Q,A" - by (auto intro: nvalid_augment_Faults) - assume exec: "\\\dynCall init p return c,Normal s\ =n\ t" - assume t_notin_F: "t \ Fault ` F" - assume P: "s \ P" - with valid_modif - have valid_modif': "\\. \n. - \,\\n:\<^bsub>/UNIV\<^esub> {\} Call (p s) (Modif \),(ModifAbr \)" - by blast - from exec - have "\\\call init (p s) return c,Normal s\ =n\ t" - by (cases rule: execn_dynCall_Normal_elim) - then show "t \ Normal ` Q \ Abrupt ` A" - proof (cases rule: execn_call_Normal_elim) - fix bdy m t' - assume bdy: "\ (p s) = Some bdy" - assume exec_body: "\\\bdy,Normal (init s)\ =m\ Normal t'" - assume exec_c: "\\\c s t',Normal (return s t')\ =Suc m\ t" - assume n: "n = Suc m" - from exec_body n bdy - have "\\\Call (p s) ,Normal (init s)\ =n\ Normal t'" - by (auto simp add: intro: execn.intros) - from cnvalidD [OF valid_modif' [rule_format, of n "init s"] ctxt' this] P - have "t' \ Modif (init s)" - by auto - with ret_modif have "Normal (return' s t') = Normal (return s t')" - by simp - with exec_body exec_c bdy n - have "\\\call init (p s) return' c,Normal s\ =n\ t" - by (auto intro: execn_call) - hence "\\\dynCall init p return' c,Normal s\ =n\ t" - by (rule execn_dynCall) - from cnvalidD [OF valid_call ctxt this] P t_notin_F - show ?thesis - by simp - next - fix bdy m t' - assume bdy: "\ (p s) = Some bdy" - assume exec_body: "\\\bdy,Normal (init s)\ =m\ Abrupt t'" - assume n: "n = Suc m" - assume t: "t = Abrupt (return s t')" - also from exec_body n bdy - have "\\\Call (p s) ,Normal (init s)\ =n\ Abrupt t'" - by (auto simp add: intro: execn.intros) - from cnvalidD [OF valid_modif' [rule_format, of n "init s"] ctxt' this] P - have "t' \ ModifAbr (init s)" - by auto - with ret_modifAbr have "Abrupt (return s t') = Abrupt (return' s t')" - by simp - finally have "t = Abrupt (return' s t')" . - with exec_body bdy n - have "\\\call init (p s) return' c,Normal s\ =n\ t" - by (auto intro: execn_callAbrupt) - hence "\\\dynCall init p return' c,Normal s\ =n\ t" - by (rule execn_dynCall) - from cnvalidD [OF valid_call ctxt this] P t_notin_F - show ?thesis - by simp - next - fix bdy m f - assume bdy: "\ (p s) = Some bdy" - assume "\\\bdy,Normal (init s)\ =m\ Fault f" "n = Suc m" - "t = Fault f" - with bdy have "\\\call init (p s) return' c ,Normal s\ =n\ t" - by (auto intro: execn_callFault) - hence "\\\dynCall init p return' c,Normal s\ =n\ t" - by (rule execn_dynCall) - from valid_call ctxt this P t_notin_F - show ?thesis - by (rule cnvalidD) - next - fix bdy m - assume bdy: "\ (p s) = Some bdy" - assume "\\\bdy,Normal (init s)\ =m\ Stuck" "n = Suc m" - "t = Stuck" - with bdy have "\\\call init (p s) return' c ,Normal s\ =n\ t" - by (auto intro: execn_callStuck) - hence "\\\dynCall init p return' c,Normal s\ =n\ t" - by (rule execn_dynCall) - from valid_call ctxt this P t_notin_F - show ?thesis - by (rule cnvalidD) - next - fix m - assume "\ (p s) = None" - and "n = Suc m" "t = Stuck" - hence "\\\call init (p s) return' c ,Normal s\ =n\ t" - by (auto intro: execn_callUndefined) - hence "\\\dynCall init p return' c,Normal s\ =n\ t" - by (rule execn_dynCall) - from valid_call ctxt this P t_notin_F - show ?thesis - by (rule cnvalidD) - qed -qed + using valid_call valid_modif ret_modif ret_modifAbr + unfolding dynCall_dynCall_exn + by (rule dynProc_exnModifyReturn_sound) + + +lemma dynProc_exnModifyReturn: +assumes dyn_call: "\,\\\<^bsub>/F\<^esub> P dynCall_exn f g init p return' result_exn c Q,A" +assumes ret_modif: + "\s t. t \ Modif (init s) + \ return' s t = return s t" +assumes ret_modifAbr: "\s t. t \ ModifAbr (init s) + \ result_exn (return' s t) t = result_exn (return s t) t" +assumes modif: + "\s \ P. \\. + \,\\\<^bsub>/UNIV\<^esub> {\} Call (p s) (Modif \),(ModifAbr \)" +shows "\,\\\<^bsub>/F\<^esub> P (dynCall_exn f g init p return result_exn c) Q,A" +apply (rule hoare_complete') +apply (rule allI) +apply (rule dynProc_exnModifyReturn_sound [where Modif=Modif and ModifAbr=ModifAbr, + OF hoare_cnvalid [OF dyn_call] _ ret_modif ret_modifAbr]) +apply (intro ballI allI) +apply (rule hoare_cnvalid [OF modif [rule_format]]) +apply assumption +done lemma dynProcModifyReturn: assumes dyn_call: "\,\\\<^bsub>/F\<^esub> P dynCall init p return' c Q,A" @@ -1688,15 +1783,138 @@ assumes ret_modifAbr: "\s t. t \ ModifAbr (init s) assumes modif: "\s \ P. \\. \,\\\<^bsub>/UNIV\<^esub> {\} Call (p s) (Modif \),(ModifAbr \)" -shows "\,\\\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" -apply (rule hoare_complete') -apply (rule allI) -apply (rule dynProcModifyReturn_sound [where Modif=Modif and ModifAbr=ModifAbr, - OF hoare_cnvalid [OF dyn_call] _ ret_modif ret_modifAbr]) -apply (intro ballI allI) -apply (rule hoare_cnvalid [OF modif [rule_format]]) -apply assumption -done + shows "\,\\\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" + using dyn_call ret_modif ret_modifAbr modif + unfolding dynCall_dynCall_exn + by (rule dynProc_exnModifyReturn) + +lemma dynProc_exnModifyReturnSameFaults_sound: +assumes valid_call: "\n. \,\ \n:\<^bsub>/F\<^esub> P dynCall_exn f g init p return' result_exn c Q,A" +assumes valid_modif: + "\s \ P. \\. \n. + \,\\n:\<^bsub>/F\<^esub> {\} Call (p s) (Modif \),(ModifAbr \)" +assumes ret_modif: + "\s t. t \ Modif (init s) \ return' s t = return s t" +assumes ret_modifAbr: "\s t. t \ ModifAbr (init s) \ result_exn (return' s t) t = result_exn (return s t) t" +shows "\,\ \n:\<^bsub>/F\<^esub> P (dynCall_exn f g init p return result_exn c) Q,A" +proof (rule cnvalidI) + fix s t + assume ctxt: "\(P, p, Q, A)\\. \ \n:\<^bsub>/F\<^esub> P (Call p) Q,A" + assume exec: "\\\dynCall_exn f g init p return result_exn c,Normal s\ =n\ t" + assume t_notin_F: "t \ Fault ` F" + assume P: "s \ P" + with valid_modif + have valid_modif': "\\. \n. + \,\\n:\<^bsub>/F\<^esub> {\} Call (p s) (Modif \),(ModifAbr \)" + by blast + from exec + have exec_call: "\\\maybe_guard f g (call_exn init (p s) return result_exn c),Normal s\ =n\ t" + by (cases rule: execn_dynCall_exn_Normal_elim) + then show "t \ Normal ` Q \ Abrupt ` A" + proof (cases rule: execn_maybe_guard_Normal_elim_cases) + case noFault + from noFault have guards_ok: "s \ g" by simp + from noFault have "\\ \call_exn init (p s) return result_exn c,Normal s\ =n\ t" by simp + then show "t \ Normal ` Q \ Abrupt ` A" + + proof (cases rule: execn_call_exn_Normal_elim) + fix bdy m t' + assume bdy: "\ (p s) = Some bdy" + assume exec_body: "\\\bdy,Normal (init s)\ =m\ Normal t'" + assume exec_c: "\\\c s t',Normal (return s t')\ =Suc m\ t" + assume n: "n = Suc m" + from exec_body n bdy + have "\\\Call (p s) ,Normal (init s)\ =n \ Normal t'" + by (auto simp add: intro: execn.Call) + from cnvalidD [OF valid_modif' [rule_format, of n "init s"] ctxt this] P + have "t' \ Modif (init s)" + by auto + with ret_modif have "Normal (return' s t') = Normal (return s t')" + by simp + with exec_body exec_c bdy n + have "\\\call_exn init (p s) return' result_exn c,Normal s\ =n\ t" + by (auto intro: execn_call_exn) + from execn_maybe_guard_noFault [OF this guards_ok] + have "\\\dynCall_exn f g init p return' result_exn c,Normal s\ =n\ t" + by (simp add: dynCall_exn_def execn_maybe_guard_DynCom) + from cnvalidD [OF valid_call ctxt this] P t_notin_F + show ?thesis + by simp + next + fix bdy m t' + assume bdy: "\ (p s) = Some bdy" + assume exec_body: "\\\bdy,Normal (init s)\ =m\ Abrupt t'" + assume n: "n = Suc m" + assume t: "t = Abrupt (result_exn (return s t') t')" + also from exec_body n bdy + have "\\\Call (p s) ,Normal (init s)\ =n \ Abrupt t'" + by (auto simp add: intro: execn.intros) + from cnvalidD [OF valid_modif' [rule_format, of n "init s"] ctxt this] P + have "t' \ ModifAbr (init s)" + by auto + with ret_modifAbr have "Abrupt (result_exn (return s t') t') = Abrupt (result_exn (return' s t') t')" + by simp + finally have "t = Abrupt (result_exn (return' s t') t')" . + with exec_body bdy n + have "\\\call_exn init (p s) return' result_exn c,Normal s\ =n\ t" + by (auto intro: execn_call_exnAbrupt) + from execn_maybe_guard_noFault [OF this guards_ok] + have "\\\dynCall_exn f g init p return' result_exn c,Normal s\ =n\ t" + by (simp add: dynCall_exn_def execn_maybe_guard_DynCom) + from cnvalidD [OF valid_call ctxt this] P t_notin_F + show ?thesis + by simp + next + fix bdy m f' + assume bdy: "\ (p s) = Some bdy" + assume "\\\bdy,Normal (init s)\ =m\ Fault f'" "n = Suc m" and + t: "t = Fault f'" + with bdy have "\\\call_exn init (p s) return' result_exn c ,Normal s\ =n\ t" + by (auto intro: execn_call_exnFault) + from execn_maybe_guard_noFault [OF this guards_ok] + have "\\\dynCall_exn f g init p return' result_exn c,Normal s\ =n\ t" + by (simp add: dynCall_exn_def execn_maybe_guard_DynCom) + from cnvalidD [OF valid_call ctxt this P] t t_notin_F + show ?thesis + by simp + next + fix bdy m + assume bdy: "\ (p s) = Some bdy" + assume "\\\bdy,Normal (init s)\ =m\ Stuck" "n = Suc m" + "t = Stuck" + with bdy have "\\\call_exn init (p s) return' result_exn c ,Normal s\ =n\ t" + by (auto intro: execn_call_exnStuck) + from execn_maybe_guard_noFault [OF this guards_ok] + have "\\\dynCall_exn f g init p return' result_exn c,Normal s\ =n\ t" + by (simp add: dynCall_exn_def execn_maybe_guard_DynCom) + from valid_call ctxt this P t_notin_F + show ?thesis + by (rule cnvalidD) + next + fix m + assume "\ (p s) = None" + and "n = Suc m" "t = Stuck" + hence "\\\call_exn init (p s) return' result_exn c ,Normal s\ =n\ t" + by (auto intro: execn_call_exnUndefined) + from execn_maybe_guard_noFault [OF this guards_ok] + have "\\\dynCall_exn f g init p return' result_exn c,Normal s\ =n\ t" + by (simp add: dynCall_exn_def execn_maybe_guard_DynCom) + from valid_call ctxt this P t_notin_F + show ?thesis + by (rule cnvalidD) + qed + next + case (someFault) + then obtain guards_fail:"s \ g" + and t: "t = Fault f" by simp + from execn_maybe_guard_Fault [OF guards_fail] t + have "\\\dynCall_exn f g init p return' result_exn c,Normal s\ =n\ t" + by (simp add: dynCall_exn_def execn_guards_DynCom) + from cnvalidD [OF valid_call ctxt this] P t_notin_F + show ?thesis by simp + qed +qed + lemma dynProcModifyReturnSameFaults_sound: assumes valid_call: "\n. \,\ \n:\<^bsub>/F\<^esub> P dynCall init p return' c Q,A" @@ -1707,102 +1925,29 @@ assumes ret_modif: "\s t. t \ Modif (init s) \ return' s t = return s t" assumes ret_modifAbr: "\s t. t \ ModifAbr (init s) \ return' s t = return s t" shows "\,\ \n:\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" -proof (rule cnvalidI) - fix s t - assume ctxt: "\(P, p, Q, A)\\. \ \n:\<^bsub>/F\<^esub> P (Call p) Q,A" - assume exec: "\\\dynCall init p return c,Normal s\ =n\ t" - assume t_notin_F: "t \ Fault ` F" - assume P: "s \ P" - with valid_modif - have valid_modif': "\\. \n. - \,\\n:\<^bsub>/F\<^esub> {\} Call (p s) (Modif \),(ModifAbr \)" - by blast - from exec - have "\\\call init (p s) return c,Normal s\ =n\ t" - by (cases rule: execn_dynCall_Normal_elim) - then show "t \ Normal ` Q \ Abrupt ` A" - proof (cases rule: execn_call_Normal_elim) - fix bdy m t' - assume bdy: "\ (p s) = Some bdy" - assume exec_body: "\\\bdy,Normal (init s)\ =m\ Normal t'" - assume exec_c: "\\\c s t',Normal (return s t')\ =Suc m\ t" - assume n: "n = Suc m" - from exec_body n bdy - have "\\\Call (p s) ,Normal (init s)\ =n \ Normal t'" - by (auto simp add: intro: execn.Call) - from cnvalidD [OF valid_modif' [rule_format, of n "init s"] ctxt this] P - have "t' \ Modif (init s)" - by auto - with ret_modif have "Normal (return' s t') = Normal (return s t')" - by simp - with exec_body exec_c bdy n - have "\\\call init (p s) return' c,Normal s\ =n\ t" - by (auto intro: execn_call) - hence "\\\dynCall init p return' c,Normal s\ =n\ t" - by (rule execn_dynCall) - from cnvalidD [OF valid_call ctxt this] P t_notin_F - show ?thesis - by simp - next - fix bdy m t' - assume bdy: "\ (p s) = Some bdy" - assume exec_body: "\\\bdy,Normal (init s)\ =m\ Abrupt t'" - assume n: "n = Suc m" - assume t: "t = Abrupt (return s t')" - also from exec_body n bdy - have "\\\Call (p s) ,Normal (init s)\ =n \ Abrupt t'" - by (auto simp add: intro: execn.intros) - from cnvalidD [OF valid_modif' [rule_format, of n "init s"] ctxt this] P - have "t' \ ModifAbr (init s)" - by auto - with ret_modifAbr have "Abrupt (return s t') = Abrupt (return' s t')" - by simp - finally have "t = Abrupt (return' s t')" . - with exec_body bdy n - have "\\\call init (p s) return' c,Normal s\ =n\ t" - by (auto intro: execn_callAbrupt) - hence "\\\dynCall init p return' c,Normal s\ =n\ t" - by (rule execn_dynCall) - from cnvalidD [OF valid_call ctxt this] P t_notin_F - show ?thesis - by simp - next - fix bdy m f - assume bdy: "\ (p s) = Some bdy" - assume "\\\bdy,Normal (init s)\ =m\ Fault f" "n = Suc m" and - t: "t = Fault f" - with bdy have "\\\call init (p s) return' c ,Normal s\ =n\ t" - by (auto intro: execn_callFault) - hence "\\\dynCall init p return' c,Normal s\ =n\ t" - by (rule execn_dynCall) - from cnvalidD [OF valid_call ctxt this P] t t_notin_F - show ?thesis - by simp - next - fix bdy m - assume bdy: "\ (p s) = Some bdy" - assume "\\\bdy,Normal (init s)\ =m\ Stuck" "n = Suc m" - "t = Stuck" - with bdy have "\\\call init (p s) return' c ,Normal s\ =n\ t" - by (auto intro: execn_callStuck) - hence "\\\dynCall init p return' c,Normal s\ =n\ t" - by (rule execn_dynCall) - from valid_call ctxt this P t_notin_F - show ?thesis - by (rule cnvalidD) - next - fix m - assume "\ (p s) = None" - and "n = Suc m" "t = Stuck" - hence "\\\call init (p s) return' c ,Normal s\ =n\ t" - by (auto intro: execn_callUndefined) - hence "\\\dynCall init p return' c,Normal s\ =n\ t" - by (rule execn_dynCall) - from valid_call ctxt this P t_notin_F - show ?thesis - by (rule cnvalidD) - qed -qed + using valid_call valid_modif ret_modif ret_modifAbr + unfolding dynCall_dynCall_exn + by (rule dynProc_exnModifyReturnSameFaults_sound) + +lemma dynProc_exnModifyReturnSameFaults: +assumes dyn_call: "\,\\\<^bsub>/F\<^esub> P dynCall_exn f g init p return' result_exn c Q,A" +assumes ret_modif: + "\s t. t \ Modif (init s) + \ return' s t = return s t" +assumes ret_modifAbr: "\s t. t \ ModifAbr (init s) + \ result_exn (return' s t) t = result_exn (return s t) t" +assumes modif: + "\s \ P. \\. \,\\\<^bsub>/F\<^esub> {\} Call (p s) (Modif \),(ModifAbr \)" +shows "\,\\\<^bsub>/F\<^esub> P (dynCall_exn f g init p return result_exn c) Q,A" +apply (rule hoare_complete') +apply (rule allI) +apply (rule dynProc_exnModifyReturnSameFaults_sound + [where Modif=Modif and ModifAbr=ModifAbr, + OF hoare_cnvalid [OF dyn_call] _ ret_modif ret_modifAbr]) +apply (intro ballI allI) +apply (rule hoare_cnvalid [OF modif [rule_format]]) +apply assumption + done lemma dynProcModifyReturnSameFaults: assumes dyn_call: "\,\\\<^bsub>/F\<^esub> P dynCall init p return' c Q,A" @@ -1813,16 +1958,10 @@ assumes ret_modifAbr: "\s t. t \ ModifAbr (init s) \ return' s t = return s t" assumes modif: "\s \ P. \\. \,\\\<^bsub>/F\<^esub> {\} Call (p s) (Modif \),(ModifAbr \)" -shows "\,\\\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" -apply (rule hoare_complete') -apply (rule allI) -apply (rule dynProcModifyReturnSameFaults_sound - [where Modif=Modif and ModifAbr=ModifAbr, - OF hoare_cnvalid [OF dyn_call] _ ret_modif ret_modifAbr]) -apply (intro ballI allI) -apply (rule hoare_cnvalid [OF modif [rule_format]]) -apply assumption -done + shows "\,\\\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" + using dyn_call ret_modif ret_modifAbr modif + unfolding dynCall_dynCall_exn + by (rule dynProc_exnModifyReturnSameFaults) subsubsection \Conjunction of Postcondition\ diff --git a/tools/c-parser/Simpl/HoareTotal.thy b/tools/c-parser/Simpl/HoareTotal.thy index cfaf1c8be..da94e97dd 100644 --- a/tools/c-parser/Simpl/HoareTotal.thy +++ b/tools/c-parser/Simpl/HoareTotal.thy @@ -1,29 +1,10 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL -*) - -(* Title: HoareTotal.thy - Author: Norbert Schirmer, TU Muenchen Copyright (C) 2004-2008 Norbert Schirmer -Some rights reserved, TU Muenchen +Copyright (c) 2022 Apple Inc. All rights reserved. -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA *) section \Derived Hoare Rules for Total Correctness\ @@ -475,18 +456,18 @@ using adapt apply blast done -lemma Block: +lemma Block_exn: assumes adapt: "P \ {s. init s \ P' s}" -assumes bdy: "\s. \,\\\<^sub>t\<^bsub>/F\<^esub> (P' s) bdy {t. return s t \ R s t},{t. return s t \ A}" +assumes bdy: "\s. \,\\\<^sub>t\<^bsub>/F\<^esub> (P' s) bdy {t. return s t \ R s t},{t. result_exn (return s t) t \ A}" assumes c: "\s t. \,\\\<^sub>t\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" -shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (block init bdy return c) Q,A" +shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (block_exn init bdy return result_exn c) Q,A" apply (rule conseq [where P'="\Z. {s. s=Z \ init s \ P' Z}" and Q'="\Z. Q" and A'="\Z. A"]) prefer 2 using adapt apply blast apply (rule allI) -apply (unfold block_def) +apply (unfold block_exn_def) apply (rule HoareTotalDef.DynCom) apply (rule ballI) apply clarsimp @@ -501,7 +482,7 @@ apply (rule SeqSwap) apply (rule c [rule_format]) apply (rule Basic) apply clarsimp -apply (rule_tac R="{t. return Z t \ A}" in HoareTotalDef.Catch) +apply (rule_tac R="{t. result_exn (return Z t) t \ A}" in HoareTotalDef.Catch) apply (rule_tac R="{i. i \ P' Z}" in Seq) apply (rule Basic) apply clarsimp @@ -513,6 +494,13 @@ apply (rule Basic) apply simp done +lemma Block: +assumes adapt: "P \ {s. init s \ P' s}" +assumes bdy: "\s. \,\\\<^sub>t\<^bsub>/F\<^esub> (P' s) bdy {t. return s t \ R s t},{t. return s t \ A}" +assumes c: "\s t. \,\\\<^sub>t\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" +shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (block init bdy return c) Q,A" + using adapt bdy c unfolding block_def by (rule Block_exn) + lemma BlockSwap: assumes c: "\s t. \,\\\<^sub>t\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" assumes bdy: "\s. \,\\\<^sub>t\<^bsub>/F\<^esub> (P' s) bdy {t. return s t \ R s t},{t. return s t \ A}" @@ -521,22 +509,30 @@ shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (block init bdy using adapt bdy c by (rule Block) -lemma BlockSpec: +lemma Block_exnSwap: +assumes c: "\s t. \,\\\<^sub>t\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" +assumes bdy: "\s. \,\\\<^sub>t\<^bsub>/F\<^esub> (P' s) bdy {t. return s t \ R s t},{t. result_exn (return s t) t \ A}" +assumes adapt: "P \ {s. init s \ P' s}" +shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (block_exn init bdy return result_exn c) Q,A" + using adapt bdy c + by (rule Block_exn) + +lemma Block_exnSpec: assumes adapt: "P \ {s. \Z. init s \ P' Z \ (\t. t \ Q' Z \ return s t \ R s t) \ - (\t. t \ A' Z \ return s t \ A)}" + (\t. t \ A' Z \ result_exn (return s t) t \ A)}" assumes c: "\s t. \,\\\<^sub>t\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" assumes bdy: "\Z. \,\\\<^sub>t\<^bsub>/F\<^esub> (P' Z) bdy (Q' Z),(A' Z)" - shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (block init bdy return c) Q,A" + shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (block_exn init bdy return result_exn c) Q,A" apply (rule conseq [where P'="\Z. {s. init s \ P' Z \ (\t. t \ Q' Z \ return s t \ R s t) \ - (\t. t \ A' Z \ return s t \ A)}" and Q'="\Z. Q" and + (\t. t \ A' Z \ result_exn (return s t) t \ A)}" and Q'="\Z. Q" and A'="\Z. A"]) prefer 2 using adapt apply blast apply (rule allI) -apply (unfold block_def) +apply (unfold block_exn_def) apply (rule HoareTotalDef.DynCom) apply (rule ballI) apply clarsimp @@ -551,7 +547,7 @@ apply (rule SeqSwap) apply (rule c [rule_format]) apply (rule Basic) apply clarsimp -apply (rule_tac R="{t. return s t \ A}" in HoareTotalDef.Catch) +apply (rule_tac R="{t. result_exn (return s t) t \ A}" in HoareTotalDef.Catch) apply (rule_tac R="{i. i \ P' Z}" in Seq) apply (rule Basic) apply clarsimp @@ -565,6 +561,15 @@ apply (rule Basic) apply simp done +lemma BlockSpec: + assumes adapt: "P \ {s. \Z. init s \ P' Z \ + (\t. t \ Q' Z \ return s t \ R s t) \ + (\t. t \ A' Z \ return s t \ A)}" + assumes c: "\s t. \,\\\<^sub>t\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" + assumes bdy: "\Z. \,\\\<^sub>t\<^bsub>/F\<^esub> (P' Z) bdy (Q' Z),(A' Z)" + shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (block init bdy return c) Q,A" + using adapt c bdy unfolding block_def by (rule Block_exnSpec) + lemma Throw: "P \ A \ \,\\\<^sub>t\<^bsub>/F\<^esub> P Throw Q,A" by (rule hoaret.Throw [THEN conseqPre]) @@ -597,6 +602,16 @@ lemma condCatchSwap: "\\,\\\<^sub>t\<^bsub>/F\< \ \,\\\<^sub>t\<^bsub>/F\<^esub> P condCatch c\<^sub>1 b c\<^sub>2 Q,A" by (rule condCatch) +lemma Proc_exnSpec: + assumes adapt: "P \ {s. \Z. init s \ P' Z \ + (\t. t \ Q' Z \ return s t \ R s t) \ + (\t. t \ A' Z \ result_exn (return s t) t \ A)}" + assumes c: "\s t. \,\\\<^sub>t\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" + assumes p: "\Z. \,\\\<^sub>t\<^bsub>/F\<^esub> (P' Z) Call p (Q' Z),(A' Z)" + shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (call_exn init p return result_exn c) Q,A" +using adapt c p +apply (unfold call_exn_def) + by (rule Block_exnSpec) lemma ProcSpec: assumes adapt: "P \ {s. \Z. init s \ P' Z \ @@ -609,14 +624,14 @@ using adapt c p apply (unfold call_def) by (rule BlockSpec) -lemma ProcSpec': +lemma Proc_exnSpec': assumes adapt: "P \ {s. \Z. init s \ P' Z \ (\t \ Q' Z. return s t \ R s t) \ - (\t \ A' Z. return s t \ A)}" + (\t \ A' Z. result_exn (return s t) t \ A)}" assumes c: "\s t. \,\\\<^sub>t\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" assumes p: "\Z. \,\\\<^sub>t\<^bsub>/F\<^esub> (P' Z) Call p (Q' Z),(A' Z)" - shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (call init p return c) Q,A" -apply (rule ProcSpec [OF _ c p]) + shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (call_exn init p return result_exn c) Q,A" +apply (rule Proc_exnSpec [OF _ c p]) apply (insert adapt) apply clarsimp apply (drule (1) subsetD) @@ -625,6 +640,26 @@ apply (rule_tac x=Z in exI) apply blast done +lemma ProcSpec': + assumes adapt: "P \ {s. \Z. init s \ P' Z \ + (\t \ Q' Z. return s t \ R s t) \ + (\t \ A' Z. return s t \ A)}" + assumes c: "\s t. \,\\\<^sub>t\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" + assumes p: "\Z. \,\\\<^sub>t\<^bsub>/F\<^esub> (P' Z) Call p (Q' Z),(A' Z)" + shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (call init p return c) Q,A" + using adapt c p unfolding call_call_exn by (rule Proc_exnSpec') + + +lemma Proc_exnSpecNoAbrupt: + assumes adapt: "P \ {s. \Z. init s \ P' Z \ + (\t. t \ Q' Z \ return s t \ R s t)}" + assumes c: "\s t. \,\\\<^sub>t\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" + assumes p: "\Z. \,\\\<^sub>t\<^bsub>/F\<^esub> (P' Z) Call p (Q' Z),{}" + shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (call_exn init p return result_exn c) Q,A" +apply (rule Proc_exnSpec [OF _ c p]) +using adapt +apply simp + done lemma ProcSpecNoAbrupt: assumes adapt: "P \ {s. \Z. init s \ P' Z \ @@ -764,9 +799,25 @@ apply (rule ProcBody [where \=\, OF _ bdy [rule_format] body]) apply simp done +lemma Call_exnBody: +assumes adapt: "P \ {s. init s \ P' s}" +assumes bdy: "\s. \,\\\<^sub>t\<^bsub>/F\<^esub> (P' s) body {t. return s t \ R s t},{t. result_exn (return s t) t \ A}" +assumes c: "\s t. \,\\\<^sub>t\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" +assumes body: "\ p = Some body" +shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (call_exn init p return result_exn c) Q,A" +apply (unfold call_exn_def) +apply (rule Block_exn [OF adapt _ c]) +apply (rule allI) +apply (rule ProcBody [where \=\, OF _ bdy [rule_format] body]) +apply simp + done + lemmas ProcModifyReturn = HoareTotalProps.ProcModifyReturn lemmas ProcModifyReturnSameFaults = HoareTotalProps.ProcModifyReturnSameFaults +lemmas Proc_exnModifyReturn = HoareTotalProps.Proc_exnModifyReturn +lemmas Proc_exnModifyReturnSameFaults = HoareTotalProps.Proc_exnModifyReturnSameFaults + lemma ProcModifyReturnNoAbr: assumes spec: "\,\\\<^sub>t\<^bsub>/F\<^esub> P (call init p return' c) Q,A" assumes result_conform: @@ -776,6 +827,15 @@ lemma ProcModifyReturnNoAbr: shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (call init p return c) Q,A" by (rule ProcModifyReturn [OF spec result_conform _ modifies_spec]) simp +lemma Proc_exnModifyReturnNoAbr: + assumes spec: "\,\\\<^sub>t\<^bsub>/F\<^esub> P (call_exn init p return' result_exn c) Q,A" + assumes result_conform: + "\s t. t \ Modif (init s) \ (return' s t) = (return s t)" + assumes modifies_spec: + "\\. \,\\\<^bsub>/UNIV\<^esub> {\} Call p (Modif \),{}" + shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (call_exn init p return result_exn c) Q,A" + by (rule Proc_exnModifyReturn [OF spec result_conform _ modifies_spec]) simp + lemma ProcModifyReturnNoAbrSameFaults: assumes spec: "\,\\\<^sub>t\<^bsub>/F\<^esub> P (call init p return' c) Q,A" @@ -786,21 +846,29 @@ lemma ProcModifyReturnNoAbrSameFaults: shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (call init p return c) Q,A" by (rule ProcModifyReturnSameFaults [OF spec result_conform _ modifies_spec]) simp +lemma Proc_exnModifyReturnNoAbrSameFaults: + assumes spec: "\,\\\<^sub>t\<^bsub>/F\<^esub> P (call_exn init p return' result_exn c) Q,A" + assumes result_conform: + "\s t. t \ Modif (init s) \ (return' s t) = (return s t)" + assumes modifies_spec: + "\\. \,\\\<^bsub>/F\<^esub> {\} Call p (Modif \),{}" + shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (call_exn init p return result_exn c) Q,A" + by (rule Proc_exnModifyReturnSameFaults [OF spec result_conform _ modifies_spec]) simp -lemma DynProc: +lemma DynProc_exn: assumes adapt: "P \ {s. \Z. init s \ P' s Z \ (\t. t \ Q' s Z \ return s t \ R s t) \ - (\t. t \ A' s Z \ return s t \ A)}" + (\t. t \ A' s Z \ result_exn (return s t) t \ A)}" assumes c: "\s t. \,\\\<^sub>t\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" assumes p: "\s\ P. \Z. \,\\\<^sub>t\<^bsub>/F\<^esub> (P' s Z) Call (p s) (Q' s Z),(A' s Z)" - shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P dynCall init p return c Q,A" + shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P dynCall_exn f UNIV init p return result_exn c Q,A" apply (rule conseq [where P'="\Z. {s. s=Z \ s \ P}" and Q'="\Z. Q" and A'="\Z. A"]) prefer 2 using adapt apply blast apply (rule allI) -apply (unfold dynCall_def call_def block_def) +apply (unfold dynCall_exn_def maybe_guard_UNIV call_exn_def block_exn_def guards.simps) apply (rule HoareTotalDef.DynCom) apply clarsimp apply (rule HoareTotalDef.DynCom) @@ -834,7 +902,41 @@ apply (rule SeqSwap) apply (rule c [rule_format]) apply (rule Basic) apply clarsimp -done + done + +lemma DynProc_exn_guards_cons: + assumes p: "\,\\\<^sub>t\<^bsub>/F\<^esub> P dynCall_exn f UNIV init p return result_exn c Q,A" + shows "\,\\\<^sub>t\<^bsub>/F\<^esub> (g \ P) dynCall_exn f g init p return result_exn c Q,A" + using p apply (clarsimp simp add: dynCall_exn_def maybe_guard_def) + apply (rule Guard) + apply (rule subset_refl) + apply assumption + done + +lemma DynProc: + assumes adapt: "P \ {s. \Z. init s \ P' s Z \ + (\t. t \ Q' s Z \ return s t \ R s t) \ + (\t. t \ A' s Z \ return s t \ A)}" + assumes c: "\s t. \,\\\<^sub>t\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" + assumes p: "\s\ P. \Z. \,\\\<^sub>t\<^bsub>/F\<^esub> (P' s Z) Call (p s) (Q' s Z),(A' s Z)" + shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P dynCall init p return c Q,A" + using adapt c p unfolding dynCall_dynCall_exn by (rule DynProc_exn) + +lemma DynProc_exn': + assumes adapt: "P \ {s. \Z. init s \ P' s Z \ + (\t \ Q' s Z. return s t \ R s t) \ + (\t \ A' s Z. result_exn (return s t) t \ A)}" + assumes c: "\s t. \,\\\<^sub>t\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" + assumes p: "\s\ P. \Z. \,\\\<^sub>t\<^bsub>/F\<^esub> (P' s Z) Call (p s) (Q' s Z),(A' s Z)" + shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P dynCall_exn f UNIV init p return result_exn c Q,A" +proof - + from adapt have "P \ {s. \Z. init s \ P' s Z \ + (\t. t \ Q' s Z \ return s t \ R s t) \ + (\t. t \ A' s Z \ result_exn (return s t) t \ A)}" + by blast + from this c p show ?thesis + by (rule DynProc_exn) +qed lemma DynProc': assumes adapt: "P \ {s. \Z. init s \ P' s Z \ @@ -843,27 +945,20 @@ lemma DynProc': assumes c: "\s t. \,\\\<^sub>t\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" assumes p: "\s\ P. \Z. \,\\\<^sub>t\<^bsub>/F\<^esub> (P' s Z) Call (p s) (Q' s Z),(A' s Z)" shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P dynCall init p return c Q,A" -proof - - from adapt have "P \ {s. \Z. init s \ P' s Z \ - (\t. t \ Q' s Z \ return s t \ R s t) \ - (\t. t \ A' s Z \ return s t \ A)}" - by blast - from this c p show ?thesis - by (rule DynProc) -qed + using adapt c p unfolding dynCall_dynCall_exn by (rule DynProc_exn') -lemma DynProcStaticSpec: +lemma DynProc_exnStaticSpec: assumes adapt: "P \ {s. s \ S \ (\Z. init s \ P' Z \ (\\. \ \ Q' Z \ return s \ \ R s \) \ - (\\. \ \ A' Z \ return s \ \ A))}" + (\\. \ \ A' Z \ result_exn (return s \) \ \ A))}" assumes c: "\s t. \,\\\<^sub>t\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" assumes spec: "\s\S. \Z. \,\\\<^sub>t\<^bsub>/F\<^esub> (P' Z) Call (p s) (Q' Z),(A' Z)" -shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" +shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (dynCall_exn f UNIV init p return result_exn c) Q,A" proof - from adapt have P_S: "P \ S" by blast - have "\,\\\<^sub>t\<^bsub>/F\<^esub> (P \ S) (dynCall init p return c) Q,A" - apply (rule DynProc [where P'="\s Z. P' Z" and Q'="\s Z. Q' Z" + have "\,\\\<^sub>t\<^bsub>/F\<^esub> (P \ S) (dynCall_exn f UNIV init p return result_exn c) Q,A" + apply (rule DynProc_exn [where P'="\s Z. P' Z" and Q'="\s Z. Q' Z" and A'="\s Z. A' Z", OF _ c]) apply clarsimp apply (frule in_mono [rule_format, OF adapt]) @@ -876,6 +971,26 @@ proof - qed +lemma DynProcStaticSpec: +assumes adapt: "P \ {s. s \ S \ (\Z. init s \ P' Z \ + (\\. \ \ Q' Z \ return s \ \ R s \) \ + (\\. \ \ A' Z \ return s \ \ A))}" +assumes c: "\s t. \,\\\<^sub>t\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" +assumes spec: "\s\S. \Z. \,\\\<^sub>t\<^bsub>/F\<^esub> (P' Z) Call (p s) (Q' Z),(A' Z)" +shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" + using adapt c spec unfolding dynCall_dynCall_exn by (rule DynProc_exnStaticSpec) + +lemma DynProc_exnProcPar: +assumes adapt: "P \ {s. p s = q \ (\Z. init s \ P' Z \ + (\\. \ \ Q' Z \ return s \ \ R s \) \ + (\\. \ \ A' Z \ result_exn (return s \) \ \ A))}" +assumes c: "\s t. \,\\\<^sub>t\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" +assumes spec: "\Z. \,\\\<^sub>t\<^bsub>/F\<^esub> (P' Z) Call q (Q' Z),(A' Z)" +shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (dynCall_exn f UNIV init p return result_exn c) Q,A" + apply (rule DynProc_exnStaticSpec [where S="{s. p s = q}",simplified, OF adapt c]) + using spec + apply simp + done lemma DynProcProcPar: assumes adapt: "P \ {s. p s = q \ (\Z. init s \ P' Z \ @@ -889,17 +1004,16 @@ shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p apply simp done - -lemma DynProcProcParNoAbrupt: +lemma DynProc_exnProcParNoAbrupt: assumes adapt: "P \ {s. p s = q \ (\Z. init s \ P' Z \ (\\. \ \ Q' Z \ return s \ \ R s \))}" assumes c: "\s t. \,\\\<^sub>t\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" assumes spec: "\Z. \,\\\<^sub>t\<^bsub>/F\<^esub> (P' Z) Call q (Q' Z),{}" -shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" +shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (dynCall_exn f UNIV init p return result_exn c) Q,A" proof - have "P \ {s. p s = q \ (\ Z. init s \ P' Z \ (\t. t \ Q' Z \ return s t \ R s t) \ - (\t. t \ {} \ return s t \ A))}" + (\t. t \ {} \ result_exn (return s t) t \ A))}" (is "P \ ?P'") proof fix s @@ -918,19 +1032,60 @@ proof - note P = this show ?thesis apply - - apply (rule DynProcStaticSpec [where S="{s. p s = q}",simplified, OF P c]) + apply (rule DynProc_exnStaticSpec [where S="{s. p s = q}",simplified, OF P c]) apply (insert spec) apply auto done qed +lemma DynProcProcParNoAbrupt: +assumes adapt: "P \ {s. p s = q \ (\Z. init s \ P' Z \ + (\\. \ \ Q' Z \ return s \ \ R s \))}" +assumes c: "\s t. \,\\\<^sub>t\<^bsub>/F\<^esub> (R s t) (c s t) Q,A" +assumes spec: "\Z. \,\\\<^sub>t\<^bsub>/F\<^esub> (P' Z) Call q (Q' Z),{}" +shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" + using adapt c spec unfolding dynCall_dynCall_exn by (rule DynProc_exnProcParNoAbrupt) + +lemma DynProc_exnModifyReturnNoAbr: + assumes to_prove: "\,\\\<^sub>t\<^bsub>/F\<^esub> P (dynCall_exn f g init p return' result_exn c) Q,A" + assumes ret_nrm_modif: "\s t. t \ (Modif (init s)) + \ return' s t = return s t" + assumes modif_clause: + "\s \ P. \\. \,\\\<^bsub>/UNIV\<^esub> {\} Call (p s) (Modif \),{}" + shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (dynCall_exn f g init p return result_exn c) Q,A" +proof - + from ret_nrm_modif + have "\s t. t \ (Modif (init s)) + \ return' s t = return s t" + by iprover + then + have ret_nrm_modif': "\s t. t \ (Modif (init s)) + \ return' s t = return s t" + by simp + have ret_abr_modif': "\s t. t \ {} + \ result_exn (return' s t) t = result_exn (return s t) t" + by simp + from to_prove ret_nrm_modif' ret_abr_modif' modif_clause show ?thesis + by (rule dynProc_exnModifyReturn) +qed + lemma DynProcModifyReturnNoAbr: assumes to_prove: "\,\\\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return' c) Q,A" assumes ret_nrm_modif: "\s t. t \ (Modif (init s)) \ return' s t = return s t" assumes modif_clause: "\s \ P. \\. \,\\\<^bsub>/UNIV\<^esub> {\} Call (p s) (Modif \),{}" - shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" + shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" + using to_prove ret_nrm_modif modif_clause unfolding dynCall_dynCall_exn + by (rule DynProc_exnModifyReturnNoAbr) + +lemma ProcDyn_exnModifyReturnNoAbrSameFaults: + assumes to_prove: "\,\\\<^sub>t\<^bsub>/F\<^esub> P (dynCall_exn f g init p return' result_exn c) Q,A" + assumes ret_nrm_modif: "\s t. t \ (Modif (init s)) + \ return' s t = return s t" + assumes modif_clause: + "\s \ P. \\. \,\\\<^bsub>/F\<^esub> {\} (Call (p s)) (Modif \),{}" + shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (dynCall_exn f g init p return result_exn c) Q,A" proof - from ret_nrm_modif have "\s t. t \ (Modif (init s)) @@ -941,33 +1096,44 @@ proof - \ return' s t = return s t" by simp have ret_abr_modif': "\s t. t \ {} - \ return' s t = return s t" + \ result_exn (return' s t) t = result_exn (return s t) t" by simp from to_prove ret_nrm_modif' ret_abr_modif' modif_clause show ?thesis - by (rule dynProcModifyReturn) + by (rule dynProc_exnModifyReturnSameFaults) qed + lemma ProcDynModifyReturnNoAbrSameFaults: assumes to_prove: "\,\\\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return' c) Q,A" assumes ret_nrm_modif: "\s t. t \ (Modif (init s)) \ return' s t = return s t" assumes modif_clause: "\s \ P. \\. \,\\\<^bsub>/F\<^esub> {\} (Call (p s)) (Modif \),{}" - shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" + shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" + using to_prove ret_nrm_modif modif_clause unfolding dynCall_dynCall_exn + by (rule ProcDyn_exnModifyReturnNoAbrSameFaults) + +lemma Proc_exnProcParModifyReturn: + assumes q: "P \ {s. p s = q} \ P'" + \ \@{thm[source] DynProcProcPar} introduces the same constraint as first conjunction in + @{term P'}, so the vcg can simplify it.\ + assumes to_prove: "\,\\\<^sub>t\<^bsub>/F\<^esub> P' (dynCall_exn f g init p return' result_exn c) Q,A" + assumes ret_nrm_modif: "\s t. t \ (Modif (init s)) + \ return' s t = return s t" + assumes ret_abr_modif: "\s t. t \ (ModifAbr (init s)) + \ result_exn (return' s t) t = result_exn (return s t) t" + assumes modif_clause: + "\\. \,\\\<^bsub>/UNIV\<^esub> {\} (Call q) (Modif \),(ModifAbr \)" + shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (dynCall_exn f g init p return result_exn c) Q,A" proof - - from ret_nrm_modif - have "\s t. t \ (Modif (init s)) - \ return' s t = return s t" - by iprover - then - have ret_nrm_modif': "\s t. t \ (Modif (init s)) - \ return' s t = return s t" - by simp - have ret_abr_modif': "\s t. t \ {} - \ return' s t = return s t" - by simp - from to_prove ret_nrm_modif' ret_abr_modif' modif_clause show ?thesis - by (rule dynProcModifyReturnSameFaults) + from to_prove have "\,\\\<^sub>t\<^bsub>/F\<^esub> ({s. p s = q} \ P') (dynCall_exn f g init p return' result_exn c) Q,A" + by (rule conseqPre) blast + from this ret_nrm_modif + ret_abr_modif + have "\,\\\<^sub>t\<^bsub>/F\<^esub> ({s. p s = q} \ P') (dynCall_exn f g init p return result_exn c) Q,A" + by (rule dynProc_exnModifyReturn) (insert modif_clause,auto) + from this q show ?thesis + by (rule conseqPre) qed lemma ProcProcParModifyReturn: @@ -981,20 +1147,35 @@ lemma ProcProcParModifyReturn: \ return' s t = return s t" assumes modif_clause: "\\. \,\\\<^bsub>/UNIV\<^esub> {\} (Call q) (Modif \),(ModifAbr \)" - shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" + shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" + using q to_prove ret_nrm_modif ret_abr_modif modif_clause unfolding dynCall_dynCall_exn + by (rule Proc_exnProcParModifyReturn) + +lemma Proc_exnProcParModifyReturnSameFaults: + assumes q: "P \ {s. p s = q} \ P'" + \ \@{thm[source] DynProcProcPar} introduces the same constraint as first conjunction in + @{term P'}, so the vcg can simplify it.\ + assumes to_prove: "\,\\\<^sub>t\<^bsub>/F\<^esub> P' (dynCall_exn f g init p return' result_exn c) Q,A" + assumes ret_nrm_modif: "\s t. t \ (Modif (init s)) + \ return' s t = return s t" + assumes ret_abr_modif: "\s t. t \ (ModifAbr (init s)) + \ result_exn (return' s t) t = result_exn (return s t) t" + assumes modif_clause: + "\\. \,\\\<^bsub>/F\<^esub> {\} Call q (Modif \),(ModifAbr \)" + shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (dynCall_exn f g init p return result_exn c) Q,A" proof - - from to_prove have "\,\\\<^sub>t\<^bsub>/F\<^esub> ({s. p s = q} \ P') (dynCall init p return' c) Q,A" + from to_prove + have "\,\\\<^sub>t\<^bsub>/F\<^esub> ({s. p s = q} \ P') (dynCall_exn f g init p return' result_exn c) Q,A" by (rule conseqPre) blast from this ret_nrm_modif ret_abr_modif - have "\,\\\<^sub>t\<^bsub>/F\<^esub> ({s. p s = q} \ P') (dynCall init p return c) Q,A" - by (rule dynProcModifyReturn) (insert modif_clause,auto) + have "\,\\\<^sub>t\<^bsub>/F\<^esub> ({s. p s = q} \ P') (dynCall_exn f g init p return result_exn c) Q,A" + by (rule dynProc_exnModifyReturnSameFaults) (insert modif_clause,auto) from this q show ?thesis by (rule conseqPre) qed - lemma ProcProcParModifyReturnSameFaults: assumes q: "P \ {s. p s = q} \ P'" \ \@{thm[source] DynProcProcPar} introduces the same constraint as first conjunction in @@ -1006,15 +1187,26 @@ lemma ProcProcParModifyReturnSameFaults: \ return' s t = return s t" assumes modif_clause: "\\. \,\\\<^bsub>/F\<^esub> {\} Call q (Modif \),(ModifAbr \)" - shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" + shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" + using q to_prove ret_nrm_modif ret_abr_modif modif_clause unfolding dynCall_dynCall_exn + by (rule Proc_exnProcParModifyReturnSameFaults) + +lemma Proc_exnProcParModifyReturnNoAbr: + assumes q: "P \ {s. p s = q} \ P'" + \ \@{thm[source] DynProcProcParNoAbrupt} introduces the same constraint as + first conjunction in @{term P'}, so the vcg can simplify it.\ + assumes to_prove: "\,\\\<^sub>t\<^bsub>/F\<^esub> P' (dynCall_exn f g init p return' result_exn c) Q,A" + assumes ret_nrm_modif: "\s t. t \ (Modif (init s)) + \ return' s t = return s t" + assumes modif_clause: + "\\. \,\\\<^bsub>/UNIV\<^esub> {\} (Call q) (Modif \),{}" + shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (dynCall_exn f g init p return result_exn c) Q,A" proof - - from to_prove - have "\,\\\<^sub>t\<^bsub>/F\<^esub> ({s. p s = q} \ P') (dynCall init p return' c) Q,A" + from to_prove have "\,\\\<^sub>t\<^bsub>/F\<^esub> ({s. p s = q} \ P') (dynCall_exn f g init p return' result_exn c) Q,A" by (rule conseqPre) blast from this ret_nrm_modif - ret_abr_modif - have "\,\\\<^sub>t\<^bsub>/F\<^esub> ({s. p s = q} \ P') (dynCall init p return c) Q,A" - by (rule dynProcModifyReturnSameFaults) (insert modif_clause,auto) + have "\,\\\<^sub>t\<^bsub>/F\<^esub> ({s. p s = q} \ P') (dynCall_exn f g init p return result_exn c) Q,A" + by (rule DynProc_exnModifyReturnNoAbr) (insert modif_clause,auto) from this q show ?thesis by (rule conseqPre) qed @@ -1028,18 +1220,32 @@ lemma ProcProcParModifyReturnNoAbr: \ return' s t = return s t" assumes modif_clause: "\\. \,\\\<^bsub>/UNIV\<^esub> {\} (Call q) (Modif \),{}" - shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" + shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" + using q to_prove ret_nrm_modif modif_clause unfolding dynCall_dynCall_exn + by (rule Proc_exnProcParModifyReturnNoAbr) + + +lemma Proc_exnProcParModifyReturnNoAbrSameFaults: + assumes q: "P \ {s. p s = q} \ P'" + \ \@{thm[source] DynProcProcParNoAbrupt} introduces the same constraint as + first conjunction in @{term P'}, so the vcg can simplify it.\ + assumes to_prove: "\,\\\<^sub>t\<^bsub>/F\<^esub> P' (dynCall_exn f g init p return' result_exn c) Q,A" + assumes ret_nrm_modif: "\s t. t \ (Modif (init s)) + \ return' s t = return s t" + assumes modif_clause: + "\\. \,\\\<^bsub>/F\<^esub> {\} (Call q) (Modif \),{}" + shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (dynCall_exn f g init p return result_exn c) Q,A" proof - - from to_prove have "\,\\\<^sub>t\<^bsub>/F\<^esub> ({s. p s = q} \ P') (dynCall init p return' c) Q,A" + from to_prove have + "\,\\\<^sub>t\<^bsub>/F\<^esub> ({s. p s = q} \ P') (dynCall_exn f g init p return' result_exn c) Q,A" by (rule conseqPre) blast from this ret_nrm_modif - have "\,\\\<^sub>t\<^bsub>/F\<^esub> ({s. p s = q} \ P') (dynCall init p return c) Q,A" - by (rule DynProcModifyReturnNoAbr) (insert modif_clause,auto) + have "\,\\\<^sub>t\<^bsub>/F\<^esub> ({s. p s = q} \ P') (dynCall_exn f g init p return result_exn c) Q,A" + by (rule ProcDyn_exnModifyReturnNoAbrSameFaults) (insert modif_clause,auto) from this q show ?thesis by (rule conseqPre) qed - lemma ProcProcParModifyReturnNoAbrSameFaults: assumes q: "P \ {s. p s = q} \ P'" \ \@{thm[source] DynProcProcParNoAbrupt} introduces the same constraint as @@ -1049,17 +1255,10 @@ lemma ProcProcParModifyReturnNoAbrSameFaults: \ return' s t = return s t" assumes modif_clause: "\\. \,\\\<^bsub>/F\<^esub> {\} (Call q) (Modif \),{}" - shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" -proof - - from to_prove have - "\,\\\<^sub>t\<^bsub>/F\<^esub> ({s. p s = q} \ P') (dynCall init p return' c) Q,A" - by (rule conseqPre) blast - from this ret_nrm_modif - have "\,\\\<^sub>t\<^bsub>/F\<^esub> ({s. p s = q} \ P') (dynCall init p return c) Q,A" - by (rule ProcDynModifyReturnNoAbrSameFaults) (insert modif_clause,auto) - from this q show ?thesis - by (rule conseqPre) -qed + shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" + using q to_prove ret_nrm_modif modif_clause unfolding dynCall_dynCall_exn + by (rule Proc_exnProcParModifyReturnNoAbrSameFaults) + lemma MergeGuards_iff: "\,\\\<^sub>t\<^bsub>/F\<^esub> P merge_guards c Q,A = \,\\\<^sub>t\<^bsub>/F\<^esub> P c Q,A" by (auto intro: MergeGuardsI MergeGuardsD) diff --git a/tools/c-parser/Simpl/HoareTotalDef.thy b/tools/c-parser/Simpl/HoareTotalDef.thy index 318c8ce15..1ddf92b64 100644 --- a/tools/c-parser/Simpl/HoareTotalDef.thy +++ b/tools/c-parser/Simpl/HoareTotalDef.thy @@ -1,29 +1,8 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL -*) -(* Title: HoareTotalDef.thy - Author: Norbert Schirmer, TU Muenchen - -Copyright (C) 2004-2008 Norbert Schirmer -Some rights reserved, TU Muenchen - -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA +Copyright (C) 2006-2008 Norbert Schirmer *) section \Hoare Logic for Total Correctness\ diff --git a/tools/c-parser/Simpl/HoareTotalProps.thy b/tools/c-parser/Simpl/HoareTotalProps.thy index 9559428a2..074eaa544 100644 --- a/tools/c-parser/Simpl/HoareTotalProps.thy +++ b/tools/c-parser/Simpl/HoareTotalProps.thy @@ -1,29 +1,9 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL -*) - -(* Title: HoarePartial.thy - Author: Norbert Schirmer, TU Muenchen Copyright (C) 2004-2008 Norbert Schirmer -Some rights reserved, TU Muenchen - -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA +Copyright (c) 2022 Apple Inc. All rights reserved. *) section \Properties of Total Correctness Hoare Logic\ @@ -2185,15 +2165,15 @@ subsection \And Now: Some Useful Rules\ subsubsection \Modify Return\ -lemma ProcModifyReturn_sound: - assumes valid_call: "\,\ \\<^sub>t\<^bsub>/F\<^esub> P call init p return' c Q,A" +lemma Proc_exnModifyReturn_sound: + assumes valid_call: "\,\ \\<^sub>t\<^bsub>/F\<^esub> P call_exn init p return' result_exn c Q,A" assumes valid_modif: "\\. \,\ \\<^bsub>/UNIV\<^esub> {\} (Call p) (Modif \),(ModifAbr \)" assumes res_modif: "\s t. t \ Modif (init s) \ return' s t = return s t" assumes ret_modifAbr: - "\s t. t \ ModifAbr (init s) \ return' s t = return s t" - shows "\,\ \\<^sub>t\<^bsub>/F\<^esub> P (call init p return c) Q,A" + "\s t. t \ ModifAbr (init s) \ result_exn (return' s t) t = result_exn (return s t) t" + shows "\,\ \\<^sub>t\<^bsub>/F\<^esub> P (call_exn init p return result_exn c) Q,A" proof (rule cvalidtI) fix s t assume ctxt: "\(P, p, Q, A)\\. \ \\<^sub>t\<^bsub>/F\<^esub> P (Call p) Q,A" @@ -2201,12 +2181,12 @@ proof (rule cvalidtI) by (auto simp add: validt_def) then have ctxt': "\(P, p, Q, A)\\. \ \\<^bsub>/UNIV\<^esub> P (Call p) Q,A" by (auto intro: valid_augment_Faults) - assume exec: "\\\call init p return c,Normal s\ \ t" + assume exec: "\\\call_exn init p return result_exn c,Normal s\ \ t" assume P: "s \ P" assume t_notin_F: "t \ Fault ` F" from exec show "t \ Normal ` Q \ Abrupt ` A" - proof (cases rule: exec_call_Normal_elim) + proof (cases rule: exec_call_exn_Normal_elim) fix bdy t' assume bdy: "\ p = Some bdy" assume exec_body: "\\\bdy,Normal (init s)\ \ Normal t'" @@ -2220,8 +2200,8 @@ proof (rule cvalidtI) with res_modif have "Normal (return' s t') = Normal (return s t')" by simp with exec_body exec_c bdy - have "\\\call init p return' c,Normal s\ \ t" - by (auto intro: exec_call) + have "\\\call_exn init p return' result_exn c,Normal s\ \ t" + by (auto intro: exec_call_exn) from cvalidt_postD [OF valid_call ctxt this] P t_notin_F show ?thesis by simp @@ -2229,19 +2209,19 @@ proof (rule cvalidtI) fix bdy t' assume bdy: "\ p = Some bdy" assume exec_body: "\\\bdy,Normal (init s)\ \ Abrupt t'" - assume t: "t = Abrupt (return s t')" + assume t: "t = Abrupt (result_exn (return s t') t')" also from exec_body bdy have "\\\(Call p),Normal (init s)\ \ Abrupt t'" by (auto simp add: intro: exec.intros) from cvalidD [OF valid_modif [rule_format, of "init s"] ctxt' this] P have "t' \ ModifAbr (init s)" by auto - with ret_modifAbr have "Abrupt (return s t') = Abrupt (return' s t')" + with ret_modifAbr have "Abrupt (result_exn (return s t') t') = Abrupt (result_exn (return' s t') t')" by simp - finally have "t = Abrupt (return' s t')" . + finally have "t = Abrupt (result_exn (return' s t') t')" . with exec_body bdy - have "\\\call init p return' c,Normal s\ \ t" - by (auto intro: exec_callAbrupt) + have "\\\call_exn init p return' result_exn c,Normal s\ \ t" + by (auto intro: exec_call_exnAbrupt) from cvalidt_postD [OF valid_call ctxt this] P t_notin_F show ?thesis by simp @@ -2250,8 +2230,8 @@ proof (rule cvalidtI) assume bdy: "\ p = Some bdy" assume "\\\bdy,Normal (init s)\ \ Fault f" and t: "t = Fault f" - with bdy have "\\\call init p return' c ,Normal s\ \ t" - by (auto intro: exec_callFault) + with bdy have "\\\call_exn init p return' result_exn c ,Normal s\ \ t" + by (auto intro: exec_call_exnFault) from cvalidt_postD [OF valid_call ctxt this P] t t_notin_F show ?thesis by simp @@ -2260,15 +2240,15 @@ proof (rule cvalidtI) assume bdy: "\ p = Some bdy" assume "\\\bdy,Normal (init s)\ \ Stuck" "t = Stuck" - with bdy have "\\\call init p return' c ,Normal s\ \ t" - by (auto intro: exec_callStuck) + with bdy have "\\\call_exn init p return' result_exn c ,Normal s\ \ t" + by (auto intro: exec_call_exnStuck) from valid_call ctxt this P t_notin_F show ?thesis by (rule cvalidt_postD) next assume "\ p = None" "t=Stuck" - hence "\\\call init p return' c ,Normal s\ \ t" - by (auto intro: exec_callUndefined) + hence "\\\call_exn init p return' result_exn c ,Normal s\ \ t" + by (auto intro: exec_call_exnUndefined) from valid_call ctxt this P t_notin_F show ?thesis by (rule cvalidt_postD) @@ -2282,9 +2262,9 @@ next by (auto intro: valid_augment_Faults) assume P: "s \ P" from valid_call ctxt P - have call: "\\call init p return' c\ Normal s" + have call: "\\call_exn init p return' result_exn c\ Normal s" by (rule cvalidt_termD) - show "\\call init p return c \ Normal s" + show "\\call_exn init p return result_exn c \ Normal s" proof (cases "p \ dom \") case True with call obtain bdy where @@ -2309,14 +2289,44 @@ next } with bdy termi_bdy show ?thesis - by (iprover intro: terminates_call) + by (iprover intro: terminates_call_exn) next case False thus ?thesis - by (auto intro: terminates_callUndefined) + by (auto intro: terminates_call_exnUndefined) qed qed +lemma ProcModifyReturn_sound: + assumes valid_call: "\,\ \\<^sub>t\<^bsub>/F\<^esub> P call init p return' c Q,A" + assumes valid_modif: + "\\. \,\ \\<^bsub>/UNIV\<^esub> {\} (Call p) (Modif \),(ModifAbr \)" + assumes res_modif: + "\s t. t \ Modif (init s) \ return' s t = return s t" + assumes ret_modifAbr: + "\s t. t \ ModifAbr (init s) \ return' s t = return s t" +shows "\,\ \\<^sub>t\<^bsub>/F\<^esub> P (call init p return c) Q,A" + using valid_call valid_modif res_modif ret_modifAbr unfolding call_call_exn + by (rule Proc_exnModifyReturn_sound) + + +lemma Proc_exnModifyReturn: + assumes spec: "\,\\\<^sub>t\<^bsub>/F\<^esub> P (call_exn init p return' result_exn c) Q,A" + assumes res_modif: + "\s t. t \ Modif (init s) \ (return' s t) = (return s t)" + assumes ret_modifAbr: + "\s t. t \ ModifAbr (init s) \ (result_exn (return' s t) t) = (result_exn (return s t) t)" + assumes modifies_spec: + "\\. \,\\\<^bsub>/UNIV\<^esub> {\} (Call p) (Modif \),(ModifAbr \)" + shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (call_exn init p return result_exn c) Q,A" +apply (rule hoaret_complete') +apply (rule Proc_exnModifyReturn_sound [where Modif=Modif and ModifAbr=ModifAbr, + OF _ _ res_modif ret_modifAbr]) +apply (rule hoaret_sound [OF spec]) +using modifies_spec +apply (blast intro: hoare_sound) +done + lemma ProcModifyReturn: assumes spec: "\,\\\<^sub>t\<^bsub>/F\<^esub> P (call init p return' c) Q,A" assumes res_modif: @@ -2325,35 +2335,29 @@ lemma ProcModifyReturn: "\s t. t \ ModifAbr (init s) \ (return' s t) = (return s t)" assumes modifies_spec: "\\. \,\\\<^bsub>/UNIV\<^esub> {\} (Call p) (Modif \),(ModifAbr \)" - shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (call init p return c) Q,A" -apply (rule hoaret_complete') -apply (rule ProcModifyReturn_sound [where Modif=Modif and ModifAbr=ModifAbr, - OF _ _ res_modif ret_modifAbr]) -apply (rule hoaret_sound [OF spec]) -using modifies_spec -apply (blast intro: hoare_sound) -done +shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (call init p return c) Q,A" + using spec res_modif ret_modifAbr modifies_spec unfolding call_call_exn by (rule Proc_exnModifyReturn) -lemma ProcModifyReturnSameFaults_sound: - assumes valid_call: "\,\ \\<^sub>t\<^bsub>/F\<^esub> P call init p return' c Q,A" +lemma Proc_exnModifyReturnSameFaults_sound: + assumes valid_call: "\,\ \\<^sub>t\<^bsub>/F\<^esub> P call_exn init p return' result_exn c Q,A" assumes valid_modif: "\\. \,\ \\<^bsub>/F\<^esub> {\} Call p (Modif \),(ModifAbr \)" assumes res_modif: "\s t. t \ Modif (init s) \ return' s t = return s t" assumes ret_modifAbr: - "\s t. t \ ModifAbr (init s) \ return' s t = return s t" - shows "\,\ \\<^sub>t\<^bsub>/F\<^esub> P (call init p return c) Q,A" + "\s t. t \ ModifAbr (init s) \ result_exn (return' s t) t = result_exn (return s t) t" + shows "\,\ \\<^sub>t\<^bsub>/F\<^esub> P (call_exn init p return result_exn c) Q,A" proof (rule cvalidtI) fix s t assume ctxt: "\(P, p, Q, A)\\. \ \\<^sub>t\<^bsub>/F\<^esub> P (Call p) Q,A" hence ctxt': "\(P, p, Q, A)\\. \ \\<^bsub>/F\<^esub> P (Call p) Q,A" by (auto simp add: validt_def) - assume exec: "\\\call init p return c,Normal s\ \ t" + assume exec: "\\\call_exn init p return result_exn c,Normal s\ \ t" assume P: "s \ P" assume t_notin_F: "t \ Fault ` F" from exec show "t \ Normal ` Q \ Abrupt ` A" - proof (cases rule: exec_call_Normal_elim) + proof (cases rule: exec_call_exn_Normal_elim) fix bdy t' assume bdy: "\ p = Some bdy" assume exec_body: "\\\bdy,Normal (init s)\ \ Normal t'" @@ -2367,8 +2371,8 @@ proof (rule cvalidtI) with res_modif have "Normal (return' s t') = Normal (return s t')" by simp with exec_body exec_c bdy - have "\\\call init p return' c,Normal s\ \ t" - by (auto intro: exec_call) + have "\\\call_exn init p return' result_exn c,Normal s\ \ t" + by (auto intro: exec_call_exn) from cvalidt_postD [OF valid_call ctxt this] P t_notin_F show ?thesis by simp @@ -2376,7 +2380,7 @@ proof (rule cvalidtI) fix bdy t' assume bdy: "\ p = Some bdy" assume exec_body: "\\\bdy,Normal (init s)\ \ Abrupt t'" - assume t: "t = Abrupt (return s t')" + assume t: "t = Abrupt (result_exn (return s t') t')" also from exec_body bdy have "\\\Call p ,Normal (init s)\ \ Abrupt t'" @@ -2384,12 +2388,12 @@ proof (rule cvalidtI) from cvalidD [OF valid_modif [rule_format, of "init s"] ctxt' this] P have "t' \ ModifAbr (init s)" by auto - with ret_modifAbr have "Abrupt (return s t') = Abrupt (return' s t')" + with ret_modifAbr have "Abrupt (result_exn (return s t') t') = Abrupt (result_exn (return' s t') t')" by simp - finally have "t = Abrupt (return' s t')" . + finally have "t = Abrupt (result_exn (return' s t') t')" . with exec_body bdy - have "\\\call init p return' c,Normal s\ \ t" - by (auto intro: exec_callAbrupt) + have "\\\call_exn init p return' result_exn c,Normal s\ \ t" + by (auto intro: exec_call_exnAbrupt) from cvalidt_postD [OF valid_call ctxt this] P t_notin_F show ?thesis by simp @@ -2398,8 +2402,8 @@ proof (rule cvalidtI) assume bdy: "\ p = Some bdy" assume "\\\bdy,Normal (init s)\ \ Fault f" and t: "t = Fault f" - with bdy have "\\\call init p return' c ,Normal s\ \ t" - by (auto intro: exec_callFault) + with bdy have "\\\call_exn init p return' result_exn c ,Normal s\ \ t" + by (auto intro: exec_call_exnFault) from cvalidt_postD [OF valid_call ctxt this P] t t_notin_F show ?thesis by simp @@ -2408,15 +2412,15 @@ proof (rule cvalidtI) assume bdy: "\ p = Some bdy" assume "\\\bdy,Normal (init s)\ \ Stuck" "t = Stuck" - with bdy have "\\\call init p return' c,Normal s\ \ t" - by (auto intro: exec_callStuck) + with bdy have "\\\call_exn init p return' result_exn c,Normal s\ \ t" + by (auto intro: exec_call_exnStuck) from valid_call ctxt this P t_notin_F show ?thesis by (rule cvalidt_postD) next assume "\ p = None" "t=Stuck" - hence "\\\call init p return' c,Normal s\ \ t" - by (auto intro: exec_callUndefined) + hence "\\\call_exn init p return' result_exn c,Normal s\ \ t" + by (auto intro: exec_call_exnUndefined) from valid_call ctxt this P t_notin_F show ?thesis by (rule cvalidt_postD) @@ -2428,9 +2432,9 @@ next by (auto simp add: validt_def) assume P: "s \ P" from valid_call ctxt P - have call: "\\call init p return' c\ Normal s" + have call: "\\call_exn init p return' result_exn c\ Normal s" by (rule cvalidt_termD) - show "\\call init p return c \ Normal s" + show "\\call_exn init p return result_exn c \ Normal s" proof (cases "p \ dom \") case True with call obtain bdy where @@ -2455,14 +2459,44 @@ next } with bdy termi_bdy show ?thesis - by (iprover intro: terminates_call) + by (iprover intro: terminates_call_exn) next case False thus ?thesis - by (auto intro: terminates_callUndefined) + by (auto intro: terminates_call_exnUndefined) qed qed +lemma ProcModifyReturnSameFaults_sound: + assumes valid_call: "\,\ \\<^sub>t\<^bsub>/F\<^esub> P call init p return' c Q,A" + assumes valid_modif: + "\\. \,\ \\<^bsub>/F\<^esub> {\} Call p (Modif \),(ModifAbr \)" + assumes res_modif: + "\s t. t \ Modif (init s) \ return' s t = return s t" + assumes ret_modifAbr: + "\s t. t \ ModifAbr (init s) \ return' s t = return s t" +shows "\,\ \\<^sub>t\<^bsub>/F\<^esub> P (call init p return c) Q,A" + using valid_call valid_modif res_modif ret_modifAbr unfolding call_call_exn + by (rule Proc_exnModifyReturnSameFaults_sound) + +lemma Proc_exnModifyReturnSameFaults: + assumes spec: "\,\\\<^sub>t\<^bsub>/F\<^esub> P (call_exn init p return' result_exn c) Q,A" + assumes res_modif: + "\s t. t \ Modif (init s) \ (return' s t) = (return s t)" + assumes ret_modifAbr: + "\s t. t \ ModifAbr (init s) \ result_exn (return' s t) t = result_exn (return s t) t" + assumes modifies_spec: + "\\. \,\\\<^bsub>/F\<^esub> {\} (Call p) (Modif \),(ModifAbr \)" + shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (call_exn init p return result_exn c) Q,A" +apply (rule hoaret_complete') +apply (rule Proc_exnModifyReturnSameFaults_sound [where Modif=Modif and ModifAbr=ModifAbr, + OF _ _ res_modif ret_modifAbr]) +apply (rule hoaret_sound [OF spec]) +using modifies_spec +apply (blast intro: hoare_sound) +done + + lemma ProcModifyReturnSameFaults: assumes spec: "\,\\\<^sub>t\<^bsub>/F\<^esub> P (call init p return' c) Q,A" assumes res_modif: @@ -2471,27 +2505,22 @@ lemma ProcModifyReturnSameFaults: "\s t. t \ ModifAbr (init s) \ (return' s t) = (return s t)" assumes modifies_spec: "\\. \,\\\<^bsub>/F\<^esub> {\} (Call p) (Modif \),(ModifAbr \)" - shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (call init p return c) Q,A" -apply (rule hoaret_complete') -apply (rule ProcModifyReturnSameFaults_sound [where Modif=Modif and ModifAbr=ModifAbr, - OF _ _ res_modif ret_modifAbr]) -apply (rule hoaret_sound [OF spec]) -using modifies_spec -apply (blast intro: hoare_sound) -done +shows "\,\\\<^sub>t\<^bsub>/F\<^esub> P (call init p return c) Q,A" + using spec res_modif ret_modifAbr modifies_spec unfolding call_call_exn + by (rule Proc_exnModifyReturnSameFaults) + subsubsection \DynCall\ - -lemma dynProcModifyReturn_sound: -assumes valid_call: "\,\ \\<^sub>t\<^bsub>/F\<^esub> P dynCall init p return' c Q,A" +lemma dynProc_exnModifyReturn_sound: +assumes valid_call: "\,\ \\<^sub>t\<^bsub>/F\<^esub> P dynCall_exn f g init p return' result_exn c Q,A" assumes valid_modif: "\s\P. \\. \,\ \\<^bsub>/UNIV\<^esub> {\} (Call (p s)) (Modif \),(ModifAbr \)" assumes ret_modif: "\s t. t \ Modif (init s) \ return' s t = return s t" -assumes ret_modifAbr: "\s t. t \ ModifAbr (init s) \ return' s t = return s t" -shows "\,\ \\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" +assumes ret_modifAbr: "\s t. t \ ModifAbr (init s) \ result_exn (return' s t) t = result_exn (return s t) t" +shows "\,\ \\<^sub>t\<^bsub>/F\<^esub> P (dynCall_exn f g init p return result_exn c) Q,A" proof (rule cvalidtI) fix s t assume ctxt: "\(P, p, Q, A)\\. \ \\<^sub>t\<^bsub>/F\<^esub> P (Call p) Q,A" @@ -2499,7 +2528,7 @@ proof (rule cvalidtI) by (auto simp add: validt_def) then have ctxt': "\(P, p, Q, A)\\. \ \\<^bsub>/UNIV\<^esub> P (Call p) Q,A" by (auto intro: valid_augment_Faults) - assume exec: "\\\dynCall init p return c,Normal s\ \ t" + assume exec: "\\\dynCall_exn f g init p return result_exn c,Normal s\ \ t" assume t_notin_F: "t \ Fault ` F" assume P: "s \ P" with valid_modif @@ -2507,87 +2536,107 @@ proof (rule cvalidtI) "\\. \,\\\<^bsub>/UNIV\<^esub> {\} (Call (p s)) (Modif \),(ModifAbr \)" by blast from exec - have "\\\call init (p s) return c,Normal s\ \ t" - by (cases rule: exec_dynCall_Normal_elim) + have "\\\maybe_guard f g (call_exn init (p s) return result_exn c),Normal s\ \ t" + by (cases rule: exec_dynCall_exn_Normal_elim) then show "t \ Normal ` Q \ Abrupt ` A" - proof (cases rule: exec_call_Normal_elim) - fix bdy t' - assume bdy: "\ (p s) = Some bdy" - assume exec_body: "\\\bdy,Normal (init s)\ \ Normal t'" - assume exec_c: "\\\c s t',Normal (return s t')\ \ t" - from exec_body bdy - have "\\\Call (p s),Normal (init s)\ \ Normal t'" - by (auto simp add: intro: exec.Call) - from cvalidD [OF valid_modif' [rule_format, of "init s"] ctxt' this] P - have "t' \ Modif (init s)" - by auto - with ret_modif have "Normal (return' s t') = - Normal (return s t')" - by simp - with exec_body exec_c bdy - have "\\\call init (p s) return' c,Normal s\ \ t" - by (auto intro: exec_call) - hence "\\\dynCall init p return' c,Normal s\ \ t" - by (rule exec_dynCall) + proof (cases rule: exec_maybe_guard_Normal_elim_cases) + case noFault + from noFault have guards_ok: "s \ g" by simp + from noFault have "\\ \call_exn init (p s) return result_exn c,Normal s\ \ t" by simp + then show "t \ Normal ` Q \ Abrupt ` A" + proof (cases rule: exec_call_exn_Normal_elim) + fix bdy t' + assume bdy: "\ (p s) = Some bdy" + assume exec_body: "\\\bdy,Normal (init s)\ \ Normal t'" + assume exec_c: "\\\c s t',Normal (return s t')\ \ t" + from exec_body bdy + have "\\\Call (p s),Normal (init s)\ \ Normal t'" + by (auto simp add: intro: exec.Call) + from cvalidD [OF valid_modif' [rule_format, of "init s"] ctxt' this] P + have "t' \ Modif (init s)" + by auto + with ret_modif have "Normal (return' s t') = + Normal (return s t')" + by simp + with exec_body exec_c bdy + have "\\\call_exn init (p s) return' result_exn c,Normal s\ \ t" + by (auto intro: exec_call_exn) + from exec_maybe_guard_noFault [OF this guards_ok] + have "\\\dynCall_exn f g init p return' result_exn c,Normal s\ \ t" + by (simp add: dynCall_exn_def exec_maybe_guard_DynCom) + from cvalidt_postD [OF valid_call ctxt this] P t_notin_F + show ?thesis + by simp + next + fix bdy t' + assume bdy: "\ (p s) = Some bdy" + assume exec_body: "\\\bdy,Normal (init s)\ \ Abrupt t'" + assume t: "t = Abrupt (result_exn (return s t') t')" + also from exec_body bdy + have "\\\Call (p s) ,Normal (init s)\ \ Abrupt t'" + by (auto simp add: intro: exec.intros) + from cvalidD [OF valid_modif' [rule_format, of "init s"] ctxt' this] P + have "t' \ ModifAbr (init s)" + by auto + with ret_modifAbr have "Abrupt (result_exn (return s t') t') = Abrupt (result_exn (return' s t') t')" + by simp + finally have "t = Abrupt (result_exn (return' s t') t')" . + with exec_body bdy + have "\\\call_exn init (p s) return' result_exn c,Normal s\ \ t" + by (auto intro: exec_call_exnAbrupt) + from exec_maybe_guard_noFault [OF this guards_ok] + have "\\\dynCall_exn f g init p return' result_exn c,Normal s\ \ t" + by (simp add: dynCall_exn_def exec_maybe_guard_DynCom) + from cvalidt_postD [OF valid_call ctxt this] P t_notin_F + show ?thesis + by simp + next + fix bdy f' + assume bdy: "\ (p s) = Some bdy" + assume "\\\bdy,Normal (init s)\ \ Fault f'" and + t: "t = Fault f'" + with bdy have "\\\call_exn init (p s) return' result_exn c ,Normal s\ \ t" + by (auto intro: exec_call_exnFault) + from exec_maybe_guard_noFault [OF this guards_ok] + have "\\\dynCall_exn f g init p return' result_exn c,Normal s\ \ t" + by (simp add: dynCall_exn_def exec_maybe_guard_DynCom) + from cvalidt_postD [OF valid_call ctxt this P] t t_notin_F + show ?thesis + by blast + next + fix bdy + assume bdy: "\ (p s) = Some bdy" + assume "\\\bdy,Normal (init s)\ \ Stuck" + "t = Stuck" + with bdy have "\\\call_exn init (p s) return' result_exn c ,Normal s\ \ t" + by (auto intro: exec_call_exnStuck) + from exec_maybe_guard_noFault [OF this guards_ok] + have "\\\dynCall_exn f g init p return' result_exn c,Normal s\ \ t" + by (simp add: dynCall_exn_def exec_maybe_guard_DynCom) + from valid_call ctxt this P t_notin_F + show ?thesis + by (rule cvalidt_postD) + next + fix bdy + assume "\ (p s) = None" "t=Stuck" + hence "\\\call_exn init (p s) return' result_exn c ,Normal s\ \ t" + by (auto intro: exec_call_exnUndefined) + from exec_maybe_guard_noFault [OF this guards_ok] + have "\\\dynCall_exn f g init p return' result_exn c,Normal s\ \ t" + by (simp add: dynCall_exn_def exec_maybe_guard_DynCom) + from valid_call ctxt this P t_notin_F + show ?thesis + by (rule cvalidt_postD) + qed + next + case (someFault) + then obtain guards_fail:"s \ g" + and t: "t = Fault f" by simp + from exec_maybe_guard_Fault [OF guards_fail] t + have "\\\dynCall_exn f g init p return' result_exn c,Normal s\ \ t" + by (simp add: dynCall_exn_def exec_guards_DynCom) from cvalidt_postD [OF valid_call ctxt this] P t_notin_F - show ?thesis - by simp - next - fix bdy t' - assume bdy: "\ (p s) = Some bdy" - assume exec_body: "\\\bdy,Normal (init s)\ \ Abrupt t'" - assume t: "t = Abrupt (return s t')" - also from exec_body bdy - have "\\\Call (p s) ,Normal (init s)\ \ Abrupt t'" - by (auto simp add: intro: exec.intros) - from cvalidD [OF valid_modif' [rule_format, of "init s"] ctxt' this] P - have "t' \ ModifAbr (init s)" - by auto - with ret_modifAbr have "Abrupt (return s t') = Abrupt (return' s t')" - by simp - finally have "t = Abrupt (return' s t')" . - with exec_body bdy - have "\\\call init (p s) return' c,Normal s\ \ t" - by (auto intro: exec_callAbrupt) - hence "\\\dynCall init p return' c,Normal s\ \ t" - by (rule exec_dynCall) - from cvalidt_postD [OF valid_call ctxt this] P t_notin_F - show ?thesis - by simp - next - fix bdy f - assume bdy: "\ (p s) = Some bdy" - assume "\\\bdy,Normal (init s)\ \ Fault f" and - t: "t = Fault f" - with bdy have "\\\call init (p s) return' c ,Normal s\ \ t" - by (auto intro: exec_callFault) - hence "\\\dynCall init p return' c,Normal s\ \ t" - by (rule exec_dynCall) - from cvalidt_postD [OF valid_call ctxt this P] t t_notin_F - show ?thesis - by blast - next - fix bdy - assume bdy: "\ (p s) = Some bdy" - assume "\\\bdy,Normal (init s)\ \ Stuck" - "t = Stuck" - with bdy have "\\\call init (p s) return' c ,Normal s\ \ t" - by (auto intro: exec_callStuck) - hence "\\\dynCall init p return' c,Normal s\ \ t" - by (rule exec_dynCall) - from valid_call ctxt this P t_notin_F - show ?thesis - by (rule cvalidt_postD) - next - fix bdy - assume "\ (p s) = None" "t=Stuck" - hence "\\\call init (p s) return' c ,Normal s\ \ t" - by (auto intro: exec_callUndefined) - hence "\\\dynCall init p return' c,Normal s\ \ t" - by (rule exec_dynCall) - from valid_call ctxt this P t_notin_F - show ?thesis - by (rule cvalidt_postD) + show ?thesis by simp qed next fix s @@ -2598,45 +2647,87 @@ next by (auto intro: valid_augment_Faults) assume P: "s \ P" from valid_call ctxt P - have "\\dynCall init p return' c\ Normal s" + have "\\dynCall_exn f g init p return' result_exn c\ Normal s" by (rule cvalidt_termD) - hence call: "\\call init (p s) return' c\ Normal s" - by cases - have "\\call init (p s) return c \ Normal s" - proof (cases "p s \ dom \") - case True - with call obtain bdy where - bdy: "\ (p s) = Some bdy" and termi_bdy: "\\bdy \ Normal (init s)" and - termi_c: "\t. \\\bdy,Normal (init s)\ \ Normal t \ - \\c s t \ Normal (return' s t)" - by cases auto - { - fix t - assume exec_bdy: "\\\bdy,Normal (init s)\ \ Normal t" - hence "\\c s t \ Normal (return s t)" - proof - - from exec_bdy bdy - have "\\\Call (p s),Normal (init s)\ \ Normal t" - by (auto simp add: intro: exec.intros) - from cvalidD [OF valid_modif [rule_format, of s "init s"] ctxt' this] P - ret_modif - have "return' s t = return s t" - by auto - with termi_c exec_bdy show ?thesis by auto - qed - } - with bdy termi_bdy - show ?thesis - by (iprover intro: terminates_call) + thus "\\dynCall_exn f g init p return result_exn c \ Normal s" + proof (cases rule: terminates_dynCall_exn_elim) + case noFault + then obtain guards_ok: "s \ g" + and call: "\\call_exn init (p s) return' result_exn c\ Normal s" + by auto + have "\\call_exn init (p s) return result_exn c \ Normal s" + proof (cases "p s \ dom \") + case True + with call obtain bdy where + bdy: "\ (p s) = Some bdy" and termi_bdy: "\\bdy \ Normal (init s)" and + termi_c: "\t. \\\bdy,Normal (init s)\ \ Normal t \ + \\c s t \ Normal (return' s t)" + by cases auto + { + fix t + assume exec_bdy: "\\\bdy,Normal (init s)\ \ Normal t" + hence "\\c s t \ Normal (return s t)" + proof - + from exec_bdy bdy + have "\\\Call (p s),Normal (init s)\ \ Normal t" + by (auto simp add: intro: exec.intros) + from cvalidD [OF valid_modif [rule_format, of s "init s"] ctxt' this] P + ret_modif + have "return' s t = return s t" + by auto + with termi_c exec_bdy show ?thesis by auto + qed + } + with bdy termi_bdy + show ?thesis + by (iprover intro: terminates_call_exn) + next + case False + thus ?thesis + by (auto intro: terminates_call_exnUndefined) + qed + thus "\\dynCall_exn f g init p return result_exn c \ Normal s" + by (iprover intro: terminates_dynCall_exn) next - case False + case (someFault) + then have guard_fail: "s \ g" by simp thus ?thesis - by (auto intro: terminates_callUndefined) + by (simp add: terminates_maybe_guard_Fault dynCall_exn_def) qed - thus "\\dynCall init p return c \ Normal s" - by (iprover intro: terminates_dynCall) qed +lemma dynProcModifyReturn_sound: +assumes valid_call: "\,\ \\<^sub>t\<^bsub>/F\<^esub> P dynCall init p return' c Q,A" +assumes valid_modif: + "\s\P. \\. \,\ \\<^bsub>/UNIV\<^esub> {\} (Call (p s)) (Modif \),(ModifAbr \)" +assumes ret_modif: + "\s t. t \ Modif (init s) \ return' s t = return s t" +assumes ret_modifAbr: "\s t. t \ ModifAbr (init s) \ return' s t = return s t" +shows "\,\ \\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" + using valid_call valid_modif ret_modif ret_modifAbr unfolding dynCall_dynCall_exn + by (rule dynProc_exnModifyReturn_sound) + + +lemma dynProc_exnModifyReturn: +assumes dyn_call: "\,\\\<^sub>t\<^bsub>/F\<^esub> P dynCall_exn f g init p return' result_exn c Q,A" +assumes ret_modif: + "\s t. t \ Modif (init s) + \ return' s t = return s t" +assumes ret_modifAbr: "\s t. t \ ModifAbr (init s) + \ result_exn (return' s t) t = result_exn (return s t) t" +assumes modif: + "\s \ P. \\. + \,\\\<^bsub>/UNIV\<^esub> {\} Call (p s) (Modif \),(ModifAbr \)" +shows "\,\ \\<^sub>t\<^bsub>/F\<^esub> P (dynCall_exn f g init p return result_exn c) Q,A" +apply (rule hoaret_complete') +apply (rule dynProc_exnModifyReturn_sound + [where Modif=Modif and ModifAbr=ModifAbr, + OF hoaret_sound [OF dyn_call] _ ret_modif ret_modifAbr]) +apply (intro ballI allI) +apply (rule hoare_sound [OF modif [rule_format]]) +apply assumption + done + lemma dynProcModifyReturn: assumes dyn_call: "\,\\\<^sub>t\<^bsub>/F\<^esub> P dynCall init p return' c Q,A" assumes ret_modif: @@ -2647,15 +2738,188 @@ assumes ret_modifAbr: "\s t. t \ ModifAbr (init s) assumes modif: "\s \ P. \\. \,\\\<^bsub>/UNIV\<^esub> {\} Call (p s) (Modif \),(ModifAbr \)" -shows "\,\ \\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" -apply (rule hoaret_complete') -apply (rule dynProcModifyReturn_sound - [where Modif=Modif and ModifAbr=ModifAbr, - OF hoaret_sound [OF dyn_call] _ ret_modif ret_modifAbr]) -apply (intro ballI allI) -apply (rule hoare_sound [OF modif [rule_format]]) -apply assumption -done + shows "\,\ \\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" + using dyn_call ret_modif ret_modifAbr modif unfolding dynCall_dynCall_exn + by (rule dynProc_exnModifyReturn) + +lemma dynProc_exnModifyReturnSameFaults_sound: +assumes valid_call: "\,\ \\<^sub>t\<^bsub>/F\<^esub> P dynCall_exn f g init p return' result_exn c Q,A" +assumes valid_modif: + "\s\P. \\. \,\ \\<^bsub>/F\<^esub> {\} Call (p s) (Modif \),(ModifAbr \)" +assumes ret_modif: + "\s t. t \ Modif (init s) \ return' s t = return s t" +assumes ret_modifAbr: "\s t. t \ ModifAbr (init s) \ result_exn (return' s t) t = result_exn (return s t) t" +shows "\,\ \\<^sub>t\<^bsub>/F\<^esub> P (dynCall_exn f g init p return result_exn c) Q,A" +proof (rule cvalidtI) + fix s t + assume ctxt: "\(P, p, Q, A)\\. \ \\<^sub>t\<^bsub>/F\<^esub> P (Call p) Q,A" + hence ctxt': "\(P, p, Q, A)\\. \ \\<^bsub>/F\<^esub> P (Call p) Q,A" + by (auto simp add: validt_def) + assume exec: "\\\dynCall_exn f g init p return result_exn c,Normal s\ \ t" + assume t_notin_F: "t \ Fault ` F" + assume P: "s \ P" + with valid_modif + have valid_modif': + "\\. \,\\\<^bsub>/F\<^esub> {\} (Call (p s)) (Modif \),(ModifAbr \)" + by blast + from exec + have "\\\maybe_guard f g (call_exn init (p s) return result_exn c),Normal s\ \ t" + by (cases rule: exec_dynCall_exn_Normal_elim) + then show "t \ Normal ` Q \ Abrupt ` A" + proof (cases rule: exec_maybe_guard_Normal_elim_cases) + case noFault + from noFault have guards_ok: "s \ g" by simp + from noFault have "\\ \call_exn init (p s) return result_exn c,Normal s\ \ t" by simp + then show "t \ Normal ` Q \ Abrupt ` A" + proof (cases rule: exec_call_exn_Normal_elim) + fix bdy t' + assume bdy: "\ (p s) = Some bdy" + assume exec_body: "\\\bdy,Normal (init s)\ \ Normal t'" + assume exec_c: "\\\c s t',Normal (return s t')\ \ t" + from exec_body bdy + have "\\\Call (p s),Normal (init s)\ \ Normal t'" + by (auto simp add: intro: exec.intros) + from cvalidD [OF valid_modif' [rule_format, of "init s"] ctxt' this] P + have "t' \ Modif (init s)" + by auto + with ret_modif have "Normal (return' s t') = + Normal (return s t')" + by simp + with exec_body exec_c bdy + have "\\\call_exn init (p s) return' result_exn c,Normal s\ \ t" + by (auto intro: exec_call_exn) + from exec_maybe_guard_noFault [OF this guards_ok] + have "\\\dynCall_exn f g init p return' result_exn c,Normal s\ \ t" + by (simp add: dynCall_exn_def exec_maybe_guard_DynCom) + from cvalidt_postD [OF valid_call ctxt this] P t_notin_F + show ?thesis + by simp + next + fix bdy t' + assume bdy: "\ (p s) = Some bdy" + assume exec_body: "\\\bdy,Normal (init s)\ \ Abrupt t'" + assume t: "t = Abrupt (result_exn (return s t') t')" + also from exec_body bdy + have "\\\Call (p s) ,Normal (init s)\ \ Abrupt t'" + by (auto simp add: intro: exec.intros) + from cvalidD [OF valid_modif' [rule_format, of "init s"] ctxt' this] P + have "t' \ ModifAbr (init s)" + by auto + with ret_modifAbr have "Abrupt (result_exn (return s t') t') = Abrupt (result_exn (return' s t') t')" + by simp + finally have "t = Abrupt (result_exn (return' s t') t')" . + with exec_body bdy + have "\\\call_exn init (p s) return' result_exn c,Normal s\ \ t" + by (auto intro: exec_call_exnAbrupt) + from exec_maybe_guard_noFault [OF this guards_ok] + have "\\\dynCall_exn f g init p return' result_exn c,Normal s\ \ t" + by (simp add: dynCall_exn_def exec_maybe_guard_DynCom) + from cvalidt_postD [OF valid_call ctxt this] P t_notin_F + show ?thesis + by simp + next + fix bdy f' + assume bdy: "\ (p s) = Some bdy" + assume "\\\bdy,Normal (init s)\ \ Fault f'" and + t: "t = Fault f'" + with bdy have "\\\call_exn init (p s) return' result_exn c ,Normal s\ \ t" + by (auto intro: exec_call_exnFault) + from exec_maybe_guard_noFault [OF this guards_ok] + have "\\\dynCall_exn f g init p return' result_exn c,Normal s\ \ t" + by (simp add: dynCall_exn_def exec_maybe_guard_DynCom) + from cvalidt_postD [OF valid_call ctxt this P] t t_notin_F + show ?thesis + by simp + next + fix bdy + assume bdy: "\ (p s) = Some bdy" + assume "\\\bdy,Normal (init s)\ \ Stuck" + "t = Stuck" + with bdy have "\\\call_exn init (p s) return' result_exn c ,Normal s\ \ t" + by (auto intro: exec_call_exnStuck) + from exec_maybe_guard_noFault [OF this guards_ok] + have "\\\dynCall_exn f g init p return' result_exn c,Normal s\ \ t" + by (simp add: dynCall_exn_def exec_maybe_guard_DynCom) + from valid_call ctxt this P t_notin_F + show ?thesis + by (rule cvalidt_postD) + next + fix bdy + assume "\ (p s) = None" "t=Stuck" + hence "\\\call_exn init (p s) return' result_exn c ,Normal s\ \ t" + by (auto intro: exec_call_exnUndefined) + from exec_maybe_guard_noFault [OF this guards_ok] + have "\\\dynCall_exn f g init p return' result_exn c,Normal s\ \ t" + by (simp add: dynCall_exn_def exec_maybe_guard_DynCom) + from valid_call ctxt this P t_notin_F + show ?thesis + by (rule cvalidt_postD) + qed + next + case (someFault) + then obtain guards_fail:"s \ g" + and t: "t = Fault f" by simp + from exec_maybe_guard_Fault [OF guards_fail] t + have "\\\dynCall_exn f g init p return' result_exn c,Normal s\ \ t" + by (simp add: dynCall_exn_def exec_guards_DynCom) + from cvalidt_postD [OF valid_call ctxt this] P t_notin_F + show ?thesis by simp + qed +next + fix s + assume ctxt: "\(P, p, Q, A)\\. \ \\<^sub>t\<^bsub>/F\<^esub> P (Call p) Q,A" + hence ctxt': "\(P, p, Q, A)\\. \ \\<^bsub>/F\<^esub> P (Call p) Q,A" + by (auto simp add: validt_def) + assume P: "s \ P" + from valid_call ctxt P + have "\\dynCall_exn f g init p return' result_exn c\ Normal s" + by (rule cvalidt_termD) + thus "\\dynCall_exn f g init p return result_exn c \ Normal s" + proof (cases rule: terminates_dynCall_exn_elim) + case noFault + then obtain guards_ok: "s \ g" + and call: "\\call_exn init (p s) return' result_exn c\ Normal s" + by auto + have "\\call_exn init (p s) return result_exn c \ Normal s" + proof (cases "p s \ dom \") + case True + with call obtain bdy where + bdy: "\ (p s) = Some bdy" and termi_bdy: "\\bdy \ Normal (init s)" and + termi_c: "\t. \\\bdy,Normal (init s)\ \ Normal t \ + \\c s t \ Normal (return' s t)" + by cases auto + { + fix t + assume exec_bdy: "\\\bdy,Normal (init s)\ \ Normal t" + hence "\\c s t \ Normal (return s t)" + proof - + from exec_bdy bdy + have "\\\Call (p s),Normal (init s)\ \ Normal t" + by (auto simp add: intro: exec.intros) + from cvalidD [OF valid_modif [rule_format, of s "init s"] ctxt' this] P + ret_modif + have "return' s t = return s t" + by auto + with termi_c exec_bdy show ?thesis by auto + qed + } + with bdy termi_bdy + show ?thesis + by (iprover intro: terminates_call_exn) + next + case False + thus ?thesis + by (auto intro: terminates_call_exnUndefined) + qed + thus "\\dynCall_exn f g init p return result_exn c \ Normal s" + by (iprover intro: terminates_dynCall_exn) + next + case (someFault) + then have guard_fail: "s \ g" by simp + thus ?thesis + by (simp add: terminates_maybe_guard_Fault dynCall_exn_def) + qed +qed lemma dynProcModifyReturnSameFaults_sound: assumes valid_call: "\,\ \\<^sub>t\<^bsub>/F\<^esub> P dynCall init p return' c Q,A" @@ -2665,146 +2929,25 @@ assumes ret_modif: "\s t. t \ Modif (init s) \ return' s t = return s t" assumes ret_modifAbr: "\s t. t \ ModifAbr (init s) \ return' s t = return s t" shows "\,\ \\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" -proof (rule cvalidtI) - fix s t - assume ctxt: "\(P, p, Q, A)\\. \ \\<^sub>t\<^bsub>/F\<^esub> P (Call p) Q,A" - hence ctxt': "\(P, p, Q, A)\\. \ \\<^bsub>/F\<^esub> P (Call p) Q,A" - by (auto simp add: validt_def) - assume exec: "\\\dynCall init p return c,Normal s\ \ t" - assume t_notin_F: "t \ Fault ` F" - assume P: "s \ P" - with valid_modif - have valid_modif': - "\\. \,\\\<^bsub>/F\<^esub> {\} (Call (p s)) (Modif \),(ModifAbr \)" - by blast - from exec - have "\\\call init (p s) return c,Normal s\ \ t" - by (cases rule: exec_dynCall_Normal_elim) - then show "t \ Normal ` Q \ Abrupt ` A" - proof (cases rule: exec_call_Normal_elim) - fix bdy t' - assume bdy: "\ (p s) = Some bdy" - assume exec_body: "\\\bdy,Normal (init s)\ \ Normal t'" - assume exec_c: "\\\c s t',Normal (return s t')\ \ t" - from exec_body bdy - have "\\\Call (p s),Normal (init s)\ \ Normal t'" - by (auto simp add: intro: exec.intros) - from cvalidD [OF valid_modif' [rule_format, of "init s"] ctxt' this] P - have "t' \ Modif (init s)" - by auto - with ret_modif have "Normal (return' s t') = - Normal (return s t')" - by simp - with exec_body exec_c bdy - have "\\\call init (p s) return' c,Normal s\ \ t" - by (auto intro: exec_call) - hence "\\\dynCall init p return' c,Normal s\ \ t" - by (rule exec_dynCall) - from cvalidt_postD [OF valid_call ctxt this] P t_notin_F - show ?thesis - by simp - next - fix bdy t' - assume bdy: "\ (p s) = Some bdy" - assume exec_body: "\\\bdy,Normal (init s)\ \ Abrupt t'" - assume t: "t = Abrupt (return s t')" - also from exec_body bdy - have "\\\Call (p s) ,Normal (init s)\ \ Abrupt t'" - by (auto simp add: intro: exec.intros) - from cvalidD [OF valid_modif' [rule_format, of "init s"] ctxt' this] P - have "t' \ ModifAbr (init s)" - by auto - with ret_modifAbr have "Abrupt (return s t') = Abrupt (return' s t')" - by simp - finally have "t = Abrupt (return' s t')" . - with exec_body bdy - have "\\\call init (p s) return' c,Normal s\ \ t" - by (auto intro: exec_callAbrupt) - hence "\\\dynCall init p return' c,Normal s\ \ t" - by (rule exec_dynCall) - from cvalidt_postD [OF valid_call ctxt this] P t_notin_F - show ?thesis - by simp - next - fix bdy f - assume bdy: "\ (p s) = Some bdy" - assume "\\\bdy,Normal (init s)\ \ Fault f" and - t: "t = Fault f" - with bdy have "\\\call init (p s) return' c ,Normal s\ \ t" - by (auto intro: exec_callFault) - hence "\\\dynCall init p return' c,Normal s\ \ t" - by (rule exec_dynCall) - from cvalidt_postD [OF valid_call ctxt this P] t t_notin_F - show ?thesis - by simp - next - fix bdy - assume bdy: "\ (p s) = Some bdy" - assume "\\\bdy,Normal (init s)\ \ Stuck" - "t = Stuck" - with bdy have "\\\call init (p s) return' c ,Normal s\ \ t" - by (auto intro: exec_callStuck) - hence "\\\dynCall init p return' c,Normal s\ \ t" - by (rule exec_dynCall) - from valid_call ctxt this P t_notin_F - show ?thesis - by (rule cvalidt_postD) - next - fix bdy - assume "\ (p s) = None" "t=Stuck" - hence "\\\call init (p s) return' c ,Normal s\ \ t" - by (auto intro: exec_callUndefined) - hence "\\\dynCall init p return' c,Normal s\ \ t" - by (rule exec_dynCall) - from valid_call ctxt this P t_notin_F - show ?thesis - by (rule cvalidt_postD) - qed -next - fix s - assume ctxt: "\(P, p, Q, A)\\. \ \\<^sub>t\<^bsub>/F\<^esub> P (Call p) Q,A" - hence ctxt': "\(P, p, Q, A)\\. \ \\<^bsub>/F\<^esub> P (Call p) Q,A" - by (auto simp add: validt_def) - assume P: "s \ P" - from valid_call ctxt P - have "\\dynCall init p return' c\ Normal s" - by (rule cvalidt_termD) - hence call: "\\call init (p s) return' c\ Normal s" - by cases - have "\\call init (p s) return c \ Normal s" - proof (cases "p s \ dom \") - case True - with call obtain bdy where - bdy: "\ (p s) = Some bdy" and termi_bdy: "\\bdy \ Normal (init s)" and - termi_c: "\t. \\\bdy,Normal (init s)\ \ Normal t \ - \\c s t \ Normal (return' s t)" - by cases auto - { - fix t - assume exec_bdy: "\\\bdy,Normal (init s)\ \ Normal t" - hence "\\c s t \ Normal (return s t)" - proof - - from exec_bdy bdy - have "\\\Call (p s),Normal (init s)\ \ Normal t" - by (auto simp add: intro: exec.intros) - from cvalidD [OF valid_modif [rule_format, of s "init s"] ctxt' this] P - ret_modif - have "return' s t = return s t" - by auto - with termi_c exec_bdy show ?thesis by auto - qed - } - with bdy termi_bdy - show ?thesis - by (iprover intro: terminates_call) - next - case False - thus ?thesis - by (auto intro: terminates_callUndefined) - qed - thus "\\dynCall init p return c \ Normal s" - by (iprover intro: terminates_dynCall) -qed + using valid_call valid_modif ret_modif ret_modifAbr unfolding dynCall_dynCall_exn + by (rule dynProc_exnModifyReturnSameFaults_sound) + +lemma dynProc_exnModifyReturnSameFaults: +assumes dyn_call: "\,\\\<^sub>t\<^bsub>/F\<^esub> P dynCall_exn f g init p return' result_exn c Q,A" +assumes ret_modif: + "\s t. t \ Modif (init s) \ return' s t = return s t" +assumes ret_modifAbr: "\s t. t \ ModifAbr (init s) \ result_exn (return' s t) t = result_exn (return s t) t" +assumes modif: + "\s \ P. \\. \,\\\<^bsub>/F\<^esub> {\} Call (p s) (Modif \),(ModifAbr \)" +shows "\,\ \\<^sub>t\<^bsub>/F\<^esub> P (dynCall_exn f g init p return result_exn c) Q,A" +apply (rule hoaret_complete') +apply (rule dynProc_exnModifyReturnSameFaults_sound + [where Modif=Modif and ModifAbr=ModifAbr, + OF hoaret_sound [OF dyn_call] _ ret_modif ret_modifAbr]) +apply (intro ballI allI) +apply (rule hoare_sound [OF modif [rule_format]]) +apply assumption + done lemma dynProcModifyReturnSameFaults: assumes dyn_call: "\,\\\<^sub>t\<^bsub>/F\<^esub> P dynCall init p return' c Q,A" @@ -2813,15 +2956,10 @@ assumes ret_modif: assumes ret_modifAbr: "\s t. t \ ModifAbr (init s) \ return' s t = return s t" assumes modif: "\s \ P. \\. \,\\\<^bsub>/F\<^esub> {\} Call (p s) (Modif \),(ModifAbr \)" -shows "\,\ \\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" -apply (rule hoaret_complete') -apply (rule dynProcModifyReturnSameFaults_sound - [where Modif=Modif and ModifAbr=ModifAbr, - OF hoaret_sound [OF dyn_call] _ ret_modif ret_modifAbr]) -apply (intro ballI allI) -apply (rule hoare_sound [OF modif [rule_format]]) -apply assumption -done + shows "\,\ \\<^sub>t\<^bsub>/F\<^esub> P (dynCall init p return c) Q,A" + using dyn_call ret_modif ret_modifAbr modif unfolding dynCall_dynCall_exn + by (rule dynProc_exnModifyReturnSameFaults) + subsubsection \Conjunction of Postcondition\ diff --git a/tools/c-parser/Simpl/Language.thy b/tools/c-parser/Simpl/Language.thy index cff132d03..c9c3d2ba8 100644 --- a/tools/c-parser/Simpl/Language.thy +++ b/tools/c-parser/Simpl/Language.thy @@ -1,29 +1,9 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL -*) - -(* Title: Language.thy - Author: Norbert Schirmer, TU Muenchen Copyright (C) 2004-2008 Norbert Schirmer -Some rights reserved, TU Muenchen - -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA +Copyright (c) 2022 Apple Inc. All rights reserved. *) section \The Simpl Syntax\ @@ -76,13 +56,43 @@ definition "bseq = Seq" definition - block:: "['s\'s,('s,'p,'f) com,'s\'s\'s,'s\'s\('s,'p,'f) com]\('s,'p,'f) com" + block_exn:: "['s\'s,('s,'p,'f) com,'s\'s\'s,'s\'s\'s,'s\'s\('s,'p,'f) com]\('s,'p,'f) com" where - "block init bdy return c = - DynCom (\s. (Seq (Catch (Seq (Basic init) bdy) (Seq (Basic (return s)) Throw)) + "block_exn init bdy return result_exn c = + DynCom (\s. (Seq (Catch (Seq (Basic init) bdy) (Seq (Basic (\t. result_exn (return s t) t)) Throw)) (DynCom (\t. Seq (Basic (return s)) (c s t)))) )" +definition + call_exn:: "('s\'s) \ 'p \ ('s \ 's \ 's)\ ('s \ 's \ 's) \('s\'s\('s,'p,'f) com)\('s,'p,'f)com" where + "call_exn init p return result_exn c = block_exn init (Call p) return result_exn c" + +primrec guards:: "('f \ 's set ) list \ ('s,'p,'f) com \ ('s,'p,'f) com" +where +"guards [] c = c" | +"guards (g#gs) c = Guard (fst g) (snd g) (guards gs c)" + + +definition maybe_guard:: "'f \ 's set \ ('s,'p,'f) com \ ('s,'p,'f) com" +where +"maybe_guard f g c = (if g = UNIV then c else Guard f g c)" + +lemma maybe_guard_UNIV [simp]: "maybe_guard f UNIV c = c" + by (simp add: maybe_guard_def) + + +definition + dynCall_exn:: "'f \ 's set \ ('s \ 's) \ ('s \ 'p) \ + ('s \ 's \ 's) \ ('s \ 's \ 's) \ ('s \ 's \ ('s,'p,'f) com) \ ('s,'p,'f) com" where + "dynCall_exn f g init p return result_exn c = + maybe_guard f g (DynCom (\s. call_exn init (p s) return result_exn c))" + +definition + block:: "['s\'s,('s,'p,'f) com,'s\'s\'s,'s\'s\('s,'p,'f) com]\('s,'p,'f) com" +where + "block init bdy return c = block_exn init bdy return (\s t. s) c" + + definition call:: "('s\'s) \ 'p \ ('s \ 's \ 's)\('s\'s\('s,'p,'f) com)\('s,'p,'f)com" where "call init p return c = block init (Call p) return c" @@ -92,11 +102,14 @@ definition ('s \ 's \ 's) \ ('s \ 's \ ('s,'p,'f) com) \ ('s,'p,'f) com" where "dynCall init p return c = DynCom (\s. call init (p s) return c)" + + definition fcall:: "('s\'s) \ 'p \ ('s \ 's \ 's)\('s \ 'v) \ ('v\('s,'p,'f) com) \('s,'p,'f)com" where "fcall init p return result c = call init p return (\s t. c (result t))" + definition lem:: "'x \ ('s,'p,'f)com \('s,'p,'f)com" where "lem x c = c" @@ -112,10 +125,6 @@ definition guaranteeStrip:: "'f \ 's set \ ('s,'p,'f) co definition guaranteeStripPair:: "'f \ 's set \ ('f \ 's set)" where "guaranteeStripPair f g = (f,g)" -primrec guards:: "('f \ 's set ) list \ ('s,'p,'f) com \ ('s,'p,'f) com" -where -"guards [] c = c" | -"guards (g#gs) c = Guard (fst g) (snd g) (guards gs c)" definition while:: "('f \ 's set) list \ 's bexp \ ('s,'p,'f) com \ ('s, 'p, 'f) com" @@ -160,6 +169,13 @@ lemma snd_guaranteeStripPair: "snd (guaranteeStripPair f g) = g" by (simp add: guaranteeStripPair_def) +lemma call_call_exn: "call init p return result = call_exn init p return (\s t. s) result" + by (simp add: call_def call_exn_def block_def) + +lemma dynCall_dynCall_exn: "dynCall init p return result = dynCall_exn undefined UNIV init p return (\s t. s) result" + by (simp add: dynCall_def dynCall_exn_def call_call_exn) + + subsection \Operations on Simpl-Syntax\ @@ -313,6 +329,10 @@ lemma flatten_bind [simp]: "flatten (bind e c) = [bind e c]" lemma flatten_bseq [simp]: "flatten (bseq c1 c2) = flatten c1 @ flatten c2" by (simp add: bseq_def) +lemma flatten_block_exn [simp]: + "flatten (block_exn init bdy return result_exn result) = [block_exn init bdy return result_exn result]" + by (simp add: block_exn_def) + lemma flatten_block [simp]: "flatten (block init bdy return result) = [block init bdy return result]" by (simp add: block_def) @@ -323,6 +343,12 @@ lemma flatten_call [simp]: "flatten (call init p return result) = [call init p r lemma flatten_dynCall [simp]: "flatten (dynCall init p return result) = [dynCall init p return result]" by (simp add: dynCall_def) +lemma flatten_call_exn [simp]: "flatten (call_exn init p return result_exn result) = [call_exn init p return result_exn result]" + by (simp add: call_exn_def) + +lemma flatten_dynCall_exn [simp]: "flatten (dynCall_exn f g init p return result_exn result) = [dynCall_exn f g init p return result_exn result]" + by (simp add: dynCall_exn_def maybe_guard_def) + lemma flatten_fcall [simp]: "flatten (fcall init p return result c) = [fcall init p return result c]" by (simp add: fcall_def) @@ -373,9 +399,9 @@ lemma normalize_bseq [simp]: ((flatten (normalize c1)) @ (flatten (normalize c2)))" by (simp add: bseq_def) -lemma normalize_block [simp]: "normalize (block init bdy return c) = - block init (normalize bdy) return (\s t. normalize (c s t))" - apply (simp add: block_def) +lemma normalize_block_exn [simp]: "normalize (block_exn init bdy return result_exn c) = + block_exn init (normalize bdy) return result_exn (\s t. normalize (c s t))" + apply (simp add: block_exn_def) apply (rule ext) apply (simp) apply (cases "flatten (normalize bdy)") @@ -397,15 +423,32 @@ lemma normalize_block [simp]: "normalize (block init bdy return c) = apply simp done +lemma normalize_block [simp]: "normalize (block init bdy return c) = + block init (normalize bdy) return (\s t. normalize (c s t))" + by (simp add: block_def) + lemma normalize_call [simp]: "normalize (call init p return c) = call init p return (\i t. normalize (c i t))" by (simp add: call_def) +lemma normalize_call_exn [simp]: + "normalize (call_exn init p return result_exn c) = call_exn init p return result_exn (\i t. normalize (c i t))" + by (simp add: call_exn_def) + lemma normalize_dynCall [simp]: "normalize (dynCall init p return c) = dynCall init p return (\s t. normalize (c s t))" by (simp add: dynCall_def) +lemma normalize_guards [simp]: + "normalize (guards gs c) = guards gs (normalize c)" + by (induct gs) auto + +lemma normalize_dynCall_exn [simp]: + "normalize (dynCall_exn f g init p return result_exn c) = + dynCall_exn f g init p return result_exn (\s t. normalize (c s t))" + by (simp add: dynCall_exn_def maybe_guard_def) + lemma normalize_fcall [simp]: "normalize (fcall init p return result c) = fcall init p return result (\v. normalize (c v))" @@ -421,9 +464,6 @@ lemma normalize_guaranteeStrip [simp]: "normalize (guaranteeStrip f g c) = guaranteeStrip f g (normalize c)" by (simp add: guaranteeStrip_def) -lemma normalize_guards [simp]: - "normalize (guards gs c) = guards gs (normalize c)" - by (induct gs) auto text \Sequencial composition with guards in the body is not preserved by normalize\ @@ -506,6 +546,11 @@ lemma strip_guards_bseq [simp]: "strip_guards F (bseq c1 c2) = bseq (strip_guards F c1) (strip_guards F c2)" by (simp add: bseq_def) +lemma strip_guards_block_exn [simp]: + "strip_guards F (block_exn init bdy return result_exn c) = + block_exn init (strip_guards F bdy) return result_exn (\s t. strip_guards F (c s t))" + by (simp add: block_exn_def) + lemma strip_guards_block [simp]: "strip_guards F (block init bdy return c) = block init (strip_guards F bdy) return (\s t. strip_guards F (c s t))" @@ -516,11 +561,25 @@ lemma strip_guards_call [simp]: call init p return (\s t. strip_guards F (c s t))" by (simp add: call_def) +lemma strip_guards_call_exn [simp]: + "strip_guards F (call_exn init p return result_exn c) = + call_exn init p return result_exn (\s t. strip_guards F (c s t))" + by (simp add: call_exn_def) + lemma strip_guards_dynCall [simp]: "strip_guards F (dynCall init p return c) = dynCall init p return (\s t. strip_guards F (c s t))" by (simp add: dynCall_def) +lemma strip_guards_guards [simp]: "strip_guards F (guards gs c) = + guards (filter (\(f,g). f \ F) gs) (strip_guards F c)" + by (induct gs) auto + +lemma strip_guards_dynCall_exn [simp]: + "strip_guards F (dynCall_exn f g init p return result_exn c) = + dynCall_exn f (if f \ F then UNIV else g) init p return result_exn (\s t. strip_guards F (c s t))" + by (simp add: dynCall_exn_def maybe_guard_def) + lemma strip_guards_fcall [simp]: "strip_guards F (fcall init p return result c) = fcall init p return result (\v. strip_guards F (c v))" @@ -540,9 +599,7 @@ lemma strip_guards_guaranteeStrip [simp]: lemma guaranteeStripPair_split_conv [simp]: "case_prod c (guaranteeStripPair f g) = c f g" by (simp add: guaranteeStripPair_def) -lemma strip_guards_guards [simp]: "strip_guards F (guards gs c) = - guards (filter (\(f,g). f \ F) gs) (strip_guards F c)" - by (induct gs) auto + lemma strip_guards_while [simp]: "strip_guards F (while gs b c) = @@ -602,6 +659,11 @@ lemma mark_guards_bseq [simp]: "mark_guards f (bseq c1 c2) = bseq (mark_guards f c1) (mark_guards f c2)" by (simp add: bseq_def) +lemma mark_guards_block_exn [simp]: + "mark_guards f (block_exn init bdy return result_exn c) = + block_exn init (mark_guards f bdy) return result_exn (\s t. mark_guards f (c s t))" + by (simp add: block_exn_def) + lemma mark_guards_block [simp]: "mark_guards f (block init bdy return c) = block init (mark_guards f bdy) return (\s t. mark_guards f (c s t))" @@ -612,11 +674,25 @@ lemma mark_guards_call [simp]: call init p return (\s t. mark_guards f (c s t))" by (simp add: call_def) +lemma mark_guards_call_exn [simp]: + "mark_guards f (call_exn init p return result_exn c) = + call_exn init p return result_exn (\s t. mark_guards f (c s t))" + by (simp add: call_exn_def) + lemma mark_guards_dynCall [simp]: "mark_guards f (dynCall init p return c) = dynCall init p return (\s t. mark_guards f (c s t))" by (simp add: dynCall_def) +lemma mark_guards_guards [simp]: + "mark_guards f (guards gs c) = guards (map (\(f',g). (f,g)) gs) (mark_guards f c)" + by (induct gs) auto + +lemma mark_guards_dynCall_exn [simp]: + "mark_guards f (dynCall_exn f' g init p return result_exn c) = + dynCall_exn f g init p return result_exn (\s t. mark_guards f (c s t))" + by (simp add: dynCall_exn_def maybe_guard_def) + lemma mark_guards_fcall [simp]: "mark_guards f (fcall init p return result c) = fcall init p return result (\v. mark_guards f (c v))" @@ -631,9 +707,6 @@ lemma mark_guards_guaranteeStrip [simp]: "mark_guards f (guaranteeStrip f' g c) = guaranteeStrip f g (mark_guards f c)" by (simp add: guaranteeStrip_def) -lemma mark_guards_guards [simp]: - "mark_guards f (guards gs c) = guards (map (\(f',g). (f,g)) gs) (mark_guards f c)" - by (induct gs) auto lemma mark_guards_while [simp]: "mark_guards f (while gs b c) = @@ -664,6 +737,7 @@ lemmas mark_guards_simps = mark_guards.simps mark_guards_raise definition is_Guard:: "('s,'p,'f) com \ bool" where "is_Guard c = (case c of Guard f g c' \ True | _ \ False)" lemma is_Guard_basic_simps [simp]: + "is_Guard (guards (pg# pgs) c) = True" "is_Guard Skip = False" "is_Guard (Basic f) = False" "is_Guard (Spec r) = False" @@ -679,14 +753,18 @@ lemma is_Guard_basic_simps [simp]: "is_Guard (condCatch c1 b c2) = False" "is_Guard (bind e cv) = False" "is_Guard (bseq c1 c2) = False" + "is_Guard (block_exn init bdy return result_exn cont) = False" "is_Guard (block init bdy return cont) = False" "is_Guard (call init p return cont) = False" "is_Guard (dynCall init P return cont) = False" + "is_Guard (call_exn init p return result_exn cont) = False" + "is_Guard (dynCall_exn f UNIV init P return result_exn cont) = False" "is_Guard (fcall init p return result cont') = False" "is_Guard (whileAnno b I V c) = False" "is_Guard (guaranteeStrip F g c) = True" by (auto simp add: is_Guard_def raise_def condCatch_def bind_def bseq_def - block_def call_def dynCall_def fcall_def whileAnno_def guaranteeStrip_def) + block_def block_exn_def call_def dynCall_def call_exn_def dynCall_exn_def + fcall_def whileAnno_def guaranteeStrip_def) lemma is_Guard_switch [simp]: @@ -776,6 +854,9 @@ lemmas merge_guards_res_simps = merge_guards_res_Skip merge_guards_res_Basic merge_guards_res_DynCom merge_guards_res_Throw merge_guards_res_Catch merge_guards_res_Guard +lemma merge_guards_guards_empty: "merge_guards (guards [] c) = merge_guards c" + by (simp) + lemma merge_guards_raise: "merge_guards (raise g) = raise g" by (simp add: raise_def) @@ -792,6 +873,11 @@ lemma merge_guards_bseq [simp]: "merge_guards (bseq c1 c2) = bseq (merge_guards c1) (merge_guards c2)" by (simp add: bseq_def) +lemma merge_guards_block_exn [simp]: + "merge_guards (block_exn init bdy return result_exn c) = + block_exn init (merge_guards bdy) return result_exn (\s t. merge_guards (c s t))" + by (simp add: block_exn_def) + lemma merge_guards_block [simp]: "merge_guards (block init bdy return c) = block init (merge_guards bdy) return (\s t. merge_guards (c s t))" @@ -802,6 +888,11 @@ lemma merge_guards_call [simp]: call init p return (\s t. merge_guards (c s t))" by (simp add: call_def) +lemma merge_guards_call_exn [simp]: + "merge_guards (call_exn init p return result_exn c) = + call_exn init p return result_exn (\s t. merge_guards (c s t))" + by (simp add: call_exn_def) + lemma merge_guards_dynCall [simp]: "merge_guards (dynCall init p return c) = dynCall init p return (\s t. merge_guards (c s t))" @@ -843,6 +934,7 @@ text \@{term "merge_guards"} for guard-lists as in @{const guards}, @{cons lemmas merge_guards_simps = merge_guards.simps merge_guards_raise merge_guards_condCatch merge_guards_bind merge_guards_bseq merge_guards_block merge_guards_dynCall merge_guards_fcall merge_guards_switch + merge_guards_block_exn merge_guards_call_exn merge_guards_guaranteeStrip merge_guards_whileAnno merge_guards_specAnno primrec noguards:: "('s,'p,'f) com \ bool" diff --git a/tools/c-parser/Simpl/Semantic.thy b/tools/c-parser/Simpl/Semantic.thy index aa1045705..acd0f1347 100644 --- a/tools/c-parser/Simpl/Semantic.thy +++ b/tools/c-parser/Simpl/Semantic.thy @@ -1,29 +1,9 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL -*) - -(* Title: Semantic.thy - Author: Norbert Schirmer, TU Muenchen Copyright (C) 2004-2008 Norbert Schirmer -Some rights reserved, TU Muenchen - -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA +Copyright (c) 2022 Apple Inc. All rights reserved. *) section \Big-Step Semantics for Simpl\ @@ -178,33 +158,62 @@ inductive_cases exec_Normal_elim_cases [cases set]: "\\\Throw,Normal s\ \ t" "\\\Catch c1 c2,Normal s\ \ t" + +lemma exec_block_exn: + "\\\\bdy,Normal (init s)\ \ Normal t; \\\c s t,Normal (return s t)\ \ u\ + \ + \\\block_exn init bdy return result_exn c,Normal s\ \ u" +apply (unfold block_exn_def) + by (fastforce intro: exec.intros) + lemma exec_block: "\\\\bdy,Normal (init s)\ \ Normal t; \\\c s t,Normal (return s t)\ \ u\ \ \\\block init bdy return c,Normal s\ \ u" -apply (unfold block_def) -by (fastforce intro: exec.intros) + unfolding block_def + by (rule exec_block_exn) + +lemma exec_block_exnAbrupt: + "\\\\bdy,Normal (init s)\ \ Abrupt t\ + \ + \\\block_exn init bdy return result_exn c,Normal s\ \ Abrupt (result_exn (return s t) t)" +apply (unfold block_exn_def) + by (fastforce intro: exec.intros) lemma exec_blockAbrupt: "\\\\bdy,Normal (init s)\ \ Abrupt t\ \ \\\block init bdy return c,Normal s\ \ Abrupt (return s t)" -apply (unfold block_def) -by (fastforce intro: exec.intros) + unfolding block_def + by (rule exec_block_exnAbrupt) + +lemma exec_block_exnFault: + "\\\\bdy,Normal (init s)\ \ Fault f\ + \ + \\\block_exn init bdy return result_exn c,Normal s\ \ Fault f" +apply (unfold block_exn_def) + by (fastforce intro: exec.intros) lemma exec_blockFault: "\\\\bdy,Normal (init s)\ \ Fault f\ \ \\\block init bdy return c,Normal s\ \ Fault f" -apply (unfold block_def) -by (fastforce intro: exec.intros) + unfolding block_def + by (rule exec_block_exnFault) + +lemma exec_block_exnStuck: + "\\\\bdy,Normal (init s)\ \ Stuck\ + \ + \\\block_exn init bdy return result_exn c,Normal s\ \ Stuck" +apply (unfold block_exn_def) + by (fastforce intro: exec.intros) lemma exec_blockStuck: "\\\\bdy,Normal (init s)\ \ Stuck\ \ \\\block init bdy return c,Normal s\ \ Stuck" -apply (unfold block_def) -by (fastforce intro: exec.intros) + unfolding block_def + by (rule exec_block_exnStuck) lemma exec_call: "\\ p=Some bdy;\\\bdy,Normal (init s)\ \ Normal t; \\\c s t,Normal (return s t)\ \ u\ @@ -216,7 +225,6 @@ apply (erule (1) Call) apply assumption done - lemma exec_callAbrupt: "\\ p=Some bdy;\\\bdy,Normal (init s)\ \ Abrupt t\ \ @@ -253,6 +261,52 @@ apply (rule exec_blockStuck) apply (erule CallUndefined) done +lemma exec_call_exn: + "\\ p=Some bdy;\\\bdy,Normal (init s)\ \ Normal t; \\\c s t,Normal (return s t)\ \ u\ + \ + \\\call_exn init p return result_exn c,Normal s\ \ u" +apply (simp add: call_exn_def) +apply (rule exec_block_exn) +apply (erule (1) Call) +apply assumption +done + +lemma exec_call_exnAbrupt: + "\\ p=Some bdy;\\\bdy,Normal (init s)\ \ Abrupt t\ + \ + \\\call_exn init p return result_exn c,Normal s\ \ Abrupt (result_exn (return s t) t)" +apply (simp add: call_exn_def) +apply (rule exec_block_exnAbrupt) +apply (erule (1) Call) +done + +lemma exec_call_exnFault: + "\\ p=Some bdy; \\\bdy,Normal (init s)\ \ Fault f\ + \ + \\\call_exn init p return result_exn c,Normal s\ \ Fault f" +apply (simp add: call_exn_def) +apply (rule exec_block_exnFault) +apply (erule (1) Call) +done + +lemma exec_call_exnStuck: + "\\ p=Some bdy; \\\bdy,Normal (init s)\ \ Stuck\ + \ + \\\call_exn init p return result_exn c,Normal s\ \ Stuck" +apply (simp add: call_exn_def) +apply (rule exec_block_exnStuck) +apply (erule (1) Call) +done + +lemma exec_call_exnUndefined: + "\\ p=None\ + \ + \\\call_exn init p return result_exn c,Normal s\ \ Stuck" +apply (simp add: call_exn_def) +apply (rule exec_block_exnStuck) +apply (erule CallUndefined) + done + lemma Fault_end: assumes exec: "\\\c,s\ \ t" and s: "s=Fault f" shows "t=Fault f" @@ -283,9 +337,8 @@ lemma exec_Call_body': by (rule exec_Call_body_aux) - -lemma exec_block_Normal_elim [consumes 1]: -assumes exec_block: "\\\block init bdy return c,Normal s\ \ t" +lemma exec_block_exn_Normal_elim [consumes 1]: +assumes exec_block: "\\\block_exn init bdy return result_exn c,Normal s\ \ t" assumes Normal: "\t'. \\\\bdy,Normal (init s)\ \ Normal t'; @@ -294,7 +347,7 @@ assumes Normal: assumes Abrupt: "\t'. \\\\bdy,Normal (init s)\ \ Abrupt t'; - t = Abrupt (return s t')\ + t = Abrupt (result_exn (return s t') t')\ \ P" assumes Fault: "\f. @@ -309,7 +362,7 @@ assumes "\\ p = None; t = Stuck\ \ P" shows "P" using exec_block -apply (unfold block_def) +apply (unfold block_exn_def) apply (elim exec_Normal_elim_cases) apply simp_all apply (case_tac s') @@ -337,6 +390,96 @@ apply (drule Stuck_end) apply simp apply (rule Stuck,assumption+) done + +lemma exec_block_Normal_elim [consumes 1]: +assumes exec_block: "\\\block init bdy return c,Normal s\ \ t" +assumes Normal: + "\t'. + \\\\bdy,Normal (init s)\ \ Normal t'; + \\\c s t',Normal (return s t')\ \ t\ + \ P" +assumes Abrupt: + "\t'. + \\\\bdy,Normal (init s)\ \ Abrupt t'; + t = Abrupt (return s t')\ + \ P" +assumes Fault: + "\f. + \\\\bdy,Normal (init s)\ \ Fault f; + t = Fault f\ + \ P" +assumes Stuck: + "\\\\bdy,Normal (init s)\ \ Stuck; + t = Stuck\ + \ P" +assumes + Undef: "\\ p = None; t = Stuck\ \ P" +shows "P" + by (rule exec_block_exn_Normal_elim [OF exec_block [simplified block_def] + Normal Abrupt Fault Stuck Undef ]) + +lemma exec_call_exn_Normal_elim [consumes 1]: +assumes exec_call: "\\\call_exn init p return result_exn c,Normal s\ \ t" +assumes Normal: + "\bdy t'. + \\ p = Some bdy; \\\bdy,Normal (init s)\ \ Normal t'; + \\\c s t',Normal (return s t')\ \ t\ + \ P" +assumes Abrupt: + "\bdy t'. + \\ p = Some bdy; \\\bdy,Normal (init s)\ \ Abrupt t'; + t = Abrupt (result_exn (return s t') t')\ + \ P" +assumes Fault: + "\bdy f. + \\ p = Some bdy; \\\bdy,Normal (init s)\ \ Fault f; + t = Fault f\ + \ P" +assumes Stuck: + "\bdy. + \\ p = Some bdy; \\\bdy,Normal (init s)\ \ Stuck; + t = Stuck\ + \ P" +assumes Undef: + "\\ p = None; t = Stuck\ \ P" +shows "P" + using exec_call + apply (unfold call_exn_def) + apply (cases "\ p") + apply (erule exec_block_exn_Normal_elim) + apply (elim exec_Normal_elim_cases) + apply simp + apply simp + apply (elim exec_Normal_elim_cases) + apply simp + apply simp + apply (elim exec_Normal_elim_cases) + apply simp + apply simp + apply (elim exec_Normal_elim_cases) + apply simp + apply (rule Undef,assumption,assumption) + apply (rule Undef,assumption+) + apply (erule exec_block_exn_Normal_elim) + apply (elim exec_Normal_elim_cases) + apply simp + apply (rule Normal,assumption+) + apply simp + apply (elim exec_Normal_elim_cases) + apply simp + apply (rule Abrupt,assumption+) + apply simp + apply (elim exec_Normal_elim_cases) + apply simp + apply (rule Fault, assumption+) + apply simp + apply (elim exec_Normal_elim_cases) + apply simp + apply (rule Stuck,assumption,assumption,assumption) + apply simp + apply (rule Undef,assumption+) + done + lemma exec_call_Normal_elim [consumes 1]: assumes exec_call: "\\\call init p return c,Normal s\ \ t" assumes Normal: @@ -362,42 +505,8 @@ assumes Stuck: assumes Undef: "\\ p = None; t = Stuck\ \ P" shows "P" - using exec_call - apply (unfold call_def) - apply (cases "\ p") - apply (erule exec_block_Normal_elim) - apply (elim exec_Normal_elim_cases) - apply simp - apply simp - apply (elim exec_Normal_elim_cases) - apply simp - apply simp - apply (elim exec_Normal_elim_cases) - apply simp - apply simp - apply (elim exec_Normal_elim_cases) - apply simp - apply (rule Undef,assumption,assumption) - apply (rule Undef,assumption+) - apply (erule exec_block_Normal_elim) - apply (elim exec_Normal_elim_cases) - apply simp - apply (rule Normal,assumption+) - apply simp - apply (elim exec_Normal_elim_cases) - apply simp - apply (rule Abrupt,assumption+) - apply simp - apply (elim exec_Normal_elim_cases) - apply simp - apply (rule Fault, assumption+) - apply simp - apply (elim exec_Normal_elim_cases) - apply simp - apply (rule Stuck,assumption,assumption,assumption) - apply simp - apply (rule Undef,assumption+) - done + using exec_call [simplified call_call_exn] Normal Abrupt Fault Stuck Undef + by (rule exec_call_exn_Normal_elim) lemma exec_dynCall: @@ -407,6 +516,13 @@ lemma exec_dynCall: apply (simp add: dynCall_def) by (rule DynCom) +lemma exec_dynCall_exn: + "\\\\call_exn init (p s) return result_exn c,Normal s\ \ t\ + \ + \\\dynCall_exn f UNIV init p return result_exn c,Normal s\ \ t" +apply (simp add: dynCall_exn_def) + by (rule DynCom) + lemma exec_dynCall_Normal_elim: assumes exec: "\\\dynCall init p return c,Normal s\ \ t" assumes call: "\\\call init (p s) return c,Normal s\ \ t \ P" @@ -417,6 +533,137 @@ lemma exec_dynCall_Normal_elim: apply (rule call,assumption) done +lemma exec_guards_Normal_elim_cases [consumes 1, case_names noFault someFault]: + assumes exec_guards: "\\\guards gs c,Normal s\ \ t" + assumes noFault: "\f g. (f, g) \ set gs \ s \ g \ \\\c,Normal s\ \ t \ P" + assumes someFault: "\f g. find (\(f,g). s \ g) gs = Some (f, g) \ t = Fault f \ P" + shows "P" + using exec_guards noFault someFault +proof (induct gs) + case Nil + then show ?case by simp +next + case (Cons pg gs) + obtain f g where pg: "pg = (f, g)" + by (cases pg) auto + show ?thesis + proof (cases "s \ g") + case True + from Cons.prems(1) have exec_gs: "\\ \guards gs c,Normal s\ \ t" + by (simp add: pg) (meson True pg exec_Normal_elim_cases) + + from Cons.hyps [OF exec_gs] Cons.prems(2,3) + show ?thesis + by (simp add: pg True) + next + case False + from Cons.prems(1) have t: "t = Fault f" + by (simp add: pg) (meson False pg exec_Normal_elim_cases) + + from t Cons.prems(3) + show ?thesis + by (simp add: pg False) + qed +qed + +lemma exec_guards_noFault: + assumes exec: "\\\c,Normal s\ \ t" + assumes noFault: "\f g. (f, g) \ set gs \ s \ g" + shows "\\\guards gs c,Normal s\ \ t" + using exec noFault by (induct gs) (auto intro: exec.intros) + +lemma exec_guards_Fault: + assumes Fault: "find (\(f,g). s \ g) gs = Some (f, g)" + shows "\\\guards gs c,Normal s\ \ Fault f" + using Fault by (induct gs) (auto intro: exec.intros split: prod.splits if_split_asm) + +lemma exec_guards_DynCom: + assumes exec_c: "\\\guards gs (c s), Normal s\ \ t" + shows "\\\guards gs (DynCom c), Normal s\ \ t" + using exec_c apply (induct gs) + apply (fastforce intro: exec.intros) + apply simp + by (metis exec.Guard exec.GuardFault exec_Normal_elim_cases) + +lemma exec_guards_DynCom_Normal_elim: + assumes exec: "\\\guards gs (DynCom c), Normal s\ \ t" + assumes call: "\\\guards gs (c s), Normal s\ \ t \ P" + shows "P" + using exec call proof (induct gs) + case Nil + then show ?case + apply simp + apply (erule exec_Normal_elim_cases) + apply simp + done +next + case (Cons g gs) + then show ?case + apply (cases g) + apply simp + apply (erule exec_Normal_elim_cases) + apply simp + apply (meson Guard) + apply simp + apply (meson GuardFault) + done +qed + +lemma exec_maybe_guard_DynCom: + assumes exec_c: "\\\maybe_guard f g (c s), Normal s\ \ t" + shows "\\\maybe_guard f g (DynCom c), Normal s\ \ t" + using exec_c + by (metis DynCom Guard GuardFault exec_Normal_elim_cases(5) maybe_guard_def) + +lemma exec_maybe_guard_Normal_elim_cases [consumes 1, case_names noFault someFault]: + assumes exec_guards: "\\\maybe_guard f g c,Normal s\ \ t" + assumes noFault: "s \ g \ \\\c,Normal s\ \ t \ P" + assumes someFault: "s \ g \ t = Fault f \ P" + shows "P" + using exec_guards noFault someFault + by (metis UNIV_I exec_Normal_elim_cases(5) maybe_guard_def) + +lemma exec_maybe_guard_noFault: + assumes exec: "\\\c,Normal s\ \ t" + assumes noFault: "s \ g" + shows "\\\maybe_guard f g c,Normal s\ \ t" + using exec noFault + by (simp add: Guard maybe_guard_def) + +lemma exec_maybe_guard_Fault: + assumes Fault: "s \ g" + shows "\\\maybe_guard f g c,Normal s\ \ Fault f" + using Fault + by (metis GuardFault iso_tuple_UNIV_I maybe_guard_def) + +lemma exec_maybe_guard_DynCom_Normal_elim: + assumes exec: "\\\maybe_guard f g (DynCom c), Normal s\ \ t" + assumes call: "\\\maybe_guard f g (c s), Normal s\ \ t \ P" + shows "P" + using exec call + apply (cases "g=UNIV") + subgoal + apply simp + apply (erule exec_Normal_elim_cases) + apply simp + done + subgoal + apply (simp add: maybe_guard_def) + apply (erule exec_Normal_elim_cases) + apply (meson Guard exec_Normal_elim_cases(12)) + by (meson GuardFault) + done + + +lemma exec_dynCall_exn_Normal_elim: + assumes exec: "\\\dynCall_exn f g init p return result_exn c,Normal s\ \ t" + assumes call: "\\\maybe_guard f g (call_exn init (p s) return result_exn c),Normal s\ \ t \ P" + shows "P" + using exec + apply (simp add: dynCall_exn_def) + apply (erule exec_maybe_guard_DynCom_Normal_elim) + by (rule call) + lemma exec_Call_body: "\ p=Some bdy \ @@ -564,33 +811,61 @@ lemma execn_Abrupt_end: assumes exec: "\\\c,s\ shows "t=Abrupt s'" using exec s by (induct) auto +lemma execn_block_exn: + "\\\\bdy,Normal (init s)\ =n\ Normal t; \\\c s t,Normal (return s t)\ =n\ u\ + \ + \\\block_exn init bdy return result_exn c,Normal s\ =n\ u" +apply (unfold block_exn_def) + by (fastforce intro: execn.intros) + lemma execn_block: "\\\\bdy,Normal (init s)\ =n\ Normal t; \\\c s t,Normal (return s t)\ =n\ u\ \ \\\block init bdy return c,Normal s\ =n\ u" -apply (unfold block_def) -by (fastforce intro: execn.intros) + unfolding block_def + by (rule execn_block_exn) + +lemma execn_block_exnAbrupt: + "\\\\bdy,Normal (init s)\ =n\ Abrupt t\ + \ + \\\block_exn init bdy return result_exn c,Normal s\ =n\ Abrupt (result_exn (return s t) t)" +apply (unfold block_exn_def) + by (fastforce intro: execn.intros) lemma execn_blockAbrupt: "\\\\bdy,Normal (init s)\ =n\ Abrupt t\ \ \\\block init bdy return c,Normal s\ =n\ Abrupt (return s t)" -apply (unfold block_def) -by (fastforce intro: execn.intros) + unfolding block_def + by (rule execn_block_exnAbrupt) + +lemma execn_block_exnFault: + "\\\\bdy,Normal (init s)\ =n\ Fault f\ + \ + \\\block_exn init bdy return result_exn c,Normal s\ =n\ Fault f" +apply (unfold block_exn_def) + by (fastforce intro: execn.intros) lemma execn_blockFault: "\\\\bdy,Normal (init s)\ =n\ Fault f\ \ \\\block init bdy return c,Normal s\ =n\ Fault f" -apply (unfold block_def) -by (fastforce intro: execn.intros) + unfolding block_def +by (rule execn_block_exnFault) + +lemma execn_block_exnStuck: + "\\\\bdy,Normal (init s)\ =n\ Stuck\ + \ + \\\block_exn init bdy return result_exn c,Normal s\ =n\ Stuck" +apply (unfold block_exn_def) + by (fastforce intro: execn.intros) lemma execn_blockStuck: "\\\\bdy,Normal (init s)\ =n\ Stuck\ \ \\\block init bdy return c,Normal s\ =n\ Stuck" -apply (unfold block_def) -by (fastforce intro: execn.intros) + unfolding block_def +by (rule execn_block_exnStuck) lemma execn_call: @@ -604,6 +879,17 @@ apply (erule (1) Call) apply assumption done +lemma execn_call_exn: + "\\ p=Some bdy;\\\bdy,Normal (init s)\ =n\ Normal t; + \\\c s t,Normal (return s t)\ =Suc n\ u\ + \ + \\\call_exn init p return result_exn c,Normal s\ =Suc n\ u" +apply (simp add: call_exn_def) +apply (rule execn_block_exn) +apply (erule (1) Call) +apply assumption +done + lemma execn_callAbrupt: "\\ p=Some bdy;\\\bdy,Normal (init s)\ =n\ Abrupt t\ @@ -614,6 +900,15 @@ apply (rule execn_blockAbrupt) apply (erule (1) Call) done +lemma execn_call_exnAbrupt: + "\\ p=Some bdy;\\\bdy,Normal (init s)\ =n\ Abrupt t\ + \ + \\\call_exn init p return result_exn c,Normal s\ =Suc n\ Abrupt (result_exn (return s t) t)" +apply (simp add: call_exn_def) +apply (rule execn_block_exnAbrupt) +apply (erule (1) Call) + done + lemma execn_callFault: "\\ p=Some bdy; \\\bdy,Normal (init s)\ =n\ Fault f\ \ @@ -623,6 +918,15 @@ apply (rule execn_blockFault) apply (erule (1) Call) done +lemma execn_call_exnFault: + "\\ p=Some bdy; \\\bdy,Normal (init s)\ =n\ Fault f\ + \ + \\\call_exn init p return result_exn c,Normal s\ =Suc n\ Fault f" +apply (simp add: call_exn_def) +apply (rule execn_block_exnFault) +apply (erule (1) Call) +done + lemma execn_callStuck: "\\ p=Some bdy; \\\bdy,Normal (init s)\ =n\ Stuck\ \ @@ -632,6 +936,15 @@ apply (rule execn_blockStuck) apply (erule (1) Call) done +lemma execn_call_exnStuck: + "\\ p=Some bdy; \\\bdy,Normal (init s)\ =n\ Stuck\ + \ + \\\call_exn init p return result_exn c,Normal s\ =Suc n\ Stuck" +apply (simp add: call_exn_def) +apply (rule execn_block_exnStuck) +apply (erule (1) Call) + done + lemma execn_callUndefined: "\\ p=None\ \ @@ -641,8 +954,17 @@ apply (rule execn_blockStuck) apply (erule CallUndefined) done -lemma execn_block_Normal_elim [consumes 1]: -assumes execn_block: "\\\block init bdy return c,Normal s\ =n\ t" +lemma execn_call_exnUndefined: + "\\ p=None\ + \ + \\\call_exn init p return result_exn c,Normal s\ =Suc n\ Stuck" +apply (simp add: call_exn_def) +apply (rule execn_block_exnStuck) +apply (erule CallUndefined) +done + +lemma execn_block_exn_Normal_elim [consumes 1]: +assumes execn_block: "\\\block_exn init bdy return result_exn c,Normal s\ =n\ t" assumes Normal: "\t'. \\\\bdy,Normal (init s)\ =n\ Normal t'; @@ -651,7 +973,7 @@ assumes Normal: assumes Abrupt: "\t'. \\\\bdy,Normal (init s)\ =n\ Abrupt t'; - t = Abrupt (return s t')\ + t = Abrupt (result_exn (return s t') t')\ \ P" assumes Fault: "\f. @@ -666,7 +988,7 @@ assumes Undef: "\\ p = None; t = Stuck\ \ P" shows "P" using execn_block -apply (unfold block_def) +apply (unfold block_exn_def) apply (elim execn_Normal_elim_cases) apply simp_all apply (case_tac s') @@ -694,6 +1016,99 @@ apply (drule execn_Stuck_end) apply simp apply (rule Stuck,assumption+) done +lemma execn_block_Normal_elim [consumes 1]: +assumes execn_block: "\\\block init bdy return c,Normal s\ =n\ t" +assumes Normal: + "\t'. + \\\\bdy,Normal (init s)\ =n\ Normal t'; + \\\c s t',Normal (return s t')\ =n\ t\ + \ P" +assumes Abrupt: + "\t'. + \\\\bdy,Normal (init s)\ =n\ Abrupt t'; + t = Abrupt (return s t')\ + \ P" +assumes Fault: + "\f. + \\\\bdy,Normal (init s)\ =n\ Fault f; + t = Fault f\ + \ P" +assumes Stuck: + "\\\\bdy,Normal (init s)\ =n\ Stuck; + t = Stuck\ + \ P" +assumes Undef: + "\\ p = None; t = Stuck\ \ P" +shows "P" + using execn_block [unfolded block_def] Normal Abrupt Fault Stuck Undef + by (rule execn_block_exn_Normal_elim) + +lemma execn_call_exn_Normal_elim [consumes 1]: +assumes exec_call: "\\\call_exn init p return result_exn c,Normal s\ =n\ t" +assumes Normal: + "\bdy i t'. + \\ p = Some bdy; \\\bdy,Normal (init s)\ =i\ Normal t'; + \\\c s t',Normal (return s t')\ =Suc i\ t; n = Suc i\ + \ P" +assumes Abrupt: + "\bdy i t'. + \\ p = Some bdy; \\\bdy,Normal (init s)\ =i\ Abrupt t'; n = Suc i; + t = Abrupt (result_exn (return s t') t')\ + \ P" +assumes Fault: + "\bdy i f. + \\ p = Some bdy; \\\bdy,Normal (init s)\ =i\ Fault f; n = Suc i; + t = Fault f\ + \ P" +assumes Stuck: + "\bdy i. + \\ p = Some bdy; \\\bdy,Normal (init s)\ =i\ Stuck; n = Suc i; + t = Stuck\ + \ P" +assumes Undef: + "\i. \\ p = None; n = Suc i; t = Stuck\ \ P" +shows "P" + using exec_call + apply (unfold call_exn_def) + apply (cases n) + apply (simp only: block_exn_def) + apply (fastforce elim: execn_Normal_elim_cases) + apply (cases "\ p") + apply (erule execn_block_exn_Normal_elim) + apply (elim execn_Normal_elim_cases) + apply simp + apply simp + apply (elim execn_Normal_elim_cases) + apply simp + apply simp + apply (elim execn_Normal_elim_cases) + apply simp + apply simp + apply (elim execn_Normal_elim_cases) + apply simp + apply (rule Undef,assumption,assumption,assumption) + apply (rule Undef,assumption+) + apply (erule execn_block_exn_Normal_elim) + apply (elim execn_Normal_elim_cases) + apply simp + apply (rule Normal,assumption+) + apply simp + apply (elim execn_Normal_elim_cases) + apply simp + apply (rule Abrupt,assumption+) + apply simp + apply (elim execn_Normal_elim_cases) + apply simp + apply (rule Fault,assumption+) + apply simp + apply (elim execn_Normal_elim_cases) + apply simp + apply (rule Stuck,assumption,assumption,assumption,assumption) + apply (rule Undef,assumption,assumption,assumption) + apply (rule Undef,assumption+) + done + + lemma execn_call_Normal_elim [consumes 1]: assumes exec_call: "\\\call init p return c,Normal s\ =n\ t" assumes Normal: @@ -719,45 +1134,9 @@ assumes Stuck: assumes Undef: "\i. \\ p = None; n = Suc i; t = Stuck\ \ P" shows "P" - using exec_call - apply (unfold call_def) - apply (cases n) - apply (simp only: block_def) - apply (fastforce elim: execn_Normal_elim_cases) - apply (cases "\ p") - apply (erule execn_block_Normal_elim) - apply (elim execn_Normal_elim_cases) - apply simp - apply simp - apply (elim execn_Normal_elim_cases) - apply simp - apply simp - apply (elim execn_Normal_elim_cases) - apply simp - apply simp - apply (elim execn_Normal_elim_cases) - apply simp - apply (rule Undef,assumption,assumption,assumption) - apply (rule Undef,assumption+) - apply (erule execn_block_Normal_elim) - apply (elim execn_Normal_elim_cases) - apply simp - apply (rule Normal,assumption+) - apply simp - apply (elim execn_Normal_elim_cases) - apply simp - apply (rule Abrupt,assumption+) - apply simp - apply (elim execn_Normal_elim_cases) - apply simp - apply (rule Fault,assumption+) - apply simp - apply (elim execn_Normal_elim_cases) - apply simp - apply (rule Stuck,assumption,assumption,assumption,assumption) - apply (rule Undef,assumption,assumption,assumption) - apply (rule Undef,assumption+) - done + using exec_call [simplified call_call_exn] Normal Abrupt Fault Stuck Undef + by (rule execn_call_exn_Normal_elim) + lemma execn_dynCall: "\\\\call init (p s) return c,Normal s\ =n\ t\ @@ -766,6 +1145,13 @@ lemma execn_dynCall: apply (simp add: dynCall_def) by (rule DynCom) +lemma execn_dynCall_exn: + "\\\\call_exn init (p s) return result_exn c,Normal s\ =n\ t\ + \ + \\\dynCall_exn f UNIV init p return result_exn c,Normal s\ =n\ t" +apply (simp add: dynCall_exn_def) + by (rule DynCom) + lemma execn_dynCall_Normal_elim: assumes exec: "\\\dynCall init p return c,Normal s\ =n\ t" assumes "\\\call init (p s) return c,Normal s\ =n\ t \ P" @@ -776,9 +1162,134 @@ lemma execn_dynCall_Normal_elim: apply fact done +lemma execn_guards_Normal_elim_cases [consumes 1, case_names noFault someFault]: + assumes exec_guards: "\\\guards gs c,Normal s\ =n\ t" + assumes noFault: "\f g. (f, g) \ set gs \ s \ g \ \\\c,Normal s\ =n\ t \ P" + assumes someFault: "\f g. find (\(f,g). s \ g) gs = Some (f, g) \ t = Fault f \ P" + shows "P" + using exec_guards noFault someFault +proof (induct gs) + case Nil + then show ?case by simp +next + case (Cons pg gs) + obtain f g where pg: "pg = (f, g)" + by (cases pg) auto + show ?thesis + proof (cases "s \ g") + case True + from Cons.prems(1) have exec_gs: "\\ \guards gs c,Normal s\ =n\ t" + by (simp add: pg) (meson True pg execn_Normal_elim_cases) + + from Cons.hyps [OF exec_gs] Cons.prems(2,3) + show ?thesis + by (simp add: pg True) + next + case False + from Cons.prems(1) have t: "t = Fault f" + by (simp add: pg) (meson False pg execn_Normal_elim_cases) + + from t Cons.prems(3) + show ?thesis + by (simp add: pg False) + qed +qed + +lemma execn_maybe_guard_Normal_elim_cases [consumes 1, case_names noFault someFault]: + assumes exec_guards: "\\\maybe_guard f g c,Normal s\ =n\ t" + assumes noFault: "s \ g \ \\\c,Normal s\ =n\ t \ P" + assumes someFault: "s \ g \ t = Fault f \ P" + shows "P" + using exec_guards noFault someFault + by (metis UNIV_I execn_Normal_elim_cases(5) maybe_guard_def) + +lemma execn_guards_noFault: + assumes exec: "\\\c,Normal s\ =n\ t" + assumes noFault: "\f g. (f, g) \ set gs \ s \ g" + shows "\\\guards gs c,Normal s\ =n\ t" + using exec noFault by (induct gs) (auto intro: execn.intros) + +lemma execn_guards_Fault: + assumes Fault: "find (\(f,g). s \ g) gs = Some (f, g)" + shows "\\\guards gs c,Normal s\ =n\ Fault f" + using Fault by (induct gs) (auto intro: execn.intros split: prod.splits if_split_asm) + +lemma execn_maybe_guard_noFault: + assumes exec: "\\\c,Normal s\ =n\ t" + assumes noFault: "s \ g" + shows "\\\maybe_guard f g c,Normal s\ =n\ t" + using exec noFault + by (auto intro: execn.intros simp add: maybe_guard_def) + +lemma execn_maybe_guard_Fault: + assumes Fault: "s \ g" + shows "\\\maybe_guard f g c,Normal s\ =n\ Fault f" + using Fault by (auto simp add: maybe_guard_def intro: execn.intros split: prod.splits if_split_asm) + +lemma execn_guards_DynCom_Normal_elim: + assumes exec: "\\\guards gs (DynCom c), Normal s\ =n\ t" + assumes call: "\\\guards gs (c s), Normal s\ =n\ t \ P" + shows "P" + using exec call proof (induct gs) + case Nil + then show ?case + apply simp + apply (erule execn_Normal_elim_cases) + apply simp + done +next + case (Cons g gs) + then show ?case + apply (cases g) + apply simp + apply (erule execn_Normal_elim_cases) + apply simp + apply (meson execn.Guard) + apply simp + apply (meson execn.GuardFault) + done +qed + +lemma execn_maybe_guard_DynCom_Normal_elim: + assumes exec: "\\\maybe_guard f g (DynCom c), Normal s\ =n\ t" + assumes call: "\\\maybe_guard f g (c s), Normal s\ =n\ t \ P" + shows "P" + using exec call + by (metis execn.Guard execn.GuardFault execn_Normal_elim_cases(12) execn_Normal_elim_cases(5) maybe_guard_def) + +lemma execn_guards_DynCom: + assumes exec_c: "\\\guards gs (c s), Normal s\ =n\ t" + shows "\\\guards gs (DynCom c), Normal s\ =n\ t" + using exec_c apply (induct gs) + apply (fastforce intro: execn.intros) + apply simp + by (metis execn.Guard execn.GuardFault execn_Normal_elim_cases) + +lemma execn_maybe_guard_DynCom: + assumes exec_c: "\\\maybe_guard f g (c s), Normal s\ =n\ t" + shows "\\\maybe_guard f g (DynCom c), Normal s\ =n\ t" + using exec_c + apply (cases "g = UNIV") + subgoal + apply simp + apply (rule execn.intros) + apply simp + done + subgoal + apply (simp add: maybe_guard_def) + by (metis execn.DynCom execn.Guard execn.GuardFault execn_Normal_elim_cases(5)) + done - +lemma execn_dynCall_exn_Normal_elim: + assumes exec: "\\\dynCall_exn f g init p return result_exn c,Normal s\ =n\ t" + assumes "\\\maybe_guard f g (call_exn init (p s) return result_exn c),Normal s\ =n\ t \ P" + shows "P" + using exec + apply (simp add: dynCall_exn_def) + apply (erule execn_maybe_guard_DynCom_Normal_elim) + apply fact + done lemma execn_Seq': "\\\\c1,s\ =n\ s'; \\\c2,s'\ =n\ s''\ @@ -4379,7 +4890,7 @@ subsection "Restriction of Procedure Environment" lemma restrict_SomeD: "(m|\<^bsub>A\<^esub>) x = Some y \ m x = Some y" by (auto simp add: restrict_map_def split: if_split_asm) -(* FIXME: To Map *) +(* fixme: To Map *) lemma restrict_dom_same [simp]: "m|\<^bsub>dom m\<^esub> = m" apply (rule ext) apply (clarsimp simp add: restrict_map_def) diff --git a/tools/c-parser/Simpl/Simpl.thy b/tools/c-parser/Simpl/Simpl.thy index 51eb7e213..744bc9031 100644 --- a/tools/c-parser/Simpl/Simpl.thy +++ b/tools/c-parser/Simpl/Simpl.thy @@ -1,28 +1,7 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL -*) -(* Title: Simpl.thy - Author: Norbert Schirmer, TU Muenchen - -Copyright (C) 2008 Norbert Schirmer -Some rights reserved, TU Muenchen - -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA +Copyright (C) 2006-2008 Norbert Schirmer *) (*<*) theory Simpl diff --git a/tools/c-parser/Simpl/Simpl_Heap.thy b/tools/c-parser/Simpl/Simpl_Heap.thy index 56c29e2c4..66b2ff92c 100644 --- a/tools/c-parser/Simpl/Simpl_Heap.thy +++ b/tools/c-parser/Simpl/Simpl_Heap.thy @@ -1,28 +1,7 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL -*) -(* Title: Heap.thy - Author: Norbert Schirmer, TU Muenchen - -Copyright (C) 2004-2008 Norbert Schirmer -Some rights reserved, TU Muenchen - -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA +Copyright (C) 2006-2008 Norbert Schirmer *) theory Simpl_Heap diff --git a/tools/c-parser/Simpl/SmallStep.thy b/tools/c-parser/Simpl/SmallStep.thy index 4df30a0e0..f25e115b0 100644 --- a/tools/c-parser/Simpl/SmallStep.thy +++ b/tools/c-parser/Simpl/SmallStep.thy @@ -1,29 +1,8 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL -*) - -(* Title: SmallStep.thy - Author: Norbert Schirmer, TU Muenchen Copyright (C) 2006-2008 Norbert Schirmer -Some rights reserved, TU Muenchen - -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA *) section \Small-Step Semantics and Infinite Computations\ diff --git a/tools/c-parser/Simpl/StateSpace.thy b/tools/c-parser/Simpl/StateSpace.thy index 6c464e28c..fa62158d5 100644 --- a/tools/c-parser/Simpl/StateSpace.thy +++ b/tools/c-parser/Simpl/StateSpace.thy @@ -1,29 +1,10 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL -*) - -(* Title: StateSpace.thy - Author: Norbert Schirmer, TU Muenchen Copyright (C) 2004-2008 Norbert Schirmer -Some rights reserved, TU Muenchen +Copyright (c) 2022 Apple Inc. All rights reserved. -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA *) section \State Space Template\ @@ -37,10 +18,21 @@ definition where "upd_globals upd s = s\globals := upd (globals s)\" -record ('g, 'n, 'val) stateSP = "'g state" + - locals :: "'n \ 'val" +named_theorems state_simp -lemma upd_globals_conv: "upd_globals f = (\s. s\globals := f (globals s)\)" +lemma upd_globals_conv [state_simp]: "upd_globals f = (\s. s\globals := f (globals s)\)" by (rule ext) (simp add: upd_globals_def) +record ('g, 'l) state_locals = "'g state" + + locals :: 'l + +(* +record ('g, 'n, 'val) stateSP = "'g state" + + locals :: "'n \ 'val" +*) + +type_synonym ('g, 'n, 'val) stateSP = "('g, 'n \ 'val) state_locals" +type_synonym ('g, 'n, 'val, 'x) stateSP_scheme = "('g, 'n \ 'val, 'x) state_locals_scheme" + + end diff --git a/tools/c-parser/Simpl/SyntaxTest.thy b/tools/c-parser/Simpl/SyntaxTest.thy index c80acc165..e7e0b11b2 100644 --- a/tools/c-parser/Simpl/SyntaxTest.thy +++ b/tools/c-parser/Simpl/SyntaxTest.thy @@ -1,30 +1,10 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL -*) - -(* Title: SyntaxTest.thy - Author: Norbert Schirmer, TU Muenchen Copyright (C) 2006-2008 Norbert Schirmer -Some rights reserved, TU Muenchen - -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA *) + (*<*) theory SyntaxTest imports HeapList Vcg begin diff --git a/tools/c-parser/Simpl/Termination.thy b/tools/c-parser/Simpl/Termination.thy index 9196093fa..3519a842d 100644 --- a/tools/c-parser/Simpl/Termination.thy +++ b/tools/c-parser/Simpl/Termination.thy @@ -1,29 +1,9 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL -*) - -(* Title: Termination.thy - Author: Norbert Schirmer, TU Muenchen Copyright (C) 2004-2008 Norbert Schirmer -Some rights reserved, TU Muenchen - -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA +Copyright (c) 2022 Apple Inc. All rights reserved. *) section \Terminating Programs\ @@ -207,17 +187,24 @@ next qed qed +lemma terminates_block_exn: +"\\\bdy \ Normal (init s); + \t. \\\bdy,Normal (init s)\ \ Normal t \ \\c s t \ Normal (return s t)\ + \ \\block_exn init bdy return result_exn c \ Normal s" +apply (unfold block_exn_def) +apply (fastforce intro: terminates.intros elim!: exec_Normal_elim_cases + dest!: not_isAbrD) + done + lemma terminates_block: "\\\bdy \ Normal (init s); \t. \\\bdy,Normal (init s)\ \ Normal t \ \\c s t \ Normal (return s t)\ \ \\block init bdy return c \ Normal s" -apply (unfold block_def) -apply (fastforce intro: terminates.intros elim!: exec_Normal_elim_cases - dest!: not_isAbrD) -done + unfolding block_def + by (rule terminates_block_exn) -lemma terminates_block_elim [cases set, consumes 1]: -assumes termi: "\\block init bdy return c \ Normal s" +lemma terminates_block_exn_elim [cases set, consumes 1]: +assumes termi: "\\block_exn init bdy return result_exn c \ Normal s" assumes e: "\\\bdy \ Normal (init s); \t. \\\bdy,Normal (init s)\ \ Normal t \ \\c s t \ Normal (return s t) \ \ P" @@ -227,7 +214,7 @@ proof - by (auto intro: exec.intros) with termi have "\\bdy \ Normal (init s)" - apply (unfold block_def) + apply (unfold block_exn_def) apply (elim terminates_Normal_elim_cases) by simp moreover @@ -238,10 +225,10 @@ proof - proof - from exec_bdy have "\\\Catch (Seq (Basic init) bdy) - (Seq (Basic (return s)) Throw),Normal s\ \ Normal t" + (Seq (Basic (\t. result_exn (return s t) t)) Throw),Normal s\ \ Normal t" by (fastforce intro: exec.intros) with termi have "\\DynCom (\t. Seq (Basic (return s)) (c s t)) \ Normal t" - apply (unfold block_def) + apply (unfold block_exn_def) apply (elim terminates_Normal_elim_cases) by simp thus ?thesis @@ -253,6 +240,14 @@ proof - ultimately show P by (iprover intro: e) qed +lemma terminates_block_elim [cases set, consumes 1]: +assumes termi: "\\block init bdy return c \ Normal s" +assumes e: "\\\bdy \ Normal (init s); + \t. \\\bdy,Normal (init s)\ \ Normal t \ \\c s t \ Normal (return s t) + \ \ P" +shows P + using termi e unfolding block_def by (rule terminates_block_exn_elim) + lemma terminates_call: "\\ p = Some bdy; \\bdy \ Normal (init s); @@ -264,6 +259,16 @@ lemma terminates_call: apply (auto elim: exec_Normal_elim_cases) done +lemma terminates_call_exn: +"\\ p = Some bdy; \\bdy \ Normal (init s); + \t. \\\bdy,Normal (init s)\ \ Normal t \ \\c s t \ Normal (return s t)\ + \ \\call_exn init p return result_exn c \ Normal s" + apply (unfold call_exn_def) + apply (rule terminates_block_exn) + apply (iprover intro: terminates.intros) + apply (auto elim: exec_Normal_elim_cases) + done + lemma terminates_callUndefined: "\\ p = None\ \ \\call init p return result \ Normal s" @@ -273,8 +278,17 @@ lemma terminates_callUndefined: apply (auto elim: exec_Normal_elim_cases) done -lemma terminates_call_elim [cases set, consumes 1]: -assumes termi: "\\call init p return c \ Normal s" +lemma terminates_call_exnUndefined: +"\\ p = None\ + \ \\call_exn init p return result_exn result \ Normal s" + apply (unfold call_exn_def) + apply (rule terminates_block_exn) + apply (iprover intro: terminates.intros) + apply (auto elim: exec_Normal_elim_cases) + done + +lemma terminates_call_exn_elim [cases set, consumes 1]: +assumes termi: "\\call_exn init p return result_exn c \ Normal s" assumes bdy: "\bdy. \\ p = Some bdy; \\bdy \ Normal (init s); \t. \\\bdy,Normal (init s)\ \ Normal t \ \\c s t \ Normal (return s t)\ \ P" assumes undef: "\\ p = None\ \ P" @@ -282,8 +296,8 @@ shows P apply (cases "\ p") apply (erule undef) using termi -apply (unfold call_def) -apply (erule terminates_block_elim) +apply (unfold call_exn_def) +apply (erule terminates_block_exn_elim) apply (erule terminates_Normal_elim_cases) apply simp apply (frule (1) bdy) @@ -292,6 +306,15 @@ apply assumption apply simp done +lemma terminates_call_elim [cases set, consumes 1]: +assumes termi: "\\call init p return c \ Normal s" +assumes bdy: "\bdy. \\ p = Some bdy; \\bdy \ Normal (init s); + \t. \\\bdy,Normal (init s)\ \ Normal t \ \\c s t \ Normal (return s t)\ \ P" +assumes undef: "\\ p = None\ \ P" +shows P + using termi bdy undef unfolding call_call_exn by (rule terminates_call_exn_elim) + + lemma terminates_dynCall: "\\\call init (p s) return c \ Normal s\ \ \\dynCall init p return c \ Normal s" @@ -299,6 +322,28 @@ lemma terminates_dynCall: apply (auto intro: terminates.intros terminates_call) done +lemma terminates_guards: "\\c \ Normal s \ \\guards gs c \ Normal s" + by (induct gs) (auto intro: terminates.intros) + +lemma terminates_guards_Fault: "find (\(f, g). s \ g) gs = Some (f, g) \ \\guards gs c \ Normal s" + by (induct gs) (auto intro: terminates.intros split: if_split_asm prod.splits) + +lemma terminates_maybe_guard_Fault: "s \ g \ \\maybe_guard f g c \ Normal s" + by (metis UNIV_I maybe_guard_def terminates.GuardFault) + +lemma terminates_guards_DynCom: "\\(c s) \ Normal s \ \\guards gs (DynCom c) \ Normal s" + by (induct gs) (auto intro: terminates.intros) + +lemma terminates_maybe_guard_DynCom: "\\(c s) \ Normal s \ \\maybe_guard f g (DynCom c) \ Normal s" + by (metis maybe_guard_def terminates.DynCom terminates.Guard terminates.GuardFault) + + +lemma terminates_dynCall_exn: +"\\\call_exn init (p s) return result_exn c \ Normal s\ + \ \\dynCall_exn f g init p return result_exn c \ Normal s" + apply (unfold dynCall_exn_def) + by (rule terminates_maybe_guard_DynCom) + lemma terminates_dynCall_elim [cases set, consumes 1]: assumes termi: "\\dynCall init p return c \ Normal s" assumes "\\\call init (p s) return c \ Normal s\ \ P" @@ -309,6 +354,34 @@ apply (elim terminates_Normal_elim_cases) apply fact done +lemma terminates_guards_elim [cases set, consumes 1, case_names noFault someFault]: + assumes termi: "\\guards gs c \ Normal s" + assumes noFault: "\\f g. (f, g) \ set gs \ s \ g; \\c \ Normal s\ \ P" + assumes someFault: "\f g. find (\(f,g). s \ g) gs = Some (f, g) \ P" + shows P + using termi noFault someFault + by (induct gs) + (auto elim: terminates_Normal_elim_cases split: if_split_asm prod.splits) + +lemma terminates_maybe_guard_elim [cases set, consumes 1, case_names noFault someFault]: + assumes termi: "\\maybe_guard f g c \ Normal s" + assumes noFault: "\s \ g; \\c \ Normal s\ \ P" + assumes someFault: "s \ g \ P" + shows P + using termi noFault someFault + by (metis maybe_guard_def terminates_Normal_elim_cases(2)) + +lemma terminates_dynCall_exn_elim [cases set, consumes 1, case_names noFault someFault]: +assumes termi: "\\dynCall_exn f g init p return result_exn c \ Normal s" +assumes noFault: "\s \ g; + \\call_exn init (p s) return result_exn c \ Normal s\ \ P" +assumes someFault: "s \ g \ P" +shows P +using termi noFault someFault + apply (unfold dynCall_exn_def) + apply (erule terminates_maybe_guard_elim) + apply (auto elim: terminates_Normal_elim_cases) + done (* ************************************************************************* *) subsection \Lemmas about @{const "sequence"}, @{const "flatten"} and diff --git a/tools/c-parser/Simpl/UserGuide.thy b/tools/c-parser/Simpl/UserGuide.thy index cfeb2e1a0..9772badbd 100644 --- a/tools/c-parser/Simpl/UserGuide.thy +++ b/tools/c-parser/Simpl/UserGuide.thy @@ -1,28 +1,8 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL -*) - -(* Title: UserGuide.thy - Author: Norbert Schirmer, TU Muenchen Copyright (C) 2004-2008 Norbert Schirmer -Some rights reserved, TU Muenchen - -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA +Copyright (c) 2022 Apple Inc. All rights reserved. *) section \User Guide \label{sec:UserGuide}\ @@ -222,7 +202,7 @@ for procedure calls (that creates the proper @{term init}, @{term return} and @{term result} functions on the fly) and creates locales and statespaces to reason about the procedure. The purpose of locales is to set up logical contexts to support modular reasoning. Locales can be seen as freeze-dried proof contexts that -get alive as you setup a new lemma or theorem (\<^cite>\"Ballarin-04-locales"\). +get alive as you setup a new lemma or theorem (\cite{Ballarin-04-locales}). The locale the user deals with is named \Square_impl\. It defines the procedure name (internally @{term "Square_'proc"}), the procedure body (named \Square_body\) and the statespaces for parameters and local and @@ -344,7 +324,7 @@ subsubsection \Usage\ text\Let us see how we can use procedure specifications.\ -(* FIXME: maybe don't show this at all *) +(* fixme: maybe don't show this at all *) lemma (in Square_impl) shows "\\\\I = 2\ \R :== CALL Square(\I) \\R = 4\" txt \Remember that we have already proven @{thm [source] "Square_spec"} in the locale @@ -537,7 +517,7 @@ the lookup of variable \x\ in the state \\\. The approach to specify procedures on lists -basically follows \<^cite>\"MehtaN-CADE03"\. From the pointer structure +basically follows \cite{MehtaN-CADE03}. From the pointer structure in the heap we (relationally) abstract to HOL lists of references. Then we can specify further properties on the level of HOL lists, rather then on the heap. The basic abstractions are: @@ -795,7 +775,7 @@ since the lists are already uniquely determined by the relational abstraction: \ text \ -The next contrived example is taken from \<^cite>\"Homeier-95-vcg"\, to illustrate +The next contrived example is taken from \cite{Homeier-95-vcg}, to illustrate a more complex termination criterion for mutually recursive procedures. The procedures do not calculate anything useful. @@ -873,7 +853,8 @@ apply (hoare_rule HoareTotal_ProcRec2 \ txt \@{subgoals [margin=75,display]}\ apply simp_all - by (vcg,force)+ +by (vcg,simp)+ + text \By doing some arithmetic we can express the termination condition with a single measure function. \ @@ -1534,7 +1515,7 @@ procedures init' (|p) = subsubsection \Extending State Spaces\ text \ The records in Isabelle are -extensible \<^cite>\"Nipkow-02-hol" and "NaraschewskiW-TPHOLs98"\. In principle this can be exploited +extensible \cite{Nipkow-02-hol,NaraschewskiW-TPHOLs98}. In principle this can be exploited during verification. The state space can be extended while we we add procedures. But there is one major drawback: \begin{itemize} diff --git a/tools/c-parser/Simpl/Vcg.thy b/tools/c-parser/Simpl/Vcg.thy index 433c64090..d4337822e 100644 --- a/tools/c-parser/Simpl/Vcg.thy +++ b/tools/c-parser/Simpl/Vcg.thy @@ -1,28 +1,9 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL -*) - -(* Title: Vcg.thy - Author: Norbert Schirmer, TU Muenchen Copyright (C) 2004-2008 Norbert Schirmer -Some rights reserved, TU Muenchen +Copyright (c) 2022 Apple Inc. All rights reserved. -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA *) section \Facilitating the Hoare Logic\ @@ -374,6 +355,9 @@ syntax "_Call" :: "'p \ actuals \ (('a,string,'f) com)" "_GuardedCall" :: "'p \ actuals \ (('a,string,'f) com)" ("CALL\<^sub>g __" [1000,1000] 21) "_CallAss":: "'a \ 'p \ actuals \ (('a,string,'f) com)" ("_ :== CALL __" [30,1000,1000] 21) + "_Call_exn" :: "'p \ actuals \ (('a,string,'f) com)" ("CALL\<^sub>e __" [1000,1000] 21) + "_CallAss_exn":: "'a \ 'p \ actuals \ (('a,string,'f) com)" + ("_ :== CALL\<^sub>e __" [30,1000,1000] 21) "_Proc" :: "'p \ actuals \ (('a,string,'f) com)" ("PROC __" 21) "_ProcAss":: "'a \ 'p \ actuals \ (('a,string,'f) com)" ("_ :== PROC __" [30,1000,1000] 21) @@ -383,6 +367,9 @@ syntax "_Call" :: "'p \ actuals \ (('a,string,'f) com)" "_GuardedDynCall" :: "'p \ actuals \ (('a,string,'f) com)" ("DYNCALL\<^sub>g __" [1000,1000] 21) "_DynCallAss":: "'a \ 'p \ actuals \ (('a,string,'f) com)" ("_ :== DYNCALL __" [30,1000,1000] 21) + "_DynCall_exn" :: "'p \ actuals \ (('a,string,'f) com)" ("DYNCALL\<^sub>e __" [1000,1000] 21) + "_DynCallAss_exn":: "'a \ 'p \ actuals \ (('a,string,'f) com)" + ("_ :== DYNCALL\<^sub>e __" [30,1000,1000] 21) "_GuardedDynCallAss":: "'a \ 'p \ actuals \ (('a,string,'f) com)" ("_ :== DYNCALL\<^sub>g __" [30,1000,1000] 21) @@ -440,7 +427,7 @@ parse_translation \ | idx (x::xs) y = if x=y then 0 else (idx xs y)+1 fun gen_update ctxt names (name,t) = - Hoare_Syntax.update_comp ctxt [] false true name (Bound (idx names name)) t + Hoare_Syntax.update_comp ctxt NONE [] false true name (Bound (idx names name)) t fun gen_updates ctxt names t = Library.foldr (gen_update ctxt names) (names,t) @@ -528,17 +515,21 @@ parse_translation \ parse_translation \ [(@{syntax_const "_antiquoteOld"}, Hoare_Syntax.antiquoteOld_tr), - (@{syntax_const "_Call"}, Hoare_Syntax.call_tr false false), + (@{syntax_const "_Call"}, Hoare_Syntax.call_tr false false []), + (@{syntax_const "_Call_exn"}, Hoare_Syntax.call_tr false true []), (@{syntax_const "_FCall"}, Hoare_Syntax.fcall_tr), - (@{syntax_const "_CallAss"}, Hoare_Syntax.call_ass_tr false false), - (@{syntax_const "_GuardedCall"}, Hoare_Syntax.call_tr false true), - (@{syntax_const "_GuardedCallAss"}, Hoare_Syntax.call_ass_tr false true), + (@{syntax_const "_CallAss"}, Hoare_Syntax.call_ass_tr false false []), + (@{syntax_const "_CallAss_exn"}, Hoare_Syntax.call_ass_tr false true []), + (@{syntax_const "_GuardedCall"}, Hoare_Syntax.call_tr false true []), + (@{syntax_const "_GuardedCallAss"}, Hoare_Syntax.call_ass_tr false true []), (@{syntax_const "_Proc"}, Hoare_Syntax.proc_tr), (@{syntax_const "_ProcAss"}, Hoare_Syntax.proc_ass_tr), - (@{syntax_const "_DynCall"}, Hoare_Syntax.call_tr true false), - (@{syntax_const "_DynCallAss"}, Hoare_Syntax.call_ass_tr true false), - (@{syntax_const "_GuardedDynCall"}, Hoare_Syntax.call_tr true true), - (@{syntax_const "_GuardedDynCallAss"}, Hoare_Syntax.call_ass_tr true true), + (@{syntax_const "_DynCall"}, Hoare_Syntax.call_tr true false []), + (@{syntax_const "_DynCall_exn"}, Hoare_Syntax.call_tr true true []), + (@{syntax_const "_DynCallAss"}, Hoare_Syntax.call_ass_tr true false []), + (@{syntax_const "_DynCallAss_exn"}, Hoare_Syntax.call_ass_tr true true []), + (@{syntax_const "_GuardedDynCall"}, Hoare_Syntax.call_tr true true []), + (@{syntax_const "_GuardedDynCallAss"}, Hoare_Syntax.call_ass_tr true true []), (@{syntax_const "_BasicBlock"}, Hoare_Syntax.basic_assigns_tr)] \ @@ -656,6 +647,8 @@ print_translation \ print_translation \ [(@{const_syntax call}, Hoare_Syntax.call_tr'), (@{const_syntax dynCall}, Hoare_Syntax.dyn_call_tr'), + (@{const_syntax call_exn}, Hoare_Syntax.call_exn_tr'), + (@{const_syntax dynCall_exn}, Hoare_Syntax.dyn_call_exn_tr'), (@{const_syntax fcall}, Hoare_Syntax.fcall_tr'), (@{const_syntax Call}, Hoare_Syntax.proc_tr')] \ diff --git a/tools/c-parser/Simpl/XVcg.thy b/tools/c-parser/Simpl/XVcg.thy index 65e827e73..a2e971aab 100644 --- a/tools/c-parser/Simpl/XVcg.thy +++ b/tools/c-parser/Simpl/XVcg.thy @@ -1,29 +1,8 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL -*) - -(* Title: XVcg.thy - Author: Norbert Schirmer, TU Muenchen Copyright (C) 2006-2008 Norbert Schirmer -Some rights reserved, TU Muenchen - -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA *) theory XVcg diff --git a/tools/c-parser/Simpl/ex/Closure.thy b/tools/c-parser/Simpl/ex/Closure.thy index edbdd34e7..87d7f1dce 100644 --- a/tools/c-parser/Simpl/ex/Closure.thy +++ b/tools/c-parser/Simpl/ex/Closure.thy @@ -1,29 +1,8 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL -*) - -(* Title: Closure.thy - Author: Norbert Schirmer, TU Muenchen Copyright (C) 2006-2008 Norbert Schirmer -Some rights reserved, TU Muenchen - -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA *) section "Experiments with Closures" diff --git a/tools/c-parser/Simpl/ex/ClosureEx.thy b/tools/c-parser/Simpl/ex/ClosureEx.thy index 2ec61f548..cac028ea3 100644 --- a/tools/c-parser/Simpl/ex/ClosureEx.thy +++ b/tools/c-parser/Simpl/ex/ClosureEx.thy @@ -1,29 +1,8 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL -*) - -(* Title: ClosureEx.thy - Author: Norbert Schirmer, TU Muenchen Copyright (C) 2006-2008 Norbert Schirmer -Some rights reserved, TU Muenchen - -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA *) theory ClosureEx @@ -163,13 +142,18 @@ apply (simp only: simp_thms) apply clarsimp done +declare [[hoare_trace = 1]] + +ML \ +val hoare_tacs = #hoare_tacs (Hoare.get_data @{context}); +\ lemma (in NewCounter_impl') shows "\\ \1 \ \free\ \c :== CALL NewCounter ();; dynCallClosure (\s. s) upd c_' (\s t. s\globals := globals t\) (\s t. Basic (\u. u\r_' := r_' t\)) \\r=1\" -apply vcg_step + apply vcg_step apply (rule dynCallClosure) prefer 2 apply vcg_step diff --git a/tools/c-parser/Simpl/ex/Compose.thy b/tools/c-parser/Simpl/ex/Compose.thy index fad29c886..7b5dc8136 100644 --- a/tools/c-parser/Simpl/ex/Compose.thy +++ b/tools/c-parser/Simpl/ex/Compose.thy @@ -1,29 +1,10 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL -*) - -(* Title: Compose.thy - Author: Norbert Schirmer, TU Muenchen Copyright (C) 2006-2008 Norbert Schirmer -Some rights reserved, TU Muenchen +Copyright (c) 2022 Apple Inc. All rights reserved. -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA *) section "Experiments on State Composition" @@ -1272,7 +1253,7 @@ lemma lift\<^sub>c_block [simp]: "lift\<^sub>c prj inject (block init bdy return block (lift\<^sub>f prj inject init) (lift\<^sub>c prj inject bdy) (\s. (lift\<^sub>f prj inject (return (prj s)))) (\s t. lift\<^sub>c prj inject (c (prj s) (prj t)))" - by (simp add: block_def) + by (simp add: block_def block_exn_def) (* lemma lift\<^sub>c_block [simp]: "lift\<^sub>c prj inject (block init bdy return c) = @@ -1294,7 +1275,7 @@ lemma rename_whileAnno [simp]: "rename h (whileAnno b I V c) = lemma rename_block [simp]: "rename h (block init bdy return c) = block init (rename h bdy) return (\s t. rename h (c s t))" - by (simp add: block_def) + by (simp add: block_def block_exn_def) lemma rename_call [simp]: "rename h (call init p return c) = call init (h p) return (\s t. rename h (c s t))" diff --git a/tools/c-parser/Simpl/ex/ComposeEx.thy b/tools/c-parser/Simpl/ex/ComposeEx.thy index 481992baf..fce4e0f2b 100644 --- a/tools/c-parser/Simpl/ex/ComposeEx.thy +++ b/tools/c-parser/Simpl/ex/ComposeEx.thy @@ -1,29 +1,8 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL -*) - -(* Title: ComposeEx.thy - Author: Norbert Schirmer, TU Muenchen Copyright (C) 2006-2008 Norbert Schirmer -Some rights reserved, TU Muenchen - -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA *) theory ComposeEx imports Compose "../Vcg" "../HeapList" begin diff --git a/tools/c-parser/Simpl/ex/ProcParEx.thy b/tools/c-parser/Simpl/ex/ProcParEx.thy index 4e8bced61..02a0376e1 100644 --- a/tools/c-parser/Simpl/ex/ProcParEx.thy +++ b/tools/c-parser/Simpl/ex/ProcParEx.thy @@ -1,29 +1,8 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL -*) - -(* Title: ProcParEx.thy - Author: Norbert Schirmer, TU Muenchen Copyright (C) 2006-2008 Norbert Schirmer -Some rights reserved, TU Muenchen - -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA *) section "Examples for Procedures as Parameters" diff --git a/tools/c-parser/Simpl/ex/ProcParExSP.thy b/tools/c-parser/Simpl/ex/ProcParExSP.thy index 6688268a4..c12006796 100644 --- a/tools/c-parser/Simpl/ex/ProcParExSP.thy +++ b/tools/c-parser/Simpl/ex/ProcParExSP.thy @@ -1,29 +1,10 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL -*) - -(* Title: ProcParEx.thy - Author: Norbert Schirmer, TU Muenchen Copyright (C) 2007-2008 Norbert Schirmer -Some rights reserved, TU Muenchen +Copyright (c) 2022 Apple Inc. All rights reserved. -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA *) section "Examples for Procedures as Parameters using Statespaces" @@ -87,7 +68,7 @@ declare [[hoare_use_call_tr' = true]] end -(* FIXME: typing issue with modifies locale*) +(* fixme: typing issue with modifies locale*) procedures LEQ (i::nat,j::nat | r::bool) "\r :== \i \ \j" LEQ_spec: "\\. \\ {\} PROC LEQ(\i,\j,\r) \\r = (\<^bsup>\\<^esup>i \ \<^bsup>\\<^esup>j)\" diff --git a/tools/c-parser/Simpl/ex/Quicksort.thy b/tools/c-parser/Simpl/ex/Quicksort.thy index 11b0c5164..fad6282a7 100644 --- a/tools/c-parser/Simpl/ex/Quicksort.thy +++ b/tools/c-parser/Simpl/ex/Quicksort.thy @@ -1,29 +1,8 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL -*) -(* Title: Quicksort.thy - Author: Norbert Schirmer, TU Muenchen - -Copyright (C) 2004-2008 Norbert Schirmer -Some rights reserved, TU Muenchen - -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA +Copyright (C) 2006-2008 Norbert Schirmer *) section "Example: Quicksort on Heap Lists" diff --git a/tools/c-parser/Simpl/ex/VcgEx.thy b/tools/c-parser/Simpl/ex/VcgEx.thy index 4eaa44579..4f25d87af 100644 --- a/tools/c-parser/Simpl/ex/VcgEx.thy +++ b/tools/c-parser/Simpl/ex/VcgEx.thy @@ -1,29 +1,8 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL -*) -(* Title: VcgEx.thy - Author: Norbert Schirmer, TU Muenchen - -Copyright (C) 2004-2008 Norbert Schirmer -Some rights reserved, TU Muenchen - -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA +Copyright (C) 2006-2008 Norbert Schirmer *) section \Examples using the Verification Environment\ diff --git a/tools/c-parser/Simpl/ex/VcgExSP.thy b/tools/c-parser/Simpl/ex/VcgExSP.thy index 448b2bfbf..c657a374f 100644 --- a/tools/c-parser/Simpl/ex/VcgExSP.thy +++ b/tools/c-parser/Simpl/ex/VcgExSP.thy @@ -1,29 +1,8 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL -*) -(* Title: VcgEx.thy - Author: Norbert Schirmer, TU Muenchen - -Copyright (C) 2004-2008 Norbert Schirmer -Some rights reserved, TU Muenchen - -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA +Copyright (C) 2006-2008 Norbert Schirmer *) section \Examples using Statespaces\ diff --git a/tools/c-parser/Simpl/ex/VcgExTotal.thy b/tools/c-parser/Simpl/ex/VcgExTotal.thy index 3144311d6..fa9635bed 100644 --- a/tools/c-parser/Simpl/ex/VcgExTotal.thy +++ b/tools/c-parser/Simpl/ex/VcgExTotal.thy @@ -1,29 +1,9 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL -*) - -(* Title: VcgExTotal.thy - Author: Norbert Schirmer, TU Muenchen Copyright (C) 2006-2008 Norbert Schirmer -Some rights reserved, TU Muenchen -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA *) section \Examples for Total Correctness\ @@ -318,7 +298,10 @@ lemma (in pedal_coast_clique) measure (\p. if p = coast_'proc then 1 else 0)) (\(s,p). (\<^bsup>s\<^esup>N + \<^bsup>s\<^esup>M,p))"]) apply simp_all - apply (vcg,force)+ + apply vcg + apply simp + apply vcg + apply simp done lemma (in pedal_coast_clique) @@ -329,7 +312,10 @@ lemma (in pedal_coast_clique) measure (\p. if p = coast_'proc then 1 else 0)) (\(s,p). (\<^bsup>s\<^esup>N + \<^bsup>s\<^esup>M,p))"]) apply simp_all - apply (vcg,force)+ + apply vcg + apply simp + apply vcg + apply simp done @@ -341,7 +327,11 @@ lemma (in pedal_coast_clique) apply(hoare_rule HoareTotal_ProcRec2 [where ?r= "measure (\(s,p). \<^bsup>s\<^esup>N + \<^bsup>s\<^esup>M + (if p = coast_'proc then 1 else 0))"]) apply simp_all - apply (vcg,force)+ + apply vcg + apply simp + apply arith + apply vcg + apply simp done @@ -352,8 +342,11 @@ lemma (in pedal_coast_clique) [where ?r= "(\(s,p). \<^bsup>s\<^esup>N) <*mlex*> (\(s,p). \<^bsup>s\<^esup>M) <*mlex*> measure (\(s,p). if p = coast_'proc then 1 else 0)"]) apply simp_all - apply (vcg,force)+ - done + apply vcg + apply simp + apply vcg + apply simp + done lemma (in pedal_coast_clique) @@ -363,8 +356,11 @@ lemma (in pedal_coast_clique) [where ?r= "measure (\s. \<^bsup>s\<^esup>N + \<^bsup>s\<^esup>M) <*lex*> measure (\p. if p = coast_'proc then 1 else 0)"]) apply simp_all - apply (vcg,force)+ - done + apply vcg + apply simp + apply vcg + apply simp + done end diff --git a/tools/c-parser/Simpl/ex/XVcgEx.thy b/tools/c-parser/Simpl/ex/XVcgEx.thy index 0d6ae7ebf..03086494a 100644 --- a/tools/c-parser/Simpl/ex/XVcgEx.thy +++ b/tools/c-parser/Simpl/ex/XVcgEx.thy @@ -1,29 +1,8 @@ (* Author: Norbert Schirmer Maintainer: Norbert Schirmer, norbert.schirmer at web de - License: LGPL -*) - -(* Title: XVcgEx.thy - Author: Norbert Schirmer, TU Muenchen Copyright (C) 2006-2008 Norbert Schirmer -Some rights reserved, TU Muenchen - -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA *) section "Examples for Parallel Assignments" diff --git a/tools/c-parser/Simpl/generalise_state.ML b/tools/c-parser/Simpl/generalise_state.ML index 6f6628df3..ad476a32e 100644 --- a/tools/c-parser/Simpl/generalise_state.ML +++ b/tools/c-parser/Simpl/generalise_state.ML @@ -1,41 +1,30 @@ (* Title: generalise_state.ML - Author: Norbert Schirmer, TU Muenchen -Copyright (C) 2005-2007 Norbert Schirmer - -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA +Copyright (C) 2006-2008 Norbert Schirmer +Copyright (c) 2022 Apple Inc. All rights reserved. *) signature SPLIT_STATE = -sig - val isState: term -> bool - val abs_state: term -> term option +sig val isState: Proof.context -> term -> bool + val abs_state: Proof.context -> term -> term option val abs_var: Proof.context -> term -> (string * typ) val split_state: Proof.context -> string -> typ -> term -> (term * term list) - val ex_tac: Proof.context -> term list -> tactic + val ex_tac: Proof.context -> term list -> int -> tactic (* the term-list is the list of selectors as returned by split_state. They may be used to - construct the instatiation of the existentially + construct the instantiation of the existentially quantified state. *) end; -functor GeneraliseFun (structure SplitState: SPLIT_STATE) = +signature GENERALISE = +sig + val GENERALISE: Proof.context -> int -> tactic +end + +functor Generalise (structure SplitState: SPLIT_STATE) : GENERALISE = struct val genConj = @{thm generaliseConj}; @@ -131,7 +120,7 @@ fun split_thm qnt ctxt s T t = (HOLogic.mk_Trueprop (list_exists (vs, t')), HOLogic.mk_Trueprop (HOLogic.mk_exists (s,T,t)))) in (case qnt of - Hol_ex => Goal.prove ctxt [] [] prop (fn _ => SplitState.ex_tac ctxt vars) + Hol_ex => Goal.prove ctxt [] [] prop (fn _ => SplitState.ex_tac ctxt vars 1) | _ => let val rP = conc_of genRefl'; val thm0 = Thm.instantiate (TVars.empty, Vars.make [(dest_Var rP, Thm.cterm_of ctxt prop)]) genRefl'; @@ -170,7 +159,7 @@ fun decomp ctxt (Const (@{const_name HOL.conj}, _) $ t $ t', ct) = val genAll' = Drule.rename_bvars [(s,x)] genAll; val (Const (@{const_name Pure.all},_)$Abs (s',_,_)) = genAllShift |> Thm.prems_of |> hd |> dest_prop; val genAllShift' = Drule.rename_bvars [(s',x)] genAllShift; - in if SplitState.isState (allc$Abs abst) + in if SplitState.isState ctxt (allc$Abs abst) then ([Thm.term_of cb],[cb], fn [thm] => let val P = HOLogic.dest_Trueprop (dest_prop (prem_of thm)); val thm' = split_thm Hol_all ctxt x' T P; @@ -190,7 +179,7 @@ fun decomp ctxt (Const (@{const_name HOL.conj}, _) $ t $ t', ct) = val Free (x',_) = Thm.term_of cx'; val (Const (@{const_name Pure.all},_)$Abs (s,_,_)) = genEx |> Thm.prems_of |> hd |> dest_prop; val genEx' = Drule.rename_bvars [(s,x)] genEx; - in if SplitState.isState (exc$Abs abst) + in if SplitState.isState ctxt (exc$Abs abst) then ([Thm.term_of cb],[cb], fn [thm] => let val P = HOLogic.dest_Trueprop (dest_prop (prem_of thm)); val thm' = split_thm Hol_ex ctxt x' T P; @@ -229,7 +218,7 @@ fun decomp ctxt (Const (@{const_name HOL.conj}, _) $ t $ t', ct) = val gen_all' = Drule.rename_bvars [(s,x)] gen_all; val (Const (@{const_name Pure.all},_)$Abs (s',_,_)) = gen_allShift |> Thm.prems_of |> hd |> dest_prop; val gen_allShift' = Drule.rename_bvars [(s',x)] gen_allShift; - in if SplitState.isState (allc$Abs abst) + in if SplitState.isState ctxt (allc$Abs abst) then ([Thm.term_of cb],[cb], fn [thm] => let val P = dest_prop (prem_of thm); val thm' = split_thm Meta_all ctxt x' T P; @@ -255,30 +244,26 @@ fun generalise ctxt ct = gen_thm (decomp ctxt) (Thm.term_of ct,ct); *) fun init ct = Thm.instantiate' [] [SOME ct] protectRefl; -fun generalise_over_tac ctxt P i st = - let - val t = List.nth (Thm.prems_of st, i - 1); (* FIXME !? *) - in (case P t of - SOME t' => - let - val ct = Thm.cterm_of ctxt t'; - val meta_spec_protect' = infer_instantiate ctxt [(("x", 0), ct)] @{thm meta_spec_protect}; - in - (init (Thm.adjust_maxidx_cterm 0 (List.nth (Drule.cprems_of st, i - 1))) - |> resolve_tac ctxt [meta_spec_protect'] 1 - |> Seq.maps (fn st' => - Thm.bicompose NONE {flatten = true, match = false, incremented = false} - (false, Goal.conclude st', Thm.nprems_of st') i st)) - end - | NONE => no_tac st) - end; +fun generalise_over_tac ctxt P = SUBGOAL (fn (t, i) => fn st => + (case P t of + SOME t' => + let + val ct = Thm.cterm_of ctxt t'; + val meta_spec_protect' = infer_instantiate ctxt [(("x", 0), ct)] @{thm meta_spec_protect}; + in + (init (Thm.adjust_maxidx_cterm 0 (List.nth (Drule.cprems_of st, i - 1))) + |> resolve_tac ctxt [meta_spec_protect'] 1 + |> Seq.maps (fn st' => + Thm.bicompose NONE {flatten = true, match = false, incremented = false} + (false, Goal.conclude st', Thm.nprems_of st') i st)) + end + | NONE => no_tac st)) fun generalise_over_all_states_tac ctxt i = - REPEAT (generalise_over_tac ctxt SplitState.abs_state i); + REPEAT (generalise_over_tac ctxt (SplitState.abs_state ctxt) i); -fun generalise_tac ctxt i st = +fun generalise_tac ctxt = CSUBGOAL (fn (ct, i) => fn st => let - val ct = List.nth (Drule.cprems_of st, i - 1); val ct' = Thm.dest_equals_rhs (Thm.cprop_of (Thm.eta_conversion ct)); val r = Goal.conclude (generalise ctxt ct'); in (init (Thm.adjust_maxidx_cterm 0 (List.nth (Drule.cprems_of st, i - 1))) @@ -286,7 +271,7 @@ fun generalise_tac ctxt i st = |> Seq.maps (fn st' => Thm.bicompose NONE {flatten = true, match = false, incremented = false} (false, Goal.conclude st', Thm.nprems_of st') i st)) - end + end) fun GENERALISE ctxt i = generalise_over_all_states_tac ctxt i THEN diff --git a/tools/c-parser/Simpl/hoare.ML b/tools/c-parser/Simpl/hoare.ML index e69f5545d..c8f93a9b0 100644 --- a/tools/c-parser/Simpl/hoare.ML +++ b/tools/c-parser/Simpl/hoare.ML @@ -2,28 +2,14 @@ Author: Norbert Schirmer, TU Muenchen Copyright (C) 2004-2007 Norbert Schirmer - -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA +Copyright (c) 2022 Apple Inc. All rights reserved. *) signature HOARE = sig datatype hoareMode = Partial | Total val gen_proc_rec: Proof.context -> hoareMode -> int -> thm - datatype state_kind = Record | Function + datatype state_kind = Record | Function | Other of string (* future extensions of state space *) datatype par_kind = In | Out val deco: string val proc_deco: string @@ -32,12 +18,31 @@ sig val is_state_var: string -> bool val extern: Proof.context -> string -> string val remdeco: Proof.context -> string -> string - val remdeco': string -> string + val remdeco': Proof.context -> string -> string val undeco: Proof.context -> term -> term val varname: string -> string val resuffix: string -> string -> string -> string + type state_space = { + name: string, + is_state_type: Proof.context -> typ -> bool, + generalise: Proof.context -> int -> tactic, + state_simprocs: simproc list, + state_upd_simprocs: simproc list, + state_ex_sel_eq_simprocs: simproc list, + + (* syntax *) + read_function_name: Proof.context -> xstring -> term, + is_defined: Proof.context -> xstring -> bool, + lookup_tr: Proof.context -> xstring -> term, + update_tr: Proof.context -> xstring -> term, + is_lookup: Proof.context -> term -> bool, + lookup_tr': Proof.context -> term -> term, + dest_update_tr': Proof.context -> term -> term * term * term option, + update_tr': Proof.context -> term -> term + } + type lense = {lookup: term, update : term} type proc_info = - {params: ((par_kind * string) list), + {params: ((par_kind * string * lense option) list), recursive: bool, state_kind: state_kind} type hoare_tac = (bool -> int -> tactic) -> Proof.context -> hoareMode -> int -> tactic @@ -45,18 +50,25 @@ sig {proc_info: proc_info Symtab.table, active_procs: string list list, default_state_kind: state_kind, - generate_guard: (stamp * (Proof.context -> term -> term option)), - wp_tacs: (string * hoare_tac) list, + generate_guard: (stamp option * (Proof.context -> term -> term option)), + name_tr: (stamp option * (Proof.context -> bool -> string -> string)), (* bool indicates input tr: true vs. output tr: false *) hoare_tacs: (string * hoare_tac) list, - vcg_simps: thm list} + vcg_simps: thm list, + state_spaces: (string * state_space) list (* registry for state space extensions *) + } val get_data: Proof.context -> hoare_data - val get_params: string -> Proof.context -> (par_kind * string) list option + val get_params: string -> Proof.context -> (par_kind * string * lense option) list option val get_default_state_kind: Proof.context -> state_kind val get_state_kind: string -> Proof.context -> state_kind option + val get_default_state_space: Proof.context -> state_space option val clique_name: string list -> string val install_generate_guard: (Proof.context -> term -> term option) -> Context.generic -> Context.generic val generate_guard: Proof.context -> term -> term option + val install_name_tr: (Proof.context -> bool -> string -> string) -> + Context.generic -> Context.generic + val name_tr: Proof.context -> bool -> string -> string + val install_state_space: state_space -> Context.generic -> Context.generic val BasicSimpTac: Proof.context -> state_kind -> bool -> thm list -> (int -> tactic) -> int -> tactic val hoare: (Proof.context -> Proof.method) context_parser @@ -76,14 +88,25 @@ sig val vcg_tac : string -> string -> string list -> Proof.context -> int -> tactic val hoare_rule_tac : Proof.context -> thm list -> int -> tactic + val solve_modifies_tac: Proof.context -> state_kind -> (term -> int) -> int -> tactic + + val add_hoare_tacs: (string * hoare_tac) list -> Context.generic -> Context.generic datatype 'a bodykind = BodyTyp of 'a | BodyTerm of 'a val proc_specs : (bstring * string) list parser - val add_params : morphism -> string -> (par_kind * string) list -> + val add_params : morphism -> string -> (par_kind * string * lense option) list -> Context.generic -> Context.generic val set_default_state_kind : state_kind -> Context.generic -> Context.generic val add_state_kind : morphism -> string -> state_kind -> Context.generic -> Context.generic val add_recursive : morphism -> string -> Context.generic -> Context.generic + + structure FunSplitState : SPLIT_STATE + val first_subterm: (term -> bool) -> term -> ((string * typ) list * term) option + val dest_string: term -> string + val dest_hoare_raw: term -> term * term * term * term * hoareMode * term * term * term + val idx: ('a -> string -> bool) -> 'a list -> string -> int + val sort_variables: bool Config.T + val destr_to_constr: term -> term end; structure Hoare: HOARE = @@ -96,7 +119,7 @@ val use_generalise = Attrib.setup_config_bool @{binding hoare_use_generalise} (K val sort_variables = Attrib.setup_config_bool @{binding hoare_sort_variables} (K true); val use_cond_inv_modifies = Attrib.setup_config_bool @{binding hoare_use_cond_inv_modifies} (K true); -val hoare_trace = Attrib.setup_config_bool @{binding hoare_trace} (K false); +val hoare_trace = Attrib.setup_config_int @{binding hoare_trace} (K 0); val body_def_sfx = "_body"; @@ -164,6 +187,15 @@ datatype hoareMode = Partial | Total fun get_rule p t Partial = p | get_rule p t Total = t +fun get_rule' p t m Partial true = m + | get_rule' p t m Partial false = p + | get_rule' p t m Total _ = t + +fun get_call_rule p t p_exn t_exn Partial NONE = p + | get_call_rule p t p_exn t_exn Partial (SOME _) = p_exn + | get_call_rule p t p_exn t_exn Total NONE = t + | get_call_rule p t p_exn t_exn Total (SOME _) = t_exn + val Guard = get_rule @{thm HoarePartial.Guard} @{thm HoareTotal.Guard}; val GuardStrip = get_rule @{thm HoarePartial.GuardStrip} @{thm HoareTotal.GuardStrip}; @@ -195,19 +227,19 @@ val Throw = get_rule @{thm HoarePartial.Throw} @{thm HoareTotal.Throw}; val Raise = get_rule @{thm HoarePartial.raise} @{thm HoareTotal.raise}; -val Catch = get_rule @{thm HoarePartial.Catch} @{thm HoareTotal.Catch}; +val Catch = get_rule' @{thm HoarePartial.Catch} @{thm HoareTotal.Catch} @{thm HoarePartial.CatchSame}; -val CondCatch = get_rule @{thm HoarePartial.condCatch} @{thm HoareTotal.condCatch}; +val CondCatch = get_rule' @{thm HoarePartial.condCatch} @{thm HoareTotal.condCatch} @{thm HoarePartial.condCatchSame}; val CatchSwap = get_rule @{thm HoarePartial.CatchSwap} @{thm HoareTotal.CatchSwap}; val CondCatchSwap = get_rule @{thm HoarePartial.condCatchSwap} @{thm HoareTotal.condCatchSwap}; -val Seq = get_rule @{thm HoarePartial.Seq} @{thm HoareTotal.Seq}; +val Seq = get_rule' @{thm HoarePartial.Seq} @{thm HoareTotal.Seq} @{thm HoarePartial.SeqSame}; val SeqSwap = get_rule @{thm HoarePartial.SeqSwap} @{thm HoareTotal.SeqSwap}; -val BSeq = get_rule @{thm HoarePartial.BSeq} @{thm HoareTotal.BSeq}; +val BSeq = get_rule' @{thm HoarePartial.BSeq} @{thm HoareTotal.BSeq} @{thm HoarePartial.BSeqSame}; val Cond = get_rule @{thm HoarePartial.Cond} @{thm HoareTotal.Cond}; @@ -235,60 +267,79 @@ val Block = get_rule @{thm HoarePartial.Block} @{thm HoareTotal.Block}; val BlockSwap = get_rule @{thm HoarePartial.BlockSwap} @{thm HoareTotal.BlockSwap}; -val Proc = get_rule @{thm HoarePartial.ProcSpec} @{thm HoareTotal.ProcSpec}; +val Proc = get_call_rule + @{thm HoarePartial.ProcSpec} @{thm HoareTotal.ProcSpec} + @{thm HoarePartial.Proc_exnSpec} @{thm HoareTotal.Proc_exnSpec}; -val ProcNoAbr = get_rule @{thm HoarePartial.ProcSpecNoAbrupt} @{thm HoareTotal.ProcSpecNoAbrupt}; +val ProcNoAbr = get_call_rule + @{thm HoarePartial.ProcSpecNoAbrupt} @{thm HoareTotal.ProcSpecNoAbrupt} + @{thm HoarePartial.Proc_exnSpecNoAbrupt} @{thm HoareTotal.Proc_exnSpecNoAbrupt}; val ProcBody = get_rule @{thm HoarePartial.ProcBody} @{thm HoareTotal.ProcBody}; -val CallBody = get_rule @{thm HoarePartial.CallBody} @{thm HoareTotal.CallBody}; +val CallBody = get_call_rule + @{thm HoarePartial.CallBody} @{thm HoareTotal.CallBody} + @{thm HoarePartial.Call_exnBody} @{thm HoareTotal.Call_exnBody}; val FCall = get_rule @{thm HoarePartial.FCall} @{thm HoareTotal.FCall}; val ProcRecSpecs = get_rule @{thm HoarePartial.ProcRecSpecs} @{thm HoareTotal.ProcRecSpecs}; -val ProcModifyReturnSameFaults = - get_rule @{thm HoarePartial.ProcModifyReturnSameFaults} @{thm HoareTotal.ProcModifyReturnSameFaults}; +val ProcModifyReturnSameFaults = get_call_rule + @{thm HoarePartial.ProcModifyReturnSameFaults} @{thm HoareTotal.ProcModifyReturnSameFaults} + @{thm HoarePartial.Proc_exnModifyReturnSameFaults} @{thm HoareTotal.Proc_exnModifyReturnSameFaults}; -val ProcModifyReturn = get_rule @{thm HoarePartial.ProcModifyReturn} @{thm HoareTotal.ProcModifyReturn}; +val ProcModifyReturn = get_call_rule + @{thm HoarePartial.ProcModifyReturn} @{thm HoareTotal.ProcModifyReturn} + @{thm HoarePartial.Proc_exnModifyReturn} @{thm HoareTotal.Proc_exnModifyReturn}; -val ProcModifyReturnNoAbr = get_rule @{thm HoarePartial.ProcModifyReturnNoAbr} @{thm HoareTotal.ProcModifyReturnNoAbr}; +val ProcModifyReturnNoAbr = get_call_rule + @{thm HoarePartial.ProcModifyReturnNoAbr} @{thm HoareTotal.ProcModifyReturnNoAbr} + @{thm HoarePartial.Proc_exnModifyReturnNoAbr} @{thm HoareTotal.Proc_exnModifyReturnNoAbr}; val ProcModifyReturnNoAbrSameFaultsPartial = @{thm HoarePartial.ProcModifyReturnNoAbrSameFaults}; val ProcModifyReturnNoAbrSameFaultsTotal = @{thm HoareTotal.ProcModifyReturnNoAbrSameFaults}; -val ProcModifyReturnNoAbrSameFaults = - get_rule ProcModifyReturnNoAbrSameFaultsPartial ProcModifyReturnNoAbrSameFaultsTotal; +val ProcModifyReturnNoAbrSameFaults = get_call_rule + ProcModifyReturnNoAbrSameFaultsPartial ProcModifyReturnNoAbrSameFaultsTotal + @{thm HoarePartial.Proc_exnModifyReturnNoAbrSameFaults} @{thm HoareTotal.Proc_exnModifyReturnNoAbrSameFaults}; val TrivPost = get_rule @{thm HoarePartial.TrivPost} @{thm HoareTotal.TrivPost}; val TrivPostNoAbr = get_rule @{thm HoarePartial.TrivPostNoAbr} @{thm HoareTotal.TrivPostNoAbr}; -val DynProcProcPar = get_rule @{thm HoarePartial.DynProcProcPar} @{thm HoareTotal.DynProcProcPar}; +val DynProcProcPar = get_call_rule + @{thm HoarePartial.DynProcProcPar} @{thm HoareTotal.DynProcProcPar} + @{thm HoarePartial.DynProc_exnProcPar} @{thm HoareTotal.DynProc_exnProcPar}; -val DynProcProcParNoAbr = get_rule @{thm HoarePartial.DynProcProcParNoAbrupt} @{thm HoareTotal.DynProcProcParNoAbrupt}; +val DynProcProcParNoAbr = get_call_rule + @{thm HoarePartial.DynProcProcParNoAbrupt} @{thm HoareTotal.DynProcProcParNoAbrupt} + @{thm HoarePartial.DynProc_exnProcParNoAbrupt} @{thm HoareTotal.DynProc_exnProcParNoAbrupt}; -val ProcProcParModifyReturn = get_rule @{thm HoarePartial.ProcProcParModifyReturn} @{thm HoareTotal.ProcProcParModifyReturn}; +val ProcProcParModifyReturn = get_call_rule + @{thm HoarePartial.ProcProcParModifyReturn} @{thm HoareTotal.ProcProcParModifyReturn} + @{thm HoarePartial.Proc_exnProcParModifyReturn} @{thm HoareTotal.Proc_exnProcParModifyReturn}; val ProcProcParModifyReturnSameFaultsPartial = @{thm HoarePartial.ProcProcParModifyReturnSameFaults}; val ProcProcParModifyReturnSameFaultsTotal = @{thm HoareTotal.ProcProcParModifyReturnSameFaults}; -val ProcProcParModifyReturnSameFaults = - get_rule ProcProcParModifyReturnSameFaultsPartial - ProcProcParModifyReturnSameFaultsTotal; +val ProcProcParModifyReturnSameFaults = get_call_rule + ProcProcParModifyReturnSameFaultsPartial ProcProcParModifyReturnSameFaultsTotal + @{thm HoarePartial.ProcProcParModifyReturnSameFaults} @{thm HoareTotal.ProcProcParModifyReturnSameFaults}; -val ProcProcParModifyReturnNoAbr = - get_rule @{thm HoarePartial.ProcProcParModifyReturnNoAbr} @{thm HoareTotal.ProcProcParModifyReturnNoAbr}; +val ProcProcParModifyReturnNoAbr = get_call_rule + @{thm HoarePartial.ProcProcParModifyReturnNoAbr} @{thm HoareTotal.ProcProcParModifyReturnNoAbr} + @{thm HoarePartial.Proc_exnProcParModifyReturnNoAbr} @{thm HoareTotal.Proc_exnProcParModifyReturnNoAbr}; val ProcProcParModifyReturnNoAbrSameFaultsPartial = @{thm HoarePartial.ProcProcParModifyReturnNoAbrSameFaults}; val ProcProcParModifyReturnNoAbrSameFaultsTotal = @{thm HoareTotal.ProcProcParModifyReturnNoAbrSameFaults}; -val ProcProcParModifyReturnNoAbrSameFaults = - get_rule ProcProcParModifyReturnNoAbrSameFaultsPartial - ProcProcParModifyReturnNoAbrSameFaultsTotal; +val ProcProcParModifyReturnNoAbrSameFaults = get_call_rule + ProcProcParModifyReturnNoAbrSameFaultsPartial ProcProcParModifyReturnNoAbrSameFaultsTotal + @{thm HoarePartial.Proc_exnProcParModifyReturnNoAbrSameFaults} @{thm HoareTotal.Proc_exnProcParModifyReturnNoAbrSameFaults}; val DynCom = get_rule @{thm HoarePartial.DynComConseq} @{thm HoareTotal.DynComConseq}; @@ -389,38 +440,10 @@ fun resuffix sfx1 sfx2 s = suffix sfx2 (unsuffix sfx1 s) handle Fail _ => s; -(* state space representation dependent functions *) - -datatype state_kind = Record | Function -fun state_simprocs Record = [Record.simproc] - | state_simprocs Function = [Record.simproc, StateFun.lookup_simproc]; - -fun state_upd_simproc Record = Record.upd_simproc - | state_upd_simproc Function = StateFun.update_simproc; - -fun state_ex_sel_eq_simproc Record = Record.ex_sel_eq_simproc - | state_ex_sel_eq_simproc Function = StateFun.ex_lookup_eq_simproc; - -val state_split_simp_tac = Record.split_simp_tac -val state_hierarchy = Record.dest_recTs - - -fun stateT_id T = case (state_hierarchy T) of [] => NONE | Ts => SOME (last Ts); - -fun globalsT (Type (_, T :: _)) = SOME T - | globalsT _ = NONE; - -fun stateT_ids T = - (case stateT_id T of - NONE => NONE - | SOME sT => (case globalsT T of - NONE => SOME [sT] - | SOME gT => (case stateT_id gT of - NONE => SOME [sT] - | SOME gT' => SOME [sT,gT']))); - datatype par_kind = In | Out +datatype state_kind = Record | Function | Other of string; + (*** utilities ***) @@ -439,100 +462,38 @@ fun chopsfx sfx str = val is_state_var = can (unsuffix deco); -(* removes the suffix of the string beginning with deco. - * "xys_'a" --> "xys"; - * The a is also chopped, since sometimes the bound variables - * are renamed, I think SELECT_GOAL in rename_goal is to blame - *) -fun remdeco' str = - let - fun chop (p::ps) (x::xs) = chop ps xs - | chop [] xs = [] - | chop (p::ps) [] = error "remdeco: code should never be reached"; - - fun remove prf (s as (x::xs)) = if is_prefix (op =) prf s then chop prf s - else (x::remove prf xs) - | remove prf [] = []; - - in String.implode (remove (String.explode deco) (String.explode str)) end; fun extern ctxt s = (case try (Proof_Context.extern_const ctxt o Lexicon.unmark_const) s of NONE => s | SOME s' => s'); -fun remdeco ctxt s = remdeco' (extern ctxt s); - -fun undeco ctxt (Const (c, T)) = Const (remdeco ctxt c, T) - | undeco ctxt ((f as Const (@{syntax_const "_free"},_)) $ Free (x, T)) = - (*f$*)Const (remdeco' x, T) - | undeco ctxt (Const _ $ _ $ ((Const (@{syntax_const "_free"},_)) $ Free (x, T))) = - (*f$*)Const (remdeco' x, T) - | undeco ctxt (Free (c, T)) = Const (remdeco' c, T) - | undeco ctxt x = x - fun varname x = x ^ deco -val dest_string = map (chr o HOLogic.dest_char) o HOLogic.dest_list; +val dest_string = implode o map (chr o HOLogic.dest_char) o HOLogic.dest_list; fun dest_string' t = (case try dest_string t of - SOME s => implode s + SOME s => s | NONE => (case t of Free (s,_) => s | Const (s,_) => Long_Name.base_name s | _ => raise TERM ("dest_string'",[t]))) +val state_hierarchy = Record.dest_recTs +fun stateT_id T = case (state_hierarchy T) of [] => NONE | Ts => SOME (last Ts); -fun is_state_space_var Tids t = - let - fun is_stateT T = (case stateT_id T of NONE => 0 - | SOME id => if member (op =) Tids id then ~1 else 0); - in - (case t of - Const _ $ Abs (_,T,_) => is_stateT T - | Free (_,T) => is_stateT T - | _ => 0) - end; - - -datatype callMode = Static | Parameter - -fun proc_name Static (Const (p,_)$_) = resuffix deco proc_deco (Long_Name.base_name p) - | proc_name Static (Const (@{const_name StateFun.lookup},_)$_$Free (p,_)$_) = - suffix proc_deco (remdeco' (Long_Name.base_name p)) - | proc_name Static p = dest_string' p - | proc_name Parameter (Const (p,_)) = resuffix deco proc_deco (Long_Name.base_name p) - | proc_name Parameter (Abs (_,_,Const (p,_)$Bound 0)) = - resuffix deco proc_deco (Long_Name.base_name p) - | proc_name Parameter (Abs (_,_,Const (@{const_name StateFun.lookup},_)$_$Free (p,_)$_)) = - suffix proc_deco (remdeco' (Long_Name.base_name p)) - | proc_name _ t = raise TERM ("proc_name",[t]); - - - -fun dest_call (Const (@{const_name Language.call},_)$init$pname$return$c) = - (init,pname,return,c,Static,true) - | dest_call (Const (@{const_name Language.fcall},_)$init$pname$return$_$c) = - (init,pname,return,c,Static,true) - | dest_call (Const (@{const_name Language.com.Call},_)$pname) = - (Bound 0,pname,Bound 0,Bound 0,Static,false) - | dest_call (Const (@{const_name Language.dynCall},_)$init$pname$return$c) = - (init,pname,return,c,Parameter,true) - | dest_call t = raise TERM ("Hoare.dest_call: unexpected term",[t]); - -fun dest_whileAnno (Const (@{const_name Language.whileAnnoG},_) $gs$b$I$V$c) = - (SOME gs,b,I,V,c,false) - | dest_whileAnno (Const (@{const_name Language.whileAnno},_) $b$I$V$c) = (NONE,b,I,V,c,false) - | dest_whileAnno (Const (@{const_name Language.whileAnnoGFix},_)$gs$b$I$V$c) = - (SOME gs,b,I,V,c,true) - | dest_whileAnno (Const (@{const_name Language.whileAnnoFix},_) $b$I$V$c) = (NONE,b,I,V,c,true) - | dest_whileAnno t = raise TERM ("Hoare.dest_while: unexpected term",[t]); - -fun dest_Guard (Const (@{const_name Language.com.Guard},_)$f$g$c) = (f,g,c,false) - | dest_Guard (Const (@{const_name Language.guaranteeStrip},_)$f$g$c) = (f,g,c,true) - | dest_Guard t = raise TERM ("Hoare.dest_guard: unexpected term",[t]); +fun globalsT (Type (_, T :: _)) = SOME T + | globalsT _ = NONE; +fun stateT_ids T = + (case stateT_id T of + NONE => NONE + | SOME sT => (case globalsT T of + NONE => SOME [sT] + | SOME gT => (case stateT_id gT of + NONE => SOME [sT] + | SOME gT' => SOME [sT,gT']))); (*** extend theory by procedure definition ***) @@ -546,28 +507,62 @@ fun add_declaration name decl thy = (* data kind 'HOL/hoare' *) +type lense = {lookup: term, update : term} + type proc_info = - {params: ((par_kind * string) list), - recursive: bool, - state_kind: state_kind} + { + params: ((par_kind * string * lense option) list), + recursive: bool, + state_kind: state_kind + }; + +type state_space = + { + name: string, + is_state_type: Proof.context -> typ -> bool, + generalise: Proof.context -> int -> tactic, + state_simprocs: simproc list, + state_upd_simprocs: simproc list, + state_ex_sel_eq_simprocs: simproc list, + is_defined: Proof.context -> xstring -> bool, + read_function_name: Proof.context -> xstring -> term, + lookup_tr: Proof.context -> xstring -> term, + update_tr: Proof.context -> xstring -> term, + is_lookup: Proof.context -> term -> bool, + lookup_tr': Proof.context -> term -> term, + dest_update_tr': Proof.context -> term -> term * term * term option, + update_tr': Proof.context -> term -> term + }; + type hoare_tac = (bool -> int -> tactic) -> Proof.context -> hoareMode -> int -> tactic; type hoare_data = - {proc_info: proc_info Symtab.table, - active_procs: string list list, - default_state_kind: state_kind, - generate_guard: (stamp * (Proof.context -> term -> term option)), - wp_tacs: (string * hoare_tac) list, - hoare_tacs: (string * hoare_tac) list, - vcg_simps: thm list}; + { + proc_info: proc_info Symtab.table, + active_procs: string list list, + default_state_kind: state_kind, + generate_guard: (stamp option * (Proof.context -> term -> term option)), + name_tr: (stamp option * (Proof.context -> bool -> string -> string)), + hoare_tacs: (string * hoare_tac) list, + vcg_simps: thm list, + state_spaces: (string * state_space) list + }; fun make_hoare_data proc_info active_procs default_state_kind generate_guard - wp_tacs hoare_tacs vcg_simps = + name_tr hoare_tacs vcg_simps state_spaces = {proc_info = proc_info, active_procs = active_procs, default_state_kind = default_state_kind, generate_guard = generate_guard, - wp_tacs = wp_tacs, hoare_tacs = hoare_tacs, vcg_simps = vcg_simps}; + name_tr = name_tr, hoare_tacs = hoare_tacs, vcg_simps = vcg_simps, state_spaces = state_spaces}; + +fun merge_stamped err_msg ((NONE, _), p) = p + | merge_stamped err_msg (p, (NONE,_)) = p + | merge_stamped err_msg ((SOME (stamp1:stamp), x), (SOME stamp2, _)) = + if stamp1 = stamp2 then (SOME stamp1, x) + else error err_msg; + +fun fast_merge merge (x, y) = if pointer_eq (x, y) then x else merge (x, y) structure Hoare_Data = Generic_Data ( @@ -577,33 +572,74 @@ structure Hoare_Data = Generic_Data (Symtab.empty: proc_info Symtab.table) ([]:string list list) (Function) - (stamp (),(K (K NONE)): Proof.context -> term -> term option) + (NONE,(K (K NONE)): Proof.context -> term -> term option) + (NONE,(K (K I)): Proof.context -> bool -> string -> string) ([]:(string * hoare_tac) list) - ([]:(string * hoare_tac) list) - ([]:thm list); + ([]:thm list) + ([]:(string * state_space) list); - (* FIXME exponential blowup due to append !? *) - fun merge ({proc_info = proc_info1, active_procs = active_procs1, + val merge = fast_merge (fn ({proc_info = proc_info1, active_procs = active_procs1, default_state_kind = _, - generate_guard = (stmp1,generate_gaurd1), - wp_tacs = wp_tacs1, hoare_tacs = hoare_tacs1, vcg_simps = vcg_simps1}, + generate_guard = generate_guard1, + name_tr = name_tr1, hoare_tacs = hoare_tacs1, vcg_simps = vcg_simps1, state_spaces=state_spaces1}, {proc_info = proc_info2, active_procs = active_procs2, default_state_kind = default_state_kind2, - generate_guard = (stmp2, _), - wp_tacs = wp_tacs2, hoare_tacs = hoare_tacs2, vcg_simps=vcg_simps2}) : T = - if stmp1=stmp2 then + generate_guard = generate_guard2, + name_tr = name_tr2, hoare_tacs = hoare_tacs2, vcg_simps=vcg_simps2, state_spaces=state_spaces2}) => make_hoare_data (Symtab.merge (K true) (proc_info1,proc_info2)) (active_procs1 @ active_procs2) (default_state_kind2) - (stmp1,generate_gaurd1) - (wp_tacs1 @ wp_tacs2) - (hoare_tacs1 @ hoare_tacs2) + (merge_stamped + "Theories have different aux. functions to generate guards, please resolve before merge" + (generate_guard1, generate_guard2)) + (merge_stamped + "Theories have different aux. functions to translate names, please resolve before merge" + (name_tr1, name_tr2)) + (AList.merge (op =) (K true) (hoare_tacs1, hoare_tacs2)) (Thm.merge_thms (vcg_simps1,vcg_simps2)) - else error ("Theories have different aux. functions to generate guards") + (AList.merge (op =) (K true) (state_spaces1, state_spaces2))) ); val get_data = Hoare_Data.get o Context.Proof; +(* state space representation dependent functions *) + +fun get_state_space_comps sel ctxt n = + AList.lookup (op =) (#state_spaces (Hoare_Data.get (Context.Proof ctxt))) n + |> Option.map sel |> these; + + +fun state_simprocs ctxt Record = [Record.simproc] + | state_simprocs ctxt Function = [Record.simproc, StateFun.lookup_simproc] + | state_simprocs ctxt (Other n) = get_state_space_comps (#state_simprocs) ctxt n; + + +fun state_upd_simprocs ctxt Record = [Record.upd_simproc] + | state_upd_simprocs ctxt Function = [StateFun.update_simproc] + | state_upd_simprocs ctxt (Other n) = get_state_space_comps (#state_upd_simprocs) ctxt n; + +fun state_ex_sel_eq_simprocs ctxt Record = [Record.ex_sel_eq_simproc] + | state_ex_sel_eq_simprocs ctxt Function = [StateFun.ex_lookup_eq_simproc] + | state_ex_sel_eq_simprocs ctxt (Other n) = get_state_space_comps (#state_ex_sel_eq_simprocs) ctxt n; + +val state_split_simp_tac = Record.split_simp_tac +val state_hierarchy = Record.dest_recTs + + +fun stateT_id T = case (state_hierarchy T) of [] => NONE | Ts => SOME (last Ts); + +fun globalsT (Type (_, T :: _)) = SOME T + | globalsT _ = NONE; + +fun stateT_ids T = + (case stateT_id T of + NONE => NONE + | SOME sT => (case globalsT T of + NONE => SOME [sT] + | SOME gT => (case stateT_id gT of + NONE => SOME [sT] + | SOME gT' => SOME [sT,gT']))); + (* access 'params' *) @@ -625,52 +661,52 @@ datatype 'a bodykind = BodyTyp of 'a | BodyTerm of 'a fun set_default_state_kind sk context = let - val {proc_info,active_procs,default_state_kind,generate_guard,wp_tacs,hoare_tacs, - vcg_simps,...} + val {proc_info,active_procs,default_state_kind,generate_guard,name_tr,hoare_tacs, + vcg_simps,state_spaces, ...} = Hoare_Data.get context; val data = make_hoare_data proc_info active_procs sk - generate_guard wp_tacs hoare_tacs vcg_simps; + generate_guard name_tr hoare_tacs vcg_simps state_spaces; in Hoare_Data.put data context end; val get_default_state_kind = #default_state_kind o get_data; +fun get_default_state_space ctxt = + case get_default_state_kind ctxt of + Other sp => AList.lookup (op =) (#state_spaces (Hoare_Data.get (Context.Proof ctxt))) sp + | _ => NONE + fun add_active_procs phi ps context = let - val {proc_info,active_procs,default_state_kind,generate_guard,wp_tacs,hoare_tacs, - vcg_simps,...} + val {proc_info,active_procs,default_state_kind,generate_guard,name_tr,hoare_tacs, + vcg_simps,state_spaces, ...} = Hoare_Data.get context; val data = make_hoare_data proc_info ((map (morph_name context phi) ps)::active_procs) default_state_kind - generate_guard wp_tacs hoare_tacs vcg_simps; + generate_guard name_tr hoare_tacs vcg_simps state_spaces; in Hoare_Data.put data context end; fun add_hoare_tacs tacs context = let - val {proc_info,active_procs, default_state_kind, generate_guard,wp_tacs,hoare_tacs, - vcg_simps,...} + val {proc_info,active_procs, default_state_kind, generate_guard,name_tr,hoare_tacs, + vcg_simps,state_spaces,...} = Hoare_Data.get context; val data = make_hoare_data proc_info active_procs default_state_kind generate_guard - wp_tacs (hoare_tacs@tacs) vcg_simps; + name_tr (AList.merge (op =) (K true) (hoare_tacs, tacs)) vcg_simps state_spaces; in Hoare_Data.put data context end; fun map_vcg_simps f context = let - val {proc_info,active_procs,default_state_kind,generate_guard,wp_tacs,hoare_tacs, - vcg_simps,...} + val {proc_info,active_procs,default_state_kind,generate_guard,name_tr,hoare_tacs, + vcg_simps,state_spaces,...} = Hoare_Data.get context; val data = make_hoare_data proc_info active_procs default_state_kind generate_guard - wp_tacs hoare_tacs (f vcg_simps); + name_tr hoare_tacs (f vcg_simps) state_spaces; in Hoare_Data.put data context end; -fun thy_attrib f = Thm.declaration_attribute (fn thm => map_vcg_simps (f thm)); - -val vcg_simpadd = Thm.add_thm -val vcg_simpdel = Thm.del_thm - -val vcg_simp_add = thy_attrib vcg_simpadd; -val vcg_simp_del = thy_attrib vcg_simpdel; +val vcg_simp_add = Thm.declaration_attribute (map_vcg_simps o Thm.add_thm o Thm.trim_context); +val vcg_simp_del = Thm.declaration_attribute (map_vcg_simps o Thm.del_thm); (* add 'procedure' *) @@ -687,18 +723,21 @@ fun map_proc_info_state_kind f {params,recursive,state_kind} = mk_proc_info params recursive (f state_kind); +fun morph_lense phi ({lookup, update}:lense) = + {lookup = Morphism.term phi lookup, update = Morphism.term phi update}:lense; fun add_params phi name frmls context = let - val {proc_info,active_procs,default_state_kind,generate_guard,wp_tacs,hoare_tacs, - vcg_simps,...} + val {proc_info,active_procs,default_state_kind,generate_guard,name_tr,hoare_tacs, + vcg_simps,state_spaces, ...} = Hoare_Data.get context; - val params = map (apsnd (morph_name context phi)) frmls; + val params = map (fn (kind, name, lense_opt) => + (kind, morph_name context phi name, Option.map (morph_lense phi) lense_opt)) frmls; val f = map_proc_info_params (K params); val default = f empty_proc_info; - val proc_info' = Symtab.map_default (morph_name context phi name,default) f proc_info; + val proc_info' = Symtab.map_default (morph_name context phi name, default) f proc_info; val data = make_hoare_data proc_info' active_procs default_state_kind - generate_guard wp_tacs hoare_tacs vcg_simps; + generate_guard name_tr hoare_tacs vcg_simps state_spaces; in Hoare_Data.put data context end; fun get_params name ctxt = @@ -707,14 +746,14 @@ fun get_params name ctxt = fun add_recursive phi name context = let - val {proc_info,active_procs,default_state_kind,generate_guard,wp_tacs,hoare_tacs, - vcg_simps,...} + val {proc_info,active_procs,default_state_kind,generate_guard,name_tr,hoare_tacs, + vcg_simps,state_spaces, ...} = Hoare_Data.get context; val f = map_proc_info_recursive (K true); val default = f empty_proc_info; val proc_info'= Symtab.map_default (morph_name context phi name,default) f proc_info; val data = make_hoare_data proc_info' active_procs default_state_kind - generate_guard wp_tacs hoare_tacs vcg_simps; + generate_guard name_tr hoare_tacs vcg_simps state_spaces; in Hoare_Data.put data context end; fun get_recursive name ctxt = @@ -722,14 +761,14 @@ fun get_recursive name ctxt = fun add_state_kind phi name sk context = let - val {proc_info,active_procs,default_state_kind,generate_guard,wp_tacs,hoare_tacs, - vcg_simps,...} + val {proc_info,active_procs,default_state_kind,generate_guard,name_tr,hoare_tacs, + vcg_simps,state_spaces,...} = Hoare_Data.get context; val f = map_proc_info_state_kind (K sk); val default = f empty_proc_info; val proc_info'= Symtab.map_default (morph_name context phi name,default) f proc_info; val data = make_hoare_data proc_info' active_procs default_state_kind - generate_guard wp_tacs hoare_tacs vcg_simps; + generate_guard name_tr hoare_tacs vcg_simps state_spaces; in Hoare_Data.put data context end; fun get_state_kind name ctxt = @@ -737,15 +776,124 @@ fun get_state_kind name ctxt = fun install_generate_guard f context = let - val {proc_info,active_procs, default_state_kind, generate_guard,wp_tacs,hoare_tacs, - vcg_simps,...} = + val {proc_info,active_procs, default_state_kind, generate_guard,name_tr,hoare_tacs, + vcg_simps,state_spaces,...} = Hoare_Data.get context; - val data = make_hoare_data proc_info active_procs default_state_kind (stamp (), f) - wp_tacs hoare_tacs vcg_simps + val data = make_hoare_data proc_info active_procs default_state_kind (SOME (stamp ()), f) + name_tr hoare_tacs vcg_simps state_spaces in Hoare_Data.put data context end; fun generate_guard ctxt = snd (#generate_guard (get_data ctxt)) ctxt; +fun install_state_space sp ctxt = + let + val {proc_info,active_procs, default_state_kind, generate_guard,name_tr,hoare_tacs, + vcg_simps,state_spaces,...} = + Hoare_Data.get ctxt; + val data = make_hoare_data proc_info active_procs default_state_kind generate_guard + name_tr hoare_tacs vcg_simps (AList.update (op =) (#name sp, sp) state_spaces) + in Hoare_Data.put data ctxt end; + +fun generalise_other ctxt name = + Option.map #generalise (AList.lookup (op =) (#state_spaces (get_data ctxt)) name); + +fun install_name_tr f ctxt = + let + val {proc_info,active_procs, default_state_kind, generate_guard,name_tr,hoare_tacs, + vcg_simps,state_spaces,...} = + Hoare_Data.get ctxt; + val data = make_hoare_data proc_info active_procs default_state_kind generate_guard + (SOME (stamp ()), f) hoare_tacs vcg_simps state_spaces + in Hoare_Data.put data ctxt end; + +fun name_tr ctxt = snd (#name_tr (get_data ctxt)) ctxt; + + +(* utils for variable name decorations *) + + +(* removes the suffix of the string beginning with deco. + * "xys_'a" --> "xys"; + * The a is also chopped, since sometimes the bound variables + * are renamed, I think SELECT_GOAL in rename_goal is to blame + *) +fun remdeco' ctxt str = + let + fun chop (p::ps) (x::xs) = chop ps xs + | chop [] xs = [] + | chop (p::ps) [] = error "remdeco: code should never be reached"; + + fun remove prf (s as (x::xs)) = if is_prefix (op =) prf s then chop prf s + else (x::remove prf xs) + | remove prf [] = []; + + in name_tr ctxt false (String.implode (remove (String.explode deco) (String.explode str))) end; + + +fun remdeco ctxt s = remdeco' ctxt (extern ctxt s); + +fun undeco ctxt (Const (c, T)) = Const (remdeco ctxt c, T) + | undeco ctxt ((f as Const (@{syntax_const "_free"},_)) $ Free (x, T)) = + (*f$*)Const (remdeco' ctxt x, T) + | undeco ctxt (Const _ $ _ $ ((Const (@{syntax_const "_free"},_)) $ Free (x, T))) = + (*f$*)Const (remdeco' ctxt x, T) + | undeco ctxt (Free (c, T)) = Const (remdeco' ctxt c, T) + | undeco ctxt x = x + +fun is_state_space_var Tids t = + let + fun is_stateT T = (case stateT_id T of NONE => 0 + | SOME id => if member (op =) Tids id then ~1 else 0); + in + (case t of + Const _ $ Abs (_,T,_) => is_stateT T + | Free (_,T) => is_stateT T + | _ => 0) + end; + + +datatype callMode = Static | Parameter + +fun proc_name ctxt Static (Const (p,_)$_) = resuffix deco proc_deco (Long_Name.base_name p) + | proc_name ctxt Static (Const (@{const_name StateFun.lookup},_)$_$Free (p,_)$_) = + suffix proc_deco (remdeco' ctxt (Long_Name.base_name p)) + | proc_name ctxt Static p = dest_string' p + | proc_name ctxt Parameter (Const (p,_)) = resuffix deco proc_deco (Long_Name.base_name p) + | proc_name ctxt Parameter (Abs (_,_,Const (p,_)$Bound 0)) = + resuffix deco proc_deco (Long_Name.base_name p) + | proc_name ctxt Parameter (Abs (_,_,Const (@{const_name StateFun.lookup},_)$_$Free (p,_)$_)) = + suffix proc_deco (remdeco' ctxt (Long_Name.base_name p)) + | proc_name _ _ t = raise TERM ("proc_name",[t]); + + +fun dest_call (Const (@{const_name Language.call},_)$init$pname$return$c) = + (init,pname,return,c,Static,true,NONE) + | dest_call (Const (@{const_name Language.fcall},_)$init$pname$return$_$c) = + (init,pname,return,c,Static,true,NONE) + | dest_call (Const (@{const_name Language.com.Call},_)$pname) = + (Bound 0,pname,Bound 0,Bound 0,Static,false,NONE) + | dest_call (Const (@{const_name Language.dynCall},_)$init$pname$return$c) = + (init,pname,return,c,Parameter,true,NONE) + | dest_call (Const (@{const_name Language.call_exn},_)$init$pname$return$result_exn$c) = + (init,pname,return,c,Static,true,SOME result_exn) + | dest_call (Const (@{const_name Language.dynCall_exn},_)$init$pname$return$result_exn$c) = + (init,pname,return,c,Parameter,true,SOME result_exn) + | dest_call t = raise TERM ("Hoare.dest_call: unexpected term",[t]); + + +fun dest_whileAnno (Const (@{const_name Language.whileAnnoG},_) $gs$b$I$V$c) = + (SOME gs,b,I,V,c,false) + | dest_whileAnno (Const (@{const_name Language.whileAnno},_) $b$I$V$c) = (NONE,b,I,V,c,false) + | dest_whileAnno (Const (@{const_name Language.whileAnnoGFix},_)$gs$b$I$V$c) = + (SOME gs,b,I,V,c,true) + | dest_whileAnno (Const (@{const_name Language.whileAnnoFix},_) $b$I$V$c) = (NONE,b,I,V,c,true) + | dest_whileAnno t = raise TERM ("Hoare.dest_while: unexpected term",[t]); + +fun dest_Guard (Const (@{const_name Language.com.Guard},_)$f$g$c) = (f,g,c,false) + | dest_Guard (Const (@{const_name Language.guaranteeStrip},_)$f$g$c) = (f,g,c,true) + | dest_Guard t = raise TERM ("Hoare.dest_guard: unexpected term",[t]); + + fun check_procedures_definition procs thy = let @@ -775,7 +923,7 @@ fun check_procedures_definition procs thy = maps (fn (name,inpars,outpars,locals,_,_,_) => duplicate_pars name (inpars @ locals) @ duplicate_pars name (outpars @ locals)) procs; - (* FIXME: Check that no global variables are used as result parameters *) + (* fixme: Check that no global variables are used as result parameters *) val errs = err_already_defined @ err_duplicate_procs @ err_duplicate_pars; in if null errs then () else error (cat_lines errs) end; @@ -783,12 +931,13 @@ fun check_procedures_definition procs thy = fun add_parameter_info phi cname (name,(inpars,outpars,state_kind)) context = let fun par_deco' T = if T = "" then deco else par_deco (cname name); - val pars = map (fn (par,T) => (In,suffix (par_deco' T) par)) inpars@ - map (fn (par,T) => (Out,suffix (par_deco' T) par)) outpars; - in - context - |> add_params phi name pars - |> add_state_kind phi name state_kind + val pars = map (fn (par,T) => (In,suffix (par_deco' T) par, NONE)) inpars@ + map (fn (par,T) => (Out,suffix (par_deco' T) par, NONE)) outpars; + + val ctxt_decl = context + |> add_params phi name pars + |> add_state_kind phi name state_kind + in ctxt_decl end; fun mk_loc_exp xs = @@ -947,7 +1096,7 @@ fun procedures_definition locname procs thy = val bodies = map read_body name_body; fun dcall t = (case try dest_call t of - SOME (_,p,_,_,m,_) => SOME (proc_name m p) + SOME (_,p,_,_,m,_,_) => SOME (proc_name (Context.proof_of context) m p) | _ => NONE); fun in_names x = if member (op =) names x then SOME x else NONE; fun add_edges n = fold (fn x => Graph.add_edge (n, x)); @@ -1014,7 +1163,7 @@ fun procedures_definition locname procs thy = let val name' = unsuffix proc_deco name; val fixes = [Element.Fixes [(Binding.name name, SOME proc_nameT, NoSyn)]]; - (* FIXME: may use HOLogic.typeT as soon as locale type-inference works properly *) + (* fixme: may use HOLogic.typeT as soon as locale type-inference works properly *) val pE = mk_loc_exp [intern_locale thy (suffix parametersN cname)]; val sN = suffix signatureN name'; in thy @@ -1038,7 +1187,7 @@ fun procedures_definition locname procs thy = val callees = filter_out (fn n => n = name) (get_calls name) val fixes = [Element.Fixes [(Binding.name name, SOME proc_nameT, NoSyn)]]; - (* FIXME: may use HOLogic.typeT as soon as locale type-inference works properly *) + (* fixme: may use HOLogic.typeT as soon as locale type-inference works properly *) val pE = mk_loc_exp (map (intern_locale thy) ([lname variablesN (the (my_clique name))]@ @@ -1074,7 +1223,7 @@ fun procedures_definition locname procs thy = if has_body name then let - (* FIXME: All the read_term stuff is just because type-inference/abbrevs for + (* fixme: All the read_term stuff is just because type-inference/abbrevs for * new locale elements does not work right now; * We read the term to expand the abbreviations, then we print it again * (without folding the abbreviation) and reread as string *) @@ -1087,7 +1236,7 @@ fun procedures_definition locname procs thy = HOLogic.mk_eq (Free (gamma,fastype_of nt --> fastype_of rhs)$nt,rhs) val consts = Sign.consts_of thy; val eqs = - YXML.string_of_body (Term_XML.Encode.term consts (Consts.dummy_types consts eq)); + YXML.string_of_body (Term_XML.Encode.term consts (Consts.dummy_types consts eq)); val assms = Element.Assumes [((Binding.name (suffix bodyP name'), []),[(eqs,[])])] in [assms] end @@ -1328,7 +1477,12 @@ fun cond_rename_bvars cond name thm = val rename_bvars = cond_rename_bvars (K true); -fun trace_tac ctxt str st = (if Config.get ctxt hoare_trace then tracing str else (); all_tac st); +fun trace_msg ctxt str = if Config.get ctxt hoare_trace > 0 then tracing str else () +fun trace_tac ctxt str st = (trace_msg ctxt str; all_tac st); + +fun trace_subgoal_tac ctxt s i = + SUBGOAL (fn (prem, _) => trace_tac ctxt (s ^ (Syntax.string_of_term ctxt prem))) i + fun error_tac str st = (error str;no_tac st); @@ -1430,7 +1584,7 @@ fun mk_split_thms ctxt (vars as _::_) = end; fun prove_simp simps prop = - let val ([prop'], _) = Variable.importT_terms [prop] ctxt (* FIXME continue context!? *) + let val ([prop'], _) = Variable.importT_terms [prop] ctxt (* fixme continue context!? *) in Goal.prove_global thy [] [] prop' (fn {context = goal_ctxt, ...} => @@ -1559,17 +1713,19 @@ fun add_foldcongsimps simps thy = FoldCongData.map (fn ss => *) fun in_assertion_simp_tac ctxt state_kind thms i = let - val vcg_simps = #vcg_simps (get_data ctxt); - val fold_simps = get_foldcong_ss (Proof_Context.theory_of ctxt) + val thy = Proof_Context.theory_of ctxt + val vcg_simps = map (Thm.transfer thy) (#vcg_simps (get_data ctxt)); + val fold_simps = get_foldcong_ss thy + val state_simps = Named_Theorems.get ctxt @{named_theorems "state_simp"} in EVERY [simp_tac (put_simpset HOL_basic_ss ctxt addsimps ([mem_Collect_eq,@{thm Set.Un_iff},@{thm Set.Int_iff}, @{thm Set.empty_subsetI}, @{thm Set.empty_iff}, UNIV_I, - @{thm Hoare.Collect_False}]@thms@K_convs@vcg_simps) - addsimprocs (state_simprocs state_kind) + @{thm Hoare.Collect_False}]@state_simps@thms@K_convs@vcg_simps) + addsimprocs (state_simprocs ctxt state_kind) |> fold Simplifier.add_cong K_congs) i THEN_MAYBE - (simp_tac (put_simpset fold_simps ctxt addsimprocs [state_upd_simproc state_kind]) i) + (simp_tac (put_simpset fold_simps ctxt addsimprocs (state_upd_simprocs ctxt state_kind)) i) ] end; @@ -1606,12 +1762,16 @@ fun before_set2pred_simp_tac ctxt = (** simplification done by full_simp_tac **) (*****************************************************************************) +val Collect_subset_to_pred = +@{lemma \(\x. A x \ P x) + \ {x. A x} \ {x. P x}\ + by (rule subsetI, rule CollectI, drule CollectD, assumption)} + + fun set2pred_tac ctxt i thm = ((before_set2pred_simp_tac ctxt i) THEN_MAYBE (EVERY [trace_tac ctxt "set2pred", - resolve_tac ctxt [subsetI] i, - resolve_tac ctxt [CollectI] i, - dresolve_tac ctxt [CollectD] i, + resolve_tac ctxt [Collect_subset_to_pred] i, full_simp_tac (put_simpset HOL_basic_ss ctxt) i ])) thm @@ -1627,7 +1787,7 @@ fun set2pred_tac ctxt i thm = fun MaxSimpTac ctxt tac i = TRY (FIRST[resolve_tac ctxt [subset_refl] i, - set2pred_tac ctxt i THEN_MAYBE tac i, + (set2pred_tac ctxt i THEN_MAYBE tac i) ORELSE tac i, trace_tac ctxt "final_tac failed" ]); @@ -1667,7 +1827,7 @@ fun post_conforms_tac ctxt state_kind i = (fn i => (REPEAT (resolve_tac ctxt [allI,impI] i)) THEN (full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps [mem_Collect_eq,@{thm Set.singleton_iff},@{thm Set.empty_iff},UNIV_I] - addsimprocs (state_simprocs state_kind)) i))) i]; + addsimprocs (state_simprocs ctxt state_kind)) i))) i]; fun dest_hoare_raw (Const(@{const_name HoarePartialDef.hoarep},_)$G$T$F$P$C$Q$A) = (P,C,Q,A,Partial,G,T,F) @@ -1689,7 +1849,7 @@ fun dest_hoare t = let val triple = (strip_qnt_body @{const_name "All"} o - HOLogic.dest_Trueprop o strip_qnt_body @{const_name Pure.all}) t; + HOLogic.dest_Trueprop o Logic.strip_assums_concl) t; in dest_hoare_raw triple end; @@ -1727,37 +1887,24 @@ val conseq1_ss_base = @K_convs @ @{thms simp_thms} @ @{thms ex_simps} @ @{thms all_simps}) delsimps [@{thm Hoare.all_imp_to_ex}] |> fold Simplifier.add_cong K_congs) -val conseq1_ss_record = - simpset_of (put_simpset conseq1_ss_base @{context} addsimprocs (state_simprocs Record)); -val conseq1_ss_fun = - simpset_of (put_simpset conseq1_ss_base @{context} addsimprocs (state_simprocs Function)); -fun conseq1_ss Record = conseq1_ss_record - | conseq1_ss Function = conseq1_ss_fun; val conseq2_ss_base = simpset_of (put_simpset HOL_basic_ss @{context} addsimps (@{thms Hoare.all_imp_eq_triv} @ @{thms simp_thms} @ @{thms ex_simps} @ @{thms all_simps}) delsimps [@{thm Hoare.all_imp_to_ex}] |> Simplifier.add_cong @{thm imp_cong}); - -val conseq2_ss_record = - simpset_of (put_simpset conseq2_ss_base @{context} - addsimprocs [state_upd_simproc Record, state_ex_sel_eq_simproc Record]); -val conseq2_ss_fun = - simpset_of (put_simpset conseq2_ss_base @{context} - addsimprocs [state_upd_simproc Function, state_ex_sel_eq_simproc Function]); -fun conseq2_ss Record = conseq2_ss_record - | conseq2_ss Function = conseq2_ss_fun; - in fun raw_conseq_simp_tac ctxt state_kind thms i = let val ctxt' = Config.put simp_depth_limit 0 ctxt; in - simp_tac (put_simpset (conseq1_ss state_kind) ctxt' addsimps thms) i + simp_tac (put_simpset conseq1_ss_base ctxt' + addsimprocs (state_simprocs ctxt' state_kind) + addsimps thms) i THEN_MAYBE - simp_tac (put_simpset (conseq2_ss state_kind) ctxt') i + simp_tac (put_simpset conseq2_ss_base ctxt' + addsimprocs (state_upd_simprocs ctxt' state_kind @ state_ex_sel_eq_simprocs ctxt' state_kind)) i end end @@ -1782,7 +1929,7 @@ fun gen_context_thms ctxt mode params G T F = val hoare = (case mode of Partial => @{const_name HoarePartialDef.hoarep} | Total => @{const_name HoareTotalDef.hoaret}); - (* FIXME: Use future Proof_Context.rename_vars or make closed term and remove by hand *) + (* fixme: Use future Proof_Context.rename_vars or make closed term and remove by hand *) (* fun free_params ps t = foldr (fn ((x,xT),t) => snd (variant_abs (x,xT,t))) (ps,t); val PpQA' = mkCallQuadruple (strip_qnt_body @{const_name Pure.all} (free_params params (Term.list_all (vars,PpQA)))); @@ -1810,10 +1957,11 @@ fun gen_context_thms ctxt mode params G T F = let val vars = map fst (strip_qnt_vars @{const_name All} (HOLogic.dest_Trueprop (Logic.strip_assums_concl prop))); + val [asmUN'] = adapt_aux_var ctxt true vars [get_aux_tvar (AsmUN mode)] in Goal.prove ctxt params [] prop (fn {context = ctxt', ...} => EVERY[trace_tac ctxt' "extracting specifications from hoare context", - resolve_tac ctxt' (adapt_aux_var ctxt' true vars [get_aux_tvar (AsmUN mode)]) 1, + resolve_tac ctxt' [asmUN'] 1, DEPTH_SOLVE_1 (resolve_tac ctxt' [subset_refl,refl] 1 ORELSE ((resolve_tac ctxt' [@{thm Hoare.subset_unI1}] 1 APPEND resolve_tac ctxt' [@{thm Hoare.subset_unI2}] 1) ORELSE @@ -1826,10 +1974,11 @@ fun gen_context_thms ctxt mode params G T F = val specs = hoare_context_specs mode G T F; in map (mk_prove mode) specs end; +fun is_modifies_assertion t = + exists_subterm (fn (Const (@{const_name Hoare.meq},_)) => true| _ => false) t fun is_modifies_clause t = - exists_subterm (fn (Const (@{const_name Hoare.meq},_)) => true| _ => false) - (#3 (dest_hoare (Logic.strip_assums_concl t))) + is_modifies_assertion (#3 (dest_hoare (Logic.strip_assums_concl t))) handle (TERM _) => false; val is_spec_clause = not o is_modifies_clause; @@ -1843,7 +1992,7 @@ fun swap_constr_destr f (t as (Const (@{const_name Fun.id},_))) = t | swap_constr_destr f (t as (Const (c,Type ("fun",[T,valT])))) = (Const (f c, Type ("fun",[valT,T])) handle Empty => raise TERM ("Hoare.swap_constr_destr",[t])) - | swap_constr_destr f (Const ("StateFun.map_fun",Type ("fun", (* FIXME unknown "StateFun.map_fun" !? *) + | swap_constr_destr f (Const ("StateFun.map_fun",Type ("fun", (* fixme: unknown "StateFun.map_fun" !? *) [Type ("fun",[T,valT]), Type ("fun",[Type ("fun",[xT,T']), Type ("fun",[xT',valT'])])]))$g) = @@ -1871,7 +2020,7 @@ fun swap_constr_destr f (t as (Const (@{const_name Fun.id},_))) = t Type ("fun",[bsT,asT])]))$swap_constr_destr f g) | swap_constr_destr f t = raise TERM ("Hoare.swap_constr_destr",[t]); -(* FIXME: unused? *) +(* fixme: unused? *) val destr_to_constr = let fun convert c = @@ -1881,17 +2030,16 @@ val destr_to_constr = in swap_constr_destr convert end; fun gen_call_tac cont_tac mode cmode state_kind state_space ctxt asms spec_sfx - pname return has_args _ = + pname return has_args result_exn _ = let val thy = Proof_Context.theory_of ctxt; - val pname' = unsuffix proc_deco pname; + val pname' = chopsfx proc_deco pname; val spec = (case AList.lookup (op =) asms pname of SOME s => SOME s | NONE => try (Proof_Context.get_thm ctxt) (suffix spec_sfx pname')); - fun auxvars_for p t = (case first_subterm_dest (try dest_call) t of - SOME (vars,(_,p',_,_,m,_)) => (if m=Static andalso + SOME (vars,(_,p',_,_,m,_,_)) => (if m=Static andalso p=(dest_string' p') then SOME vars else NONE) @@ -1916,7 +2064,7 @@ fun gen_call_tac cont_tac mode cmode state_kind state_space ctxt asms spec_sfx fun check_spec name P thm = (case try dest_hoare (Thm.concl_of thm) of SOME spc => (case try dest_call (#2 spc) of - SOME (_,p,_,_,m,_) => if proc_name m p = name andalso + SOME (_,p,_,_,m,_,_) => if proc_name ctxt m p = name andalso P (Thm.concl_of thm) then SOME (#5 spc,thm) else NONE @@ -1954,13 +2102,13 @@ fun gen_call_tac cont_tac mode cmode state_kind state_space ctxt asms spec_sfx | solve_spec ctxt' augment_rule asmUN_rule augment_emptyFaults mode Parameter _ _ i = (* try to infer spec out of assumptions *) let - fun tac ({context = ctxt'', prems, ...}: Subgoal.focus) = - (case (find_dyn_specs pname is_spec_clause prems) of + fun tac thms = + (case (find_dyn_specs pname is_spec_clause thms) of (spec_mode,spec)::_ - => solve_spec ctxt'' augment_rule asmUN_rule augment_emptyFaults mode Parameter + => solve_spec ctxt' augment_rule asmUN_rule augment_emptyFaults mode Parameter (SOME spec_mode) (SOME spec) 1 | _ => all_tac) - in Subgoal.FOCUS tac ctxt' i end + in Subgoal.FOCUS (tac o #prems) ctxt i end val strip_spec_vars = strip_qnt_vars @{const_name All} o HOLogic.dest_Trueprop; @@ -1974,22 +2122,21 @@ fun gen_call_tac cont_tac mode cmode state_kind state_space ctxt asms spec_sfx SOME (_,_,_,_,_,_,Theta,_) => get_auxvars_for pname Theta | _ => [])); - fun get_call_rule Static mode is_abr = - if is_abr then Proc mode else ProcNoAbr mode - | get_call_rule Parameter mode is_abr = - if is_abr then DynProcProcPar mode else DynProcProcParNoAbr mode; + fun get_call_rule' Static mode is_abr result_exn = + if is_abr then Proc mode result_exn else ProcNoAbr mode result_exn + | get_call_rule' Parameter mode is_abr result_exn = + if is_abr then DynProcProcPar mode result_exn else DynProcProcParNoAbr mode result_exn; val [call_rule,augment_ctxt_rule,asmUN_rule, augment_emptyFaults] = adapt_aux_var ctxt' true spec_vars (map get_aux_tvar - [get_call_rule cmode mode is_abr, + [get_call_rule' cmode mode is_abr result_exn, AugmentContext mode, AsmUN mode, AugmentEmptyFaults mode]); - in EVERY [resolve_tac ctxt' [call_rule] i, trace_tac ctxt' "call_tac -- basic_tac -- solving spec", - solve_spec ctxt' augment_ctxt_rule asmUN_rule augment_emptyFaults + solve_spec ctxt' augment_ctxt_rule asmUN_rule augment_emptyFaults mode cmode spec_mode spec spec_goal] end; @@ -2012,8 +2159,8 @@ fun gen_call_tac cont_tac mode cmode state_kind state_space ctxt asms spec_sfx | SOME (_,c,Q,spec_abr,spec_mode,_,_,_) => case try dest_call c of NONE => (warning msg;(true,NONE,NONE,false)) - | SOME (_,p,_,_,m,spec_has_args) - => if proc_name m p = pname + | SOME (_,p,_,_,m,spec_has_args,_) + => if proc_name ctxt m p = pname then if (mode=Total andalso spec_mode=Partial) then (warning msg;(true,NONE,NONE,false)) else if is_empty_set spec_abr then @@ -2036,7 +2183,7 @@ fun gen_call_tac cont_tac mode cmode state_kind state_space ctxt asms spec_sfx resolve_tac ctxt' [allI] (i+1), cont_tac ctxt' (i+1), trace_tac ctxt' "call_tac -- basic_tac -- simplify", - conseq_simp_tac ctxt' state_kind [@{thm StateSpace.upd_globals_def}] i, + conseq_simp_tac ctxt' state_kind (Named_Theorems.get ctxt @{named_theorems "state_simp"}) i, trace_tac ctxt' "call_tac -- basic_tac -- STOP --"] end; @@ -2111,8 +2258,8 @@ fun gen_call_tac cont_tac mode cmode state_kind state_space ctxt asms spec_sfx | modify_updatesF subst _ glob ((globs$Z)) = (glob$Bound 1) (* may_not_modify *) | modify_updatesF _ _ _ t = raise TERM ("gen_call_tac.modify_updatesF",[t]); - fun modify_updates Record = modify_updatesR - | modify_updates _ = modify_updatesF + fun modify_updates Function = modify_updatesF + | modify_updates _ (* Record and Other *) = modify_updatesR fun globalsT (Const (gupd,T)) = domain_type (hd (binder_types T)) @@ -2139,23 +2286,23 @@ fun gen_call_tac cont_tac mode cmode state_kind state_space ctxt asms spec_sfx val is_abr = not (is_empty_set modif_spec_abr); val emptyTheta = is_empty_set Theta; (*val emptyFaults = is_empty_set F;*) - val spec_has_args = #6 (dest_call call); + val (_,_,_,_,_,spec_has_args,_) = dest_call call; val () = if spec_has_args then error "procedure call in modifies-specification must be parameterless!" else (); val (mxprem,ModRet) = (case cmode of Static => (8,if is_abr - then if emptyTheta then (ProcModifyReturn mode) - else (ProcModifyReturnSameFaults mode) - else if emptyTheta then (ProcModifyReturnNoAbr mode) - else (ProcModifyReturnNoAbrSameFaults mode)) + then if emptyTheta then (ProcModifyReturn mode result_exn) + else (ProcModifyReturnSameFaults mode result_exn) + else if emptyTheta then (ProcModifyReturnNoAbr mode result_exn) + else (ProcModifyReturnNoAbrSameFaults mode result_exn)) | Parameter => (9,if is_abr - then if emptyTheta then (ProcProcParModifyReturn mode) - else (ProcProcParModifyReturnSameFaults mode) - else if emptyTheta then (ProcProcParModifyReturnNoAbr mode) - else (ProcProcParModifyReturnNoAbrSameFaults mode))); + then if emptyTheta then (ProcProcParModifyReturn mode result_exn) + else (ProcProcParModifyReturnSameFaults mode result_exn) + else if emptyTheta then (ProcProcParModifyReturnNoAbr mode result_exn) + else (ProcProcParModifyReturnNoAbrSameFaults mode result_exn))); val to_prove_prem = (case cmode of Static => 0 | Parameter => 1); val spec_goal = if is_abr then i + mxprem - 5 else i + mxprem - 6 @@ -2170,7 +2317,7 @@ fun gen_call_tac cont_tac mode cmode state_kind state_space ctxt asms spec_sfx else return;*) val cret = Thm.cterm_of ctxt' return'; - val (_,_,return'_var,_,_,_) = nth (Thm.prems_of ModRet) to_prove_prem + val (_,_,return'_var,_,_,_,_) = nth (Thm.prems_of ModRet) to_prove_prem |> dest_hoare |> #2 |> dest_call; val ModRet' = infer_instantiate ctxt' [(#1 (dest_Var return'_var), cret)] ModRet; @@ -2181,8 +2328,9 @@ fun gen_call_tac cont_tac mode cmode state_kind state_space ctxt asms spec_sfx (clarsimp_tac ((ctxt' |> put_claset (claset_of @{theory_context Set}) |> put_simpset (simpset_of @{theory_context Set})) - addsimps ([@{thm Hoare.mex_def},@{thm Hoare.meq_def},@{thm StateSpace.upd_globals_def}]@K_convs) - addsimprocs (state_upd_simproc Record::(state_simprocs state_kind)) + addsimps ([@{thm Hoare.mex_def},@{thm Hoare.meq_def}]@K_convs@ + (Named_Theorems.get ctxt @{named_theorems "state_simp"})) + addsimprocs (state_upd_simprocs ctxt Record @ state_simprocs ctxt state_kind) |> fold Simplifier.add_cong K_congs) i) THEN_MAYBE EVERY [trace_tac ctxt' "modify_tac: splitting record", @@ -2211,7 +2359,7 @@ fun gen_call_tac cont_tac mode cmode state_kind state_space ctxt asms spec_sfx |> (fn SOME res => res | NONE => raise TERM ("get_call_tac.modify_tac: no proper modifies spec", [])); - fun specs_of_assms_tac ({context = ctxt', prems, ...}: Subgoal.focus) = + fun specs_of_assms_tac ({context = ctxt', prems, ...}: Subgoal.focus) = (case get_spec pname is_spec_clause prems of SOME (_,spec) => (case get_spec pname is_modifies_clause prems of SOME (_,modifies_thm) => modify_tac ctxt' (SOME spec) modifies_thm 1 @@ -2238,7 +2386,7 @@ fun gen_call_tac cont_tac mode cmode state_kind state_space ctxt asms spec_sfx basic_tac ctxt spec))) end; - fun inline_bdy_tac has_args i = + fun inline_bdy_tac has_args result_exn i = (case try (Proof_Context.get_thm ctxt) (suffix bodyP pname') of NONE => no_tac | SOME impl => @@ -2249,7 +2397,7 @@ fun gen_call_tac cont_tac mode cmode state_kind state_space ctxt asms spec_sfx "\". Inlining procedure!"); if has_args then EVERY [trace_tac ctxt "inline_bdy_tac args", - resolve_tac ctxt [CallBody mode] i, + resolve_tac ctxt [CallBody mode result_exn] i, resolve_tac ctxt [impl] (i+3), resolve_tac ctxt [allI] (i+2), resolve_tac ctxt [allI] (i+2), @@ -2268,13 +2416,13 @@ fun gen_call_tac cont_tac mode cmode state_kind state_space ctxt asms spec_sfx (case cmode of Static => if get_recursive pname ctxt = SOME false andalso is_none spec - then inline_bdy_tac has_args + then inline_bdy_tac has_args result_exn else test_modify_in_ctxt_tac | Parameter => (case spec of - NONE => (tracing "no spec found!"; Subgoal.FOCUS specs_of_assms_tac ctxt) + NONE => (trace_msg ctxt "no spec found!"; Subgoal.FOCUS specs_of_assms_tac ctxt) | SOME spec => - (tracing "found spec!"; case check_spec pname is_spec_clause spec of + (trace_msg ctxt "found spec!"; case check_spec pname is_spec_clause spec of SOME _ => test_modify_in_ctxt_tac | NONE => (warning ("ignoring theorem " ^ (suffix spec_sfx pname') ^ "; no proper specification for procedure " ^pname'); @@ -2283,10 +2431,10 @@ fun gen_call_tac cont_tac mode cmode state_kind state_space ctxt asms spec_sfx fun call_tac cont_tac mode state_kind state_space ctxt asms spec_sfx t = let - val (_,c,_,_,_,_,_,F) = dest_hoare (Logic.strip_assums_concl t); - fun gen_tac (_,pname,return,c,cmode,has_args) = + val (_,c,_,_,_,_,_,F) = dest_hoare t; + fun gen_tac (_,pname,return,c,cmode,has_args,result_exn) = gen_call_tac cont_tac mode cmode state_kind state_space ctxt asms spec_sfx - (proc_name cmode pname) return has_args F; + (proc_name ctxt cmode pname) return has_args result_exn F; in gen_tac (dest_call c) end handle TERM _ => K no_tac; @@ -2323,6 +2471,7 @@ fun guard_tac ctxt strip cont_tac mode (t,i) = solve_in_Faults_tac ctxt (i+2), cont_tac ctxt (i+1), triv_simp ctxt i] + in if is_empty_set F then EVERY [trace_tac ctxt "Guard: basic_tac", basic_tac i] else EVERY [trace_tac ctxt "Guard: trying guarantee_tac", guarantee_tac i ORELSE basic_tac i] end handle TERM _ => no_tac @@ -2336,27 +2485,33 @@ fun in_rel_simp ctxt = simp_tac (put_simpset HOL_basic_ss ctxt addsimps [@{thm Hoare.in_measure_iff},@{thm Hoare.in_lex_iff},@{thm Hoare.in_mlex_iff},@{thm Hoare.in_inv_image_iff}, @{thm split_conv}]); -fun while_annotate_tac ctxt inv i st = +fun while_annotate_tac ctxt inv state_space i st = let val annotateWhile = Thm.lift_rule (Thm.cprem_of st i) @{thm HoarePartial.reannotateWhileNoGuard}; - val lifted_inv = fold_rev Term.abs (Logic.strip_params (Logic.get_goal (Thm.prop_of st) i)) inv; + val params = Logic.strip_params (Logic.get_goal (Thm.prop_of st) i) + val first_state_idx = find_index (fn x => state_space (Free x) <> 0) (rev params) + val inv = if first_state_idx > 0 then incr_boundvars first_state_idx inv else inv + val lifted_inv = fold_rev Term.abs params inv; val invVar = (#1 o strip_comb o #3 o dest_whileAnno o #2 o dest_hoare) (List.last (Thm.prems_of annotateWhile)); val annotate = infer_instantiate ctxt [(#1 (dest_Var invVar), Thm.cterm_of ctxt lifted_inv)] annotateWhile; - in ((trace_tac ctxt ("annotating While with: " ^ Syntax.string_of_term ctxt lifted_inv )) + in ((trace_tac ctxt ("try annotating While with: " ^ Syntax.string_of_term ctxt lifted_inv )) THEN compose_tac ctxt (false,annotate,1) i) st end; -fun cond_annotate_tac ctxt inv mode (_,i) st = +fun cond_annotate_tac ctxt inv mode state_space (_,i) st = let val annotateCond = Thm.lift_rule (Thm.cprem_of st i) (CondInv' mode); - val lifted_inv = fold_rev Term.abs (Logic.strip_params (Logic.get_goal (Thm.prop_of st) i)) inv; + val params = Logic.strip_params (Logic.get_goal (Thm.prop_of st) i) + val first_state_idx = find_index (fn x => state_space (Free x) <> 0) (rev params) + val inv = if first_state_idx > 0 then incr_boundvars first_state_idx inv else inv + val lifted_inv = fold_rev Term.abs params inv; val invVar = List.last (Thm.prems_of annotateCond) |> dest_hoare |> #3 |> strip_comb |> #1; val annotate = infer_instantiate ctxt [(#1 (dest_Var invVar), Thm.cterm_of ctxt lifted_inv)] annotateCond; - in ((trace_tac ctxt ("annotating Cond with: "^ Syntax.string_of_term ctxt lifted_inv)) + in ((trace_tac ctxt ("try annotating Cond with: "^ Syntax.string_of_term ctxt lifted_inv)) THEN compose_tac ctxt (false,annotate,5) i) st end; @@ -2379,13 +2534,13 @@ fun basic_while_tac ctxt state_kind cont_tac tac mode i = EVERY [trace_tac ctxt "basic_while_tac: basic_tac", basic_tac i] end; -fun while_tac ctxt state_kind inv cont_tac tac mode t i= +fun while_tac ctxt state_kind state_space inv cont_tac tac mode t i= let val basic_tac = basic_while_tac ctxt state_kind cont_tac tac mode; in (case inv of NONE => basic_tac i - | SOME I => EVERY [while_annotate_tac ctxt I i, basic_tac i]) + | SOME I => EVERY [while_annotate_tac ctxt I state_space i, basic_tac i]) end handle TERM _ => no_tac @@ -2501,9 +2656,9 @@ fun prems_tac ctxt i = TRY (resolve_tac ctxt (Assumption.all_prems_of ctxt) i); -fun mk_proc_assoc thms = +fun mk_proc_assoc ctxt thms = let - fun name (_,p,_,_,cmode,_) = proc_name cmode p; + fun name (_,p,_,_,cmode,_,_) = proc_name ctxt cmode p; fun proc_name thm = thm |> Thm.concl_of |> dest_hoare |> #2 |> dest_call |> name; in map (fn thm => (proc_name thm,thm)) thms end; @@ -2519,7 +2674,10 @@ fun HoareTac annotate_inv exspecs let val (P,c,Q,A,_,G,T,F) = dest_hoare (Logic.strip_assums_concl (Logic.get_goal (Thm.prop_of st) 1)); - val wp_tacs = #wp_tacs (get_data ctxt); + val solve_modifies = spec_sfx = modifysfx andalso annotate_inv andalso mode = Partial andalso + is_modifies_assertion Q andalso is_modifies_assertion A + + val hoare_tacs = #hoare_tacs (get_data ctxt); val params = (strip_vars (Logic.get_goal (Thm.prop_of st) 1)); val Inv = (if annotate_inv @@ -2530,33 +2688,36 @@ fun HoareTac annotate_inv exspecs val exspecthms = map (Proof_Context.get_thm ctxt) exspecs; val asms = try (fn () => - mk_proc_assoc (gen_context_thms ctxt mode params G T F @ exspecthms)) () + mk_proc_assoc ctxt (gen_context_thms ctxt mode params G T F @ exspecthms)) () |> the_default []; fun while_annoG_tac (t,i) = whileAnnoG_tac ctxt (annotate_inv orelse strip_guards) mode t i; fun WlpTac tac i = (* WlpTac does not end with subset_refl *) FIRST - ([EVERY [resolve_tac ctxt [Seq mode] i,trace_tac ctxt "Seq",HoareRuleTac tac false ctxt (i+1)], - EVERY [resolve_tac ctxt [Catch mode] i,trace_tac ctxt "Catch",HoareRuleTac tac false ctxt (i+1)], - EVERY [resolve_tac ctxt [CondCatch mode] i,trace_tac ctxt "CondCatch",HoareRuleTac tac false ctxt (i+1)], - EVERY [resolve_tac ctxt [BSeq mode] i,trace_tac ctxt "BSeq",HoareRuleTac tac false ctxt (i+1)], + + ([EVERY [resolve_tac ctxt [Seq mode solve_modifies] i,trace_tac ctxt "Seq", HoareRuleTac tac false ctxt (i+1)], + EVERY [resolve_tac ctxt [Catch mode solve_modifies] i,trace_tac ctxt "Catch",HoareRuleTac tac false ctxt (i+1)], + EVERY [resolve_tac ctxt [CondCatch mode solve_modifies] i,trace_tac ctxt "CondCatch",HoareRuleTac tac false ctxt (i+1)], + EVERY [resolve_tac ctxt [BSeq mode solve_modifies] i,trace_tac ctxt "BSeq",HoareRuleTac tac false ctxt (i+1)], EVERY [resolve_tac ctxt [FCall mode] i,trace_tac ctxt "FCall"], EVERY [resolve_tac ctxt [GuardsNil mode] i,trace_tac ctxt "GuardsNil"], EVERY [resolve_tac ctxt [GuardsConsGuaranteeStrip mode] i, trace_tac ctxt "GuardsConsGuaranteeStrip"], EVERY [resolve_tac ctxt [GuardsCons mode] i,trace_tac ctxt "GuardsCons"], EVERY [SUBGOAL while_annoG_tac i] - ] - @ - map (mk_hoare_tac (fn p => HoareRuleTac tac p ctxt) ctxt mode i) wp_tacs) + ]) and HoareRuleTac tac pre_cond ctxt i st = - let fun call (t,i) = call_tac (HoareRuleTac tac false) + let + val _ = if Config.get ctxt hoare_trace > 1 then + print_tac ctxt ("HoareRuleTac (" ^ @{make_string} (pre_cond, i) ^ "):") st + else all_tac st + fun call (t,i) = call_tac (HoareRuleTac tac false) mode state_kind state_space ctxt asms spec_sfx t i fun cond_tac i = if annotate_inv andalso Config.get ctxt use_cond_inv_modifies then - EVERY[SUBGOAL (cond_annotate_tac ctxt (the Inv) mode) i, + EVERY[SUBGOAL (cond_annotate_tac ctxt (the Inv) mode state_space) i, HoareRuleTac tac false ctxt (i+4), HoareRuleTac tac false ctxt (i+3), BasicSimpTac ctxt state_kind true [] tac (i+2), @@ -2571,12 +2732,12 @@ fun HoareTac annotate_inv exspecs EVERY[resolve_tac ctxt [SwitchCons mode] i,trace_tac ctxt "SwitchCons", HoareRuleTac tac false ctxt (i+2), HoareRuleTac tac false ctxt (i+1)]; - fun while_tac' (t,i) = while_tac ctxt state_kind Inv + fun while_tac' (t,i) = while_tac ctxt state_kind state_space Inv (HoareRuleTac tac true) tac mode t i; in st |> ( (WlpTac tac i THEN HoareRuleTac tac pre_cond ctxt i) ORELSE - (FIRST([EVERY[resolve_tac ctxt [Skip mode] i,trace_tac ctxt "Skip"], + (TRY (FIRST([EVERY[resolve_tac ctxt [Skip mode] i, trace_tac ctxt "Skip"], EVERY[resolve_tac ctxt [BasicCond mode] i, trace_tac ctxt "BasicCond", assertion_simp_tac ctxt state_kind [] i], (resolve_tac ctxt [Basic mode] i THEN trace_tac ctxt "Basic") @@ -2589,8 +2750,8 @@ fun HoareTac annotate_inv exspecs EVERY[resolve_tac ctxt [Throw mode] i, trace_tac ctxt "Throw"], (resolve_tac ctxt [Raise mode] i THEN trace_tac ctxt "Raise") THEN_MAYBE (assertion_string_eq_simp_tac ctxt state_kind [] i), - cond_tac i, - switch_tac i, + EVERY[cond_tac i], + EVERY[switch_tac i], EVERY[resolve_tac ctxt [Block mode] i, trace_tac ctxt "Block", resolve_tac ctxt [allI] (i+2), resolve_tac ctxt [allI] (i+2), @@ -2600,7 +2761,7 @@ fun HoareTac annotate_inv exspecs HoareRuleTac tac false ctxt (i+1)], SUBGOAL while_tac' i, SUBGOAL (guard_tac ctxt (annotate_inv orelse strip_guards) - (HoareRuleTac tac false) mode) i, + (HoareRuleTac tac false) mode THEN' (K (trace_tac ctxt "guard_tac succeeded"))) i, EVERY[SUBGOAL (specAnno_tac ctxt state_kind (HoareRuleTac tac true) mode) i], EVERY[SUBGOAL (whileAnnoFix_tac ctxt state_kind @@ -2616,12 +2777,11 @@ fun HoareTac annotate_inv exspecs EVERY[trace_tac ctxt "calling call_tac",SUBGOAL call i], EVERY[trace_tac ctxt "LemmaAnno",SUBGOAL (lemAnno_tac ctxt state_kind mode) i]] @ - map (mk_hoare_tac (fn p => HoareRuleTac tac p ctxt) ctxt mode i) hoare_tacs) - THEN (if pre_cond - then EVERY [trace_tac ctxt "pre_cond", - TRY (BasicSimpTac ctxt state_kind true [] tac i), - (* FIXME: Do we need TRY *) - trace_tac ctxt "after BasicSimpTac"] + map (mk_hoare_tac (fn p => HoareRuleTac tac p ctxt) ctxt mode i) hoare_tacs)) + THEN (if pre_cond orelse solve_modifies + then EVERY [trace_tac ctxt ("pre_cond / solve_modfies: " ^ @{make_string} (pre_cond, solve_modifies)), + TRY (BasicSimpTac ctxt state_kind true (Named_Theorems.get ctxt @{named_theorems "state_simp"}) tac i), + trace_tac ctxt ("after BasicSimpTac " ^ string_of_int i)] else (resolve_tac ctxt [subset_refl] i)))) end; in ((K (EVERY [REPEAT (resolve_tac ctxt [allI] 1), HoareRuleTac tac true ctxt 1])) @@ -2640,7 +2800,7 @@ fun HoareStepTac strip_guards mode state_kind state_space spec_sfx ctxt tac st = let val (_,_,_,_,_,G,T,F) = dest_hoare (Logic.strip_assums_concl (Logic.get_goal (Thm.prop_of st) 1)); val params = (strip_vars (Logic.get_goal (Thm.prop_of st) 1)); - in mk_proc_assoc (gen_context_thms ctxt mode params G T F) + in mk_proc_assoc ctxt (gen_context_thms ctxt mode params G T F) end) () |> the_default []; @@ -2654,11 +2814,11 @@ fun HoareStepTac strip_guards mode state_kind state_space spec_sfx ctxt tac st = TRY (hyp_subst_tac_thin true ctxt i), BasicSimpTac ctxt state_kind true [] tac i] fun while_annoG_tac (t,i) = whileAnnoG_tac ctxt strip_guards mode t i; - - in st |> + val hoare_tacs = #hoare_tacs (get_data ctxt); + in st |> CHANGED ( (REPEAT (resolve_tac ctxt [allI] 1) THEN - FIRST [resolve_tac ctxt [subset_refl] 1, + FIRST ([resolve_tac ctxt [subset_refl] 1, EVERY[resolve_tac ctxt [Skip mode] 1,TRY (BasicSimpTac ctxt state_kind false [] tac 1)], EVERY[resolve_tac ctxt [BasicCond mode] 1,trace_tac ctxt "BasicCond", TRY (BasicSimpTac ctxt state_kind false [] tac 1)], @@ -2666,9 +2826,9 @@ fun HoareStepTac strip_guards mode state_kind state_space spec_sfx ctxt tac st = EVERY[resolve_tac ctxt [Throw mode] 1,TRY (BasicSimpTac ctxt state_kind false [] tac 1)], EVERY[resolve_tac ctxt [Raise mode] 1,TRY (assertion_string_eq_simp_tac ctxt state_kind [] 1)], resolve_tac ctxt [SeqSwap mode] 1 - THEN_MAYBE HoareStepTac strip_guards mode state_kind state_space spec_sfx - ctxt tac, - EVERY[resolve_tac ctxt [BSeq mode] 1, + THEN_MAYBE TRY (HoareStepTac strip_guards mode state_kind state_space spec_sfx + ctxt tac), + EVERY[resolve_tac ctxt [BSeq mode false] 1, prefer_tac 2 THEN_MAYBE HoareStepTac strip_guards mode state_kind state_space spec_sfx ctxt tac], @@ -2703,9 +2863,11 @@ fun HoareStepTac strip_guards mode state_kind state_space spec_sfx ctxt tac st = EVERY[resolve_tac ctxt [DynCom mode] 1], EVERY[SUBGOAL call 1, BasicSimpTac ctxt state_kind false [] tac 1], EVERY[SUBGOAL (lemAnno_tac ctxt state_kind mode) 1, - BasicSimpTac ctxt state_kind false [] tac 1], - final_simp_tac 1 - ]) + BasicSimpTac ctxt state_kind false [] tac 1] + + ] @ + map (mk_hoare_tac (K (K all_tac)) ctxt mode 1) hoare_tacs @ + [final_simp_tac 1]))) end; (*****************************************************************************) @@ -2717,12 +2879,12 @@ struct val globals = @{const_name StateSpace.state.globals}; -fun isState (Const _$Abs (s,T,t)) = +fun isState _ (Const _$Abs (s,T,t)) = (case (state_hierarchy T) of ((n,_)::_) => n = "StateSpace.state.state" andalso is_none (try dest_hoare_raw (strip_qnt_body @{const_name All} t)) | _ => false) - | isState _ = false; + | isState _ _ = false; fun isFreeState (Free (_,T)) = (case (state_hierarchy T) of @@ -2730,7 +2892,7 @@ fun isFreeState (Free (_,T)) = | _ => false) | isFreeState _ = false; -val abs_state = Option.map snd o first_subterm isFreeState; +fun abs_state _ = Option.map snd o first_subterm isFreeState; fun sel_eq (Const (x,_)$_) y = (x=y) @@ -2743,8 +2905,8 @@ fun bound xs (t as (Const (x,_)$_)) = in if i < 0 then (length xs, xs@[t]) else (i,xs) end | bound xs t = raise TERM ("RecordSplitState.bound",[t]); -fun abs_var _ (Const (x,T)$_) = - (remdeco' (Long_Name.base_name x),range_type T) +fun abs_var ctxt (Const (x,T)$_) = + (remdeco' ctxt (Long_Name.base_name x),range_type T) | abs_var _ t = raise TERM ("RecordSplitState.abs_var",[t]); fun fld_eq (x, _) y = (x = y) @@ -2820,7 +2982,7 @@ fun split_state ctxt s T t = val vars' = if Config.get ctxt sort_variables then sort_vars ctxt T vars else vars; in (abstract_vars vars' s t,rev vars') end; -fun ex_tac ctxt _ st = Record.split_simp_tac ctxt @{thms simp_thms} (K ~1) 1 st; +fun ex_tac ctxt _ i = Record.split_simp_tac ctxt @{thms simp_thms} (K ~1) i; end; @@ -2829,12 +2991,12 @@ struct val full_globalsN = @{const_name StateSpace.state.globals}; -fun isState (Const _$Abs (s,T,t)) = +fun isState _ (Const _$Abs (s,T,t)) = (case (state_hierarchy T) of ((n,_)::_) => n = "StateSpace.state.state" andalso is_none (try dest_hoare_raw (strip_qnt_body @{const_name All} t)) | _ => false) - | isState _ = false; + | isState _ _ = false; fun isFreeState (Free (_,T)) = (case (state_hierarchy T) of @@ -2842,10 +3004,10 @@ fun isFreeState (Free (_,T)) = | _ => false) | isFreeState _ = false; -val abs_state = Option.map snd o first_subterm isFreeState; +fun abs_state _ = Option.map snd o first_subterm isFreeState; fun comp_name t = - case try (implode o dest_string) t of + case try dest_string t of SOME str => str | NONE => (case t of Free (s,_) => s @@ -2915,13 +3077,13 @@ fun abstract_vars vars s t = val dummy = Bound 0; in fold_state_prop var app abs other 0 s dummy t end; -fun sort_vars _ vars = +fun sort_vars ctxt vars = let val fld_idx = idx (fn s1:string => fn s2 => s1 = s2); fun compare (_$_$n$(Const (s1,_)$_),_$_$m$(Const (s2,_)$_)) = let - val n' = remdeco' (comp_name n); - val m' = remdeco' (comp_name m); + val n' = remdeco' ctxt (comp_name n); + val m' = remdeco' ctxt (comp_name m); in if s1 = full_globalsN then if s2 = full_globalsN then string_ord (n',m') @@ -2938,7 +3100,7 @@ fun split_state ctxt s _ t = val vars' = if Config.get ctxt sort_variables then sort_vars ctxt vars else vars; in (abstract_vars vars' s t,rev vars') end; -fun abs_var _ t = (remdeco' (sel_name t), sel_type t); +fun abs_var ctxt t = (remdeco' ctxt (sel_name t), sel_type t); (* Proof for: EX x_1 ... x_n. P x_1 ... x_n * ==> EX s. P (lookup destr_1 "x_1" s) ... (lookup destr_n "x_n" s) @@ -2962,11 +3124,10 @@ val ss = in -fun ex_tac ctxt vs st = +fun ex_tac ctxt vs = SUBGOAL (fn (goal, i) => let val vs' = rev vs; - val (Const (_,exT)$_) = HOLogic.dest_Trueprop - (Logic.strip_imp_concl (Logic.get_goal (Thm.prop_of st) 1)); + val (Const (_,exT)$_) = HOLogic.dest_Trueprop (Logic.strip_imp_concl goal); val sT = domain_type (domain_type exT); val s0 = Const (@{const_name HOL.undefined},sT); @@ -3014,10 +3175,14 @@ fun ex_tac ctxt vs st = in (compose_tac ctxt (false,inst_rule, Thm.nprems_of exI) i st) end; - in EVERY [REPEAT_DETERM_N (length vs) (eresolve_tac ctxt [exE] 1), - lift_inst_ex_tac 1, - simp_tac (put_simpset ss ctxt) 1 - ] st end + in EVERY + [REPEAT_DETERM_N (length vs) (eresolve_tac ctxt [exE] i), + lift_inst_ex_tac i, + simp_tac (put_simpset ss ctxt) i + ] + end +) + end (* Test: What happens when there are no lookups., EX s. True *) @@ -3025,11 +3190,12 @@ end end; -structure GeneraliseRecord = GeneraliseFun (structure SplitState=RecordSplitState); -structure GeneraliseStateFun = GeneraliseFun (structure SplitState=FunSplitState); +structure GeneraliseRecord = Generalise (structure SplitState=RecordSplitState); +structure GeneraliseStateFun = Generalise (structure SplitState=FunSplitState); -fun generalise Record = GeneraliseRecord.GENERALISE - | generalise Function = GeneraliseStateFun.GENERALISE; +fun generalise _ Record = GeneraliseRecord.GENERALISE + | generalise _ Function = GeneraliseStateFun.GENERALISE + | generalise ctxt (Other i) = the (generalise_other ctxt i); (*****************************************************************************) (** record_vanish_tac splits up the records of a verification condition, **) @@ -3038,7 +3204,7 @@ fun generalise Record = GeneraliseRecord.GENERALISE (** form "!!s Z. s=Z ==> ..., where s and Z are records **) (*****************************************************************************) -(* FIXME: Check out if removing the useless vars is a performance issue. +(* fixme: Check out if removing the useless vars is a performance issue. If so, maybe we can remove all useless vars at once (no iterated simplification) or try to avoid introducing them. Bevore splitting the gaol we can simplifiy the goal with state_simproc this may leed @@ -3054,6 +3220,29 @@ fun record_vanish_tac ctxt state_kind state_space i = | no_spec _ = true; fun state_space_no_spec t = if state_space t <> 0 andalso no_spec t then ~1 else 0; + val state_split_tac = state_split_simp_tac ctxt rem_useless_vars_simps state_space_no_spec i + fun generalise_tac split_record st = + DETERM (generalise ctxt state_kind ctxt i) st + handle (exn as (TERM _)) => + let + val _ = warning ("record_vanish_tac: generalise subgoal " ^ string_of_int i ^ + " failed" ^ (if split_record then ", fallback to record split:\n " else "") ^ + Runtime.exn_message (Runtime.exn_context (SOME ctxt) exn)); + in + if split_record then + EVERY [ + state_split_tac, + full_simp_tac (ctxt + addsimprocs (state_simprocs ctxt state_kind @ + state_upd_simprocs ctxt state_kind) + addsimps (Named_Theorems.get ctxt @{named_theorems "state_simp"})) i, + trace_subgoal_tac ctxt "after record split and simp" i, + generalise_tac false, + trace_subgoal_tac ctxt "after 'generalise_tac false'" i + ] st + else all_tac st + end; + in EVERY [trace_tac ctxt "record_vanish_tac -- START --", REPEAT (eresolve_tac ctxt [conjE] i), trace_tac ctxt "record_vanish_tac -- hyp_subst_tac ctxt --", @@ -3063,12 +3252,8 @@ fun record_vanish_tac ctxt state_kind state_space i = want to split them to avoid naming conflicts and increase performance *) trace_tac ctxt "record_vanish_tac -- Splitting records --", if Config.get ctxt use_generalise orelse state_kind = Function - then generalise state_kind ctxt i - else state_split_simp_tac ctxt rem_useless_vars_simps state_space_no_spec i - (*THEN_MAYBE - EVERY [trace_tac ctxt "record_vanish_tac -- removing useless vars --", - full_simp_tac rem_useless_vars_simpset i, - trace_tac ctxt "record_vanish_tac -- STOP --"]*) + then EVERY [generalise_tac true] + else state_split_tac ] end else @@ -3099,7 +3284,7 @@ val state_fun_update_ss = @ @{thms list.inject list.distinct char.inject cong_exp_iff_simps simp_thms} @ K_fun_convs) addsimprocs [DistinctTreeProver.distinct_simproc ["distinct_fields", "distinct_fields_globals"]] - |> Simplifier.add_cong @{thm imp_cong} (* K_fun_congs FIXME: Stefan fragen*) + |> Simplifier.add_cong @{thm imp_cong} |> Splitter.add_split @{thm if_split}); in @@ -3125,13 +3310,7 @@ fun solve_modifies_tac ctxt state_kind state_space i st = else 0 | is_split_state t = 0; val simp_ctxt = put_simpset HOL_ss ctxt addsimps (@{thm Ex_True} :: @{thm Ex_False} :: Record.get_extinjects thy); - fun try_solve Record i = (*(SOLVE*) - (((fn k => (TRY (REPEAT_ALL_NEW (resolve_tac ctxt [conjI, impI, allI]) k))) - THEN_ALL_NEW - (fn k => EVERY [state_split_simp_tac ctxt [] is_split_state k, - simp_tac simp_ctxt k THEN_MAYBE rename_goal ctxt remdeco' k - ])) i) (*)*) - | try_solve _ i = + fun try_solve Function i = ((fn k => (TRY (REPEAT_ALL_NEW (resolve_tac ctxt [conjI, impI, allI]) k))) THEN_ALL_NEW (fn k => REPEAT (resolve_tac ctxt [exI] k) THEN @@ -3139,16 +3318,22 @@ fun solve_modifies_tac ctxt state_kind state_space i st = simp_tac (put_simpset state_fun_update_ss ctxt) k THEN_MAYBE (REPEAT_ALL_NEW (resolve_tac ctxt [conjI,impI,refl]) k))) i + | try_solve _ i = (*(SOLVE*) (* Record and Others *) + (((fn k => (TRY (REPEAT_ALL_NEW (resolve_tac ctxt [conjI, impI, allI]) k))) + THEN_ALL_NEW + (fn k => EVERY [state_split_simp_tac ctxt [] is_split_state k, + simp_tac simp_ctxt k THEN_MAYBE rename_goal ctxt (remdeco' ctxt) k + ])) i) (*)*) in ((trace_tac ctxt "solve_modifies_tac" THEN clarsimp_tac ((ctxt |> put_claset (claset_of @{theory_context HOL}) |> put_simpset (simpset_of @{theory_context Set})) - addsimps ([@{thm Hoare.mex_def},@{thm Hoare.meq_def}]@K_convs) - addsimprocs (state_upd_simproc Record::(state_simprocs Record)) + addsimps (@{thms Hoare.mex_def Hoare.meq_def} @K_convs@(Named_Theorems.get ctxt @{named_theorems "state_simp"})) + addsimprocs (state_upd_simprocs ctxt Record @ state_simprocs ctxt Record) |> fold Simplifier.add_cong K_congs) i) THEN_MAYBE - try_solve state_kind i) st + (try_solve state_kind i)) st end; end @@ -3158,7 +3343,7 @@ fun proc_lookup_simp_tac ctxt i st = val name = (Logic.concl_of_goal (Thm.prop_of st) i) |> dest_hoare |> #2 |> strip_comb |> #2 |> last |> strip_comb |> #2 |> last; (* the$(Gamma$name) or the$(strip$Gamma$name) *) - val pname = (unsuffix proc_deco (dest_string' name)); + val pname = chopsfx proc_deco (dest_string' name); val thms = map_filter I (map (try (Proof_Context.get_thm ctxt)) [suffix bodyP pname, suffix (body_def_sfx^"_def") pname, @@ -3171,9 +3356,9 @@ fun proc_lookup_in_dom_simp_tac ctxt i st = let val _$name$_ = (HOLogic.dest_Trueprop (Logic.concl_of_goal (Thm.prop_of st) i)); (* name : Gamma *) - val pname = (unsuffix proc_deco (dest_string' name)); + val pname = chopsfx proc_deco (dest_string' name); val thms = map_filter I (map (try (Proof_Context.get_thm ctxt)) - [suffix bodyP pname]); + [suffix bodyP pname, suffix "_def" pname]); in simp_tac (put_simpset HOL_basic_ss ctxt addsimps (@{thm Hoare.lookup_Some_in_dom} :: @{thm dom_strip} :: thms)) i st end) () @@ -3243,7 +3428,8 @@ fun HoareCallRuleTac state_kind state_space ctxt thms i st = fun basic_tac i = (((resolve_tac ctxt thms') THEN_ALL_NEW - (fn k => (SUBGOAL solve_sidecondition_tac k))) i) + (fn k => + (SUBGOAL solve_sidecondition_tac k))) i) in (basic_tac ORELSE' (fn k => @@ -3258,17 +3444,33 @@ fun vcg_polish_tac solve_modifies ctxt state_kind state_space i = if solve_modifies then solve_modifies_tac ctxt state_kind state_space i else record_vanish_tac ctxt state_kind state_space i - THEN_MAYBE EVERY [rename_goal ctxt remdeco' i(*, + THEN_MAYBE EVERY [rename_goal ctxt (remdeco' ctxt) i(*, simp_tac (HOL_basic_ss addsimps @{thms simp_thms})) i*)]; fun is_funtype (Type ("fun", _)) = true | is_funtype _ = false; +fun get_state_kind_extension ctxt T = + let + val sps = #state_spaces (Hoare_Data.get (Context.Proof ctxt)) + in + case find_first (fn (n, sp) => (#is_state_type sp) ctxt T) sps of + SOME (n, sp) => SOME n + | NONE => NONE + end + fun state_kind_of ctxt T = let val thy = Proof_Context.theory_of ctxt; val (s,sT) = nth (fst (Record.get_recT_fields thy T)) 1; - in if Long_Name.base_name s = "locals" andalso is_funtype sT then Function else Record end + in + case get_state_kind_extension ctxt T of + SOME n => Other n + | _ => if Long_Name.base_name s = "locals" andalso is_funtype sT then + Function + else + Record + end handle Subscript => Record; fun find_state_space_in_triple ctxt t = @@ -3373,16 +3575,21 @@ val vcg_step = gen_simp_method hoare_step_tac; val trace_hoare_users = Unsynchronized.ref false -fun print_subgoal_tac ctxt s i = - SUBGOAL (fn (prem, _) => trace_tac ctxt (s ^ (Syntax.string_of_term ctxt prem))) i - fun mk_hoare_thm thm _ ctxt _ i = - EVERY [resolve_tac ctxt [thm] i, - if !trace_hoare_users then print_subgoal_tac ctxt "Tracing: " i + EVERY [resolve_tac ctxt [Thm.transfer' ctxt thm] i, + if !trace_hoare_users then trace_subgoal_tac ctxt "Tracing: " i else all_tac] val vcg_hoare_add = - Thm.declaration_attribute (fn thm => add_hoare_tacs [(Thm.derivation_name thm, mk_hoare_thm thm)]) + let + fun get_name thm = + case Properties.get (Thm.get_tags thm) Markup.nameN of + SOME n => n + | NONE => error ("theorem with attribute 'vcg_hoare' must have a name") + in + Thm.declaration_attribute (fn thm => + add_hoare_tacs [(get_name thm, mk_hoare_thm (Thm.trim_context thm))]) + end exception UNDEF val vcg_hoare_del = @@ -3398,6 +3605,5 @@ val _ = #> Attrib.setup @{binding vcg_hoare} (Attrib.add_del vcg_hoare_add vcg_hoare_del) "declaration of wp rule for vcg") - (*#> add_wp_tacs initial_wp_tacs*) end; diff --git a/tools/c-parser/Simpl/hoare_syntax.ML b/tools/c-parser/Simpl/hoare_syntax.ML index db3f4046f..1c3dcda64 100644 --- a/tools/c-parser/Simpl/hoare_syntax.ML +++ b/tools/c-parser/Simpl/hoare_syntax.ML @@ -2,24 +2,10 @@ Author: Norbert Schirmer, TU Muenchen Copyright (C) 2004-2007 Norbert Schirmer - -This library is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as -published by the Free Software Foundation; either version 2.1 of the -License, or (at your option) any later version. - -This library is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public -License along with this library; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 -USA +Copyright (c) 2022 Apple Inc. All rights reserved. *) -(* FIXME: Adapt guard generation to new syntax of op + etc. *) +(* fixme: Adapt guard generation to new syntax of op + etc. *) signature HOARE_SYNTAX = sig @@ -37,10 +23,12 @@ sig val basic_tr: Proof.context -> term list -> term val bexp_tr': string -> Proof.context -> term list -> term val bind_tr': Proof.context -> term list -> term - val call_ass_tr: bool -> bool -> Proof.context -> term list -> term + val call_ass_tr: bool -> bool -> term list -> Proof.context -> term list -> term val call_tr': Proof.context -> term list -> term - val call_tr: bool -> bool -> Proof.context -> term list -> term + val call_exn_tr': Proof.context -> term list -> term + val call_tr: bool -> bool -> term list -> Proof.context -> term list -> term val dyn_call_tr': Proof.context -> term list -> term + val dyn_call_exn_tr': Proof.context -> term list -> term val fcall_tr': Proof.context -> term list -> term val fcall_tr: Proof.context -> term list -> term val guarded_Assign_tr: Proof.context -> term list -> term @@ -68,7 +56,7 @@ sig val raise_tr': Proof.context -> term list -> term val raise_tr: Proof.context -> term list -> term val switch_tr': Proof.context -> term list -> term - val update_comp: Proof.context -> string list -> bool -> bool -> xstring -> term -> term -> term + val update_comp: Proof.context -> Hoare.lense option -> string list -> bool -> bool -> xstring -> term -> term -> term val use_call_tr': bool Config.T val whileAnnoGFix_tr': Proof.context -> term list -> term val whileAnnoG_tr': Proof.context -> term list -> term @@ -84,11 +72,11 @@ val globalsN = "globals"; val localsN = "locals"; val globals_updateN = suffix Record.updateN globalsN; val locals_updateN = suffix Record.updateN localsN; -val upd_globalsN = "upd_globals"; (* FIXME authentic syntax !? *) +val upd_globalsN = "upd_globals"; (* fixme authentic syntax !? *) val allocN = "alloc_'"; val freeN = "free_'"; -val Null = Syntax.free "Simpl_Heap.Null"; (* FIXME ?? *) +val Null = Syntax.free "Simpl_Heap.Null"; (* fixme ?? *) (** utils **) @@ -119,13 +107,21 @@ fun is_prefix_or_suffix s t = can (unprefix s) t orelse can (unsuffix s) t; +fun is_other ctxt = case Hoare.get_default_state_kind ctxt of Hoare.Other _ => true | _ => false + (** hoare data **) fun is_global_comp ctxt name = - (case StateSpace.get_comp (Context.Proof ctxt) name of - SOME (_, ln) => is_prefix_or_suffix "globals" (Long_Name.base_name ln) - | NONE => false); - + let + val res = case Hoare.get_default_state_space ctxt of + SOME {is_defined, ...} => not (is_defined ctxt name) + | _ => + (case StateSpace.get_comp' (Context.Proof ctxt) name of + SOME (_, lns) => forall (fn ln => is_prefix_or_suffix "globals" (Long_Name.base_name ln)) lns + | NONE => false) + in + res + end (** parsing and printing **) @@ -150,7 +146,7 @@ fun is_global ctxt name = exception UNDEFINED of string -(* FIXME: if is_state_var etc. is reimplemented, rethink about when adding the deco to +(* fixme: if is_state_var etc. is reimplemented, rethink about when adding the deco to the records *) fun first_successful_tr _ [] = raise TERM ("first_successful_tr: no success",[]) @@ -158,30 +154,48 @@ fun first_successful_tr _ [] = raise TERM ("first_successful_tr: no success",[]) | first_successful_tr f (x::xs) = f x handle TERM _ => first_successful_tr f xs; fun statespace_lookup_tr ctxt ps s n = - let - val cn = map Hoare.clique_name (#active_procs (Hoare.get_data ctxt)); - val procs = ps @ cn; - val names = - n :: map (fn p => (suffix (Hoare.par_deco p) (unsuffixI Hoare.deco n))) procs; - in first_successful_tr (StateSpace.gen_lookup_tr ctxt s) names - end; + case Hoare.get_default_state_space ctxt of + SOME {lookup_tr, ...} => lookup_tr ctxt n $ s + | _ => + let + val cn = map Hoare.clique_name (#active_procs (Hoare.get_data ctxt)); + val procs = ps @ cn; + val names = + (Hoare.name_tr ctxt true n) :: map (fn p => (suffix (Hoare.par_deco p) (unsuffixI Hoare.deco n))) procs; + in + first_successful_tr (StateSpace.gen_lookup_tr ctxt s) names + end + +fun K_rec_syntax v = Abs ("_", dummyT, incr_boundvars 1 v); + +fun statespace_update_tr ctxt NONE ps id n v = + (case Hoare.get_default_state_space ctxt of + SOME {update_tr, ...} => update_tr ctxt n $ K_rec_syntax v + | _ => + let + fun gen_update_tr id ctxt n v = + StateSpace.gen'_update_tr true id ctxt n v (Bound 0) |> dest_comb |> fst + + val cn = map Hoare.clique_name (#active_procs (Hoare.get_data ctxt)); + val procs = ps @ cn; + val names = + (Hoare.name_tr ctxt true n) :: map (fn p => (suffix (Hoare.par_deco p) (unsuffixI Hoare.deco n))) procs; + in first_successful_tr (fn n => gen_update_tr id ctxt n v) names + end) + | statespace_update_tr ctxt (SOME {lookup, update}) ps id n v = + update $ K_rec_syntax v -fun statespace_update_tr ctxt ps id n v s = - let - val cn = map Hoare.clique_name (#active_procs (Hoare.get_data ctxt)); - val procs = ps @ cn; - val names = - n :: map (fn p => (suffix (Hoare.par_deco p) (unsuffixI Hoare.deco n))) procs; - in first_successful_tr (fn n => StateSpace.gen_update_tr id ctxt n v s) names - end; local fun is_record_sel ctxt nm = let - val consts = Proof_Context.consts_of ctxt; - val exists_const = can (Consts.the_const consts) o intern_const_syntax consts; - val exists_abbrev = can (Consts.the_abbreviation consts) o intern_const_syntax consts; - in (exists_const nm) orelse (exists_abbrev nm) end; + val SOME (Const (c, T)) = try (Syntax.read_term ctxt) nm + val recT = domain_type T + val (flds, _) = Record.get_recT_fields (Proof_Context.theory_of ctxt) recT + in member (op =) (map fst flds) c end + handle TYPE _ => false + | Bind => false + | Match => false in fun lookup_comp ctxt ps name = @@ -196,7 +210,7 @@ fun lookup_comp ctxt ps name = in (fn s => statespace_lookup_tr ctxt ps (sel $ s) name) end; (* -FIXME: +fixme: update of global and local components: One should generally provide functions: glob_upd:: ('g => 'g) => 's => 's @@ -210,9 +224,9 @@ This would make the composition more straightforward... Basically one wants the map on a component rather then the update. Maps can be composed nicer... *) -fun K_rec_syntax v = Abs ("_", dummyT, incr_boundvars 1 v); -fun update_comp ctxt ps atomic id name value = + +fun update_comp ctxt lense_opt ps atomic id name value = if is_record_sel ctxt name then let @@ -220,7 +234,7 @@ fun update_comp ctxt ps atomic id name value = in if atomic andalso is_global ctxt name then (fn s => - Syntax.free globals_updateN $ (K_rec_syntax (upd $ (Syntax.free globalsN $ s))) $ s) + Syntax.free globals_updateN $ (*(K_rec_syntax*) upd $ s) else (fn s => upd $ s) end else @@ -231,8 +245,8 @@ fun update_comp ctxt ps atomic id name value = in fn s => if atomic then - upd $ (K_rec_syntax (statespace_update_tr ctxt ps id name value (sel $ s))) $ s - else statespace_update_tr ctxt ps id name value s + upd $ statespace_update_tr ctxt lense_opt ps id name value $ s + else statespace_update_tr ctxt lense_opt ps id name value $ s end; end; @@ -282,6 +296,17 @@ fun antiquoteOld_tr ctxt [s, n] = | Const (c, T) => lookup_comp ctxt [] (Hoare.varname c) s | _ => n $ s); +fun first_match [] t = raise Match + | first_match (f::fs) t = f t handle Match => first_match fs t + +fun lookup_tr' ctxt t = t |> first_match [ + fn t => + case Hoare.get_default_state_space ctxt of + SOME {lookup_tr', ...} => lookup_tr' ctxt t + | NONE => raise Match, + fn t => Hoare.undeco ctxt t] + + fun antiquote_tr' ctxt name = let fun is_state i t = @@ -291,7 +316,7 @@ fun antiquote_tr' ctxt name = i = j andalso member (op =) [globalsN, localsN] (Long_Name.base_name g) | _ => false); fun tr' i (t $ u) = - if is_state i u then Syntax.const name $ tr' i (Hoare.undeco ctxt t) + if is_state i u then Syntax.const name $ tr' i (lookup_tr' ctxt t) else tr' i t $ tr' i u | tr' i (Abs (x, T, t)) = Abs (x, T, tr' (i + 1) t) | tr' i a = if a = Bound i then raise Match else a; @@ -323,23 +348,24 @@ fun antiquote_applied_only_to P = in test 0 end; + fun antiquote_mult_tr' ctxt is_selector current old = let fun tr' i (t $ u) = state_test u (fn Bound j => - if j = i then Syntax.const current $ tr' i (Hoare.undeco ctxt t) + if j = i then Syntax.const current $ tr' i (lookup_tr' ctxt t) else if is_selector t (* other quantified states *) - then Syntax.const old $ Bound j $ tr' i (Hoare.undeco ctxt t) + then Syntax.const old $ Bound j $ tr' i (lookup_tr' ctxt t) else tr' i t $ tr' i u | pre as ((Const (m,_) $ Free _)) (* pre state *) => if (m = @{syntax_const "_bound"} orelse m = @{syntax_const "_free"}) andalso is_selector t - then Syntax.const old $ pre $ tr' i (Hoare.undeco ctxt t) + then Syntax.const old $ pre $ tr' i (lookup_tr' ctxt t) else tr' i t $ pre | pre as ((Const (m,_) $ Var _)) (* pre state *) => if m = @{syntax_const "_var"} andalso is_selector t - then Syntax.const old $ pre $ tr' i (Hoare.undeco ctxt t) + then Syntax.const old $ pre $ tr' i (lookup_tr' ctxt t) else tr' i t $ pre | u => tr' i t $ tr' i u) | tr' i (Abs (x, T, t)) = Abs (x, T, tr' (i + 1) t) @@ -360,14 +386,15 @@ fun app_quote_mult_tr' ctxt is_selector f (t :: ts) = | app_quote_mult_tr' _ _ _ _ = raise Match; + fun atomic_var_tr ctxt ps name value = - update_comp ctxt ps true false name value; + update_comp ctxt NONE ps true false name value; fun heap_var_tr ctxt hp p value = let fun upd s = - update_comp ctxt [] true false hp + update_comp ctxt NONE [] true false hp (Syntax.const @{const_syntax fun_upd} $ lookup_comp ctxt [] hp s $ p $ value) s; in upd end; @@ -543,14 +570,14 @@ fun new_tr ctxt (ts as [var,size,init]) = val g = Syntax.free globalsN $ Bound 0; val alloc = lookup_comp ctxt [] allocN (Bound 0); - val new = Syntax.free "new" $ (Syntax.const @{const_syntax set} $ alloc); (* FIXME new !? *) + val new = Syntax.free "new" $ (Syntax.const @{const_syntax set} $ alloc); (* fixme new !? *) fun mk_upd (var,v) = let val varn = Hoare.varname var; val var' = lookup_comp ctxt [] varn (Bound 0); in - update_comp ctxt [] false false varn + update_comp ctxt NONE [] false false varn (Syntax.const @{const_syntax fun_upd} $ var' $ new $ v) end; @@ -559,10 +586,10 @@ fun new_tr ctxt (ts as [var,size,init]) = val freetest = Syntax.const @{const_syntax Orderings.less_eq} $ size $ free; val alloc_upd = - update_comp ctxt [] false false allocN + update_comp ctxt NONE [] false false allocN (Syntax.const @{const_syntax Cons} $ new $ alloc); val free_upd = - update_comp ctxt [] false false freeN + update_comp ctxt NONE [] false false freeN (Syntax.const @{const_syntax Groups.minus} $ free $ size); val g' = @@ -592,14 +619,14 @@ fun nnew_tr ctxt (ts as [var,size,init]) = val g = Syntax.free globalsN $ Bound 0; val alloc = lookup_comp ctxt [] allocN (Bound 0); - val new = Syntax.free "new" $ (Syntax.const @{const_syntax set} $ alloc); (* FIXME new !? *) + val new = Syntax.free "new" $ (Syntax.const @{const_syntax set} $ alloc); (* fixme new !? *) fun mk_upd (var,v) = let val varn = Hoare.varname var; val var' = lookup_comp ctxt [] varn (Bound 0); in - update_comp ctxt [] false false varn + update_comp ctxt NONE [] false false varn (Syntax.const @{const_syntax fun_upd} $ var' $ new $ v) end; @@ -608,10 +635,10 @@ fun nnew_tr ctxt (ts as [var,size,init]) = val freetest = Syntax.const @{const_syntax Orderings.less_eq} $ size $ free; val alloc_upd = - update_comp ctxt [] false false allocN + update_comp ctxt NONE [] false false allocN (Syntax.const @{const_syntax Cons} $ new $ alloc); val free_upd = - update_comp ctxt [] false false freeN + update_comp ctxt NONE [] false false freeN (Syntax.const @{const_syntax Groups.minus} $ free $ size); val g' = @@ -633,7 +660,7 @@ fun loc_tr ctxt (ts as [init, bdy]) = fun dest_init (Const (@{syntax_const "_locinit"}, _) $ Const (var,_) $ v) = (var, v) | dest_init (Const (@{syntax_const "_locnoinit"}, _) $ Const (var, _)) = (var, Syntax.const antiquoteCur $ Syntax.free (Hoare.varname var)) - (* FIXME could skip this dummy initialisation v := v s and + (* fixme: could skip this dummy initialisation v := v s and derive non init variables in the print translation from the return function instead the init function *) | dest_init _ = raise Match; @@ -644,10 +671,10 @@ fun loc_tr ctxt (ts as [init, bdy]) = | dest_inits _ = raise Match; fun mk_init_upd (var, v) = - update_comp ctxt [] true false var (antiquoteCur_tr ctxt v); + update_comp ctxt NONE [] true false var (antiquoteCur_tr ctxt v); fun mk_ret_upd var = - update_comp ctxt [] true false var (lookup_comp ctxt [] var (Bound 1)); + update_comp ctxt NONE [] true false var (lookup_comp ctxt [] var (Bound 1)); val var_vals = map (apfst Hoare.varname) (dest_inits init); val ini = Abs ("s", dummyT, fold mk_init_upd var_vals (Bound 0)); @@ -672,7 +699,7 @@ local fun le l r = Syntax.const @{const_syntax Orderings.less} $ l $ r; -fun in_range t = Syntax.free "in_range" $ t; (* FIXME ?? *) +fun in_range t = Syntax.free "in_range" $ t; (* fixme ?? *) fun not_zero t = Syntax.const @{const_syntax Not} $ @@ -680,7 +707,7 @@ fun not_zero t = fun not_Null t = Syntax.const @{const_syntax Not} $ - (Syntax.const @{const_syntax HOL.eq} $ t $ Syntax.free "Simpl_Heap.Null"); (* FIXME ?? *) + (Syntax.const @{const_syntax HOL.eq} $ t $ Syntax.free "Simpl_Heap.Null"); (* fixme ?? *) fun in_length i l = Syntax.const @{const_syntax Orderings.less} $ i $ @@ -725,7 +752,7 @@ fun guard ctxt Ts (add as (Const (@{const_name Groups.plus},_) $ l $ r)) = | guard ctxt Ts (Const (@{const_name HOL.disj},_) $ l $ r) = guard ctxt Ts l & mk_imp (HOLogic.Not $ l,guard ctxt Ts r) | guard ctxt Ts (dv as (Const (@{const_name Rings.divide},_) $ l $ r)) = - guard ctxt Ts l & guard ctxt Ts r & SOME (not_zero r) & SOME (in_range dv) (* FIXME: Make more concrete guard...*) + guard ctxt Ts l & guard ctxt Ts r & SOME (not_zero r) & SOME (in_range dv) (* fixme: Make more concrete guard...*) | guard ctxt Ts (Const (@{const_name Rings.modulo},_) $ l $ r) = guard ctxt Ts l & guard ctxt Ts r & SOME (not_zero r) | guard ctxt Ts (un as (Const (@{const_name Groups.uminus},_) $ n)) = @@ -759,7 +786,7 @@ in in guard ctxt [T] t' end; end; -(* FIXME: make guard function a parameter of all parse-translations that need it.*) +(* fixme: make guard function a parameter of all parse-translations that need it.*) val _ = Theory.setup (Context.theory_map (Hoare.install_generate_guard mk_guard)); @@ -862,22 +889,22 @@ fun dest_actuals (Const (@{syntax_const "_actuals_empty"}, _)) = [] | dest_actuals t = raise TERM ("dest_actuals", [t]); -fun mk_call_tr ctxt grd Call formals pn pt actuals has_args cont = +fun mk_call_tr ctxt grd Call formals pn pt actuals has_args result_exn cont = let val fcall = cont <> NONE; val state_kind = the_default (Hoare.get_default_state_kind ctxt) (Hoare.get_state_kind pn ctxt); - fun init_par_tr name arg = - update_comp ctxt [] false false name (antiquoteCur_tr ctxt arg); + fun init_par_tr name lense_opt arg = + update_comp ctxt lense_opt [] false false name (antiquoteCur_tr ctxt arg); fun result_par_tr name arg = let fun offset_old n = 2; fun offset n = if is_global ctxt n then 0 else 2; + val lookup = lookup_comp ctxt [] name (Bound 1) in - update_tr ctxt [pn] offset offset_old - (lookup_comp ctxt [] name (Bound 1)) arg + update_tr ctxt [pn] offset offset_old lookup arg end; val _ = if not (Config.get ctxt StateSpace.silent) andalso @@ -895,8 +922,8 @@ fun mk_call_tr ctxt grd Call formals pn pt actuals has_args cont = [Syntax.const globals_updateN $ (K_rec_syntax (Const (globalsN, dummyT) $ Bound 0))]; val ret = Abs ("s", dummyT, Abs ("t", dummyT, Library.foldr (op $) (globals, Bound 1))); - val val_formals = filter (fn (kind, _) => kind = Hoare.In) formals; - val res_formals = filter (fn (kind, _) => kind = Hoare.Out) formals; + val val_formals = filter (fn (kind, _, _) => kind = Hoare.In) formals; + val res_formals = filter (fn (kind, _, _) => kind = Hoare.Out) formals; val (val_actuals, res_actuals) = chop (length val_formals) actuals; val init_bdy = @@ -904,12 +931,12 @@ fun mk_call_tr ctxt grd Call formals pn pt actuals has_args cont = val state = (case state_kind of Hoare.Record => Bound 0 - | Hoare.Function => Syntax.const localsN $ Bound 0); - val upds = fold2 (fn (_, name) => init_par_tr name) val_formals val_actuals state; + | _ => Syntax.const localsN $ Bound 0); + val upds = fold2 (fn (_, name, lense_opt) => init_par_tr name lense_opt) val_formals val_actuals state; in (case state_kind of Hoare.Record => upds - | Hoare.Function => Syntax.const locals_updateN $ K_rec_syntax upds $ Bound 0) + | _ => Syntax.const locals_updateN $ K_rec_syntax upds $ Bound 0) end; val init = Abs ("s", dummyT, init_bdy); @@ -919,18 +946,19 @@ fun mk_call_tr ctxt grd Call formals pn pt actuals has_args cont = NONE => (* Procedure call *) let val results = - map (fn ((_, name), arg) => result_par_tr name arg) + map (fn ((_, name, _), arg) => result_par_tr name arg) (rev (res_formals ~~ res_actuals)); val res = Abs ("i", dummyT, Abs ("t", dummyT, Syntax.const @{const_syntax Basic} $ Abs ("s", dummyT, fold_rev (fn f => fn s => f s) results (Bound 0)))); - in if has_args then Call $init $ pt $ ret $ res else Call $ pt end + val args = [init, pt, ret] @ result_exn @ [res] + in if has_args then list_comb (Call, args) else Call $ pt end | SOME c => (* Function call *) let val res = (case res_formals of - [(_, n)] => Abs ("s", dummyT, lookup_comp ctxt [] n (Bound 0)) + [(_, n, _)] => Abs ("s", dummyT, lookup_comp ctxt [] n (Bound 0)) | _ => if Config.get ctxt StateSpace.silent then Abs ("s", dummyT, lookup_comp ctxt [] "dummy" (Bound 0)) @@ -949,79 +977,80 @@ fun mk_call_tr ctxt grd Call formals pn pt actuals has_args cont = end; -(* FIXME: What is prfx for, maybe unused *) -fun dest_procname ctxt prfx false (Const (p, _)) = - (prfx ^ suffix Hoare.proc_deco p, HOLogic.mk_string p) - | dest_procname ctxt prfx false (t as Free (p, T)) = - (prfx ^ suffix Hoare.proc_deco p, Free (suffix Hoare.proc_deco p, T)) - | dest_procname ctxt prfx false (Const (@{syntax_const "_free"},_) $ Free (p,T)) = - (prfx ^ suffix Hoare.proc_deco p, Free (suffix Hoare.proc_deco p, T)) - | dest_procname ctxt prfx false (t as (Const (@{syntax_const "_antiquoteCur"},_) $ Const (p, _))) = - (prfx ^ Hoare.resuffix Hoare.deco Hoare.proc_deco p, t) - | dest_procname ctxt prfx false (t as (Const (@{syntax_const "_antiquoteCur"}, _) $ Free (p, _))) = - (prfx ^ Hoare.resuffix Hoare.deco Hoare.proc_deco p, t) - | dest_procname ctxt prfx false (t as Const (p, _) $ _) = - (prfx ^ Hoare.resuffix Hoare.deco Hoare.proc_deco p, t) (* antiquoteOld *) - | dest_procname ctxt prfx false (t as Free (p,_)$_) = - (prfx ^ Hoare.resuffix Hoare.deco Hoare.proc_deco p, t) (* antiquoteOld *) - | dest_procname ctxt prfx false (t as Const (@{syntax_const "_antiquoteOld"}, _) $ _ $ Const (p, _)) = - (prfx ^ suffix Hoare.proc_deco p, t) - | dest_procname ctxt prfx false (t as Const (@{syntax_const "_antiquoteOld"}, _) $ _ $ Free (p,_)) = - (prfx ^ suffix Hoare.proc_deco p, t) - (* FIXME StateFun.lookup !? *) - | dest_procname ctxt prfx false (t as Const (@{const_name "StateFun.lookup"}, _) $ _ $ Free (p, _) $ _) = - (prfx ^ suffix Hoare.proc_deco (Hoare.remdeco' p), t) (* antiquoteOld *) +fun dest_procname ctxt false (Const (p, _)) = + (suffix Hoare.proc_deco p, HOLogic.mk_string p) + | dest_procname ctxt false (t as Free (p, T)) = + (case Hoare.get_default_state_space ctxt of + SOME {read_function_name, ...} => (p, read_function_name ctxt p) + | _ => (suffix Hoare.proc_deco p, Free (suffix Hoare.proc_deco p, T))) + | dest_procname ctxt false (Const (@{syntax_const "_free"},_) $ Free (p,T)) = + (suffix Hoare.proc_deco p, Free (suffix Hoare.proc_deco p, T)) + | dest_procname ctxt false (t as (Const (@{syntax_const "_antiquoteCur"},_) $ Const (p, _))) = + (Hoare.resuffix Hoare.deco Hoare.proc_deco p, t) + | dest_procname ctxt false (t as (Const (@{syntax_const "_antiquoteCur"}, _) $ Free (p, _))) = + (Hoare.resuffix Hoare.deco Hoare.proc_deco p, t) + | dest_procname ctxt false (t as Const (p, _) $ _) = + (Hoare.resuffix Hoare.deco Hoare.proc_deco p, t) (* antiquoteOld *) + | dest_procname ctxt false (t as Free (p,_)$_) = + (Hoare.resuffix Hoare.deco Hoare.proc_deco p, t) (* antiquoteOld *) + | dest_procname ctxt false (t as Const (@{syntax_const "_antiquoteOld"}, _) $ _ $ Const (p, _)) = + (suffix Hoare.proc_deco p, t) + | dest_procname ctxt false (t as Const (@{syntax_const "_antiquoteOld"}, _) $ _ $ Free (p,_)) = + (suffix Hoare.proc_deco p, t) + | dest_procname ctxt false (t as Const (@{const_name "StateFun.lookup"}, _) $ _ $ Free (p, _) $ _) = + (suffix Hoare.proc_deco (Hoare.remdeco' ctxt p), t) (* antiquoteOld *) - | dest_procname ctxt prfx false t = (prfx, t) - | dest_procname ctxt prfx true t = + | dest_procname ctxt false t = ("", t) + | dest_procname ctxt true t = let fun quote t = Abs ("s", dummyT, antiquoteCur_tr ctxt t) in (case quote t of (t' as Abs (_, _, Free (p, _) $ Bound 0)) => - (prfx ^ Hoare.resuffix Hoare.deco Hoare.proc_deco p, t') - (* FIXME StateFun.lookup !? *) + (Hoare.resuffix Hoare.deco Hoare.proc_deco p, t') | (t' as Abs (_, _, Const (@{const_name "StateFun.lookup"}, _) $ _ $ Free (p, _) $ (_ $ Bound 0))) => - (prfx ^ suffix Hoare.proc_deco (Hoare.remdeco' p), t') - | t' => (prfx, t')) + (suffix Hoare.proc_deco (Hoare.remdeco' ctxt p), t') + | t' => ("", t')) end -fun gen_call_tr prfx dyn grd ctxt p actuals has_args cont = +fun gen_call_tr dyn grd ctxt p actuals has_args result_exn cont = let - fun Call false true NONE = Const (@{const_syntax call}, dummyT) - | Call false false NONE = Const (@{const_syntax Call}, dummyT) - | Call true true NONE = Const (@{const_syntax dynCall}, dummyT) - | Call false true (SOME c) = Const (@{const_syntax fcall}, dummyT) - | Call _ _ _ = raise TERM ("gen_call_tr: no proper procedure call", []); + fun Call false true [] NONE = Const (@{const_syntax call}, dummyT) + | Call false true _ NONE = Const (@{const_syntax call_exn}, dummyT) + | Call false false [] NONE = Const (@{const_syntax Call}, dummyT) + | Call true true [] NONE = Const (@{const_syntax dynCall}, dummyT) + | Call true true _ NONE = Const (@{const_syntax dynCall_exn}, dummyT) + | Call false true [] (SOME c) = Const (@{const_syntax fcall}, dummyT) + | Call _ _ _ _ = raise TERM ("gen_call_tr: no proper procedure call", []); - val (pn, pt) = dest_procname ctxt prfx dyn (Term_Position.strip_positions p); + val (pn, pt) = dest_procname ctxt dyn (Term_Position.strip_positions p); in (case Hoare.get_params pn ctxt of SOME formals => - mk_call_tr ctxt grd (Call dyn has_args cont) formals pn pt actuals has_args cont + mk_call_tr ctxt grd (Call dyn has_args result_exn cont) formals pn pt actuals has_args result_exn cont | NONE => if Config.get ctxt StateSpace.silent - then mk_call_tr ctxt grd (Call dyn has_args cont) [] pn pt [] has_args cont + then mk_call_tr ctxt grd (Call dyn has_args result_exn cont) [] pn pt [] has_args result_exn cont else raise TERM ("gen_call_tr: procedure " ^ quote pn ^ " not defined", [])) end; -fun call_tr dyn grd ctxt [p, actuals] = - gen_call_tr "" dyn grd ctxt p (dest_actuals actuals) true NONE - | call_tr _ _ _ t = raise TERM ("call_tr", t); +fun call_tr dyn grd result_exn ctxt [p, actuals] = + gen_call_tr dyn grd ctxt p (dest_actuals actuals) true result_exn NONE + | call_tr _ _ _ _ t = raise TERM ("call_tr", t); -fun call_ass_tr dyn grd ctxt [l, p, actuals] = - gen_call_tr "" dyn grd ctxt p (dest_actuals actuals @ [l]) true NONE - | call_ass_tr _ _ _ t = raise TERM ("call_ass_tr", t); +fun call_ass_tr dyn grd result_exn ctxt [l, p, actuals] = + gen_call_tr dyn grd ctxt p (dest_actuals actuals @ [l]) true result_exn NONE + | call_ass_tr _ _ _ _ t = raise TERM ("call_ass_tr", t); fun proc_tr ctxt [p, actuals] = - gen_call_tr "" false false ctxt p (dest_actuals actuals) false NONE + gen_call_tr false false ctxt p (dest_actuals actuals) false [] NONE | proc_tr _ t = raise TERM ("proc_tr", t); fun proc_ass_tr ctxt [l, p, actuals] = - gen_call_tr "" false false ctxt p (dest_actuals actuals @ [l]) false NONE + gen_call_tr false false ctxt p (dest_actuals actuals @ [l]) false [] NONE | proc_ass_tr _ t = raise TERM ("proc_ass_tr", t); fun fcall_tr ctxt [p, actuals, c] = - gen_call_tr "" false false ctxt p (dest_actuals actuals) true (SOME c) + gen_call_tr false false ctxt p (dest_actuals actuals) true [] (SOME c) | fcall_tr _ t = raise TERM ("fcall_tr", t); @@ -1042,7 +1071,11 @@ fun update_name_tr' ctxt (Free x) = Const (upd_tr' ctxt x) | update_name_tr' ctxt ((c as Const (@{syntax_const "_free"}, _)) $ Free x) = (*c $*) Const (upd_tr' ctxt x) | update_name_tr' ctxt (Const x) = Const (upd_tr' ctxt x) - | update_name_tr' _ _ = raise Match; + | update_name_tr' ctxt t = + (case Hoare.get_default_state_space ctxt of + SOME {update_tr',...} => update_tr' ctxt t + | NONE => raise Match); + fun term_name_eq (Const (x, _)) (Const (y, _)) = (x = y) | term_name_eq (Free (x, _)) (Free (y, _)) = (x = y) @@ -1076,7 +1109,7 @@ fun list_mult_update_tr' l (r as Const (@{const_syntax list_multupd},_) $ var $ (Syntax.const @{const_syntax list_multsel} $ var $ idxs, values) | list_mult_update_tr' l r = (l, r); -fun update_tr' l (r as Const (@{const_syntax fun_upd}, _) $ +fun update_tr' ctxt l (r as Const (@{const_syntax fun_upd}, _) $ (hp as (Const (@{syntax_const "_antiquoteCur"}, _) $ _)) $ p $ value) = if term_name_eq l hp then (case value of @@ -1084,94 +1117,159 @@ fun update_tr' l (r as Const (@{const_syntax fun_upd}, _) $ | (Const (@{const_syntax list_multupd},_) $ _ $ _ $ _) => list_mult_update_tr' (l $ p) value | _ => (l $ p, value)) else (l, r) - | update_tr' l (r as Const (@{const_syntax list_update},_) $ + | update_tr' ctxt l (r as Const (@{const_syntax list_update},_) $ (var as (Const (@{syntax_const "_antiquoteCur"}, _) $ _)) $ i $ value) = if term_name_eq l var then list_update_tr' l r else (l, r) - | update_tr' l (r as Const (@{const_syntax list_multupd}, _) $ + | update_tr' ctxt l (r as Const (@{const_syntax list_multupd}, _) $ (var as (Const (@{syntax_const "_antiquoteCur"}, _) $ _)) $ idxs $ values) = if term_name_eq l var then list_mult_update_tr' l r else (l, r) - | update_tr' l r = (l, r); + | update_tr' ctxt l r = (l, r); -fun dest_K_rec (Abs (_, _, v)) = - if member (op =) (loose_bnos v) 0 then NONE else SOME (incr_boundvars ~1 v) - | dest_K_rec (Abs (_, _, Abs (_, _, v) $ Bound 0)) = (* eta expanded version *) +fun dest_K_rec (Abs (_, _, Abs (_, _, v) $ Bound 0)) = (* eta expanded version *) let val lbv = loose_bnos v; in if member (op =) lbv 0 orelse member (op =) lbv 1 then NONE else SOME (incr_boundvars ~2 v) end + | dest_K_rec (Abs (_, _, v)) = + if member (op =) (loose_bnos v) 0 then NONE else SOME (incr_boundvars ~1 v) + | dest_K_rec (Const (@{const_syntax K_statefun}, _) $ v) = SOME v | dest_K_rec _ = NONE; +fun the_Match (SOME x) = x + | the_Match (NONE) = raise Match + +fun dest_update ctxt (upd' $ dest $ constr $ n $ v $ s) = + (n, v, SOME s) + | dest_update ctxt (upd' $ dest $ constr $ n $ v) = + (n, v, NONE) + | dest_update ctxt t = + case Hoare.get_default_state_space ctxt of + SOME {dest_update_tr', ...} => dest_update_tr' ctxt t + | NONE => raise Match + local -fun uncover (upd,v) = - (case (upd, v) of - (Const (cupd, _), upd' $ dest $ constr $ n $ (Const (@{const_syntax K_statefun}, _) $ v') $ s) => +fun uncover ctxt (upd,v) = (upd, v) |> first_match [ + fn (Const (cupd, _), t) => if member (op =) [globals_updateN, locals_updateN] (Long_Name.base_name cupd) - then (case s of (Const (g, _) $ _) => - if member (op =) [localsN, globalsN] (Long_Name.base_name g) - then (n, v') - else raise Match - | _ => raise Match) - else (upd, v) - | (Const (gupd, _), upd' $ k $ s) => - (case dest_K_rec k of - SOME v' => - if Long_Name.base_name gupd = globals_updateN - then - (case s of - Const (gl, _) $ _ => - if Long_Name.base_name gl = globalsN (* assignment *) - then (upd',v') - else raise Match - | _ => raise Match) + then case dest_update ctxt t of + (n, v', SOME s) => (case s of (Const (g, _) $ _) => + if member (op =) [localsN, globalsN] (Long_Name.base_name g) + then (n, the_Match (dest_K_rec v')) + else raise Match + | _ => raise Match) + | (n, v', NONE) => (n, the_Match (dest_K_rec v')) + else (upd, v), + fn (upd, v ) => + (case (upd, v) of + (Const (gupd, _), t as (upd' $ k $ s)) => + (case dest_K_rec k of + SOME v' => + if Long_Name.base_name gupd = globals_updateN + then + (case s of + Const (gl, _) $ _ => + if Long_Name.base_name gl = globalsN (* assignment *) + then (upd',v') + else raise Match + | _ => raise Match) + else (upd, v) + | _ => (upd, v)) + | (Const (upd_glob, _), upd' $ v') => + if Long_Name.base_name upd_glob = upd_globalsN (* result parameter *) + then (upd', v') + else if Long_Name.base_name upd_glob = globals_updateN + then (case dest_K_rec v' of + SOME v'' => (upd',v'') + | _ => (upd, v)) else (upd, v) - | _ => (upd, v)) - | (Const (upd_glob, _), upd' $ v') => - if Long_Name.base_name upd_glob = upd_globalsN (* result parameter *) - then (upd', v') else (upd, v) - | _ => (upd, v)); + | _ => (upd, v))] in -fun global_upd_tr' upd k = +fun global_upd_tr' ctxt upd k = (case dest_K_rec k of - SOME v => uncover (upd, v) - | NONE => uncover (upd, k)); - + SOME v => uncover ctxt (upd, v) + | NONE => uncover ctxt (upd, k)) end; - -fun dest_updates (t as (upd as Const (u, _)) $ k $ state) = +fun dest_updates ctxt t = t |> first_match [ + fn (t as (upd as Const (u, _)) $ k $ state) => (case dest_K_rec k of SOME value => if member (op =) [globals_updateN, locals_updateN] (Long_Name.base_name u) - then dest_updates value + then dest_updates ctxt value else if can (unsuffix Record.updateN) u orelse Long_Name.base_name u = upd_globalsN - then (upd,value)::dest_updates state + then (upd,value)::dest_updates ctxt state else raise Match - | NONE => raise Match) - | dest_updates (t as (upd as Const (u,_))$k) = + | NONE => raise Match (*dest_updates ctxt k @ dest_updates ctxt state*) (* check for nested update (e.g. locals-stack) *) + (*handle Match => []*)), (* t could be just (globals $ s) *) + fn (t as (upd as Const (u,_))$k) => (case dest_K_rec k of SOME value => if member (op =) [globals_updateN, locals_updateN] (Long_Name.base_name u) - then dest_updates value + then dest_updates ctxt value else if can (unsuffix Record.updateN) u orelse Long_Name.base_name u = upd_globalsN then [(upd,value)] else if Long_Name.base_name u = globalsN then [] else raise Match - | NONE => []) (* t could be just (globals $ s) *) - | dest_updates ((Const (u, _)) $ _ $ _ $ n $ (Const (@{const_syntax K_statefun},_) $ value) $ state) = + | NONE => dest_updates ctxt k (* check for nested update (e.g. locals-stack) *) + handle Match => []), (* t could be just (globals $ s) *) + fn ((Const (u, _)) $ _ $ _ $ n $ k $ state) => if Long_Name.base_name u = Long_Name.base_name StateFun.updateN - then (n, value) :: dest_updates state - else raise Match - | dest_updates t = []; + then case dest_K_rec k of SOME value => (n, value) :: dest_updates ctxt state | _ => raise Match + else raise Match, + fn ((Const (u, _)) $ _ $ _ $ n $ k) => + if Long_Name.base_name u = Long_Name.base_name StateFun.updateN + then case dest_K_rec k of SOME value => [(n, value)] | _ => raise Match + else raise Match, + fn t => + (case Hoare.get_default_state_space ctxt of + SOME {dest_update_tr', ...} => + (case dest_update_tr' ctxt t of + (n, v, SOME s) => (n, the_Match (dest_K_rec v))::dest_updates ctxt s + | (n, v, NONE) => [(n, the_Match (dest_K_rec v))]) + | NONE => raise Match), + fn t => []] -(* FIXME: externalize names properly before removing decoration! *) +fun dest_updates ctxt t = t |> first_match [ + fn (t as (upd as Const (u, _)) $ k $ state) => + if member (op =) [globals_updateN, locals_updateN] (Long_Name.base_name u) then + dest_updates ctxt k @ dest_updates ctxt state + else if can (unsuffix Record.updateN) u orelse Long_Name.base_name u = upd_globalsN then + (upd, the_Match (dest_K_rec k))::dest_updates ctxt state + else raise Match, (* t could be just (globals $ s) *) + fn (t as (upd as Const (u,_))$k) => + if member (op =) [globals_updateN, locals_updateN] (Long_Name.base_name u) then + dest_updates ctxt k + else if can (unsuffix Record.updateN) u orelse Long_Name.base_name u = upd_globalsN then + [(upd, the_Match (dest_K_rec k))] + (*else if Long_Name.base_name u = globalsN then [] *) + else raise Match, + fn ((Const (u, _)) $ _ $ _ $ n $ k $ state) => + if Long_Name.base_name u = Long_Name.base_name StateFun.updateN then + (n, the_Match (dest_K_rec k)) :: dest_updates ctxt state + else raise Match, + fn ((Const (u, _)) $ _ $ _ $ n $ k) => + if Long_Name.base_name u = Long_Name.base_name StateFun.updateN then + [(n, the_Match (dest_K_rec k))] + else raise Match, + fn t => + (case Hoare.get_default_state_space ctxt of + SOME {dest_update_tr', ...} => + (case dest_update_tr' ctxt t of + (n, v, SOME s) => (n, the_Match (dest_K_rec v))::dest_updates ctxt s + | (n, v, NONE) => [(n, the_Match (dest_K_rec v))]) + | NONE => raise Match), + fn t => []] + + +(* fixme: externalize names properly before removing decoration! *) fun init_tr' ctxt [Abs (_,_,t)] = let val upds = - case dest_updates t of + case dest_updates ctxt t of us as [(Const (gupd, _), v)] => if Long_Name.base_name gupd = globals_updateN - then dest_updates v else us + then dest_updates ctxt v else us | us => us; val comps = @@ -1202,16 +1300,16 @@ fun tr' ctxt c (upd,v) = let val l = Syntax.const antiquoteCur $ update_name_tr' ctxt upd; val r = quote_tr' ctxt antiquoteCur (Abs ("s", dummyT, v)); - val (l', r') = update_tr' l r; + val (l', r') = update_tr' ctxt l r; in (c $ l' $ r') end; in fun app_assign_tr' c ctxt (Abs (s, _, upd $ v $ Bound 0) :: ts) = - tr' ctxt c (global_upd_tr' upd v) + tr' ctxt c (global_upd_tr' ctxt upd v) | app_assign_tr' c ctxt ((upd $ v) :: ts) = (case upd of u $ v => raise Match - | _ => tr' ctxt c (global_upd_tr' upd v)) + | _ => tr' ctxt c (global_upd_tr' ctxt upd v)) | app_assign_tr' _ _ _ = raise Match; end; @@ -1239,7 +1337,7 @@ fun basic_tr' ctxt [Abs (s, T, t)] = ((t' as (Const (@{const_syntax Let'},_) $ _ $ _)) $ Bound 0) => (true, t') | _ => (false, t); val (recomb, t'') = split_Let' t'; - val upds = dest_updates t''; + val upds = dest_updates ctxt t''; val _ = if length upds <= 1 andalso not has_let then raise Match else (); val ass = map (fn (u, v) => app_assign_tr' (Syntax.const @{syntax_const "_BAssign"}) ctxt @@ -1254,8 +1352,8 @@ fun loc_tr' ctxt [init, bdy, return, c] = (let val upds = (case init of - Abs (_, _, t as (upd $ v $ s)) => dest_updates t - | upd $ v => dest_updates (upd $ v $ Bound 0) + Abs (_, _, t as (upd $ v $ s)) => dest_updates ctxt t + | upd $ v => dest_updates ctxt (upd $ v $ Bound 0) | _ => raise Match); fun mk_locinit c v = @@ -1279,14 +1377,14 @@ fun loc_tr' ctxt [init, bdy, return, c] = if Long_Name.base_name lookup = Long_Name.base_name StateFun.lookupN andalso Long_Name.base_name locals = localsN then init_or_not c c' v - else mk_locinit (Hoare.remdeco' c) v - | _ => mk_locinit (Hoare.remdeco' c) v) + else mk_locinit (Hoare.remdeco' ctxt c) v + | _ => mk_locinit (Hoare.remdeco' ctxt c) v) | mk_init _ = raise Match; val inits = foldr1 (fn (t, u) => Syntax.const @{syntax_const "_locinits"} $ t $ u) (map mk_init (rev upds)); - in Syntax.const @{syntax_const "_Loc"} $ inits $ bdy end handle Fail _ => raise Match) + in Syntax.const @{syntax_const "_Loc"} $ inits $ bdy end handle Fail _ => raise Match | Empty => raise Match) | loc_tr' _ _ = raise Match; @@ -1299,46 +1397,48 @@ fun actuals_tr' acts = fun gen_call_tr' ctxt Call CallAss init p return c = let - fun get_init_updates (Abs (s, _, upds)) = dest_updates upds - | get_init_updates upds = dest_updates upds; + fun get_init_updates (Abs (s, _, upds)) = dest_updates ctxt upds + | get_init_updates upds = dest_updates ctxt upds; fun get_res_updates (Abs (i, _, Abs (t, _, Const (@{const_syntax Basic}, _) $ Abs (s, _, upds)))) = - dest_updates upds + dest_updates ctxt upds | get_res_updates (Abs (i, _, Abs (t, _, Const (@{const_syntax Basic}, _) $ upds))) = - dest_updates upds + dest_updates ctxt upds | get_res_updates _ = raise Match; - fun init_par_tr' par = + val init_upds = rev (get_init_updates init) + fun init_par_tr' par = Syntax.const @{syntax_const "_par"} $ quote_tr' ctxt antiquoteCur (Abs ("s", dummyT, par)); - val init_actuals = - map (fn (_, value) => init_par_tr' value) (rev (get_init_updates init)); + val init_actuals = + map (fn (_, value) => init_par_tr' value) init_upds; - fun tr' c (upd, v) = - let - val l = Syntax.const antiquoteCur $ update_name_tr' ctxt upd; - val r = - quote_tr' ctxt antiquoteCur + fun tr' c (upd, v) = + let + val l = Syntax.const antiquoteCur $ update_name_tr' ctxt upd; + val r = + quote_tr' ctxt antiquoteCur + (quote_tr' ctxt antiquoteCur (quote_tr' ctxt antiquoteCur - (quote_tr' ctxt antiquoteCur - (Abs ("i", dummyT, Abs ("t", dummyT, Abs ("s", dummyT, v)))))); - val (l', _) = update_tr' l r; - in c $ l' end; + (Abs ("i", dummyT, Abs ("t", dummyT, Abs ("s", dummyT, v)))))); + val (l', _) = update_tr' ctxt l r; + in c $ l' end; - fun ret_par_tr' (upd, v) = - tr' (Syntax.const @{syntax_const "_par"}) (global_upd_tr' upd v); + fun ret_par_tr' (upd, v) = + tr' (Syntax.const @{syntax_const "_par"}) (global_upd_tr' ctxt upd v); - val res_updates = rev (get_res_updates c); - val res_actuals = map ret_par_tr' res_updates; - in if Config.get ctxt use_call_tr' then + val res_updates = rev (get_res_updates c); + val res_actuals = map ret_par_tr' res_updates; + in + if Config.get ctxt use_call_tr' then (case res_actuals of [l] => CallAss $ l $ p $ actuals_tr' init_actuals | _ => Call $ p $ actuals_tr' (init_actuals @ res_actuals)) - else raise Match + else raise Match end; fun gen_fcall_tr' ctxt init p return result c = let - fun get_init_updates (Abs (s, _, upds)) = dest_updates upds + fun get_init_updates (Abs (s, _, upds)) = dest_updates ctxt upds | get_init_updates _ = raise Match; fun init_par_tr' par = @@ -1363,7 +1463,7 @@ fun pname_tr' ctxt ((f as Const (@{syntax_const "_free"}, _)) $ Free (p, T)) = | pname_tr' ctxt p = let (* from HOL strings to ML strings *) - fun dest_nib c = (* FIXME authentic syntax *) + fun dest_nib c = (* fixme authentic syntax *) (case raw_explode c of ["N", "i", "b", "b", "l", "e", h] => if "0" <= h andalso h <= "9" then ord h - ord "0" @@ -1391,6 +1491,12 @@ fun call_tr' ctxt [init, p, return, result] = (Const (@{syntax_const "_CallAss"}, dummyT)) init (pname_tr' ctxt p) return result | call_tr' _ _ = raise Match; +fun call_exn_tr' ctxt [init, p, return, result_exn, result] = + gen_call_tr' ctxt + (Const (@{syntax_const "_Call_exn"}, dummyT)) + (Const (@{syntax_const "_CallAss_exn"}, dummyT)) init (pname_tr' ctxt p) return result + | call_exn_tr' _ _ = raise Match; + fun dyn_call_tr' ctxt [init, p, return, result] = let val p' = quote_tr' ctxt antiquoteCur p @@ -1401,13 +1507,22 @@ fun dyn_call_tr' ctxt [init, p, return, result] = end | dyn_call_tr' _ _ = raise Match; +fun dyn_call_exn_tr' ctxt [init, p, return, result_exn, result] = + let val p' = quote_tr' ctxt antiquoteCur p + in + gen_call_tr' ctxt + (Const (@{syntax_const "_DynCall_exn"}, dummyT)) + (Const (@{syntax_const "_DynCallAss_exn"}, dummyT)) init p' return result + end + | dyn_call_exn_tr' _ _ = raise Match; + fun proc_tr' ctxt [p] = let val p' = pname_tr' ctxt p; - val pn = fst (dest_procname ctxt "" false p'); + val pn = fst (dest_procname ctxt false p'); val formals = the (Hoare.get_params pn ctxt) handle Option.Option => raise Match; - val val_formals = map_filter (fn (Hoare.In, p) => SOME p | _ => NONE) formals; - val res_formals = map_filter (fn (Hoare.Out, p) => SOME p | _ => NONE) formals; + val val_formals = map_filter (fn (Hoare.In, p, _) => SOME p | _ => NONE) formals; + val res_formals = map_filter (fn (Hoare.Out, p, _) => SOME p | _ => NONE) formals; fun mkpar n = Syntax.const @{syntax_const "_par"} $ (Syntax.const antiquoteCur $ Syntax.const (Hoare.remdeco ctxt n)); @@ -1439,7 +1554,10 @@ fun assert_tr' ctxt ((t as Abs (_, _, p)) :: ts) = fun selector (Const (c, T)) = Hoare.is_state_var c | selector (Const (l, _) $ _ $ _) = Long_Name.base_name l = Long_Name.base_name StateFun.lookupN - | selector t = false; + | selector t = + (case Hoare.get_default_state_space ctxt of + SOME {is_lookup,...} => is_lookup ctxt t + | _ => false) fun fix_state (Const (@{const_syntax HOL.eq},_) $ (Const (@{syntax_const "_free"}, _) $ _)) = true | fix_state (Const (@{const_syntax HOL.eq},_) $ (Const (@{syntax_const "_bound"}, _) $ _)) = true @@ -1477,9 +1595,9 @@ fun new_tr' ctxt | mk_init ((f as Const (@{syntax_const "_free"}, _)) $ Free (var, T), Const (@{const_syntax fun_upd},_) $ _ $ _ $ v) = Syntax.const @{syntax_const "_newinit"} $ - (f $ Free (Hoare.remdeco' var, T)) $ v; + (f $ Free (Hoare.remdeco' ctxt var, T)) $ v; - val inits_free_allocs = dest_updates inits_free_alloc; + val inits_free_allocs = dest_updates ctxt inits_free_alloc; val inits = map mk_init (take (length inits_free_allocs - 2) (inits_free_allocs)); val inits' = @@ -1489,10 +1607,10 @@ fun new_tr' ctxt let val l = Syntax.const antiquoteCur $ update_name_tr' ctxt upd; val r = quote_tr' ctxt antiquoteCur (Abs (s, dummyT, v)); - val (l', r') = update_tr' l r + val (l', r') = update_tr' ctxt l r in l' end; - val l = tr' (global_upd_tr' upd' null); + val l = tr' (global_upd_tr' ctxt upd' null); in Syntax.const @{syntax_const "_New"} $ l $ size $ inits' end | new_tr' _ _ = raise Match; @@ -1510,9 +1628,9 @@ fun nnew_tr' ctxt | mk_init ((f as Const (@{syntax_const "_free"}, _)) $ Free (var, T), Const (@{const_syntax fun_upd}, _) $_ $ _ $ v) = Syntax.const @{syntax_const "_newinit"} $ - (f $ Free (Hoare.remdeco' var, T)) $ v; + (f $ Free (Hoare.remdeco' ctxt var, T)) $ v; - val free_inits_allocs = dest_updates free_inits_alloc; + val free_inits_allocs = dest_updates ctxt free_inits_alloc; val inits = map mk_init (take (length free_inits_allocs - 2) (tl free_inits_allocs)); val inits' = @@ -1522,10 +1640,10 @@ fun nnew_tr' ctxt let val l = Syntax.const antiquoteCur $ update_name_tr' ctxt upd; val r = quote_tr' ctxt antiquoteCur (Abs (s, dummyT, v)); - val (l', r') = update_tr' l r; + val (l', r') = update_tr' ctxt l r; in l' end; - val l = tr' (global_upd_tr' upd' null); + val l = tr' (global_upd_tr' ctxt upd' null); in Syntax.const @{syntax_const "_NNew"} $ l $ size $ inits' end | nnew_tr' _ _ = raise Match;