├── AUTHORS ├── ln ├── _CoqProject ├── .vscode │ └── settings.json ├── README.md ├── STLC_Core_Soundness.v ├── STLC_Core_FullBeta.v ├── STLC_Ref_Soundness_Common.v ├── Makefile ├── STLC_Exn_Soundness.v ├── STLC_Core_Definitions.v ├── BigStep_Definitions.v ├── CoC_Conversion.v ├── Lambda_Definitions.v ├── Fsub_Soundness_OmniSmall.v ├── ISK_Confluence.v ├── STLC_Ref_Soundness_Small.v ├── STLC_Exn_Definitions.v ├── STLC_Data_Soundness.v ├── CoC_BetaStar.v ├── CPS_Definitions.v ├── STLC_Core_Safety.v ├── STLC_Core_Adequacy.v ├── CPS_Correctness.v └── STLC_Exn_Infrastructure.v ├── Makefile ├── .gitignore ├── tuto ├── open.sh ├── _CoqProject ├── .vscode │ └── settings.json ├── Makefile └── README.md ├── omni ├── _CoqProject ├── .vscode │ └── settings.json ├── Makefile ├── README.md ├── Hprop.v ├── Big.v ├── EquivSmallBig.v ├── Syntax.v ├── LibSepVar.v └── SepLogicOmniBig.v ├── pretty ├── _CoqProject ├── .vscode │ └── settings.json ├── Common.v ├── Lambda_Syntax.v ├── LambdaRef_Syntax.v ├── Lambda_Typing.v ├── README.md ├── Makefile ├── LambdaExn_Interp.v ├── LambdaExn_Syntax.v ├── Lambda_Big.v ├── Lambda_CombiErr_Typing_Sound.v ├── LambdaExnSum_Small.v ├── Lambda_CombiErr.v ├── LambdaExnSum_Big.v ├── Lambda_PrettyErr_Typing_Sound.v ├── CoreCaml_Syntax.v ├── LambdaExn_Big.v ├── LambdaExn_Interp_BigErr_Correct.v ├── LambdaExnSum_EncodeExn.v ├── LambdaExn_PrettyErr_Typing_Sound.v ├── LambdaExn_Interp_CombiErr_Correct.v ├── LambdaExnSum_Syntax.v └── LambdaExn_PrettyErr.v ├── LICENSE └── README.md /AUTHORS: -------------------------------------------------------------------------------- 1 | 2 | Arthur Charguéraud 3 | 4 | -------------------------------------------------------------------------------- /ln/_CoqProject: -------------------------------------------------------------------------------- 1 | 2 | -R . Top -arg -w -arg -deprecated 3 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | SUBDIRS=tuto ln pretty 2 | 3 | default: all 4 | 5 | $(SUBDIRS):: 6 | $(MAKE) -C $@ $(MAKECMDGOALS) 7 | 8 | all proofs vo vos vok clean : $(SUBDIRS) 9 | 10 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.vo 2 | *.vok 3 | *.vos 4 | *.aux 5 | *.cmx 6 | *.glob 7 | *.native 8 | */Makefile.generated 9 | */*Makefile.generated.d 10 | */Makefile.generated.conf 11 | *.lia.cache -------------------------------------------------------------------------------- /tuto/open.sh: -------------------------------------------------------------------------------- 1 | COQBIN= 2 | TLC= 3 | if [ -f settings.sh ] 4 | then 5 | source settings.sh 6 | fi 7 | ${COQBIN}coqide -async-proofs off -async-proofs-command-error-resilience off -R ${TLC} TLC -R . PRETTY $* 8 | -------------------------------------------------------------------------------- /tuto/_CoqProject: -------------------------------------------------------------------------------- 1 | -Q . TLC 2 | 3 | -arg -w -arg -implicit-core-hint-db,-deprecated-ident-entry 4 | 5 | # ,-omega-is-deprecated,-deprecated-hint-without-locality,,-deprecated-instance-without-locality,-deprecated-hint-rewrite-without-locality 6 | -------------------------------------------------------------------------------- /omni/_CoqProject: -------------------------------------------------------------------------------- 1 | -R . Top -arg -w -arg -deprecated 2 | 3 | #-implicit-core-hint-db,-deprecated-ident-entry,-omega-is-deprecated,-deprecated-hint-without-locality,-deprecated-instance-without-locality,-deprecated-hint-rewrite-without-locality,deprecated-hint-rewrite-without-locality,deprecated-hint-without-locality,deprecated-instance-without-locality 4 | -------------------------------------------------------------------------------- /pretty/_CoqProject: -------------------------------------------------------------------------------- 1 | -R . Top -arg -w -arg -deprecated 2 | 3 | #-implicit-core-hint-db,-deprecated-ident-entry,-omega-is-deprecated,-deprecated-hint-without-locality,-deprecated-instance-without-locality,-deprecated-hint-rewrite-without-locality,deprecated-hint-rewrite-without-locality,deprecated-hint-without-locality,deprecated-instance-without-locality 4 | -------------------------------------------------------------------------------- /ln/.vscode/settings.json: -------------------------------------------------------------------------------- 1 | { 2 | "search.exclude": { 3 | "*.aux": true, 4 | "*.glob": true, 5 | "*.d": true, 6 | "*.vo": true, 7 | "*.vos": true, 8 | "*.vok": true, 9 | "*.generated": true, 10 | "*.generated.conf": true, 11 | }, 12 | "files.trimTrailingWhitespace": true, 13 | "files.insertFinalNewline": true, 14 | "editor.tabSize": 2, 15 | "editor.detectIndentation": false, 16 | "files.associations": { 17 | "*.Makefile": "makefile", 18 | } 19 | } 20 | -------------------------------------------------------------------------------- /omni/.vscode/settings.json: -------------------------------------------------------------------------------- 1 | { 2 | "search.exclude": { 3 | "*.aux": true, 4 | "*.glob": true, 5 | "*.d": true, 6 | "*.vo": true, 7 | "*.vos": true, 8 | "*.vok": true, 9 | "*.generated": true, 10 | "*.generated.conf": true, 11 | }, 12 | "files.trimTrailingWhitespace": true, 13 | "files.insertFinalNewline": true, 14 | "editor.tabSize": 2, 15 | "editor.detectIndentation": false, 16 | "files.associations": { 17 | "*.Makefile": "makefile", 18 | } 19 | } 20 | -------------------------------------------------------------------------------- /pretty/.vscode/settings.json: -------------------------------------------------------------------------------- 1 | { 2 | "search.exclude": { 3 | "*.aux": true, 4 | "*.glob": true, 5 | "*.d": true, 6 | "*.vo": true, 7 | "*.vos": true, 8 | "*.vok": true, 9 | "*.generated": true, 10 | "*.generated.conf": true, 11 | }, 12 | "files.trimTrailingWhitespace": true, 13 | "files.insertFinalNewline": true, 14 | "editor.tabSize": 2, 15 | "editor.detectIndentation": false, 16 | "files.associations": { 17 | "*.Makefile": "makefile", 18 | } 19 | } 20 | -------------------------------------------------------------------------------- /tuto/.vscode/settings.json: -------------------------------------------------------------------------------- 1 | { 2 | "search.exclude": { 3 | "*.aux": true, 4 | "*.glob": true, 5 | "*.d": true, 6 | "*.vo": true, 7 | "*.vos": true, 8 | "*.vok": true, 9 | "*.generated": true, 10 | "*.generated.conf": true, 11 | }, 12 | "files.trimTrailingWhitespace": true, 13 | "files.insertFinalNewline": true, 14 | "editor.tabSize": 2, 15 | "editor.detectIndentation": false, 16 | "files.associations": { 17 | "*.Makefile": "makefile", 18 | } 19 | } 20 | -------------------------------------------------------------------------------- /tuto/Makefile: -------------------------------------------------------------------------------- 1 | ############################################################################ 2 | # Files 3 | 4 | VFILES=\ 5 | Classic.v 6 | 7 | ############################################################################ 8 | # Compilation using the Makefile generated by coq_makefile. 9 | 10 | # The desired warnings are set in _CoqProject. 11 | 12 | -include Makefile.generated 13 | 14 | Makefile.generated: 15 | @ $(COQBIN)coq_makefile $(VFILES) -o $@ 16 | 17 | ############################################################################ 18 | # Clean rules 19 | 20 | .PHONY: clean 21 | 22 | clean:: 23 | @ rm -f Makefile.generated Makefile.generated.conf 24 | @ rm -rf .lia.cache 25 | @ rm -rf *.v.d .*.aux 26 | -------------------------------------------------------------------------------- /pretty/Common.v: -------------------------------------------------------------------------------- 1 | (************************************************************ 2 | * Wrapper around the library TLC * 3 | *************************************************************) 4 | 5 | Set Implicit Arguments. 6 | From TLC Require Export LibTactics LibCore LibVar LibEnv. 7 | Generalizable Variables A B. 8 | 9 | (** Extension to [LibNat] *) 10 | 11 | Definition max (n m:nat) := 12 | If n < m then m else n. 13 | 14 | Lemma max_cases : forall n m, 15 | (n <= m /\ max n m = m) \/ 16 | (m <= n /\ max n m = n). 17 | Proof. 18 | intros. unfold max. case_if. 19 | left. math. 20 | right. math. 21 | Qed. 22 | 23 | (** Extension to [LibRelation *) 24 | 25 | CoInductive infclosure A (R:binary A) : A -> Prop := 26 | | infclosure_step : forall y x, 27 | R x y -> infclosure R y -> infclosure R x. 28 | -------------------------------------------------------------------------------- /omni/Makefile: -------------------------------------------------------------------------------- 1 | 2 | FILES :=\ 3 | LibSepVar \ 4 | LibSepFmap \ 5 | Syntax \ 6 | Hprop \ 7 | Small \ 8 | Big \ 9 | OmniSmall \ 10 | OmniBig \ 11 | EquivSmallBig \ 12 | EquivOmni \ 13 | SepLogicCommon \ 14 | SepLogicSmall \ 15 | SepLogicOmniBig \ 16 | SepLogicOmniSmall \ 17 | SepLogicWithGhostOmniBig 18 | 19 | VFILES=$(FILES:=.v) 20 | 21 | 22 | ############################################################################ 23 | # Compilation using the Makefile generated by coq_makefile. 24 | 25 | # The desired warnings are set in _CoqProject. 26 | 27 | -include Makefile.generated 28 | 29 | Makefile.generated: 30 | @ $(COQBIN)coq_makefile -f _CoqProject $(VFILES) -o $@ 31 | 32 | 33 | ############################################################################ 34 | # Clean rules 35 | 36 | .PHONY: clean 37 | 38 | clean:: 39 | @ rm -f Makefile.generated Makefile.generated.conf 40 | @ rm -rf .lia.cache 41 | @ rm -rf *.v.d .*.aux 42 | 43 | 44 | -------------------------------------------------------------------------------- /pretty/Lambda_Syntax.v: -------------------------------------------------------------------------------- 1 | (************************************************************ 2 | * Lambda-calculus, * 3 | * Syntax * 4 | *************************************************************) 5 | 6 | Set Implicit Arguments. 7 | Require Export Common. 8 | 9 | 10 | (*==========================================================*) 11 | (* * Definitions *) 12 | 13 | (************************************************************) 14 | (* ** Syntax of the language *) 15 | 16 | Inductive val : Type := 17 | | val_int : int -> val 18 | | val_clo : var -> trm -> val 19 | 20 | with trm : Type := 21 | | trm_val : val -> trm 22 | | trm_var : var -> trm 23 | | trm_abs : var -> trm -> trm 24 | | trm_app : trm -> trm -> trm. 25 | 26 | Coercion trm_val : val >-> trm. 27 | 28 | 29 | (************************************************************) 30 | (* ** Definition of substitution *) 31 | 32 | Fixpoint subst (x:var) (v:val) (t:trm) : trm := 33 | let s := subst x v in 34 | match t with 35 | | trm_val v => t 36 | | trm_var y => If x = y then trm_val v else t 37 | | trm_abs y t3 => trm_abs y (If x = y then t3 else s t3) 38 | | trm_app t1 t2 => trm_app (s t1) (s t2) 39 | end. 40 | 41 | -------------------------------------------------------------------------------- /pretty/LambdaRef_Syntax.v: -------------------------------------------------------------------------------- 1 | (************************************************************ 2 | * Lambda-calculus with references * 3 | * Syntax * 4 | *************************************************************) 5 | 6 | Set Implicit Arguments. 7 | Require Export Common LibHeap. 8 | Notation "x ~~ a" := (single x a) 9 | (at level 27, left associativity) : env_scope. 10 | 11 | 12 | (************************************************************) 13 | (* * Definition of the language *) 14 | 15 | (** Representation of locations *) 16 | 17 | Definition loc := nat. 18 | 19 | (** Grammar of values and terms *) 20 | 21 | Inductive val : Type := 22 | | val_int : int -> val 23 | | val_clo : env val -> var -> trm -> val 24 | | val_loc : loc -> val 25 | 26 | with trm : Type := 27 | | trm_val : val -> trm 28 | | trm_var : var -> trm 29 | | trm_abs : var -> trm -> trm 30 | | trm_app : trm -> trm -> trm 31 | | trm_new : trm -> trm 32 | | trm_get : trm -> trm 33 | | trm_set : trm -> trm -> trm. 34 | 35 | Coercion trm_val : val >-> trm. 36 | 37 | (** Contexts (executable) *) 38 | 39 | Definition ctx := env val. 40 | 41 | (** Memory store (executable) *) 42 | 43 | Definition mem := Heap.heap loc val. 44 | 45 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT X11 LICENSE 2 | --------------- 3 | 4 | Copyright (c) 2020 Arthur Charguéraud 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining a copy 7 | of this software and associated documentation files (the "Software"), to deal 8 | in the Software without restriction, including without limitation the rights 9 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | copies of the Software, and to permit persons to whom the Software is 11 | furnished to do so, subject to the following conditions: 12 | 13 | The above copyright notice and this permission notice shall be included in all 14 | copies or substantial portions of the Software. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 19 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 21 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 22 | SOFTWARE. 23 | 24 | Except as contained in this notice, the name of the copyright holders shall not 25 | be used in advertising or otherwise to promote the sale, use or other dealings 26 | in this Software without prior written authorization from the copyright holders. 27 | -------------------------------------------------------------------------------- /tuto/README.md: -------------------------------------------------------------------------------- 1 | # Tutorials on Coq 2 | 3 | See the README.md file in the parent directory for installation instructions 4 | and link to the research papers. 5 | 6 | 7 | Classical Logic 8 | ------------------- 9 | 10 | Coq is originally based on a constructive logic. 11 | Following the tradition, many users refuse to depend on classical axioms. 12 | 13 | For certain mathematical proofs, e.g. in fundational geometry, being able 14 | to precisely investigate the set of axioms that each result depends upon 15 | is great. 16 | 17 | For many other practical applications, however, there are mostly benefits 18 | to using the classical axioms, which users of other proof assistants such 19 | as HOL or Isabelle/HOL have been happily using for decades. 20 | 21 | The main benefits of classical logic are: 22 | 23 | - to avoid the need for dependently-typed programming, in particular for 24 | defining partial recursive functions; 25 | - to allow for simpler statements of many definitions and equivalences; 26 | - to allow proofs that simply wouldn't be possible outside of classical 27 | logic, e.g. to justify that the big-step characterization of divergence 28 | is equivalent to the small-step characterization of divergence; 29 | besides, for reasoning about real numbers, classical results appear to 30 | be a must-have. 31 | 32 | 33 | 34 | The file `Classic.v` gives a tour of the classical axioms and their 35 | practical applications. 36 | -------------------------------------------------------------------------------- /ln/README.md: -------------------------------------------------------------------------------- 1 | # Arthur Charguéraud's Archive of Locally Nameless Developments 2 | 3 | See the README.md file in the parent directory for installation instructions 4 | and link to the research papers. 5 | 6 | 7 | Type soundness proofs 8 | ------------------- 9 | 10 | The folder contains a number of type soundness proofs: 11 | 12 | - `STLC_Core`: simply typed lambda-calculus (STLC) 13 | - `STLC_Ref`: STLC plus references and nondeterminism 14 | - `STLC_Exn`: STLC plus exceptions 15 | - `Fsub`: System-F with subtyping (POPLMark challenge) 16 | - `CoC`: Calculus of constructions (dependent types) 17 | - `ML`: ML types with references and exceptions and pattern matching 18 | 19 | All the proofs are based the standart "preservation and progress" small-step approach, 20 | except the files `STLC_Ref_Soundness_OmniBig.v` and `STLC_Ref_Soundness_OmniSmall.v` and `Fsub_Soundness_OmniSmall.v`, 21 | which are based on novel techniques described in the Omni-Semantics paper (TOPLAS'23). 22 | http://www.chargueraud.org/research/2022/omnisemantics/omnisemantics.pdf 23 | 24 | 25 | Other results on semantics 26 | ------------------- 27 | 28 | - `ISK_Confluence`: confluence of the minimalistic ISK system 29 | - `CoC_ChurchRosser`: confluence of the calculus of constructions (dependent types) 30 | - `Lambda_ChurchRosser`: confluence of the pure lambda-calculus 31 | - `BigStep_Equivalence`: equivalence of big-step and small-step semantics 32 | - `CPS_Correctness`: correctness of the CPS translation 33 | 34 | Other files 35 | ------------------- 36 | 37 | - `Lambda_JAR_paper`: companion to the JAR'11 paper "The Locally Nameless Representation" 38 | 39 | -------------------------------------------------------------------------------- /pretty/Lambda_Typing.v: -------------------------------------------------------------------------------- 1 | (************************************************************ 2 | * Lambda-calculus, * 3 | * Simple typing * 4 | *************************************************************) 5 | 6 | Set Implicit Arguments. 7 | Require Import Lambda_Syntax. 8 | From TLC Require Import LibLN LibInt. 9 | 10 | Implicit Types v : val. 11 | Implicit Types t : trm. 12 | 13 | 14 | (*==========================================================*) 15 | (* * Definitions *) 16 | 17 | Notation "x ~~ a" := (single x a) 18 | (at level 27, left associativity) : env_scope. 19 | 20 | (************************************************************) 21 | (* ** Grammar of simple types *) 22 | 23 | CoInductive typ := 24 | | typ_int : typ 25 | | typ_arrow : typ -> typ -> typ. 26 | 27 | 28 | (************************************************************) 29 | (* ** Typing judgment *) 30 | 31 | Inductive typing : env typ -> trm -> typ -> Prop := 32 | | typing_int : forall E k, 33 | ok E -> 34 | typing E (val_int k) typ_int 35 | | typing_clo : forall E x T1 T2 t1, 36 | ok E -> 37 | typing (empty & x ~~ T1) t1 T2 -> 38 | typing E (val_clo x t1) (typ_arrow T1 T2) 39 | | typing_var : forall E x T, 40 | ok E -> 41 | binds x T E -> 42 | typing E (trm_var x) T 43 | | typing_abs : forall x E U T t1, 44 | typing (E & x ~~ U) t1 T -> 45 | typing E (trm_abs x t1) (typ_arrow U T) 46 | | typing_app : forall T1 T2 E t1 t2, 47 | typing E t1 (typ_arrow T1 T2) -> 48 | typing E t2 T1 -> 49 | typing E (trm_app t1 t2) T2. 50 | -------------------------------------------------------------------------------- /pretty/README.md: -------------------------------------------------------------------------------- 1 | # Arthur Charguéraud's Archive of Pretty-Big-Step Developments 2 | 3 | See the README.md file in the parent directory for installation instructions 4 | and link to the research papers. 5 | 6 | 7 | Contents 8 | ======== 9 | 10 | Languages formalized: 11 | 12 | - `Lambda`: lambda-calculus 13 | - `LambdaExn`: lambda-calculus with exceptions 14 | - `LambdaExnSum`: lambda-calculus with sum and case constructs 15 | - `CoreCaml`: a significant subset of Caml-light, not far from CakeML's language 16 | 17 | For each language, the syntax and the semantics are characterized as follows: 18 | 19 | - `_Syntax`: contains the syntax of the language 20 | - `_Err`: suffix indicated that the semantics includes error propagation rules 21 | - `_Interp`: contains a reference interpreter, i.e. a functional big-step semantics 22 | - `_Small`: contains a small-step semantics 23 | - `_Big`: contains a big-step semantics 24 | - `_Pretty`: contains a pretty-big-step semantics 25 | - `_Indexed`: a experimental variant of pretty-big-step where the evaluation judgment is indexed with a natural number 26 | - `_Combi`: another variant of pretty-big-step where the `terminate` constructor of behavior is indexed with a natural number 27 | 28 | Moreover, several proofs are carried out with respect to pretty-big-style semantics: 29 | 30 | - `_Typing`: simple types for the lambda-calculus (STLC) 31 | - `_Sound`: type soundness proof for STLC 32 | - `_EncodeExn`: source-to-source translation encoding exceptions into a monad 33 | - `_Interp_Correct`: proof of correctness and completeness of an interpreter 34 | 35 | Other files: 36 | 37 | - `Common`: a few common definitions 38 | - `LibHeap`: a formalization of the mutable store, used by `LambdaRef` and `CoreCaml` 39 | -------------------------------------------------------------------------------- /pretty/Makefile: -------------------------------------------------------------------------------- 1 | 2 | DEV_LAMBDA :=\ 3 | Lambda_Syntax \ 4 | Lambda_Big \ 5 | Lambda_Pretty \ 6 | Lambda_Combi \ 7 | Lambda_Indexed \ 8 | Lambda_PrettyErr \ 9 | Lambda_CombiErr \ 10 | Lambda_Typing \ 11 | Lambda_PrettyErr_Typing_Sound \ 12 | Lambda_CombiErr_Typing_Sound 13 | 14 | DEV_LAMBDAREF :=\ 15 | LambdaRef_Syntax \ 16 | LambdaRef_Pretty_Interp \ 17 | 18 | DEV_LAMBDAEXN :=\ 19 | LambdaExn_Syntax \ 20 | LambdaExn_Big \ 21 | LambdaExn_Pretty \ 22 | LambdaExn_Combi 23 | 24 | DEV_LAMBDAEXNERR :=\ 25 | LambdaExn_Interp \ 26 | LambdaExn_CombiErr \ 27 | LambdaExn_BigErr \ 28 | LambdaExn_PrettyErr \ 29 | LambdaExn_PrettyErr_Typing_Sound \ 30 | LambdaExn_Interp_CombiErr_Correct \ 31 | LambdaExn_Interp_BigErr_Correct 32 | 33 | DEV_CORECAML :=\ 34 | CoreCaml_Syntax \ 35 | CoreCaml_Pretty \ 36 | CoreCaml_Small \ 37 | CoreCaml_Big 38 | 39 | DEV_LAMBDAEXNSUM :=\ 40 | LambdaExnSum_Syntax \ 41 | LambdaExnSum_Pretty \ 42 | LambdaExnSum_Combi \ 43 | LambdaExnSum_Small \ 44 | LambdaExnSum_Big \ 45 | LambdaExnSum_EncodeExn \ 46 | LambdaExnSum_EncodeExn_Big_Correct 47 | 48 | FILES :=\ 49 | Common \ 50 | LibHeap \ 51 | $(DEV_CORECAML) \ 52 | $(DEV_COMMAND) \ 53 | $(DEV_LAMBDAEXNSUM) \ 54 | $(DEV_LAMBDAEXNERR) \ 55 | $(DEV_LAMBDAEXN) \ 56 | $(DEV_LAMBDA) \ 57 | $(DEV_LAMBDAREF) 58 | 59 | VFILES=$(FILES:=.v) 60 | 61 | 62 | ############################################################################ 63 | # Compilation using the Makefile generated by coq_makefile. 64 | 65 | # The desired warnings are set in _CoqProject. 66 | 67 | -include Makefile.generated 68 | 69 | Makefile.generated: 70 | @ $(COQBIN)coq_makefile -f _CoqProject $(VFILES) -o $@ 71 | 72 | 73 | ############################################################################ 74 | # Clean rules 75 | 76 | .PHONY: clean 77 | 78 | clean:: 79 | @ rm -f Makefile.generated Makefile.generated.conf 80 | @ rm -rf .lia.cache 81 | @ rm -rf *.v.d .*.aux 82 | 83 | -------------------------------------------------------------------------------- /pretty/LambdaExn_Interp.v: -------------------------------------------------------------------------------- 1 | (************************************************************ 2 | * Lambda-calculus with exceptions * 3 | * Definition of an interpreter * 4 | *************************************************************) 5 | 6 | Set Implicit Arguments. 7 | Require Export LambdaExn_Syntax. 8 | Import AssumeDeterministic. 9 | Import BehaviorsWithErrors. 10 | 11 | Implicit Types v : val. 12 | Implicit Types t : trm. 13 | Implicit Types b : beh. 14 | 15 | 16 | (*==========================================================*) 17 | (* * Definitions *) 18 | 19 | (************************************************************) 20 | (* ** Results *) 21 | 22 | (** Grammar of results of the interpreter *) 23 | 24 | Inductive res := 25 | | res_return : beh -> res 26 | | res_bottom : res. 27 | 28 | Coercion res_return : beh >-> res. 29 | Implicit Types r : res. 30 | 31 | 32 | (************************************************************) 33 | (* ** Monadic operators *) 34 | 35 | (** Bind-style operators *) 36 | 37 | Definition if_success (r:res) (k:val->res) : res := 38 | match r with 39 | | res_return (beh_ret v) => k v 40 | | _ => r 41 | end. 42 | 43 | Definition if_fault (r:res) (k:val->res) : res := 44 | match r with 45 | | res_return (beh_exn v) => k v 46 | | _ => r 47 | end. 48 | 49 | Definition if_isclo (v:val) (k:var->trm->res) : res := 50 | match v with 51 | | val_clo x t => k x t 52 | | _ => beh_err 53 | end. 54 | 55 | 56 | (************************************************************) 57 | (* ** Interpreter *) 58 | 59 | (** Definition of the interpreter *) 60 | 61 | Fixpoint run (n:nat) (t:trm) : res := 62 | match n with 63 | | O => res_bottom 64 | | S m => 65 | match t with 66 | | trm_val v => v 67 | | trm_abs x t1 => val_clo x t1 68 | | trm_var x => beh_err 69 | | trm_app t1 t2 => 70 | if_success (run m t1) (fun v1 => 71 | if_success (run m t2) (fun v2 => 72 | if_isclo v1 (fun x t3 => 73 | run m (subst x v2 t3)))) 74 | | trm_try t1 t2 => 75 | if_fault (run m t1) (fun v => run m (trm_app t2 v)) 76 | | trm_raise t1 => 77 | if_success (run m t1) (fun v1 => beh_exn v1) 78 | | trm_rand => val_int 0 79 | end 80 | end. 81 | 82 | 83 | -------------------------------------------------------------------------------- /ln/STLC_Core_Soundness.v: -------------------------------------------------------------------------------- 1 | (*************************************************************************** 2 | * Safety for Simply Typed Lambda Calculus (CBV) - Proofs * 3 | * Brian Aydemir & Arthur Chargueraud, July 2007 * 4 | ***************************************************************************) 5 | 6 | Set Implicit Arguments. 7 | From TLC Require Import LibLN. 8 | Require Import 9 | STLC_Core_Definitions 10 | STLC_Core_Infrastructure. 11 | 12 | 13 | (* ********************************************************************** *) 14 | (** * Proofs *) 15 | 16 | (** Typing is preserved by weakening. *) 17 | 18 | Require Import Coq.Program.Equality. 19 | 20 | Lemma typing_weaken : forall G E F t T, 21 | (E & G) |= t ~: T -> 22 | ok (E & F & G) -> 23 | (E & F & G) |= t ~: T. 24 | Proof. 25 | introv Typ. inductions Typ; introv Ok. 26 | apply* typing_var. apply* binds_weaken. 27 | apply_fresh* typing_abs. apply_ih_bind* H0. 28 | apply* typing_app. 29 | Qed. 30 | 31 | (** Typing is preserved by substitution. *) 32 | 33 | Lemma typing_subst : forall F U E t T z u, 34 | (E & z ~ U & F) |= t ~: T -> 35 | E |= u ~: U -> 36 | (E & F) |= [z ~> u]t ~: T. 37 | Proof. 38 | introv Typt Typu. inductions Typt; introv; simpl. 39 | case_var. 40 | binds_mid~. apply_empty* typing_weaken. 41 | apply~ typing_var. apply* binds_subst. 42 | apply_fresh typing_abs. 43 | rewrite* subst_open_var. 44 | apply_ih_bind* H0. 45 | apply* typing_app. 46 | Qed. 47 | 48 | (** Preservation (typing is preserved by reduction). *) 49 | 50 | Lemma preservation_result : preservation. 51 | Proof. 52 | introv Typ. gen t'. inductions Typ; introv Red; inversions Red. 53 | inversions Typ1. pick_fresh x. rewrite* (@subst_intro x). 54 | apply_empty* typing_subst. 55 | apply* typing_app. 56 | apply* typing_app. 57 | Qed. 58 | 59 | (** Progress (a well-typed term is either a value or it can 60 | take a step of reduction). *) 61 | 62 | Lemma progress_result : progress. 63 | Proof. 64 | introv Typ. lets Typ': Typ. inductions Typ. 65 | false* binds_empty_inv. 66 | left*. 67 | right. destruct~ IHTyp1 as [Val1 | [t1' Red1]]. 68 | destruct~ IHTyp2 as [Val2 | [t2' Red2]]. 69 | inversions Typ1; inversions Val1. exists* (t0 ^^ t2). 70 | exists* (trm_app t1 t2'). 71 | exists* (trm_app t1' t2). 72 | Qed. 73 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Arthur Charguéraud's Archive of Formal Metatheory in Coq 2 | 3 | This repository contains a collection of formalizations 4 | of programming language semantics and type soundness proofs. 5 | 6 | Feel free to use them as templates for your own developments. 7 | 8 | 9 | Contents 10 | ======== 11 | 12 | - The folder `ln` contains locally nameless developments. 13 | See the paper "The Locally Nameless Representation" (JAR'11). 14 | http://www.chargueraud.org/research/2009/ln/main.pdf 15 | 16 | The folder `ln` includes type soundness proofs, w.r.t. omni-big-step and omni-small-step semantics. 17 | See the Omni-Semantics paper (TOPLAS'23). 18 | http://www.chargueraud.org/research/2022/omnisemantics/omnisemantics.pdf 19 | 20 | - The folder `pretty` contains pretty-big-step developments. 21 | See the Pretty-Big-Step paper (ESOP'13). 22 | http://www.chargueraud.org/research/2012/pretty/pretty.pdf 23 | 24 | The folder `pretty` also contains type soundness proofs, w.r.t. pretty-big-step semantics 25 | 26 | - The folder `omni` formalizes omni-small-steps and omni-big-step semantics, 27 | and relate the to standard small-step and big-step semantics. 28 | See the Omni-Semantics paper (TOPLAS'23). 29 | http://www.chargueraud.org/research/2022/omnisemantics/omnisemantics.pdf 30 | 31 | - Folder `tuto` contains a tutorial on the use of classical logic in Coq. 32 | 33 | 34 | Compilation 35 | =========== 36 | 37 | The files compile with Coq v8.18. 38 | 39 | A tutorial on how to best configure Coq in VScode is available from: 40 | https://chargueraud.org/teach/verif/install/install.html 41 | 42 | The compilation of the files depends on the TLC library, available from `opam`. 43 | 44 | ``` 45 | opam install coq-tlc 46 | ``` 47 | 48 | Alternatively, TLC may be installed by hand. 49 | 50 | ``` 51 | git clone git@github.com:charguer/tlc.git 52 | make -j4 all && make install 53 | ``` 54 | 55 | To play the files interactively, enter one of the subfolders, compile 56 | the scripts, then edit them, e.g., in VScode: 57 | 58 | ``` 59 | cd ln 60 | make -j4 61 | code . & 62 | ``` 63 | 64 | 65 | 66 | License 67 | ======= 68 | 69 | All files are distributed under the MIT X11 license. See the LICENSE file. 70 | 71 | Authors 72 | ======= 73 | 74 | All files in this repository are authored by Arthur Charguéraud. 75 | 76 | -------------------------------------------------------------------------------- /ln/STLC_Core_FullBeta.v: -------------------------------------------------------------------------------- 1 | (*************************************************************************** 2 | * Safety for Simply Typed Lambda Calculus (CBV) - Full Beta Reduction * 3 | * Brian Aydemir & Arthur Chargueraud, July 2007 * 4 | ***************************************************************************) 5 | 6 | Set Implicit Arguments. 7 | From TLC Require Import LibLN. 8 | 9 | Require Import 10 | STLC_Core_Definitions 11 | STLC_Core_Infrastructure 12 | STLC_Core_Soundness. 13 | 14 | (* ********************************************************************** *) 15 | (** * Definitions *) 16 | 17 | (** Full beta reduction *) 18 | 19 | Inductive fullred : trm -> trm -> Prop := 20 | | fullred_red : forall t1 t2, 21 | body t1 -> 22 | term t2 -> 23 | fullred (trm_app (trm_abs t1) t2) (t1 ^^ t2) 24 | | fullred_app1 : forall t1 t1' t2, 25 | term t2 -> 26 | fullred t1 t1' -> 27 | fullred (trm_app t1 t2) (trm_app t1' t2) 28 | | fullred_app2 : forall t1 t2 t2', 29 | term t1 -> 30 | fullred t2 t2' -> 31 | fullred (trm_app t1 t2) (trm_app t1 t2') 32 | | fullred_abs : forall L t1 t1', 33 | (forall x, x \notin L -> fullred (t1 ^ x) (t1' ^ x)) -> 34 | fullred (trm_abs t1) (trm_abs t1'). 35 | 36 | Notation "t -->> t'" := (fullred t t') (at level 68). 37 | 38 | (* ********************************************************************** *) 39 | (** * Infrastructure *) 40 | 41 | Lemma fullred_regular : forall e e', 42 | fullred e e' -> term e /\ term e'. 43 | Proof. 44 | lets: value_regular. induction 1; jauto. 45 | split; apply_fresh term_abs as x; forwards*: (H1 x). 46 | Qed. 47 | 48 | Hint Extern 1 (term ?t) => 49 | match goal with 50 | | H: fullred t _ |- _ => apply (proj1 (fullred_regular H)) 51 | | H: fullred _ t |- _ => apply (proj2 (fullred_regular H)) 52 | end. 53 | 54 | Hint Constructors fullred. 55 | 56 | (* ********************************************************************** *) 57 | (** * Proofs *) 58 | 59 | Lemma preservation_for_full_reduction : forall E t t' T, 60 | E |= t ~: T -> 61 | t -->> t' -> 62 | E |= t' ~: T. 63 | Proof. 64 | introv Typ. gen t'. 65 | induction Typ; intros t' Red; inversions Red. 66 | apply_fresh* typing_abs as x. 67 | inversions Typ1. pick_fresh x. 68 | rewrite* (@subst_intro x). apply_empty* typing_subst. 69 | apply* typing_app. 70 | apply* typing_app. 71 | Qed. -------------------------------------------------------------------------------- /pretty/LambdaExn_Syntax.v: -------------------------------------------------------------------------------- 1 | (************************************************************ 2 | * Lambda-calculus with exceptions, * 3 | * Syntax * 4 | *************************************************************) 5 | 6 | Set Implicit Arguments. 7 | Require Export Common. 8 | 9 | (*==========================================================*) 10 | (* * Definitions *) 11 | 12 | (************************************************************) 13 | (* ** Syntax *) 14 | 15 | (** Grammar of values and terms *) 16 | 17 | Inductive val : Type := 18 | | val_int : int -> val 19 | | val_clo : var -> trm -> val 20 | | val_err : val 21 | 22 | with trm : Type := 23 | | trm_val : val -> trm 24 | | trm_var : var -> trm 25 | | trm_abs : var -> trm -> trm 26 | | trm_app : trm -> trm -> trm 27 | | trm_try : trm -> trm -> trm 28 | | trm_raise : trm -> trm 29 | | trm_rand : trm. 30 | 31 | Coercion trm_val : val >-> trm. 32 | 33 | (** Substitution *) 34 | 35 | Fixpoint subst (x:var) (v:val) (t:trm) : trm := 36 | let s := subst x v in 37 | match t with 38 | | trm_val v => t 39 | | trm_var y => If x = y then trm_val v else t 40 | | trm_abs y t3 => trm_abs y (If x = y then t3 else s t3) 41 | | trm_app t1 t2 => trm_app (s t1) (s t2) 42 | | trm_try t1 t2 => trm_try (s t1) (s t2) 43 | | trm_raise t1 => trm_raise (s t1) 44 | | trm_rand => t 45 | end. 46 | 47 | 48 | (************************************************************) 49 | (* ** Definition shared by the semantics *) 50 | 51 | (** If [ParamDeterministic], then [rand] always reduces to zero, 52 | otherwise it non-deterministically reduces to any number *) 53 | 54 | Parameter ParamDeterministic : Prop. 55 | 56 | (** Assuming a deterministic semantics *) 57 | 58 | Module AssumeDeterministic. 59 | Parameter Deterministic : ParamDeterministic = True. 60 | End AssumeDeterministic. 61 | 62 | 63 | (** Grammar of behaviors without errors *) 64 | 65 | Module BehaviorsWithoutErrors. 66 | 67 | Inductive beh := 68 | | beh_ret : val -> beh 69 | | beh_exn : val -> beh. 70 | 71 | Coercion beh_ret : val >-> beh. 72 | 73 | End BehaviorsWithoutErrors. 74 | 75 | 76 | (** Grammar of behaviors, including errors *) 77 | 78 | Module BehaviorsWithErrors. 79 | 80 | Inductive beh := 81 | | beh_ret : val -> beh 82 | | beh_exn : val -> beh 83 | | beh_err : beh. 84 | 85 | Coercion beh_ret : val >-> beh. 86 | 87 | End BehaviorsWithErrors. 88 | 89 | -------------------------------------------------------------------------------- /omni/README.md: -------------------------------------------------------------------------------- 1 | # Arthur Charguéraud's Archive of Omni-Semantics Developments 2 | 3 | See the README.md file in the parent directory for installation instructions. 4 | 5 | This folder contains formal developments around the omni-big-step and 6 | omni-small-step semantics. These semantics are described in the TOPLAS'23 paper: 7 | http://www.chargueraud.org/research/2022/omnisemantics/omnisemantics.pdf 8 | 9 | The construction of type soundness proofs using omni-big-step and omni-small-step 10 | semantics are described in the files `STLC_Ref_Soundness_OmniBig.v` and 11 | `STLC_Ref_Soundness_OmniSmall.v` from the folder `../ln` of the present 12 | repository. 13 | 14 | The construction of a Separation Logic on top of an omni-big-step semantics 15 | in described in the course "Separation Logic Foundations", Volume 6 of the 16 | "Software Foundations" series. It is not reproduced here, only the proof 17 | of the consequence and frame properties are established. 18 | 19 | The files in the present folder contain proofs of the properties of the 20 | omni-small and omni-big judgments, and proofs of equivalence with standard 21 | small-step and big-step semantics. The developments are presented on a 22 | standard, nondeterministic, imperative lambda-calculus. 23 | 24 | 25 | Contents 26 | ======== 27 | 28 | Semantics formalized: 29 | 30 | - `Syntax`: syntax of a nondeterministic, imperative lambda calculus, and of the entailment judgment 31 | - `Small`: standard small-step semantics 32 | - `Big`: standard big-step semantics 33 | - `OmniSmall`: omni-small-step semantics, and eventually and divergence judgment, 34 | their properties, and equivalence with small-step semantics. 35 | - `OmniBig`: omni-big-step semantics, inductive and coinductive, 36 | their properties, and equivalence with big-step semantics. 37 | - `EquivSmallBig`: equivalence between standard small-step and standard big-step semantics 38 | - `EquivOmni`: equivalence of omni-semantics and standard semantics 39 | 40 | Formalization of a core Separation Logic: 41 | - `SepLogicCommon`: heap predicates and entailment 42 | - `SepLogicSmall`: separation logic built on top of standard small-step semantics 43 | - `SepLogicOmniBig`: separation logic built on top of omni-big-step semantics 44 | - `SepLogicOmniSmall`: separation logic built on top of omni-small-step semantics 45 | - `SepLogicWithGhostOmniBig`: (work in progress) on the formalization of ghost state 46 | 47 | Other files: 48 | 49 | - `LibSepFmap`: a formalisation of finite maps, used to represent the mutable store. 50 | 51 | -------------------------------------------------------------------------------- /ln/STLC_Ref_Soundness_Common.v: -------------------------------------------------------------------------------- 1 | (*************************************************************************** 2 | * Safety for STLC with References - Common Parts of Type Soundness Proofs * 3 | * Arthur Chargueraud, Dec 2023 * 4 | ***************************************************************************) 5 | 6 | Set Implicit Arguments. 7 | Require Export STLC_Ref_Definitions STLC_Ref_Infrastructure. 8 | 9 | Hint Constructors typing. 10 | 11 | (** Typing is preserved by weakening. *) 12 | 13 | Lemma typing_weaken : forall G E F Y t T, 14 | (E & G) ! Y |= t ~: T -> 15 | ok (E & F & G) -> 16 | (E & F & G) ! Y |= t ~: T. 17 | Proof. 18 | introv Typ. gen_eq H: (E & G). gen G. 19 | induction Typ; introv EQ Ok; subst. 20 | apply* typing_var. apply* binds_weaken. 21 | apply_fresh* typing_abs as y. apply_ih_bind* H0. 22 | autos*. 23 | autos*. 24 | autos*. 25 | autos*. 26 | autos*. 27 | autos*. 28 | autos*. 29 | autos*. 30 | Qed. 31 | 32 | (** Typing is preserved by substitution. *) 33 | 34 | Lemma typing_subst : forall F E Y t T z u U, 35 | (E & z ~ U & F) ! Y |= t ~: T -> 36 | E ! Y |= u ~: U -> 37 | (E & F) ! Y |= [z ~> u]t ~: T. 38 | Proof. 39 | introv Typt Typu. gen_eq G: (E & z ~ U & F). gen F. 40 | induction Typt; introv Equ; subst; simpl subst. 41 | case_var. 42 | binds_get H0. apply_empty* typing_weaken. 43 | binds_cases H0; apply* typing_var. 44 | apply_fresh typing_abs as y. 45 | rewrite* subst_open_var. apply_ih_bind* H0. 46 | autos*. 47 | autos*. 48 | autos*. 49 | autos*. 50 | autos*. 51 | autos*. 52 | autos*. 53 | autos*. 54 | Qed. 55 | 56 | (** Typing is preserved by an extension of store typing. *) 57 | 58 | Lemma typing_stability : forall Y E Y' t T, 59 | E ! Y |= t ~: T -> 60 | extends Y Y' -> 61 | E ! Y' |= t ~: T. 62 | Proof. 63 | introv Typ Ext. induction* Typ. 64 | Qed. 65 | 66 | Hint Resolve typing_stability. 67 | 68 | (** Store typing preserved by allocation of a well-typed term. *) 69 | 70 | Lemma sto_typing_push : forall Y mu l t T, 71 | Y |== mu -> 72 | value t -> 73 | empty ! Y |= t ~: T -> 74 | l # mu -> l # Y -> 75 | (Y & l ~ T) |== (mu & l ~ t). 76 | Proof. 77 | unfold sto_typing. introv (StoOk&Dom&Ext). splits 3. 78 | auto. 79 | intros l0 Fr. simpl_dom. lets: (Dom l0). 80 | asserts* Fr2: (l <> l0). asserts* Fr3: (l0 # Y). auto. 81 | intros l' T' Has. binds_cases Has. 82 | destruct (Ext _ _ B) as (t'&Hast'&Typt'). 83 | exists* t'. 84 | subst. exists* t. 85 | Qed. 86 | -------------------------------------------------------------------------------- /pretty/Lambda_Big.v: -------------------------------------------------------------------------------- 1 | (************************************************************ 2 | * Lambda-calculus, * 3 | * Big-step semantics * 4 | *************************************************************) 5 | 6 | Set Implicit Arguments. 7 | Require Export Lambda_Syntax. 8 | 9 | Implicit Types v : val. 10 | Implicit Types t : trm. 11 | 12 | 13 | (*==========================================================*) 14 | (* * Definitions *) 15 | 16 | (************************************************************) 17 | (* ** Semantics *) 18 | 19 | Inductive bigred : trm -> val -> Prop := 20 | | bigred_val : forall v, 21 | bigred v v 22 | | bigred_abs : forall x t, 23 | bigred (trm_abs x t) (val_clo x t) 24 | | bigred_app : forall t1 t2 x t3 v2 v, 25 | bigred t1 (val_clo x t3) -> 26 | bigred t2 v2 -> 27 | bigred (subst x v2 t3) v -> 28 | bigred (trm_app t1 t2) v. 29 | 30 | CoInductive bigdiv : trm -> Prop := 31 | | bigdiv_app_1 : forall t1 t2, 32 | bigdiv t1 -> 33 | bigdiv (trm_app t1 t2) 34 | | bigdiv_app_2 : forall t1 v1 t2, 35 | bigred t1 v1 -> 36 | bigdiv t2 -> 37 | bigdiv (trm_app t1 t2) 38 | | bigdiv_app_3 : forall t1 t2 x t3 v2, 39 | bigred t1 (val_clo x t3) -> 40 | bigred t2 v2 -> 41 | bigdiv (subst x v2 t3) -> 42 | bigdiv (trm_app t1 t2) . 43 | 44 | 45 | (*==========================================================*) 46 | (* * Proofs *) 47 | 48 | (************************************************************) 49 | (* ** Induction principle on the height of a derivation *) 50 | 51 | (** Ideally, would be automatically generated by Coq *) 52 | 53 | Section BigredInd. 54 | 55 | Inductive bigredh : nat -> trm -> val -> Prop := 56 | | bigredh_val : forall n v, 57 | bigredh (S n) v v 58 | | bigredh_abs : forall n x t, 59 | bigredh (S n) (trm_abs x t) (val_clo x t) 60 | | bigredh_app : forall n t1 t2 x t3 v2 v, 61 | bigredh n t1 (val_clo x t3) -> 62 | bigredh n t2 v2 -> 63 | bigredh n (subst x v2 t3) v -> 64 | bigredh (S n) (trm_app t1 t2) v. 65 | 66 | Hint Constructors bigred bigredh. 67 | Hint Extern 1 (_ < _) => math. 68 | 69 | Lemma bigredh_lt : forall n n' t v, 70 | bigredh n t v -> n < n' -> bigredh n' t v. 71 | Proof. 72 | introv H. gen n'. induction H; introv L; 73 | (destruct n' as [|n']; [ false; math | autos* ]). 74 | Qed. 75 | 76 | Lemma bigred_bigredh : forall t v, 77 | bigred t v -> exists n, bigredh n t v. 78 | Proof. hint bigredh_lt. introv H. induction H; try induct_height. Qed. 79 | 80 | End BigredInd. 81 | 82 | -------------------------------------------------------------------------------- /ln/Makefile: -------------------------------------------------------------------------------- 1 | 2 | 3 | ############################################################################ 4 | # STABLE DEVELOPMENTS 5 | 6 | CORE :=\ 7 | STLC_Core_Definitions \ 8 | STLC_Core_Infrastructure \ 9 | STLC_Core_Soundness \ 10 | STLC_Core_Safety \ 11 | STLC_Core_Adequacy \ 12 | STLC_Core_FullBeta \ 13 | STLC_Core_Light \ 14 | STLC_Core_Tutorial 15 | BIG :=\ 16 | BigStep_Definitions \ 17 | BigStep_Infrastructure \ 18 | BigStep_Equivalence 19 | FSUB :=\ 20 | Fsub_Definitions \ 21 | Fsub_Infrastructure \ 22 | Fsub_Soundness \ 23 | Fsub_Soundness_OmniSmall 24 | COC :=\ 25 | CoC_Definitions \ 26 | CoC_Infrastructure \ 27 | CoC_BetaStar \ 28 | CoC_ChurchRosser \ 29 | CoC_Conversion \ 30 | CoC_Preservation 31 | ML :=\ 32 | ML_Definitions \ 33 | ML_Infrastructure \ 34 | ML_Soundness 35 | EXN :=\ 36 | STLC_Exn_Definitions \ 37 | STLC_Exn_Infrastructure \ 38 | STLC_Exn_Soundness 39 | REF :=\ 40 | STLC_Ref_Definitions \ 41 | STLC_Ref_Infrastructure \ 42 | STLC_Ref_Soundness_Common \ 43 | STLC_Ref_Soundness_Small \ 44 | STLC_Ref_Soundness_OmniSmall \ 45 | STLC_Ref_Soundness_OmniBig 46 | CPS :=\ 47 | CPS_Definitions \ 48 | CPS_Infrastructure \ 49 | CPS_Correctness 50 | LAMBDA :=\ 51 | Lambda_Definitions \ 52 | Lambda_Infrastructure \ 53 | Lambda_ChurchRosser 54 | JAR :=\ 55 | Lambda_JAR_paper 56 | ISK :=\ 57 | ISK_Confluence 58 | 59 | BASEFILES := $(CORE) $(BIG) $(EXN) $(REF) $(CPS) $(ISK) $(LAMBDA) $(COC) $(ML) $(FSUB) $(JAR) 60 | 61 | VFILES=$(BASEFILES:=.v) 62 | 63 | 64 | ############################################################################ 65 | # Compilation using the Makefile generated by coq_makefile. 66 | 67 | # The desired warnings are set in _CoqProject. 68 | 69 | -include Makefile.generated 70 | 71 | Makefile.generated: 72 | @ $(COQBIN)coq_makefile -f _CoqProject $(VFILES) -o $@ 73 | 74 | 75 | ############################################################################ 76 | # Clean rules 77 | 78 | .PHONY: clean 79 | 80 | clean:: 81 | @ rm -f Makefile.generated Makefile.generated.conf 82 | @ rm -rf .lia.cache 83 | @ rm -rf *.v.d .*.aux 84 | 85 | 86 | ############################################################## 87 | # Other goals 88 | 89 | core: $(CORE:=.vok) 90 | big: $(BIG:=.vok) 91 | mut: $(MUT:=.vok) 92 | fsub: $(FSUB:=.vok) 93 | coc: $(COC:=.vok) 94 | ml: $(ML:=.vok) 95 | exn: $(EXN:=.vok) 96 | ref: $(REF:=.vok) 97 | corewf: $(COREWF:=.vok) 98 | data: $(DATA:=.vok) 99 | cps: $(CPS:=.vok) 100 | isk: $(ISK:=.vok) 101 | pat: $(PAT:=.vok) 102 | patopen: $(PATOPEN:=.vok) 103 | lambda: $(LAMBDA:=.vok) 104 | mlcore: $(MLCORE:=.vok) 105 | 106 | -------------------------------------------------------------------------------- /omni/Hprop.v: -------------------------------------------------------------------------------- 1 | (**************************************************************** 2 | * Imperative Lambda-calculus * 3 | * Heap predicates * 4 | ****************************************************************) 5 | 6 | Set Implicit Arguments. 7 | Require Export Syntax. 8 | 9 | 10 | (* ########################################################### *) 11 | (* ########################################################### *) 12 | (* ########################################################### *) 13 | (** * Heap Predicates and Entailment *) 14 | 15 | (* ########################################################### *) 16 | (** ** Heap Predicates *) 17 | 18 | Declare Scope heap_scope. 19 | Open Scope heap_scope. 20 | 21 | (** Heap is a synonymous for state *) 22 | 23 | Definition heap : Type := state. 24 | 25 | (** Heap predicate *) 26 | 27 | Definition hprop := state -> Prop. 28 | 29 | Implicit Types H : hprop. 30 | Implicit Types Q : val->hprop. 31 | 32 | 33 | (* ########################################################### *) 34 | (** ** Entailment *) 35 | 36 | (** Heap entailment *) 37 | 38 | Definition himpl (H1 H2:hprop) : Prop := 39 | forall h, H1 h -> H2 h. 40 | 41 | Notation "H1 ==> H2" := (himpl H1 H2) 42 | (at level 55) : heap_scope. 43 | 44 | (** Properties *) 45 | 46 | Lemma himpl_refl : forall H, 47 | H ==> H. 48 | Proof using. introv M. auto. Qed. 49 | 50 | Hint Resolve himpl_refl. 51 | 52 | Lemma himpl_trans : forall H2 H1 H3, 53 | (H1 ==> H2) -> 54 | (H2 ==> H3) -> 55 | (H1 ==> H3). 56 | Proof using. introv M1 M2. unfolds* himpl. Qed. 57 | 58 | Lemma himpl_antisym : forall H1 H2, 59 | (H1 ==> H2) -> 60 | (H2 ==> H1) -> 61 | (H1 = H2). 62 | Proof. introv M1 M2. applys pred_ext_1. intros h. iff*. Qed. 63 | 64 | #[global] Hint Resolve himpl_refl. 65 | 66 | 67 | (* ########################################################### *) 68 | (** ** Entailment on Postconditions *) 69 | 70 | (** Entailment on postconditions *) 71 | 72 | Definition qimpl A (Q1 Q2:A->hprop) := 73 | forall x, himpl (Q1 x) (Q2 x). 74 | 75 | Notation "Q1 ===> Q2" := (qimpl Q1 Q2) 76 | (at level 55) : heap_scope. 77 | 78 | (** Properties *) 79 | 80 | Lemma qimpl_refl : forall A (Q:A->hprop), 81 | Q ===> Q. 82 | Proof using. intros. unfolds*. Qed. 83 | 84 | Lemma qimpl_trans : forall A (Q1 Q2 Q3:A->hprop), 85 | (Q1 ===> Q2) -> 86 | (Q2 ===> Q3) -> 87 | (Q1 ===> Q3). 88 | Proof using. introv M1 M2. intros v. eapply himpl_trans; eauto. Qed. 89 | 90 | #[global] Hint Resolve qimpl_refl. 91 | 92 | 93 | (* ########################################################### *) 94 | (** ** The Always-True and Always-False Postconditions *) 95 | 96 | (** Let [Any] denotes the postcondition that accepts any result. *) 97 | 98 | Definition Any : val->state->Prop := 99 | fun v s => True. 100 | 101 | Hint Unfold Any. 102 | 103 | (** Let [Empty] denotes the postcondition that rejects any result. *) 104 | 105 | Definition Empty : val->state->Prop := 106 | fun v s => False. 107 | 108 | Hint Unfold Empty. 109 | -------------------------------------------------------------------------------- /pretty/Lambda_CombiErr_Typing_Sound.v: -------------------------------------------------------------------------------- 1 | (************************************************************ 2 | * Lambda-calculus, * 3 | * Type soundness proof * 4 | * using combined pretty-big-step semantics with error rules * 5 | *************************************************************) 6 | 7 | Set Implicit Arguments. 8 | Require Import Lambda_CombiErr Lambda_Typing. 9 | From TLC Require Import LibLN LibInt. 10 | 11 | Implicit Types v : val. 12 | Implicit Types t : trm. 13 | 14 | 15 | (*==========================================================*) 16 | (* * Proofs *) 17 | 18 | (************************************************************) 19 | (* ** Proof of type soundness *) 20 | 21 | (** Hints *) 22 | 23 | Hint Constructors one typing. 24 | Hint Extern 1 (_ < _) => math. 25 | Hint Extern 1 (~ one _ -> exists _, _) => 26 | let H := fresh in intros H; false H. 27 | 28 | (** Regularity lemma *) 29 | 30 | Lemma typing_ok : forall E t T, 31 | typing E t T -> ok E. 32 | Proof. introv H. induction* H. Qed. 33 | 34 | (** Weakening for values *) 35 | 36 | Lemma typing_val_weaken : forall E v T, 37 | typing empty v T -> ok E -> typing E v T. 38 | Proof. introv H. inverts* H. Qed. 39 | 40 | (** Substitution lemma *) 41 | 42 | Lemma typing_subst : forall E x T U t v, 43 | typing empty v U -> 44 | typing (empty & single x U & E) t T -> 45 | typing E (subst x v t) T. 46 | Proof. 47 | introv Tv Tt. inductions Tt; simpl. 48 | constructors*. 49 | constructors*. 50 | cases_if. 51 | binds_cases H0. 52 | false* binds_empty_inv. 53 | subst. applys* typing_val_weaken. 54 | lets (?&?): (ok_middle_inv H). 55 | false~ (binds_fresh_inv B0). 56 | binds_cases H0. 57 | false* binds_empty_inv. 58 | constructors~. 59 | cases_if. 60 | false. lets: typing_ok Tt. 61 | rewrite <- concat_assoc in H. 62 | lets (?&M): (ok_middle_inv H). 63 | simpl_dom. notin_false. 64 | forwards*: IHTt. rewrite* concat_assoc. 65 | constructors*. 66 | Qed. 67 | 68 | (** Soundness lemma, by induction on the height 69 | of a derivation that ends up in an error *) 70 | 71 | Lemma soundness_ind : forall n t b T, 72 | cred t (out_ter n b) -> typing empty t T -> 73 | exists v, b = beh_ret v /\ typing empty v T. 74 | Proof. 75 | induction n using peano_induction. 76 | introv R M. inverts~ R as. 77 | exists* v. 78 | inverts* M. 79 | introv R1 R2 [L2 L1]. inverts L2. inverts L1. 80 | inverts M as M1 M2. 81 | forwards~ (v1&E1&V1): H R1 M1. inverts E1. 82 | inverts V1. inverts R2 as; auto. 83 | introv R2 R3 [L3 L2]. inverts L3. inverts L2. 84 | forwards* (v2&E2&V2): H R2. 85 | inverts E2. inverts~ R3 as. 86 | introv R3 L3. inverts L3. 87 | applys* H R3. apply_empty* typing_subst. 88 | introv N. false (rm N). destruct~ t. 89 | inverts M. false* binds_empty_inv. 90 | Qed. 91 | 92 | (** Soundness theorem: 93 | Well-typed terms don't end up in an error *) 94 | 95 | Lemma soundness : forall t T, 96 | typing empty t T -> ~ cstuck t. 97 | Proof. introv M (n&R). false soundness_ind R M. Qed. 98 | 99 | 100 | -------------------------------------------------------------------------------- /pretty/LambdaExnSum_Small.v: -------------------------------------------------------------------------------- 1 | (************************************************************ 2 | * Lambda-calculus with exceptions and sums, * 3 | * Small-step semantics * 4 | *************************************************************) 5 | 6 | Set Implicit Arguments. 7 | Require Export LambdaExnSum_Syntax. 8 | From TLC Require Import LibRelation. 9 | 10 | Implicit Types v : val. 11 | Implicit Types t : trm. 12 | 13 | 14 | (*==========================================================*) 15 | (* * Definitions *) 16 | 17 | (************************************************************) 18 | (* ** Reduction contexts *) 19 | 20 | (** Grammar of contexts *) 21 | 22 | Inductive ctx := 23 | | ctx_hole : ctx 24 | | ctx_app_1 : ctx -> trm -> ctx 25 | | ctx_app_2 : val -> ctx -> ctx 26 | | ctx_case : ctx -> trm -> trm -> ctx 27 | | ctx_inj : bool -> ctx -> ctx 28 | | ctx_try : ctx -> trm -> ctx 29 | | ctx_raise : ctx -> ctx. 30 | 31 | Implicit Types c : ctx. 32 | 33 | (** Application of contexts *) 34 | 35 | Fixpoint ctx_apply c t := 36 | let r c' := ctx_apply c' t in 37 | match c with 38 | | ctx_hole => t 39 | | ctx_app_1 c' t2 => trm_app (r c') t2 40 | | ctx_app_2 v1 c' => trm_app v1 (r c') 41 | | ctx_inj b c' => trm_inj b (r c') 42 | | ctx_case c' t1 t2 => trm_case (r c') t1 t2 43 | | ctx_try c' t2 => trm_try (r c') t2 44 | | ctx_raise c' => trm_raise (r c') 45 | end. 46 | 47 | Coercion ctx_apply : ctx >-> Funclass. 48 | 49 | (** Contexts that do not contain [try] construct *) 50 | 51 | Fixpoint ctx_notry c := 52 | let r := ctx_notry in 53 | match c with 54 | | ctx_hole => True 55 | | ctx_app_1 c' t2 => r c' 56 | | ctx_app_2 v1 c' => r c' 57 | | ctx_inj b c' => r c' 58 | | ctx_case c' t1 t2 => r c' 59 | | ctx_try c' t2 => False 60 | | ctx_raise c' => r c' 61 | end. 62 | 63 | 64 | (************************************************************) 65 | (* ** Semantics *) 66 | 67 | (** Reduction *) 68 | 69 | Inductive step : binary trm := 70 | | step_ctx : forall c t1 t2, 71 | step t1 t2 -> 72 | step (c t1) (c t2) 73 | | step_exn : forall c v, 74 | ctx_notry c -> 75 | step (c (trm_raise v)) (trm_raise v) 76 | | step_abs : forall x t, 77 | step (trm_abs x t) (val_abs x t) 78 | | step_beta : forall x t3 v2, 79 | step (trm_app (val_abs x t3) v2) (subst x v2 t3) 80 | | step_try_val : forall v1 t2, 81 | step (trm_try v1 t2) v1 82 | | step_try_exn : forall v t2, 83 | step (trm_try (trm_raise v) t2) (trm_app t2 v) 84 | | step_inj : forall b v1, 85 | step (trm_inj b v1) (val_inj b v1) 86 | | sred_case_true : forall t1 t2 t3 v1, 87 | step (trm_case (val_inj true v1) t2 t3) (trm_app t2 v1) 88 | | sred_case_false : forall t1 t2 t3 v1, 89 | step (trm_case (val_inj false v1) t2 t3) (trm_app t3 v1). 90 | 91 | (** Complete evaluation *) 92 | 93 | Definition sredstar t t' := (rtclosure step) t t'. 94 | 95 | Definition sredplus t t' := (tclosure step) t t'. 96 | 97 | Definition sredval t v := sredstar t v. 98 | 99 | Definition sdiverge t := (infclosure step) t. 100 | 101 | Notation "'stepstar'" := (rtclosure step). 102 | Notation "'stepplus'" := (tclosure step). 103 | 104 | -------------------------------------------------------------------------------- /ln/STLC_Exn_Soundness.v: -------------------------------------------------------------------------------- 1 | (*************************************************************************** 2 | * Safety for STLC with Exceptions - Proofs * 3 | * Arthur Chargueraud, July 2007 * 4 | ***************************************************************************) 5 | 6 | Set Implicit Arguments. 7 | From TLC Require Import LibLN. 8 | Require Import STLC_Exn_Definitions STLC_Exn_Infrastructure. 9 | 10 | (* ********************************************************************** *) 11 | (** * Proofs *) 12 | 13 | (** Typing is preserved by weakening. *) 14 | 15 | Lemma typing_weaken : forall G E F t T, 16 | (E & G) |= t ~: T -> 17 | ok (E & F & G) -> 18 | (E & F & G) |= t ~: T. 19 | Proof. 20 | introv Typ. gen_eq H: (E & G). gen G. 21 | induction Typ; introv EQ Ok; subst. 22 | apply* typing_var. apply* binds_weaken. 23 | apply_fresh* typing_abs as y. apply_ih_bind* H0. 24 | apply* typing_app. 25 | apply* typing_raise. 26 | apply* typing_catch. 27 | Qed. 28 | 29 | (** Typing is preserved by substitution. *) 30 | 31 | Lemma typing_subst : forall F E t T z u U, 32 | (E & z ~ U & F) |= t ~: T -> 33 | E |= u ~: U -> 34 | (E & F) |= [z ~> u]t ~: T. 35 | Proof. 36 | introv Typt Typu. gen_eq G: (E & z ~ U & F). gen F. 37 | induction Typt; introv Equ; subst; simpl subst. 38 | case_var. 39 | binds_get H0. apply_empty* typing_weaken. 40 | binds_cases H0; apply* typing_var. 41 | apply_fresh typing_abs as y. 42 | rewrite* subst_open_var. apply_ih_bind* H0. 43 | apply* typing_app. 44 | apply* typing_raise. 45 | apply* typing_catch. 46 | Qed. 47 | 48 | (** Fails always returns a term of type exception. *) 49 | 50 | Lemma fails_to_exception : forall E t T e, 51 | fails t e -> 52 | E |= t ~: T -> 53 | E |= e ~: typ_exn. 54 | Proof. 55 | introv Fail Typ. induction Typ; inversions* Fail. 56 | Qed. 57 | 58 | (** Preservation (typing is preserved by reduction). *) 59 | 60 | Lemma preservation_result : preservation. 61 | Proof. 62 | introv Typ. gen t'. 63 | induction Typ; introv Red; inversions Red. 64 | inversions Typ1. pick_fresh x. rewrite* (@subst_intro x). 65 | apply_empty* typing_subst. 66 | apply* typing_app. 67 | apply* typing_app. 68 | apply* typing_raise. 69 | apply* typing_catch. 70 | assumption. 71 | apply* typing_app. apply* fails_to_exception. 72 | Qed. 73 | 74 | (** Progress (a well-typed term is either a value or it can 75 | take a step of reduction). *) 76 | 77 | Lemma progress_result : progress. 78 | Proof. 79 | introv Typ. gen_eq E: (empty : env). lets Typ': Typ. 80 | induction Typ; intros; subst. 81 | false* binds_empty_inv. 82 | branch* 1. 83 | right. destruct~ IHTyp1 as [Val1 | [[e Fail] | [t1' Red1]]]. 84 | destruct~ IHTyp2 as [Val2 | [[e Fail2] | [t2' Red2]]]. 85 | right. inversions Typ1; inversions Val1. exists* (t0 ^^ t2). 86 | left. exists* e. 87 | right. exists* (trm_app t1 t2'). 88 | left. exists* e. 89 | right. exists* (trm_app t1' t2). 90 | right. destruct~ IHTyp as [Val1 | [[e Fail] | [t1' Red1]]]. 91 | left. exists* t1. 92 | left. exists* e. 93 | right. exists* (trm_raise t1'). 94 | branch 3. destruct~ IHTyp2 as [Val2 | [[e Fail] | [t2' Red2]]]. 95 | exists* t2. 96 | exists* (trm_app t1 e). 97 | exists* (trm_catch t1 t2'). 98 | Qed. 99 | 100 | 101 | 102 | -------------------------------------------------------------------------------- /omni/Big.v: -------------------------------------------------------------------------------- 1 | (**************************************************************** 2 | * Imperative Lambda-calculus * 3 | * Big-Step Semantics * 4 | ****************************************************************) 5 | 6 | Set Implicit Arguments. 7 | Require Export Hprop. 8 | 9 | Implicit Types f : var. 10 | Implicit Types b : bool. 11 | Implicit Types p : loc. 12 | Implicit Types n : int. 13 | Implicit Types v w r vf vx : val. 14 | Implicit Types t : trm. 15 | Implicit Types s : state. 16 | 17 | Implicit Types Q : state->val->Prop. 18 | 19 | 20 | (* ########################################################### *) 21 | (* ########################################################### *) 22 | (* ########################################################### *) 23 | (** * Definitions *) 24 | 25 | (* ########################################################### *) 26 | (** ** Big-Step Judgment *) 27 | 28 | (** Judgment [big s t s' v] asserts that there exists an execution of 29 | the program [(s,t)] that reaches the final configuraiton [(s',v)]. *) 30 | 31 | Inductive big : state -> trm -> state -> val -> Prop := 32 | | big_val : forall s v, 33 | big s (trm_val v) s v 34 | | big_fix : forall s f x t1, 35 | big s (trm_fix f x t1) s (val_fix f x t1) 36 | | big_app_fix : forall s1 s2 v1 v2 f x t1 v, 37 | v1 = val_fix f x t1 -> 38 | big s1 (subst x v2 (subst f v1 t1)) s2 v -> 39 | big s1 (trm_app v1 v2) s2 v 40 | | big_let : forall s1 s2 s3 x t1 t2 v1 r, 41 | big s1 t1 s2 v1 -> 42 | big s2 (subst x v1 t2) s3 r -> 43 | big s1 (trm_let x t1 t2) s3 r 44 | | big_if : forall s1 s2 b v t1 t2, 45 | big s1 (if b then t1 else t2) s2 v -> 46 | big s1 (trm_if (val_bool b) t1 t2) s2 v 47 | | big_div : forall s n1 n2, 48 | n2 <> 0 -> 49 | big s (val_div (val_int n1) (val_int n2)) s (val_int (Z.quot n1 n2)) 50 | | big_rand : forall s n n1, 51 | 0 <= n1 < n -> 52 | big s (val_rand (val_int n)) s (val_int n1) 53 | | big_ref : forall s v p, 54 | ~ Fmap.indom s p -> 55 | big s (val_ref v) (Fmap.update s p v) (val_loc p) 56 | | big_get : forall s p, 57 | Fmap.indom s p -> 58 | big s (val_get (val_loc p)) s (Fmap.read s p) 59 | | big_set : forall s p v, 60 | Fmap.indom s p -> 61 | big s (val_set (val_loc p) v) (Fmap.update s p v) val_unit 62 | | big_free : forall s p, 63 | Fmap.indom s p -> 64 | big s (val_free (val_loc p)) (Fmap.remove s p) val_unit. 65 | 66 | 67 | (* ########################################################### *) 68 | (** ** Coinductive Big-step *) 69 | 70 | (** [codiv s t] asserts that there exists a diverging execution 71 | of the program [(s,t)]. This judgment is defined coinductively, 72 | and depends on the judgment [big]. *) 73 | 74 | CoInductive codiv : state -> trm -> Prop := 75 | | codiv_app_fix : forall s1 v1 v2 f x t1, 76 | v1 = val_fix f x t1 -> 77 | codiv s1 (subst x v2 (subst f v1 t1)) -> 78 | codiv s1 (trm_app v1 v2) 79 | | codiv_let_ctx : forall s1 x t1 t2, 80 | codiv s1 t1 -> 81 | codiv s1 (trm_let x t1 t2) 82 | | codiv_let : forall s1 s2 x t1 t2 v1, 83 | big s1 t1 s2 v1 -> 84 | codiv s2 (subst x v1 t2) -> 85 | codiv s1 (trm_let x t1 t2) 86 | | codiv_if : forall s1 b t1 t2, 87 | codiv s1 (if b then t1 else t2) -> 88 | codiv s1 (trm_if (val_bool b) t1 t2). 89 | 90 | (** Reference: 91 | Coinductive big-step operational semantics, 92 | Xavier Leroy and Hervé Grall, ESOP 2006, 93 | https://xavierleroy.org/coindsem/ *) 94 | 95 | -------------------------------------------------------------------------------- /ln/STLC_Core_Definitions.v: -------------------------------------------------------------------------------- 1 | (*************************************************************************** 2 | * Safety for Simply Typed Lambda Calculus (CBV) - Definitions * 3 | * Brian Aydemir & Arthur Chargueraud, July 2007 * 4 | ***************************************************************************) 5 | 6 | Set Implicit Arguments. 7 | From TLC Require Import LibLN. 8 | Implicit Types x : var. 9 | 10 | (** Grammar of types. *) 11 | 12 | Inductive typ : Set := 13 | | typ_var : var -> typ 14 | | typ_arrow : typ -> typ -> typ. 15 | 16 | (** Grammar of pre-terms. *) 17 | 18 | Inductive trm : Set := 19 | | trm_bvar : nat -> trm 20 | | trm_fvar : var -> trm 21 | | trm_abs : trm -> trm 22 | | trm_app : trm -> trm -> trm. 23 | 24 | (** Opening up abstractions *) 25 | 26 | Fixpoint open_rec (k : nat) (u : trm) (t : trm) {struct t} : trm := 27 | match t with 28 | | trm_bvar i => If k = i then u else (trm_bvar i) 29 | | trm_fvar x => trm_fvar x 30 | | trm_abs t1 => trm_abs (open_rec (S k) u t1) 31 | | trm_app t1 t2 => trm_app (open_rec k u t1) (open_rec k u t2) 32 | end. 33 | 34 | Definition open t u := open_rec 0 u t. 35 | 36 | Notation "{ k ~> u } t" := (open_rec k u t) (at level 67). 37 | Notation "t ^^ u" := (open t u) (at level 67). 38 | Notation "t ^ x" := (open t (trm_fvar x)). 39 | 40 | (** Terms are locally-closed pre-terms *) 41 | 42 | Inductive term : trm -> Prop := 43 | | term_var : forall x, 44 | term (trm_fvar x) 45 | | term_abs : forall L t1, 46 | (forall x, x \notin L -> term (t1 ^ x)) -> 47 | term (trm_abs t1) 48 | | term_app : forall t1 t2, 49 | term t1 -> 50 | term t2 -> 51 | term (trm_app t1 t2). 52 | 53 | (** Environment is an associative list mapping variables to types. *) 54 | 55 | Definition env := LibEnv.env typ. 56 | 57 | (** Typing relation *) 58 | 59 | Reserved Notation "E |= t ~: T" (at level 69). 60 | 61 | Inductive typing : env -> trm -> typ -> Prop := 62 | | typing_var : forall E x T, 63 | ok E -> 64 | binds x T E -> 65 | E |= (trm_fvar x) ~: T 66 | | typing_abs : forall L E U T t1, 67 | (forall x, x \notin L -> 68 | (E & x ~ U) |= t1 ^ x ~: T) -> 69 | E |= (trm_abs t1) ~: (typ_arrow U T) 70 | | typing_app : forall S T E t1 t2, 71 | E |= t1 ~: (typ_arrow S T) -> 72 | E |= t2 ~: S -> 73 | E |= (trm_app t1 t2) ~: T 74 | 75 | where "E |= t ~: T" := (typing E t T). 76 | 77 | (** Definition of values (only abstractions are values) *) 78 | 79 | Inductive value : trm -> Prop := 80 | | value_abs : forall t1, 81 | term (trm_abs t1) -> value (trm_abs t1). 82 | 83 | (** Reduction relation - one step in call-by-value *) 84 | 85 | Inductive red : trm -> trm -> Prop := 86 | | red_beta : forall t1 t2, 87 | term (trm_abs t1) -> 88 | value t2 -> 89 | red (trm_app (trm_abs t1) t2) (t1 ^^ t2) 90 | | red_app_1 : forall t1 t1' t2, 91 | term t2 -> 92 | red t1 t1' -> 93 | red (trm_app t1 t2) (trm_app t1' t2) 94 | | red_app_2 : forall t1 t2 t2', 95 | value t1 -> 96 | red t2 t2' -> 97 | red (trm_app t1 t2) (trm_app t1 t2'). 98 | 99 | Notation "t --> t'" := (red t t') (at level 68). 100 | 101 | (** Goal is to prove preservation and progress *) 102 | 103 | Definition preservation := forall E t t' T, 104 | E |= t ~: T -> 105 | t --> t' -> 106 | E |= t' ~: T. 107 | 108 | Definition progress := forall t T, 109 | empty |= t ~: T -> 110 | value t 111 | \/ exists t', t --> t'. 112 | 113 | -------------------------------------------------------------------------------- /pretty/Lambda_CombiErr.v: -------------------------------------------------------------------------------- 1 | (************************************************************ 2 | * Lambda-calculus, * 3 | * Pretty-big-step semantics with error rule * 4 | *************************************************************) 5 | 6 | Set Implicit Arguments. 7 | Require Export Lambda_PrettyErr. 8 | From TLC Require Import LibInt. 9 | 10 | Implicit Types v : val. 11 | Implicit Types t : trm. 12 | 13 | 14 | (*==========================================================*) 15 | (* * Definitions *) 16 | 17 | (************************************************************) 18 | (* ** Semantics *) 19 | 20 | (** Grammar of outcomes, with an explicit error behavior *) 21 | 22 | Inductive beh := 23 | | beh_ret : val -> beh 24 | | beh_err : beh. 25 | 26 | Coercion beh_ret : val >-> beh. 27 | Implicit Types b : beh. 28 | 29 | Inductive out := 30 | | out_ter : nat -> beh -> out 31 | | out_div : out. 32 | 33 | Implicit Types o : out. 34 | 35 | (** Partial order on the outcomes *) 36 | 37 | Implicit Types n : nat. 38 | 39 | Inductive faster : binary out := 40 | | faster_ter : forall n n' r r', 41 | n < n' -> 42 | faster (out_ter n r) (out_ter n' r') 43 | | faster_div : forall o, 44 | faster o out_div. 45 | 46 | Inductive before : binary out := 47 | | before_ter : forall n n' r, 48 | n < n' -> 49 | before (out_ter n r) (out_ter n' r) 50 | | before_div : 51 | before out_div out_div. 52 | 53 | Definition faster_before o1 o2 o := 54 | before o2 o /\ faster o1 o. 55 | 56 | (** Grammar of extended terms *) 57 | 58 | Inductive ext : Type := 59 | | ext_trm : trm -> ext 60 | | ext_app_1 : out -> trm -> ext 61 | | ext_app_2 : val -> out -> ext. 62 | 63 | Coercion ext_trm : trm >-> ext. 64 | Implicit Types e : ext. 65 | 66 | (** "One rule applies" judgment *) 67 | 68 | Inductive one : ext -> Prop := 69 | | one_val : forall v, 70 | one v 71 | | one_abs : forall x t, 72 | one (trm_abs x t) 73 | | one_app : forall t1 t2, 74 | one (trm_app t1 t2) 75 | | one_app_1_abort : forall t2, 76 | one (ext_app_1 out_div t2) 77 | | one_app_1 : forall n v1 t2, 78 | one (ext_app_1 (out_ter n v1) t2) 79 | | one_app_2_abort : forall v1, 80 | one (ext_app_2 v1 out_div) 81 | | one_app_2 : forall n x t3 v2, 82 | one (ext_app_2 (val_clo x t3) (out_ter n v2)). 83 | 84 | (** Combined evaluation *) 85 | 86 | CoInductive cred : ext -> out -> Prop := 87 | | cred_val : forall n v, 88 | cred v (out_ter n v) 89 | | cred_abs : forall n x t, 90 | cred (trm_abs x t) (out_ter n (val_clo x t)) 91 | | cred_app : forall o t1 t2 o1 o2, 92 | cred t1 o1 -> 93 | cred (ext_app_1 o1 t2) o2 -> 94 | faster_before o1 o2 o -> 95 | cred (trm_app t1 t2) o 96 | | cred_app_1_abort : forall t2, 97 | cred (ext_app_1 out_div t2) out_div 98 | | cred_app_1 : forall o n v1 t2 o2 o3, 99 | cred t2 o2 -> 100 | cred (ext_app_2 v1 o2) o3 -> 101 | faster_before o2 o3 o -> 102 | cred (ext_app_1 (out_ter n v1) t2) o 103 | | cred_app_2_abort : forall v1, 104 | cred (ext_app_2 v1 out_div) out_div 105 | | cred_app_2 : forall o n x t3 v2 o3, 106 | cred (subst x v2 t3) o3 -> 107 | before o3 o -> 108 | cred (ext_app_2 (val_clo x t3) (out_ter n v2)) o 109 | | cred_err : forall n e, 110 | ~ one e -> 111 | cred e (out_ter n beh_err). 112 | 113 | (** Main semantics judgments *) 114 | 115 | Definition credval e v := exists n, cred e (out_ter n v). 116 | 117 | Definition cdiverge e := cred e out_div. 118 | 119 | Definition cstuck e := exists n, cred e (out_ter n beh_err). 120 | 121 | -------------------------------------------------------------------------------- /ln/BigStep_Definitions.v: -------------------------------------------------------------------------------- 1 | (*************************************************************************** 2 | * Equivalence of big-step and small-step in call-by-value - Definitions * 3 | * Arthur Chargueraud, March 2009 * 4 | ***************************************************************************) 5 | 6 | Set Implicit Arguments. 7 | From TLC Require Import LibLN. 8 | 9 | (* ********************************************************************** *) 10 | (** ** Grammar of pre-terms *) 11 | 12 | Inductive trm : Set := 13 | | trm_bvar : nat -> trm 14 | | trm_fvar : var -> trm 15 | | trm_abs : trm -> trm 16 | | trm_app : trm -> trm -> trm. 17 | 18 | 19 | (* ********************************************************************** *) 20 | (** ** Operation to open up abstractions. *) 21 | 22 | Fixpoint open_rec (k : nat) (u : trm) (t : trm) {struct t} : trm := 23 | match t with 24 | | trm_bvar i => If k = i then u else (trm_bvar i) 25 | | trm_fvar x => trm_fvar x 26 | | trm_app t1 t2 => trm_app (open_rec k u t1) (open_rec k u t2) 27 | | trm_abs t1 => trm_abs (open_rec (S k) u t1) 28 | end. 29 | 30 | Definition open t u := open_rec 0 u t. 31 | 32 | Notation "t ^^ u" := (open t u) (at level 67). 33 | Notation "t ^ x" := (open t (trm_fvar x)). 34 | 35 | 36 | (* ********************************************************************** *) 37 | (** ** Definition of well-formedness of a term *) 38 | 39 | Inductive term : trm -> Prop := 40 | | term_var : forall x, 41 | term (trm_fvar x) 42 | | term_app : forall t1 t2, 43 | term t1 -> term t2 -> term (trm_app t1 t2) 44 | | term_abs : forall L t1, 45 | (forall x, x \notin L -> term (t1 ^ x)) -> 46 | term (trm_abs t1). 47 | 48 | 49 | (* ********************************************************************** *) 50 | (** ** Definition of the body of an abstraction *) 51 | 52 | Definition body t := 53 | exists L, forall x, x \notin L -> term (t ^ x). 54 | 55 | 56 | (* ********************************************************************** *) 57 | (** ** Definition of the small-step semantics *) 58 | 59 | Inductive value : trm -> Prop := 60 | | value_abs : forall t1, 61 | term (trm_abs t1) -> value (trm_abs t1). 62 | 63 | Inductive beta : trm -> trm -> Prop := 64 | | beta_red : forall t1 t2, 65 | body t1 -> 66 | value t2 -> 67 | beta (trm_app (trm_abs t1) t2) (t1 ^^ t2) 68 | | beta_app1 : forall t1 t1' t2, 69 | term t2 -> 70 | beta t1 t1' -> 71 | beta (trm_app t1 t2) (trm_app t1' t2) 72 | | beta_app2 : forall t1 t2 t2', 73 | value t1 -> 74 | beta t2 t2' -> 75 | beta (trm_app t1 t2) (trm_app t1 t2'). 76 | 77 | Inductive beta_star : trm -> trm -> Prop := 78 | | beta_star_refl : forall t, 79 | term t -> 80 | beta_star t t 81 | | beta_star_step : forall t2 t1 t3, 82 | beta t1 t2 -> 83 | beta_star t2 t3 -> 84 | beta_star t1 t3. 85 | 86 | 87 | (* ********************************************************************** *) 88 | (** ** Definition of the big-step semantics *) 89 | 90 | Inductive reds : trm -> trm -> Prop := 91 | | reds_val : forall t1, 92 | value t1 -> 93 | reds t1 t1 94 | | reds_red : forall t3 v2 v3 t1 t2, 95 | reds t1 (trm_abs t3) -> 96 | reds t2 v2 -> 97 | reds (t3 ^^ v2) v3 -> 98 | reds (trm_app t1 t2) v3. 99 | 100 | 101 | (* ********************************************************************** *) 102 | (** ** Definition of the big-step semantics *) 103 | 104 | Definition equivalence := forall t v, 105 | reds t v <-> beta_star t v /\ value v. 106 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | -------------------------------------------------------------------------------- /pretty/LambdaExnSum_Big.v: -------------------------------------------------------------------------------- 1 | (************************************************************ 2 | * Lambda-calculus with exceptions and sums, * 3 | * Big-step semantics * 4 | *************************************************************) 5 | 6 | Set Implicit Arguments. 7 | Require Export LambdaExnSum_Syntax. 8 | 9 | Implicit Types v : val. 10 | Implicit Types t : trm. 11 | 12 | 13 | (*==========================================================*) 14 | (* * Definitions *) 15 | 16 | (************************************************************) 17 | (* ** Semantics *) 18 | 19 | Inductive beh := 20 | | beh_ret : val -> beh 21 | | beh_exn : val -> beh. 22 | 23 | Coercion beh_ret : val >-> beh. 24 | 25 | (** Reduction *) 26 | 27 | Inductive bigred : trm -> beh -> Prop := 28 | | bigred_val : forall v, 29 | bigred v v 30 | | bigred_abs : forall x t, 31 | bigred (trm_abs x t) (val_abs x t) 32 | | bigred_app : forall t1 t2 x t3 v2 o, 33 | bigred t1 (val_abs x t3) -> 34 | bigred t2 v2 -> 35 | bigred (subst x v2 t3) o -> 36 | bigred (trm_app t1 t2) o 37 | | bigred_app_exn_1 : forall t1 t2 v, 38 | bigred t1 (beh_exn v) -> 39 | bigred (trm_app t1 t2) (beh_exn v) 40 | | bigred_app_exn_2 : forall t1 t2 v1 v, 41 | bigred t1 v1 -> 42 | bigred t2 (beh_exn v) -> 43 | bigred (trm_app t1 t2) (beh_exn v) 44 | | bigred_try : forall t1 t2 v1, 45 | bigred t1 v1 -> 46 | bigred (trm_try t1 t2) v1 47 | | bigred_try_1 : forall t1 t2 o2 v, 48 | bigred t1 (beh_exn v)-> 49 | bigred (trm_app t2 v) o2 -> 50 | bigred (trm_try t1 t2) o2 51 | | bigred_raise : forall t1 v1, 52 | bigred t1 v1 -> 53 | bigred (trm_raise t1) (beh_exn v1) 54 | | bigred_raise_exn_1 : forall t1 v, 55 | bigred t1 (beh_exn v) -> 56 | bigred (trm_raise t1) (beh_exn v) 57 | | bigred_inj : forall b t1 v1, 58 | bigred t1 v1 -> 59 | bigred (trm_inj b t1) (val_inj b v1) 60 | | bigred_inj_1 : forall b t1 v, 61 | bigred t1 (beh_exn v) -> 62 | bigred (trm_inj b t1) (beh_exn v) 63 | | bigred_case_true : forall t1 t2 t3 v1 o, 64 | bigred t1 (val_inj true v1) -> 65 | bigred (trm_app t2 v1) o -> 66 | bigred (trm_case t1 t2 t3) o 67 | | bigred_case_false : forall t1 t2 t3 v1 o, 68 | bigred t1 (val_inj false v1) -> 69 | bigred (trm_app t3 v1) o -> 70 | bigred (trm_case t1 t2 t3) o 71 | | bigred_case_1 : forall t1 t2 t3 v, 72 | bigred t1 (beh_exn v) -> 73 | bigred (trm_case t1 t2 t3) (beh_exn v). 74 | 75 | (** Divergence *) 76 | 77 | CoInductive bigdiv : trm -> Prop := 78 | | bigdiv_app_1 : forall t1 t2, 79 | bigdiv t1 -> 80 | bigdiv (trm_app t1 t2) 81 | | bigdiv_app_2 : forall t1 v1 t2, 82 | bigred t1 v1 -> 83 | bigdiv t2 -> 84 | bigdiv (trm_app t1 t2) 85 | | bigdiv_app_3 : forall t1 t2 x t3 v2, 86 | bigred t1 (val_abs x t3) -> 87 | bigred t2 v2 -> 88 | bigdiv (subst x v2 t3) -> 89 | bigdiv (trm_app t1 t2) 90 | | bigdiv_try_1 : forall t1 t2, 91 | bigdiv t1 -> 92 | bigdiv (trm_try t1 t2) 93 | | bigdiv_try_2 : forall t1 t2 v, 94 | bigred t1 (beh_exn v) -> 95 | bigdiv (trm_app t2 v) -> 96 | bigdiv (trm_try t1 t2) 97 | | bigdiv_raise_1 : forall t1, 98 | bigdiv t1 -> 99 | bigdiv (trm_raise t1) 100 | | bigdiv_inj_1 : forall b t1, 101 | bigdiv t1 -> 102 | bigdiv (trm_inj b t1) 103 | | bigdiv_case_1 : forall t1 t2 t3, 104 | bigdiv t1 -> 105 | bigdiv (trm_case t1 t2 t3) 106 | | bigdiv_case_true : forall t1 t2 t3 v1, 107 | bigred t1 (val_inj true v1) -> 108 | bigdiv (trm_app t2 v1) -> 109 | bigdiv (trm_case t1 t2 t3) 110 | | bigdiv_case_false : forall t1 t2 t3 v1, 111 | bigred t1 (val_inj false v1) -> 112 | bigdiv (trm_app t3 v1) -> 113 | bigdiv (trm_case t1 t2 t3). 114 | 115 | -------------------------------------------------------------------------------- /ln/CoC_Conversion.v: -------------------------------------------------------------------------------- 1 | (*************************************************************************** 2 | * Calculus of Constructions - Properties of Conversion * 3 | * Arthur Chargueraud, April 2007 * 4 | ***************************************************************************) 5 | 6 | Set Implicit Arguments. 7 | From TLC Require Import LibLN. 8 | Require Import CoC_Definitions CoC_Infrastructure 9 | CoC_BetaStar CoC_ChurchRosser. 10 | 11 | 12 | (* ********************************************************************** *) 13 | (** ** Some Properties of Conversion *) 14 | 15 | Lemma conv_red_out : red_out conv. 16 | Proof. 17 | intros_all. lets: beta_red_out. induction* H0. 18 | Qed. 19 | 20 | Lemma conv_from_beta_star : 21 | (beta star) simulated_by (conv). 22 | Proof. 23 | intros_all. induction* H. 24 | Qed. 25 | 26 | Lemma conv_from_beta_star_trans : forall T U1 U2, 27 | (beta star) U1 T -> (beta star) U2 T -> conv U1 U2. 28 | Proof. 29 | introv R1 R2. apply (@equiv_trans beta T). 30 | apply* conv_from_beta_star. 31 | apply equiv_sym. apply* conv_from_beta_star. 32 | Qed. 33 | 34 | Lemma conv_from_open_beta : forall u u' t, 35 | body t -> beta u u' -> conv (t ^^ u') (t ^^ u). 36 | Proof. 37 | introv B R. destruct B as [L Fr]. 38 | pick_fresh x. 39 | rewrite* (@subst_intro x t u). 40 | rewrite* (@subst_intro x t u'). 41 | unfold conv. apply equiv_sym. 42 | apply conv_from_beta_star. 43 | apply* beta_star_red_in. 44 | Qed. 45 | 46 | 47 | (* ********************************************************************** *) 48 | (** ** Inversion Lemmas for Conversion *) 49 | 50 | Section ProdInv. 51 | 52 | Tactic Notation "helper" := 53 | match goal with |- ex (fun _ => ex (fun _ => 54 | trm_prod ?A ?B = trm_prod _ _ /\ _)) => 55 | exists A B; splits 3; [auto | | exists_fresh ] end. 56 | 57 | Tactic Notation "helper" "*" := helper; eauto. 58 | 59 | Lemma beta_star_prod_any_inv : forall P U1 T1, 60 | (beta star) (trm_prod U1 T1) P -> 61 | exists U2, exists T2, P = trm_prod U2 T2 /\ 62 | (beta star) U1 U2 /\ 63 | exists L, forall x, x \notin L -> 64 | (beta star) (T1 ^ x) (T2 ^ x). 65 | Proof. 66 | introv H. gen_eq Q: (trm_prod U1 T1). gen U1 T1. 67 | induction H; intros; subst. 68 | inversions H. helper*. 69 | destruct~ (IHstar_1 U1 T1) as [U3 [T3 [EQ3 [H3 [L3 R3]]]]]. subst. 70 | destruct~ (IHstar_2 U3 T3) as [U2 [T2 [EQ2 [H2 [L2 R2]]]]]. subst. 71 | helper*. 72 | inversions H; helper*. 73 | Qed. 74 | 75 | End ProdInv. 76 | 77 | Lemma beta_star_type_any_inv : forall P i, 78 | (beta star) (trm_type i) P -> P = trm_type i. 79 | Proof. 80 | introv R. 81 | gen_eq T: (trm_type i). 82 | induction R; intros EQ; subst. 83 | auto. 84 | forwards*: IHR1. subst. auto. 85 | inversion H. 86 | Qed. 87 | 88 | Lemma conv_prod_prod_inv : forall U1 T1 U2 T2, 89 | conv (trm_prod U1 T1) (trm_prod U2 T2) -> 90 | conv U1 U2 91 | /\ exists L, forall x, x \notin L -> conv (T1 ^ x) (T2 ^ x). 92 | Proof. 93 | unfold conv. introv C. 94 | destruct (church_rosser_beta C) as [P3 [Red1 Red2]]. 95 | destruct (beta_star_prod_any_inv Red1) 96 | as [P3_11 [P3_12 [EQ1 [R1 [L1 S1]]]]]. 97 | destruct (beta_star_prod_any_inv Red2) 98 | as [P3_21 [P3_22 [EQ2 [R2 [L2 S2]]]]]. 99 | rewrite EQ2 in EQ1. inversions EQ1. 100 | split. applys conv_from_beta_star_trans R1 R2. 101 | exists_fresh. intros x Fr. 102 | forwards~ K1: (S1 x). forwards~ K2: (S2 x). 103 | apply* conv_from_beta_star_trans. 104 | Qed. 105 | 106 | Lemma conv_type_type_inv : forall i j, 107 | conv (trm_type i) (trm_type j) -> i = j. 108 | Proof. 109 | unfold conv. introv C. 110 | destruct (church_rosser_beta C) as [T [Red1 Red2]]. 111 | rewrite (beta_star_type_any_inv Red1) in Red2. 112 | lets K: (beta_star_type_any_inv Red2). inversions* K. 113 | Qed. 114 | 115 | Lemma conv_type_prod_inv : forall U1 U2 i, 116 | conv (trm_type i) (trm_prod U1 U2) -> False. 117 | Proof. 118 | unfold conv. introv C. 119 | destruct (church_rosser_beta C) as [P3 [Red1 Red2]]. 120 | destruct (beta_star_prod_any_inv Red2) 121 | as [P3_11 [P3_12 [EQ1 [R1 [L1 S1]]]]]. 122 | rewrite (beta_star_type_any_inv Red1) in *. 123 | false. 124 | Qed. 125 | -------------------------------------------------------------------------------- /pretty/Lambda_PrettyErr_Typing_Sound.v: -------------------------------------------------------------------------------- 1 | (************************************************************ 2 | * Lambda-calculus, * 3 | * Type soundness proof * 4 | * using pretty-big-step semantics with error rules * 5 | *************************************************************) 6 | 7 | Set Implicit Arguments. 8 | Require Import Lambda_PrettyErr Lambda_Typing. 9 | From TLC Require Import LibLN LibInt. 10 | 11 | Implicit Types v : val. 12 | Implicit Types t : trm. 13 | 14 | 15 | (*==========================================================*) 16 | (* * Proofs *) 17 | 18 | (************************************************************) 19 | (* ** Proof of type soundness *) 20 | 21 | (** Hints *) 22 | 23 | Hint Constructors one typing. 24 | Hint Extern 1 (_ < _) => math. 25 | Hint Extern 1 (~ one _ -> exists _, _) => 26 | let H := fresh in intros H; false H. 27 | 28 | (** Regularity lemma *) 29 | 30 | Lemma typing_ok : forall E t T, 31 | typing E t T -> ok E. 32 | Proof. introv H. induction* H. Qed. 33 | 34 | (** Weakening for values *) 35 | 36 | Lemma typing_val_weaken : forall E v T, 37 | typing empty v T -> ok E -> typing E v T. 38 | Proof. introv H. inverts* H. Qed. 39 | 40 | (** Substitution lemma *) 41 | 42 | Lemma typing_subst : forall E x T U t v, 43 | typing empty v U -> 44 | typing (empty & single x U & E) t T -> 45 | typing E (subst x v t) T. 46 | Proof. 47 | introv Tv Tt. inductions Tt; simpl. 48 | constructors*. 49 | constructors*. 50 | cases_if. 51 | binds_cases H0. 52 | false* binds_empty_inv. 53 | subst. applys* typing_val_weaken. 54 | lets (?&?): (ok_middle_inv H). 55 | false~ (binds_fresh_inv B0). 56 | binds_cases H0. 57 | false* binds_empty_inv. 58 | constructors~. 59 | cases_if. 60 | false. lets N: typing_ok Tt. 61 | rewrite <- concat_assoc in N. 62 | lets (?&M): (ok_middle_inv N). 63 | simpl_dom. notin_false. 64 | forwards*: IHTt. rewrite* concat_assoc. 65 | constructors*. 66 | Qed. 67 | 68 | (************************************************************) 69 | (* ** Typing judgment for extended terms *) 70 | 71 | Definition trmtyping t T := 72 | typing empty t T. 73 | 74 | Inductive outtyping : out -> typ -> Prop := 75 | | outtyping_ter : forall v T, 76 | trmtyping v T -> 77 | outtyping (out_ret v) T 78 | | outtyping_div : forall T, 79 | outtyping out_div T. 80 | 81 | Inductive exttyping : ext -> typ -> Prop := 82 | | extyping_trm : forall t T, 83 | trmtyping t T -> 84 | exttyping t T 85 | | exttyping_app_1 : forall T1 T2 o1 t2, 86 | outtyping o1 (typ_arrow T1 T2) -> 87 | trmtyping t2 T1 -> 88 | exttyping (ext_app_1 o1 t2) T2 89 | | exttyping_app_2 : forall T1 T2 v1 o2, 90 | trmtyping v1 (typ_arrow T1 T2) -> 91 | outtyping o2 T1 -> 92 | exttyping (ext_app_2 v1 o2) T2. 93 | 94 | 95 | (************************************************************) 96 | (* ** Soundness *) 97 | 98 | Hint Constructors outtyping exttyping. 99 | Hint Unfold trmtyping. 100 | 101 | Lemma abort_outyping : forall o T T', 102 | abort o -> outtyping o T -> outtyping o T'. 103 | Proof. 104 | introv A M. inverts M; inverts A. auto. 105 | Qed. 106 | 107 | Lemma soundness_ind : forall e o T, 108 | red e o -> exttyping e T -> outtyping o T. 109 | Proof. 110 | introv R. gen T. induction R; introv M. 111 | inverts M as M. auto. 112 | inverts M as M. inverts* M. 113 | inverts M as M. inverts* M. 114 | inverts M as M1 M2. forwards*: abort_outyping H. 115 | inverts M as M1 M2. inverts* M1. 116 | inverts M as M1 M2. forwards*: abort_outyping H. 117 | inverts M as M1 M2. inverts M2. inverts* M1. 118 | applys IHR. constructors. apply_empty* typing_subst. 119 | false (rm H). inverts M as. 120 | introv M. inverts M. 121 | eauto. 122 | eauto. 123 | false* binds_empty_inv. 124 | eauto. 125 | eauto. 126 | introv M1 M2. inverts* M1. 127 | introv M1 M2. inverts M1. inverts* M2. 128 | Qed. 129 | 130 | (** Soundness theorem: 131 | Well-typed terms don't end up in an error *) 132 | 133 | Lemma soundness : forall t T, 134 | typing empty t T -> ~ red t out_err. 135 | Proof. introv M R. forwards* K: soundness_ind R. inverts K. Qed. 136 | 137 | 138 | -------------------------------------------------------------------------------- /ln/Lambda_Definitions.v: -------------------------------------------------------------------------------- 1 | (*************************************************************************** 2 | * Church-Rosser Property in Pure Lambda-Calculus - Definitions * 3 | * Arthur Chargueraud, March 2007 * 4 | ***************************************************************************) 5 | 6 | Set Implicit Arguments. 7 | From TLC Require Import LibLN. 8 | Implicit Types x : var. 9 | 10 | (* ********************************************************************** *) 11 | (** ** Description of the Task (only part which has to be trusted) *) 12 | 13 | (* ********************************************************************** *) 14 | (** Grammar of pre-terms *) 15 | 16 | Inductive trm : Set := 17 | | trm_bvar : nat -> trm 18 | | trm_fvar : var -> trm 19 | | trm_app : trm -> trm -> trm 20 | | trm_abs : trm -> trm. 21 | 22 | (* ********************************************************************** *) 23 | (** Operation to open up abstractions. *) 24 | 25 | Fixpoint open_rec (k : nat) (u : trm) (t : trm) {struct t} : trm := 26 | match t with 27 | | trm_bvar i => If k = i then u else (trm_bvar i) 28 | | trm_fvar x => trm_fvar x 29 | | trm_app t1 t2 => trm_app (open_rec k u t1) (open_rec k u t2) 30 | | trm_abs t1 => trm_abs (open_rec (S k) u t1) 31 | end. 32 | 33 | Definition open t u := open_rec 0 u t. 34 | 35 | Notation "{ k ~> u } t" := (open_rec k u t) (at level 67). 36 | Notation "t ^^ u" := (open t u) (at level 67). 37 | Notation "t ^ x" := (open t (trm_fvar x)). 38 | 39 | (* ********************************************************************** *) 40 | (** Definition of well-formedness of a term *) 41 | 42 | Inductive term : trm -> Prop := 43 | | term_var : forall x, 44 | term (trm_fvar x) 45 | | term_app : forall t1 t2, 46 | term t1 -> term t2 -> term (trm_app t1 t2) 47 | | term_abs : forall L t1, 48 | (forall x, x \notin L -> term (t1 ^ x)) -> 49 | term (trm_abs t1). 50 | 51 | (* ********************************************************************** *) 52 | (** Definition of the body of an abstraction *) 53 | 54 | Definition body t := 55 | exists L, forall x, x \notin L -> term (t ^ x). 56 | 57 | (* ********************************************************************** *) 58 | (** Definition of the beta relation *) 59 | 60 | Definition relation := trm -> trm -> Prop. 61 | 62 | Inductive beta : relation := 63 | | beta_red : forall t1 t2, 64 | body t1 -> 65 | term t2 -> 66 | beta (trm_app (trm_abs t1) t2) (t1 ^^ t2) 67 | | beta_app1 : forall t1 t1' t2, 68 | term t2 -> 69 | beta t1 t1' -> 70 | beta (trm_app t1 t2) (trm_app t1' t2) 71 | | beta_app2 : forall t1 t2 t2', 72 | term t1 -> 73 | beta t2 t2' -> 74 | beta (trm_app t1 t2) (trm_app t1 t2') 75 | | beta_abs : forall L t1 t1', 76 | (forall x, x \notin L -> beta (t1 ^ x) (t1' ^ x)) -> 77 | beta (trm_abs t1) (trm_abs t1'). 78 | 79 | (* ********************************************************************** *) 80 | (** Definition of the reflexive-transitive closure of a relation *) 81 | 82 | Inductive star_ (R : relation) : relation := 83 | | star_refl : forall t, 84 | term t -> 85 | star_ R t t 86 | | star_trans : forall t2 t1 t3, 87 | star_ R t1 t2 -> star_ R t2 t3 -> star_ R t1 t3 88 | | star_step : forall t t', 89 | R t t' -> star_ R t t'. 90 | 91 | Notation "R 'star'" := (star_ R) (at level 69). 92 | 93 | (* ********************************************************************** *) 94 | (** Definition of the reflexive-symmetric-transitive closure of a relation *) 95 | 96 | Inductive equiv_ (R : relation) : relation := 97 | | equiv_refl : forall t, 98 | term t -> 99 | equiv_ R t t 100 | | equiv_sym: forall t t', 101 | equiv_ R t t' -> 102 | equiv_ R t' t 103 | | equiv_trans : forall t2 t1 t3, 104 | equiv_ R t1 t2 -> equiv_ R t2 t3 -> equiv_ R t1 t3 105 | | equiv_step : forall t t', 106 | R t t' -> equiv_ R t t'. 107 | 108 | Notation "R 'equiv'" := (equiv_ R) (at level 69). 109 | 110 | (* ********************************************************************** *) 111 | (** Definition of confluence and of the Church-Rosser property 112 | (Our goal is to prove the Church-Rosser Property for beta relation) *) 113 | 114 | Definition confluence (R : relation) := 115 | forall M S T, R M S -> R M T -> 116 | exists P, R S P /\ R T P. 117 | 118 | Definition church_rosser (R : relation) := 119 | forall t1 t2, (R equiv) t1 t2 -> 120 | exists t, (R star) t1 t /\ (R star) t2 t. 121 | -------------------------------------------------------------------------------- /ln/Fsub_Soundness_OmniSmall.v: -------------------------------------------------------------------------------- 1 | (*************************************************************************** 2 | * Safety for STLC with References - Proof in Omni-Small-Step * 3 | * Arthur Chargueraud, Dec 2023 * 4 | ***************************************************************************) 5 | 6 | (** The proof technique is explained in the Omni-Semantics paper (TOPLAS'23). 7 | http://www.chargueraud.org/research/2022/omnisemantics/omnisemantics.pdf *) 8 | 9 | Set Implicit Arguments. 10 | From TLC Require Import LibLN. 11 | Require Import Fsub_Definitions Fsub_Infrastructure Fsub_Soundness. 12 | 13 | 14 | (* ********************************************************************** *) 15 | (** * Definition of Omni-Small-Step Semantics *) 16 | 17 | (** The omni-small-step judgment [omnismall c P], where [P] is a postcondition, 18 | asserts that [c] is not stuck and that in one step it reaches a configuration 19 | that satisfies [P]. *) 20 | 21 | CoInductive omnismall : trm -> (trm->Prop) -> Prop := 22 | | omnismall_app_1 : forall e1 e2 P1 P, 23 | omnismall e1 P1 -> 24 | (forall e1', P1 e1' -> P (trm_app e1' e2)) -> 25 | omnismall (trm_app e1 e2) P 26 | | omnismall_app_2 : forall e1 e2 P1 P, 27 | value e1 -> 28 | omnismall e2 P1 -> 29 | (forall e2', P1 e2' -> P (trm_app e1 e2')) -> 30 | omnismall (trm_app e1 e2) P 31 | | omnismall_tapp : forall e1 V P1 P, 32 | omnismall e1 P1 -> 33 | (forall e1', P1 e1' -> P (trm_tapp e1' V)) -> 34 | omnismall (trm_tapp e1 V) P 35 | | omnismall_abs : forall V e1 v2 P, 36 | term (trm_abs V e1) -> 37 | value v2 -> 38 | P (open_ee e1 v2) -> 39 | omnismall (trm_app (trm_abs V e1) v2) P 40 | | omnismall_tabs : forall V1 V2 e1 P, 41 | term (trm_tabs V1 e1) -> 42 | type V2 -> 43 | P (open_te e1 V2) -> 44 | omnismall (trm_tapp (trm_tabs V1 e1) V2) P. 45 | 46 | Hint Constructors omnismall. 47 | 48 | (** [omnismall e P] is covariant in the postcondition [P]. *) 49 | 50 | Lemma omnismall_conseq : forall e P1 P2, 51 | (forall e', P1 e' -> P2 e') -> 52 | omnismall e P1 -> 53 | omnismall e P2. 54 | Proof using. introv HW Typ. inverts* Typ. Qed. 55 | 56 | 57 | (* ********************************************************************** *) 58 | (** * Hint to workaround a limitation of [eauto] *) 59 | 60 | (** Custom hint: the application of a constructor for reducing under 61 | a context, such as [omnismall_app_1], leaves in the second subgoal 62 | an hypothesis of the form [(fun e' => P1_body) e1')]. Unfortunately, 63 | [eauto] does not simplify these beta-redexes. Hence we need a hint. *) 64 | 65 | Hint Extern 1 (typing ?E ?e ?T) => 66 | match goal with H: (fun _ => _) _ |- _ => hnf in H end. 67 | 68 | 69 | (* ********************************************************************** *) 70 | (** * Soundness proof *) 71 | 72 | (** Well typed terms are either values or can take a step, 73 | and for any step they can take they reach another term 74 | that admits the same type. *) 75 | 76 | Lemma omnismall_soundness_result : forall e T, 77 | typing empty e T-> 78 | value e \/ omnismall e (fun e' => typing empty e' T). 79 | Proof using. (* 22 lines *) 80 | introv Typ. gen_eq E: (@empty bind). lets Typ': Typ. 81 | induction Typ; intros; subst. 82 | (* case: var *) 83 | { false* binds_empty_inv. } 84 | (* case: abs *) 85 | { left*. } 86 | (* case: app *) 87 | { right. forwards* [Val1|HR1]: IHTyp1. 88 | { lets (S&e3&->): (canonical_form_abs Val1 Typ1). 89 | lets (P1&S2&L&P2): typing_inv_abs Typ1 T1 T2. { apply* sub_reflexivity. } 90 | forwards* [Val2|HR2]: IHTyp2. 91 | { applys* omnismall_abs. pick_fresh X. 92 | forwards~ (K1&K2): (P2 X). rewrite* (@subst_ee_intro X). 93 | applys_eq (>> typing_through_subst_ee S (empty:env) (empty:env)); 94 | try rewrite concat_empty_r; auto. 95 | { applys* typing_sub K1. apply_empty* sub_weakening. } } } } 96 | (* case: tabs *) 97 | { left*. } 98 | (* case: tapp *) 99 | { right. forwards* [Val1|HR1]: IHTyp. 100 | { lets (S&e3&->): (canonical_form_tabs Val1 Typ). 101 | lets (P1&S2&L&P2): typing_inv_tabs Typ T1 T2. { apply* sub_reflexivity. } 102 | applys* omnismall_tabs. pick_fresh X. forwards~ (K1&K2): (P2 X). 103 | rewrite* (@subst_te_intro X). rewrite* (@subst_tt_intro X). 104 | applys_eq (>> typing_through_subst_te T1 (empty:env) (empty:env)); 105 | try rewrite map_empty; try rewrite concat_empty_r; eauto. } } 106 | (* case: sub *) 107 | { forwards* [Val1|Rede]: IHTyp. { right. applys* omnismall_conseq Rede. } } 108 | Qed. 109 | 110 | -------------------------------------------------------------------------------- /ln/ISK_Confluence.v: -------------------------------------------------------------------------------- 1 | (*************************************************************************** 2 | * Confluence property for parallel reductions in the ISK system * 3 | * Arthur Chargueraud, January 2009, updated November 2011 * 4 | ***************************************************************************) 5 | 6 | (** NOT COMPLETE: contains only the diamond property for parallel reductions *) 7 | 8 | From TLC Require Import LibTactics. 9 | Set Implicit Arguments. 10 | 11 | 12 | (* ********************************************************************** *) 13 | (** Definitions *) 14 | 15 | Inductive term : Set := 16 | | I : term 17 | | K : term 18 | | S : term 19 | | App : term -> term -> term. 20 | 21 | Definition relation := term -> term -> Prop. 22 | 23 | Inductive base : relation := 24 | | base_I : forall M, 25 | base (App I M) M 26 | | base_K : forall M N, 27 | base (App (App K M) N) M 28 | | base_S : forall F G N, 29 | base (App (App (App S F) G) N) (App (App F N) (App G N)). 30 | 31 | Inductive para : relation := 32 | | para_refl : forall M, 33 | para M M 34 | | para_base : forall M N, 35 | base M N -> para M N 36 | | para_app : forall M1 M2 N1 N2, 37 | para M1 M2 -> para N1 N2 -> para (App M1 N1) (App M2 N2). 38 | 39 | Hint Constructors base para. 40 | 41 | 42 | (* ********************************************************************** *) 43 | (** Facts *) 44 | 45 | Definition not_base T := forall M, ~ (base T M). 46 | 47 | Lemma not_base_I : not_base I. 48 | Proof. introv H. inverts H. Qed. 49 | 50 | Lemma not_base_K : forall M, ~ (base K M). 51 | Proof. introv H. inverts H. Qed. 52 | 53 | Lemma not_base_S : forall M, ~ (base S M). 54 | Proof. introv H. inverts H. Qed. 55 | 56 | Lemma not_base_K_arg : forall M N, ~ (base (App K M) N). 57 | Proof. introv H. inverts H. Qed. 58 | 59 | (** The above lemmas are not actually used in the later proofs because 60 | they are derivable by a simple inversion *) 61 | 62 | 63 | (* ********************************************************************** *) 64 | (** Lemmas *) 65 | 66 | Lemma base_functional : forall M N1 N2, 67 | base M N1 -> base M N2 -> N1 = N2. 68 | Proof. introv H1 H2. inverts H1; inverts~ H2. Qed. 69 | 70 | Lemma join_base_base : forall M N1 N2, 71 | base M N1 -> base M N2 -> exists Q, para N1 Q /\ para N2 Q. 72 | Proof. introv H1 H2. rewrite* (base_functional H1 H2). Qed. 73 | 74 | Lemma para_app_k : forall M N, 75 | para (App K M) N -> exists P, para M P /\ N = App K P. 76 | Proof. 77 | introv H. inverts H as. 78 | exists* M. 79 | introv B. inverts B. 80 | introv B1 B2. exists N2. split~. fequals. 81 | inverts B1 as H. auto. inverts H. 82 | Qed. 83 | 84 | Lemma para_app_s : forall F1 G1 N, 85 | para (App (App S F1) G1) N -> 86 | exists F2 G2, 87 | para F1 F2 /\ para G1 G2 /\ N = App (App S F2) G2. 88 | Proof. 89 | introv H. inverts H as. 90 | exists~ F1 G1. 91 | introv B1. inverts B1. 92 | introv B1 B2. inverts B1. 93 | exists~ F1 N2. 94 | inverts H. 95 | exists N0 N2. splits~. 96 | inverts H1 as H. auto. inverts H. 97 | Qed. 98 | 99 | Lemma base_app_para : forall M1 M2 N1 N2 P, 100 | base (App M1 N1) P -> (para M1 M2) -> (para N1 N2) -> 101 | exists Q, para P Q /\ para (App M2 N2) Q. 102 | Proof. 103 | introv R0 R1 R2. inverts R0. 104 | exists N2. split~. inverts R1 as H. auto. inverts~ H. 105 | lets (Q&R3&EQ): (para_app_k R1). subst. exists* Q. 106 | lets (F2&G2&R3&R4&EQ): (para_app_s R1). subst. 107 | exists* (App (App F2 N2) (App G2 N2)). 108 | Qed. 109 | 110 | Lemma join_base_para : forall M N1 N2, 111 | base M N1 -> para M N2 -> 112 | exists Q, para N1 Q /\ para N2 Q. 113 | Proof. 114 | introv R1 R2. inverts R2. 115 | exists* N1. 116 | applys join_base_base; eauto. 117 | applys base_app_para; eauto. 118 | Qed. 119 | 120 | Lemma para_diamond : 121 | forall M N P, para M N -> para M P -> 122 | exists Q, para N Q /\ para P Q. 123 | Proof. 124 | introv R1 R2. gen P. induction R1; intros. 125 | exists* P. 126 | applys join_base_para; eauto. 127 | inverts R2. 128 | exists* (App M2 N2). 129 | forwards* (Q&R3&R4): base_app_para H R1_1 R1_2. 130 | forwards~ (Q1&R3&R4): IHR1_1 M3. 131 | forwards* (Q2&R5&R6): IHR1_2 N3. 132 | Qed. 133 | 134 | 135 | (* ********************************************************************** *) 136 | (** Additional definitions *) 137 | 138 | Inductive red : relation := 139 | | red_base : forall M N, 140 | base M N -> red M N 141 | | red_app1 : forall M1 M2 N, 142 | red M1 M2 -> red (App M1 N) (App M2 N) 143 | | red_app2 : forall M N1 N2, 144 | red N1 N2 -> red (App M N1) (App M N2). 145 | 146 | Hint Constructors red. 147 | 148 | -------------------------------------------------------------------------------- /pretty/CoreCaml_Syntax.v: -------------------------------------------------------------------------------- 1 | (************************************************************ 2 | * Core Caml * 3 | * Syntax * 4 | *************************************************************) 5 | 6 | Set Implicit Arguments. 7 | Require Export Common LibHeap. 8 | Module Heap := LibHeap. 9 | Notation "x ~~ a" := (single x a) 10 | (at level 27, left associativity) : env_scope. 11 | 12 | 13 | (*==========================================================*) 14 | (* * Definitions *) 15 | 16 | (************************************************************) 17 | (* ** Auxiliary definitions for the syntax *) 18 | 19 | (** Representation of record labels *) 20 | 21 | Definition lab := var. 22 | 23 | (** Representation of constructors *) 24 | 25 | Definition constr := var. 26 | 27 | (** Particular exceptions *) 28 | 29 | Parameter constr_unit : constr. 30 | Parameter constr_div_by_zero : constr. 31 | Parameter constr_matching_failure : constr. 32 | Parameter constr_assert_failure : constr. 33 | 34 | (** Representation of locations *) 35 | 36 | Definition loc := var. 37 | 38 | Global Instance loc_Comparable : Comparable loc. 39 | Proof using. apply comparable_var. Qed. 40 | 41 | (** Representation of the direction of a for-loop *) 42 | 43 | Inductive dir : Type := dir_upto | dir_downto. 44 | 45 | (** Grammar of primitive operators *) 46 | 47 | Inductive prim : Type := 48 | | prim_raise : prim 49 | | prim_eq : prim 50 | | prim_not : prim 51 | | prim_neg : prim 52 | | prim_add : prim 53 | | prim_sub : prim 54 | | prim_mul : prim 55 | | prim_div : prim 56 | | prim_and : prim 57 | | prim_or : prim. 58 | 59 | (** Grammar of constants *) 60 | 61 | Inductive cst : Type := 62 | | cst_bool : bool -> cst 63 | | cst_int : int -> cst. 64 | 65 | (** Grammar of patterns *) 66 | 67 | Inductive pat : Type := 68 | | pat_var : var -> pat 69 | | pat_wild : pat 70 | | pat_alias : pat -> var -> pat 71 | | pat_or : pat -> pat -> pat 72 | | pat_cst : cst -> pat 73 | | pat_constr : constr -> list pat -> pat 74 | | pat_tuple : list pat -> pat 75 | | pat_record : list (lab*pat) -> pat. 76 | 77 | (** Grammar of terms *) 78 | 79 | Inductive trm : Type := 80 | | trm_var : var -> trm 81 | | trm_cst : cst -> trm 82 | | trm_abs : option var -> pat -> trm -> trm 83 | | trm_constr : constr -> list trm -> trm 84 | | trm_tuple : list trm -> trm 85 | | trm_record : list (lab*trm) -> trm 86 | | trm_unary : prim -> trm -> trm 87 | | trm_binary : prim -> trm -> trm -> trm 88 | | trm_lazy_binary : prim -> trm -> trm -> trm 89 | | trm_app : trm -> trm -> trm 90 | | trm_seq : trm -> trm -> trm 91 | | trm_let : pat -> trm -> trm -> trm 92 | | trm_get : trm -> lab -> trm 93 | | trm_set : trm -> lab -> trm -> trm 94 | | trm_if : trm -> trm -> option trm -> trm 95 | | trm_while : trm -> trm -> trm 96 | | trm_for : var -> dir -> trm -> trm -> trm -> trm 97 | | trm_match : trm -> list branch -> trm 98 | | trm_try : trm -> list branch -> trm 99 | | trm_assert : trm -> trm 100 | | trm_rand : trm 101 | 102 | with branch : Type := 103 | | branch_intro : pat -> option trm -> trm -> branch. 104 | 105 | (** Grammar of values *) 106 | 107 | Inductive val : Type := 108 | | val_cst : cst -> val 109 | | val_loc : loc -> val 110 | | val_abs : option var -> pat -> trm -> val 111 | | val_constr : constr -> list val -> val 112 | | val_tuple : list val -> val 113 | | val_record : list (lab*val) -> val. 114 | 115 | (** Representation of the memory store *) 116 | 117 | 118 | Definition mem := Heap.heap loc val. 119 | 120 | 121 | (************************************************************) 122 | (* ** Auxiliary definitions *) 123 | 124 | (** Substitution *) 125 | 126 | Definition inst := LibEnv.env val. 127 | 128 | Parameter subst : forall (x:var) (v:val) (t:trm), trm. 129 | Parameter substs : forall (i:inst) (t:trm), trm. 130 | 131 | (** [val] is inhabited *) 132 | 133 | Instance val_inhab : Inhab val. 134 | Proof. intros. apply (Inhab_of_val (val_cst (cst_bool true))). Qed. 135 | 136 | (** Shortnames for lists of terms and values *) 137 | 138 | Definition trms := list trm. 139 | Definition vals := list val. 140 | Definition labtrms := list (lab*trm). 141 | Definition labvals := list (lab*val). 142 | Definition branches := list branch. 143 | 144 | (** Shortcuts for building terms and values *) 145 | 146 | Definition val_exn k := val_constr k nil. 147 | 148 | Definition val_unit := val_constr constr_unit nil. 149 | 150 | (** Coercions *) 151 | 152 | Coercion val_exn : constr >-> val. 153 | Coercion cst_int : Z >-> cst. 154 | Coercion cst_bool : bool >-> cst. 155 | Coercion pat_var : var >-> pat. 156 | Coercion val_loc : loc >-> val. 157 | Coercion val_cst : cst >-> val. 158 | Coercion trm_cst : cst >-> trm. 159 | 160 | (** Fresh locations *) 161 | 162 | Definition fresh (m:mem) l := 163 | ~ Heap.indom m l. 164 | -------------------------------------------------------------------------------- /pretty/LambdaExn_Big.v: -------------------------------------------------------------------------------- 1 | (************************************************************ 2 | * Lambda-calculus with exceptions, * 3 | * Big-step semantics * 4 | *************************************************************) 5 | 6 | Set Implicit Arguments. 7 | Require Export LambdaExn_Syntax. 8 | Import BehaviorsWithoutErrors. 9 | 10 | Implicit Types v : val. 11 | Implicit Types t : trm. 12 | Implicit Types b : beh. 13 | 14 | (*==========================================================*) 15 | (* * Definitions *) 16 | 17 | (************************************************************) 18 | (* ** Semantics *) 19 | 20 | (** Reduction *) 21 | 22 | Inductive bigred : trm -> beh -> Prop := 23 | | bigred_val : forall v, 24 | bigred v v 25 | | bigred_abs : forall x t, 26 | bigred (trm_abs x t) (val_clo x t) 27 | | bigred_app : forall t1 t2 x t3 v2 o, 28 | bigred t1 (val_clo x t3) -> 29 | bigred t2 v2 -> 30 | bigred (subst x v2 t3) o -> 31 | bigred (trm_app t1 t2) o 32 | | bigred_app_exn_1 : forall t1 t2 v, 33 | bigred t1 (beh_exn v) -> 34 | bigred (trm_app t1 t2) (beh_exn v) 35 | | bigred_app_exn_2 : forall t1 t2 v1 v, 36 | bigred t1 v1 -> 37 | bigred t2 (beh_exn v) -> 38 | bigred (trm_app t1 t2) (beh_exn v) 39 | | bigred_try : forall t1 t2 v1, 40 | bigred t1 v1 -> 41 | bigred (trm_try t1 t2) v1 42 | | bigred_try_1 : forall t1 t2 o2 v, 43 | bigred t1 (beh_exn v)-> 44 | bigred (trm_app t2 v) o2 -> 45 | bigred (trm_try t1 t2) o2 46 | | bigred_raise : forall t1 v1, 47 | bigred t1 v1 -> 48 | bigred (trm_raise t1) (beh_exn v1) 49 | | bigred_raise_exn_1 : forall t1 v, 50 | bigred t1 (beh_exn v) -> 51 | bigred (trm_raise t1) (beh_exn v) 52 | | bigred_rand : forall k, 53 | (ParamDeterministic -> k = 0) -> 54 | bigred trm_rand (val_int k). 55 | 56 | (** Divergence *) 57 | 58 | CoInductive bigdiv : trm -> Prop := 59 | | bigdiv_app_1 : forall t1 t2, 60 | bigdiv t1 -> 61 | bigdiv (trm_app t1 t2) 62 | | bigdiv_app_2 : forall t1 v1 t2, 63 | bigred t1 v1 -> 64 | bigdiv t2 -> 65 | bigdiv (trm_app t1 t2) 66 | | bigdiv_app_3 : forall t1 t2 x t3 v2, 67 | bigred t1 (val_clo x t3) -> 68 | bigred t2 v2 -> 69 | bigdiv (subst x v2 t3) -> 70 | bigdiv (trm_app t1 t2) 71 | | bigdiv_try_1 : forall t1 t2, 72 | bigdiv t1 -> 73 | bigdiv (trm_try t1 t2) 74 | | bigdiv_try_2 : forall t1 t2 v, 75 | bigred t1 (beh_exn v) -> 76 | bigdiv (trm_app t2 v) -> 77 | bigdiv (trm_try t1 t2) 78 | | bigdiv_raise_1 : forall t1, 79 | bigdiv t1 -> 80 | bigdiv (trm_raise t1). 81 | 82 | 83 | (*==========================================================*) 84 | (* * Proofs *) 85 | 86 | (************************************************************) 87 | (* ** Induction principle on the height of a derivation *) 88 | 89 | (** Ideally, would be automatically generated by Coq *) 90 | 91 | Section BigredInd. 92 | 93 | Inductive bigredh : nat -> trm -> beh -> Prop := 94 | | bigredh_val : forall n v, 95 | bigredh (S n) v v 96 | | bigredh_abs : forall n x t, 97 | bigredh (S n) (trm_abs x t) (val_clo x t) 98 | | bigredh_app : forall n t1 t2 x t3 v2 b, 99 | bigredh n t1 (val_clo x t3) -> 100 | bigredh n t2 v2 -> 101 | bigredh n (subst x v2 t3) b -> 102 | bigredh (S n) (trm_app t1 t2) b 103 | | bigredh_app_exn_1 : forall n t1 t2 v, 104 | bigredh n t1 (beh_exn v) -> 105 | bigredh (S n) (trm_app t1 t2) (beh_exn v) 106 | | bigredh_app_exn_2 : forall n t1 t2 v1 v, 107 | bigredh n t1 v1 -> 108 | bigredh n t2 (beh_exn v) -> 109 | bigredh (S n) (trm_app t1 t2) (beh_exn v) 110 | | bigredh_try : forall n t1 t2 v1, 111 | bigredh n t1 v1 -> 112 | bigredh (S n) (trm_try t1 t2) v1 113 | | bigredh_try_1 : forall n t1 t2 o2 v, 114 | bigredh n t1 (beh_exn v)-> 115 | bigredh n (trm_app t2 v) o2 -> 116 | bigredh (S n) (trm_try t1 t2) o2 117 | | bigredh_raise : forall n t1 v1, 118 | bigredh n t1 v1 -> 119 | bigredh (S n) (trm_raise t1) (beh_exn v1) 120 | | bigredh_raise_exn_1 : forall n t1 v, 121 | bigredh n t1 (beh_exn v) -> 122 | bigredh (S n) (trm_raise t1) (beh_exn v) 123 | | bigredh_rand : forall n k, 124 | (ParamDeterministic -> k = 0) -> 125 | bigredh (S n) trm_rand (val_int k). 126 | 127 | Hint Constructors bigred bigredh. 128 | Hint Extern 1 (_ < _) => math. 129 | 130 | Lemma bigredh_lt : forall n n' t b, 131 | bigredh n t b -> n < n' -> bigredh n' t b. 132 | Proof. 133 | introv H. gen n'. induction H; introv L; 134 | (destruct n' as [|n']; [ false; math | autos* ]). 135 | Qed. 136 | 137 | Lemma bigred_bigredh : forall t b, 138 | bigred t b -> exists n, bigredh n t b. 139 | Proof. hint bigredh_lt. introv H. induction H; try induct_height. Qed. 140 | 141 | End BigredInd. 142 | 143 | -------------------------------------------------------------------------------- /pretty/LambdaExn_Interp_BigErr_Correct.v: -------------------------------------------------------------------------------- 1 | (************************************************************ 2 | * Lambda-calculus with exceptions * 3 | * Interpreter in combined pretty-big-step with error rules * 4 | *************************************************************) 5 | 6 | Set Implicit Arguments. 7 | Require Import LambdaExn_Interp LambdaExn_BigErr. 8 | 9 | Implicit Types v : val. 10 | Implicit Types t : trm. 11 | Implicit Types b : beh. 12 | Implicit Types r : res. 13 | 14 | 15 | (*==========================================================*) 16 | (* * Proofs *) 17 | 18 | Hint Extern 1 (_ < _) => math. 19 | Hint Constructors isclo abort bigred. 20 | 21 | 22 | (************************************************************) 23 | (* ** Properties of monadic operators *) 24 | 25 | Lemma if_success_abort : forall b k, 26 | abort b -> if_success b k = b. 27 | Proof. introv A. inverts* A. Qed. 28 | 29 | Lemma if_isclo_not_isclo : forall v k, 30 | ~ isclo v -> if_isclo v k = beh_err. 31 | Proof. introv N. destruct v; auto_false. Qed. 32 | 33 | 34 | (************************************************************) 35 | (* ** Correctness and completeness of the interpreter *) 36 | 37 | (** Correctness *) 38 | 39 | Lemma run_correct_red : forall n t b, 40 | bigredh n t b -> forall k, k >= n -> run k t = b. 41 | Proof. 42 | induction n using peano_induction. 43 | introv R. destruct n. inverts R. 44 | introv K. destruct k. math. 45 | asserts IH: (forall t b, bigredh n t b -> run k t = b). 46 | introv M. applys H M; math. clear H K. 47 | inverts R as; simpl. 48 | auto. 49 | auto. 50 | auto. 51 | introv R1 R2 R3. rewrites~ (>> IH R1). simpl. 52 | rewrites~ (>> IH R2). simple*. 53 | introv A R1. rewrites~ (>> IH R1). rewrite~ if_success_abort. 54 | introv A R1 R2. rewrites~ (>> IH R1). simpl. 55 | rewrites~ (>> IH R2). rewrite~ if_success_abort. 56 | introv N R1 R2. rewrites~ (>> IH R1). simpl. 57 | rewrites~ (>> IH R2). simpl. rewrite~ if_isclo_not_isclo. 58 | introv R1. rewrites~ (>> IH R1). 59 | introv R1 R2. rewrites~ (>> IH R1). simple*. 60 | introv R1. rewrites~ (>> IH R1). 61 | introv R1. rewrites~ (>> IH R1). 62 | introv A R1. rewrites~ (>> IH R1). rewrite~ if_success_abort. 63 | introv E. rewrite* E. rewrite~ Deterministic. 64 | Qed. 65 | 66 | (** Completeness *) 67 | 68 | Ltac runs b := 69 | match goal with HR: context [ run ?n ?t ] |- _ => 70 | let r := fresh "r" in let E := fresh "E" in 71 | sets_eq <- r E: (run n t); 72 | destruct r as [ b | ]; [ | inverts HR ]; 73 | match goal with IH: (forall _ _, run _ _ = _ -> bigred _ _) |- _ => 74 | let M := fresh "M" in lets M: IH E; clear E end end. 75 | 76 | Lemma run_complete_red : forall n t b, 77 | run n t = b -> bigred t b. 78 | Proof. 79 | induction n using peano_induction. 80 | introv R. destruct n; simpl in R. inverts R. 81 | lets~ IH: (rm H) n __. destruct t. 82 | inverts~ R. 83 | inverts~ R. 84 | inverts~ R. 85 | runs b1. destruct b1; inverts R as R; auto. 86 | runs b2. destruct b2; inverts R as R; autos*. 87 | tests C: (isclo v). 88 | inverts C. simpls. runs b3. inverts* R. 89 | rewrite~ if_isclo_not_isclo in R. inverts* R. 90 | runs b1. destruct b1; inverts R as R; auto. 91 | runs b2. inverts* R. 92 | runs b1. destruct b1; inverts~ R. 93 | inverts~ R. 94 | Qed. 95 | 96 | 97 | (************************************************************) 98 | (* ** Corollaries, formulated as implications *) 99 | 100 | Corollary correct_ter : forall n t b, 101 | run n t = b -> bigred t b. 102 | Proof. applys run_complete_red. Qed. 103 | 104 | Corollary complete_ter : forall t b, 105 | bigred t b -> exists m, forall n, n > m -> run n t = b. 106 | Proof. 107 | introv H. lets (n&R): bigred_bigredh H. exists n. 108 | introv L. applys* run_correct_red. math. 109 | Qed. 110 | 111 | Corollary correct_div : forall t, 112 | (forall n, run n t = res_bottom) -> bigdiv t. 113 | Proof. 114 | introv H. tests (b&B) C: (terminates t). 115 | lets (n&R): bigred_bigredh B. 116 | specializes H n. forwards: (run_correct_red R) n. 117 | math. false. 118 | applys* not_terminates_bigdiv. 119 | Qed. 120 | 121 | Corollary complete_div : forall t n, 122 | bigdiv t -> run n t = res_bottom. 123 | Proof. 124 | introv H. cases (run n t) as C; [ false | auto ]. 125 | lets H': correct_ter C. 126 | applys* bigred_bigdiv_exclusive H' H. 127 | Qed. 128 | 129 | 130 | (************************************************************) 131 | (* ** Corollaries, formulated as equivalences *) 132 | 133 | Corollary specification_ter : forall t b, 134 | (exists m, forall n, n > m -> run n t = b) 135 | <-> bigred t b. 136 | Proof. 137 | iff (n&?) ?. 138 | applys* correct_ter (S n). applys* H. math. 139 | applys* complete_ter. 140 | Qed. 141 | 142 | Corollary specification_div : forall t, 143 | (forall n, run n t = res_bottom) 144 | <-> bigdiv t. 145 | Proof. 146 | iff. 147 | applys* correct_div. 148 | intros. applys* complete_div. 149 | Qed. 150 | 151 | -------------------------------------------------------------------------------- /omni/EquivSmallBig.v: -------------------------------------------------------------------------------- 1 | (**************************************************************** 2 | * Imperative Lambda-calculus * 3 | * Equivalence Proofs for Small-Step and Big-Step Semantics * 4 | *****************************************************************) 5 | 6 | Set Implicit Arguments. 7 | Require Export Small Big. 8 | 9 | Implicit Types f : var. 10 | Implicit Types b : bool. 11 | Implicit Types p : loc. 12 | Implicit Types n : int. 13 | Implicit Types v w r vf vx : val. 14 | Implicit Types t : trm. 15 | Implicit Types s : state. 16 | 17 | 18 | (* ########################################################### *) 19 | (* ########################################################### *) 20 | (* ########################################################### *) 21 | (** * Proofs *) 22 | 23 | (* ########################################################### *) 24 | (** ** From Standard Small-Step to Standard Big-Step *) 25 | 26 | (** In this section, we establish the equivalence between 27 | the big-step judgment [big s t s' v] and the iterated 28 | small-step judgment [steps s t s' (trm_val v)]. *) 29 | 30 | (** Consider first the direction from small-step to big-step. 31 | The proof involves a key lemma, which shows how to "glue" 32 | a one-step reduction with a big-step evaluation to produce 33 | a (larger) big-step evaluation. *) 34 | 35 | Lemma big_of_step_and_eval : forall s1 s2 t1 t2 s3 v, 36 | step s1 t1 s2 t2 -> 37 | big s2 t2 s3 v -> 38 | big s1 t1 s3 v. 39 | Proof using. 40 | introv M1 M2. gen s3 v. induction M1; intros. 41 | { inverts M2 as; try false_invert. 42 | { introv M3 M4. applys* big_let. } } 43 | { inverts M2; try false_invert. applys big_fix. } 44 | { applys* big_app_fix. } 45 | { applys* big_if. } 46 | { applys* big_let. applys big_val. } 47 | { inverts M2; try false_invert. applys* big_div. } 48 | { inverts M2; try false_invert. applys* big_rand. } 49 | { inverts M2; try false_invert. applys* big_ref. } 50 | { inverts M2; try false_invert. applys* big_get. } 51 | { inverts M2; try false_invert. applys* big_set. } 52 | { inverts M2; try false_invert. applys* big_free. } 53 | Qed. 54 | 55 | (** Using the above lemmas, to establish the implication between 56 | the iterated small-step relation, it remains to perform an 57 | induction over the sequence of individual steps involved. *) 58 | 59 | Lemma big_of_steps : forall s1 s2 t v, 60 | steps s1 t s2 (trm_val v) -> 61 | big s1 t s2 v. 62 | Proof. 63 | introv M. gen_eq t': (trm_val v). gen v. 64 | induction M; intros; subst. 65 | { applys* big_val. } 66 | { applys* big_of_step_and_eval. } 67 | Qed. 68 | 69 | 70 | (* ########################################################### *) 71 | (** ** From Standard Big-Step to Standard Small-Step *) 72 | 73 | (** Let's now tackle the reciprocal direction, from big-step to 74 | small-step. This time, the key auxiliary lemma is a context 75 | rule for describing how a sequence of steps can be applied 76 | under a let-context. *) 77 | 78 | Lemma steps_let : forall s1 s2 s3 v1 v3 x t1 t2, 79 | steps s1 t1 s2 (trm_val v1) -> 80 | steps s2 (subst x v1 t2) s3 v3 -> 81 | steps s1 (trm_let x t1 t2) s3 v3. 82 | Proof using. 83 | introv M1 M2. gen_eq t1': (trm_val v1). gen v1. 84 | induction M1; intros; subst. 85 | { applys steps_step. { applys step_let. } { applys M2. } } 86 | { rename H into R1. applys steps_step. 87 | { applys step_let_ctx R1. } 88 | { applys* IHM1 M2. } } 89 | Qed. 90 | 91 | (** There remains to perfom an induction over the big-step 92 | evaluation relation. The only nontrivial case is that of 93 | the let-binding, for which we need to exploit [steps_let]. *) 94 | 95 | Lemma steps_of_eval : forall s1 s2 t v, 96 | big s1 t s2 v -> 97 | steps s1 t s2 (trm_val v). 98 | Proof using. 99 | introv M. induction M. 100 | { applys steps_refl. } 101 | { applys steps_step. { applys step_fix. } { applys steps_refl. } } 102 | { applys steps_step. { applys* step_app_fix. } { applys IHM. } } 103 | { applys* steps_let IHM1 IHM2. } 104 | { applys steps_step. { applys* step_if. } { applys IHM. } } 105 | { applys steps_step. { applys* step_div. } { applys steps_refl. } } 106 | { applys steps_step. { applys* step_rand. } { applys steps_refl. } } 107 | { applys steps_step. { applys* step_ref. } { applys steps_refl. } } 108 | { applys steps_step. { applys* step_get. } { applys steps_refl. } } 109 | { applys steps_step. { applys* step_set. } { applys steps_refl. } } 110 | { applys steps_step. { applys* step_free. } { applys steps_refl. } } 111 | Qed. 112 | 113 | (* ########################################################### *) 114 | (** ** Equivalence for Between Standard Small-Step and Standard Big-Step *) 115 | 116 | (** Putting the two directions together yields the desired equivalence. *) 117 | 118 | Lemma big_iff_steps : forall s t s' v, 119 | big s t s' v <-> steps s t s' (trm_val v). 120 | Proof using. 121 | iff M. 122 | { applys* steps_of_eval. } 123 | { applys* big_of_steps. } 124 | Qed. 125 | -------------------------------------------------------------------------------- /omni/Syntax.v: -------------------------------------------------------------------------------- 1 | (**************************************************************** 2 | * Imperative Lambda-calculus * 3 | * Syntax * 4 | ****************************************************************) 5 | 6 | Set Implicit Arguments. 7 | From TLC Require Export LibCore LibLogic. 8 | Require Export LibSepVar LibSepFmap. 9 | Module Fmap := LibSepFmap. 10 | 11 | 12 | (* ########################################################### *) 13 | (* ########################################################### *) 14 | (* ########################################################### *) 15 | (** * Syntax and Substitution *) 16 | 17 | (* ########################################################### *) 18 | (** ** Syntax *) 19 | 20 | (** The grammar of the deeply embedded language includes terms and 21 | values. Values include basic values such as [int] and [bool], 22 | locations (memory addresses, represented by natural numbers), 23 | and primitive operations. *) 24 | 25 | (** The grammar of primitive operations includes operations on the 26 | mutable store, a nondeterministic operator [val_rand], and 27 | a partial operation [val_div]. *) 28 | 29 | Inductive prim : Type := 30 | | val_ref : prim 31 | | val_get : prim 32 | | val_set : prim 33 | | val_free : prim 34 | | val_rand : prim 35 | | val_div : prim. 36 | 37 | Definition loc : Type := nat. 38 | 39 | Definition null : loc := 0%nat. 40 | 41 | (** The grammar of values. *) 42 | 43 | Inductive val : Type := 44 | | val_unit : val 45 | | val_bool : bool -> val 46 | | val_int : int -> val 47 | | val_loc : loc -> val 48 | | val_prim : prim -> val 49 | | val_fix : var -> var -> trm -> val 50 | | val_error : val 51 | 52 | (** The grammar of terms. *) 53 | 54 | with trm : Type := 55 | | trm_val : val -> trm 56 | | trm_var : var -> trm 57 | | trm_fix : var -> var -> trm -> trm 58 | | trm_app : trm -> trm -> trm 59 | | trm_let : var -> trm -> trm -> trm 60 | | trm_if : trm -> trm -> trm -> trm. 61 | 62 | 63 | (** The types of values and heap values are inhabited. *) 64 | 65 | Global Instance Inhab_val : Inhab val. 66 | Proof using. apply (Inhab_of_val val_unit). Qed. 67 | 68 | 69 | (* ########################################################### *) 70 | (** ** Mutable State *) 71 | 72 | (** A state consists of a finite map from location to values. 73 | Records and arrays are represented as sets of consecutive cells, 74 | preceeded by a header field describing the length of the block. *) 75 | 76 | Definition state : Type := fmap loc val. 77 | 78 | (** [state_empty] is a handy notation to avoid providing 79 | type arguments to [Fmap.empty] *) 80 | 81 | Notation "'state_empty'" := (@Fmap.empty loc val) 82 | (at level 0). 83 | 84 | (** [h1 \u h2] is an optional notation for union of two states; 85 | in this file, it is only used for pretty-printing. *) 86 | 87 | Notation "h1 \u h2" := (Fmap.union h1 h2) 88 | (at level 37, right associativity). 89 | 90 | 91 | (* ########################################################### *) 92 | (** ** Coercions *) 93 | 94 | (** Coercions to improve conciseness in the statment of evaluation rules. *) 95 | 96 | Coercion val_bool : bool >-> val. 97 | Coercion val_int : Z >-> val. 98 | Coercion val_loc : loc >-> val. 99 | Coercion val_prim : prim >-> val. 100 | 101 | Coercion trm_val : val >-> trm. 102 | Coercion trm_var : var >-> trm. 103 | Coercion trm_app : trm >-> Funclass. 104 | 105 | 106 | (* ########################################################### *) 107 | (** ** Substitution *) 108 | 109 | (** Capture-avoiding substitution, standard definition. *) 110 | 111 | Fixpoint subst (y:var) (v':val) (t:trm) : trm := 112 | let aux t := subst y v' t in 113 | let if_y_eq x t1 t2 := if var_eq x y then t1 else t2 in 114 | match t with 115 | | trm_val v => trm_val v 116 | | trm_var x => if_y_eq x (trm_val v') t 117 | | trm_fix f x t1 => trm_fix f x (if_y_eq f t1 (if_y_eq x t1 (aux t1))) 118 | | trm_app t1 t2 => trm_app (aux t1) (aux t2) 119 | | trm_let x t1 t2 => trm_let x (aux t1) (if_y_eq x t2 (aux t2)) 120 | | trm_if t0 t1 t2 => trm_if (aux t0) (aux t1) (aux t2) 121 | end. 122 | 123 | 124 | (* ########################################################### *) 125 | (** ** Implicit Types *) 126 | 127 | (** These definitions need to be reproduced in each file. *) 128 | 129 | Implicit Types f : var. 130 | Implicit Types b : bool. 131 | Implicit Types p : loc. 132 | Implicit Types n : int. 133 | Implicit Types v w r vf vx : val. 134 | Implicit Types t : trm. 135 | Implicit Types s : state. 136 | 137 | 138 | 139 | (* ########################################################### *) 140 | (* ########################################################### *) 141 | (* ########################################################### *) 142 | (** * TLC LibTactic Patch *) 143 | 144 | Ltac false_invert_iter ::= 145 | match goal with H:_ |- _ => 146 | solve [ inversion H; false 147 | | clear H; false_invert_iter 148 | | fail 2 ] end. 149 | 150 | Tactic Notation "constructors" := 151 | econstructor; unfold eq'. 152 | -------------------------------------------------------------------------------- /ln/STLC_Ref_Soundness_Small.v: -------------------------------------------------------------------------------- 1 | (*************************************************************************** 2 | * Safety for STLC with References - Proofs in Small-Step * 3 | * Arthur Chargueraud, July 2007, updated Dec 2023 * 4 | ***************************************************************************) 5 | 6 | Set Implicit Arguments. 7 | From TLC Require Import LibNat. 8 | Require Import STLC_Ref_Soundness_Common. 9 | 10 | 11 | (* ********************************************************************** *) 12 | (** * Statements *) 13 | 14 | (** Goal is to prove preservation and progress. Soundness will follow. *) 15 | 16 | Definition preservation := forall Y t t' mu mu' T, 17 | empty ! Y |= t ~: T -> 18 | (t,mu) --> (t',mu') -> 19 | Y |== mu -> 20 | exists Y', 21 | extends Y Y' 22 | /\ empty ! Y' |= t' ~: T 23 | /\ Y' |== mu'. 24 | 25 | Definition progress := forall Y t mu T, 26 | empty ! Y |= t ~: T -> 27 | Y |== mu -> 28 | value t 29 | \/ exists t', exists mu', (t,mu) --> (t',mu'). 30 | 31 | 32 | (* ********************************************************************** *) 33 | (** * Proofs *) 34 | 35 | (** A simple short-hand to help clarifying the following proof. 36 | It simply destruct the induction hypothesis into smaller pieces. *) 37 | 38 | Ltac pres H t' mu' := 39 | let Y' := fresh "Y'" in 40 | let Ext := fresh "Ext" in 41 | let Typt' := fresh "Typt'" in 42 | let TypSto' := fresh "TypSto'" in 43 | destruct~ (H (@refl_equal env empty) t' mu') 44 | as (Y'&Ext&Typt'&TypSto'). 45 | 46 | (** Preservation (typing is preserved by reduction). *) 47 | 48 | Lemma preservation_result : preservation. 49 | Proof. (* 26 lines *) 50 | introv Typ. gen t' mu'. gen_eq E: (empty : env). 51 | induction Typ; intros EQ t' mu' Red TypSto; subst; 52 | inversions Red. (* todo env_fix.*) 53 | exists Y. inversions Typ1. splits~ 3. 54 | pick_fresh x. rewrite* (@subst_intro x). 55 | apply_empty* typing_subst. 56 | pres IHTyp1 t1' mu'. exists* Y'. 57 | pres IHTyp2 t2' mu'. exists* Y'. 58 | exists (Y & l ~ T). 59 | asserts Fr: (l # Y). lets: (proj32 TypSto). auto. 60 | splits~ 3. apply* sto_typing_push. 61 | pres IHTyp t1' mu'. exists* Y'. 62 | exists Y. splits~ 3. 63 | inversions Typ. 64 | destruct~ ((proj33 TypSto) l T) as (t&Valt&Hast&Typt). 65 | rewrite~ (binds_functional H4 Hast). 66 | pres IHTyp t1' mu'. exists* Y'. 67 | exists Y. inversions Typ1. splits~ 3. 68 | destruct TypSto as (StoOk&Dom&Map). splits~ 3. 69 | intros. tests: (l = l0). 70 | exists t2. split~. rewrite~ (binds_functional H H6). 71 | destruct (Map _ _ H) as (t&Has&Typ). exists* t. 72 | pres IHTyp1 t1' mu'. exists* Y'. 73 | pres IHTyp2 t2' mu'. exists* Y'. 74 | exists* Y. 75 | pres IHTyp t1' mu'. exists* Y'. 76 | Qed. 77 | 78 | (** Progression (a well-typed term is either a value or it can 79 | take a step of reduction). *) 80 | 81 | Lemma progress_result : progress. 82 | Proof. (* 33 lines *) 83 | introv Typ. gen_eq E: (empty : env). lets Typ': Typ. 84 | induction Typ; intros; subst. 85 | false* binds_empty_inv. 86 | left*. 87 | right. destruct~ IHTyp1 as [Val1 | (t1'&mu'&Red1)]. 88 | destruct~ IHTyp2 as [Val2 | (t2'&mu'&Red2)]. 89 | inversions Typ1; inversions Val1. exists* (t0 ^^ t2) mu. 90 | exists* (trm_app t1 t2') mu'. 91 | exists* (trm_app t1' t2). 92 | left*. 93 | left*. 94 | left*. 95 | right. destruct~ IHTyp as [Val1 | (t1'&mu'&Red1)]. 96 | destruct (var_fresh (dom mu)) as [l Fr]. 97 | exists* (trm_loc l) (mu & l ~ t1). 98 | exists* (trm_ref t1') mu'. 99 | right. destruct~ IHTyp as [Val1 | (t1'&mu'&Red1)]. 100 | inversions Val1; inversions Typ. 101 | destruct ((proj33 H) _ _ H5) as (t'&Has'&Typt'). 102 | exists* t' mu. 103 | exists* (trm_get t1') mu'. 104 | right. destruct~ IHTyp1 as [Val1 | (t1'&mu'&Red1)]. 105 | destruct~ IHTyp2 as [Val2 | [t2' [mu' Red2]]]. 106 | inversions Val1; inversions Typ1. 107 | destruct ((proj33 H) _ _ H5) as (t'&Has'&Typt'). 108 | exists* trm_unit (mu & l ~ t2). 109 | exists* (trm_set t1 t2') mu'. 110 | exists* (trm_set t1' t2) mu'. 111 | right. destruct~ IHTyp as [Val1 | (t1'&mu'&Red1)]. 112 | inversions Val1; inversions Typ. 113 | exists* (trm_int 0) mu. constructors*. 114 | unfold max. case_if; nat_math. 115 | exists* (trm_rand t1') mu'. 116 | Qed. 117 | 118 | 119 | (* ********************************************************************** *) 120 | (** * Generic result: type soundness follows from preservation and progress *) 121 | 122 | (** Type soundness (well-typed configurations can only reach 123 | safe configurations, i.e. configurations that are values 124 | or can take a reduction step) *) 125 | 126 | Lemma soundness_result : soundness. 127 | Proof using. 128 | intros (t,mu) (Y&T&HT&HS). introv R. 129 | gen_eq c: (t,mu). gen Y t mu. induction R; intros; subst. 130 | { intros. lets [Hv|(t'&mu'&Hp)]: progress_result HT HS. 131 | { left. hnfs*. } 132 | { right. exists*. } } 133 | { intros. destruct c2 as (t2,mu2). 134 | forwards* (Y'&EP'&HT'&HS'): preservation_result HT H. } 135 | Qed. 136 | 137 | 138 | 139 | -------------------------------------------------------------------------------- /ln/STLC_Exn_Definitions.v: -------------------------------------------------------------------------------- 1 | (*************************************************************************** 2 | * Safety for STLC with Exceptions - Definitions * 3 | * Arthur Chargueraud, July 2007 * 4 | ***************************************************************************) 5 | 6 | Set Implicit Arguments. 7 | From TLC Require Import LibLN. 8 | 9 | (** Grammar of types. *) 10 | 11 | Parameter atm : Set. 12 | 13 | Inductive typ : Set := 14 | | typ_exn : typ 15 | | typ_var : atm -> typ 16 | | typ_arrow : typ -> typ -> typ. 17 | 18 | (** Grammar of pre-terms. *) 19 | 20 | Inductive trm : Set := 21 | | trm_bvar : nat -> trm 22 | | trm_fvar : var -> trm 23 | | trm_abs : trm -> trm 24 | | trm_app : trm -> trm -> trm 25 | | trm_raise : trm -> trm 26 | | trm_catch : trm -> trm -> trm. 27 | 28 | (** Opening up abstractions *) 29 | 30 | Fixpoint open_rec (k : nat) (u : trm) (t : trm) {struct t} : trm := 31 | match t with 32 | | trm_bvar i => If k = i then u else (trm_bvar i) 33 | | trm_fvar x => trm_fvar x 34 | | trm_abs t1 => trm_abs (open_rec (S k) u t1) 35 | | trm_app t1 t2 => trm_app (open_rec k u t1) (open_rec k u t2) 36 | | trm_raise t1 => trm_raise (open_rec k u t1) 37 | | trm_catch t1 t2 => trm_catch (open_rec k u t1) (open_rec k u t2) 38 | end. 39 | 40 | Definition open t u := open_rec 0 u t. 41 | 42 | Notation "{ k ~> u } t" := (open_rec k u t) (at level 67). 43 | Notation "t ^^ u" := (open t u) (at level 67). 44 | Notation "t ^ x" := (open t (trm_fvar x)). 45 | 46 | (** Terms are locally-closed pre-terms *) 47 | 48 | Inductive term : trm -> Prop := 49 | | term_var : forall x, 50 | term (trm_fvar x) 51 | | term_abs : forall L t1, 52 | (forall x, x \notin L -> term (t1 ^ x)) -> 53 | term (trm_abs t1) 54 | | term_app : forall t1 t2, 55 | term t1 -> term t2 -> term (trm_app t1 t2) 56 | | term_raise : forall t1, 57 | term t1 -> 58 | term (trm_raise t1) 59 | | term_catch : forall t1 t2, 60 | term t1 -> 61 | term t2 -> 62 | term (trm_catch t1 t2). 63 | 64 | (** Environment is an associative list mapping variables to types. *) 65 | 66 | Definition env := LibEnv.env typ. 67 | 68 | (** Typing relation *) 69 | 70 | Reserved Notation "E |= t ~: T" (at level 69). 71 | 72 | Inductive typing : env -> trm -> typ -> Prop := 73 | | typing_var : forall E x T, 74 | ok E -> 75 | binds x T E -> 76 | E |= (trm_fvar x) ~: T 77 | | typing_abs : forall L E U T t1, 78 | (forall x, x \notin L -> (E & x ~ U) |= t1 ^ x ~: T) -> 79 | E |= (trm_abs t1) ~: (typ_arrow U T) 80 | | typing_app : forall S T E t1 t2, 81 | E |= t1 ~: (typ_arrow S T) -> E |= t2 ~: S -> 82 | E |= (trm_app t1 t2) ~: T 83 | | typing_raise : forall E t1 T, 84 | E |= t1 ~: typ_exn -> 85 | E |= (trm_raise t1) ~: T 86 | | typing_catch : forall E t1 t2 T, 87 | E |= t1 ~: (typ_arrow typ_exn T) -> 88 | E |= t2 ~: T -> 89 | E |= (trm_catch t1 t2) ~: T 90 | 91 | where "E |= t ~: T" := (typing E t T). 92 | 93 | (** Definition of values (only abstractions are values) *) 94 | 95 | Inductive value : trm -> Prop := 96 | | value_abs : forall t1, 97 | term (trm_abs t1) -> value (trm_abs t1). 98 | 99 | (** Exception generation *) 100 | 101 | Inductive fails : trm -> trm -> Prop := 102 | | fails_raise_val : forall t1, 103 | value t1 -> 104 | fails (trm_raise t1) t1 105 | | fails_raise_1 : forall t1 e, 106 | fails t1 e -> 107 | fails (trm_raise t1) e 108 | | fails_app_1 : forall t1 t2 e, 109 | term t2 -> 110 | fails t1 e -> 111 | fails (trm_app t1 t2) e 112 | | fails_app_2 : forall t1 t2 e, 113 | value t1 -> 114 | fails t2 e -> 115 | fails (trm_app t1 t2) e. 116 | 117 | (** Reduction relation - one step in call-by-value *) 118 | 119 | Inductive red : trm -> trm -> Prop := 120 | | red_beta : forall t1 t2, 121 | term (trm_abs t1) -> 122 | value t2 -> 123 | red (trm_app (trm_abs t1) t2) (t1 ^^ t2) 124 | | red_app_1 : forall t1 t1' t2, 125 | term t2 -> 126 | red t1 t1' -> 127 | red (trm_app t1 t2) (trm_app t1' t2) 128 | | red_app_2 : forall t1 t2 t2', 129 | value t1 -> 130 | red t2 t2' -> 131 | red (trm_app t1 t2) (trm_app t1 t2') 132 | | red_catch_2 : forall t1 t2 t2', 133 | term t1 -> 134 | red t2 t2' -> 135 | red (trm_catch t1 t2) (trm_catch t1 t2') 136 | | red_catch_val : forall t1 t2, 137 | term t1 -> 138 | value t2 -> 139 | red (trm_catch t1 t2) t2 140 | | red_catch_exn : forall t1 t2 e, 141 | term t1 -> 142 | fails t2 e -> 143 | red (trm_catch t1 t2) (trm_app t1 e) 144 | | red_raise_1 : forall t1 t1', 145 | red t1 t1' -> 146 | red (trm_raise t1) (trm_raise t1'). 147 | 148 | Notation "t --> t'" := (red t t') (at level 68). 149 | 150 | (** Goal is to prove preservation and progress *) 151 | 152 | Definition preservation := forall E t t' T, 153 | E |= t ~: T -> 154 | t --> t' -> 155 | E |= t' ~: T. 156 | 157 | Definition progress := forall t T, 158 | empty |= t ~: T -> 159 | value t 160 | \/ (exists e, fails t e) 161 | \/ (exists t', t --> t'). 162 | 163 | -------------------------------------------------------------------------------- /pretty/LambdaExnSum_EncodeExn.v: -------------------------------------------------------------------------------- 1 | (************************************************************ 2 | * Lambda-calculus with exceptions and sums, * 3 | * Encoding of exceptions into sums * 4 | *************************************************************) 5 | 6 | Set Implicit Arguments. 7 | Require Export LambdaExnSum_Syntax. 8 | 9 | Implicit Types v : val. 10 | Implicit Types t : trm. 11 | 12 | 13 | (*==========================================================*) 14 | (* * Definitions *) 15 | 16 | (************************************************************) 17 | (* ** Variables introduced by the translation *) 18 | 19 | Parameter x1 x2 x3 : var. 20 | Parameter x1_neq_x2 : x1 <> x2. 21 | Parameter x1_neq_x3 : x1 <> x3. 22 | Parameter x2_neq_x3 : x2 <> x3. 23 | 24 | Definition L := x1::x2::x3::nil. 25 | Lemma L_eq : L = x1::x2::x3::nil. 26 | Proof. auto. Defined. 27 | Global Opaque L. 28 | 29 | Hint Resolve x1_neq_x2 x2_neq_x3 x1_neq_x3. 30 | 31 | Hint Extern 1 (_ \notin _) => rewrite L_eq in *. 32 | 33 | Coercion trm_var : var >-> trm. 34 | 35 | (************************************************************) 36 | (* ** Definition of the translation *) 37 | 38 | Definition tr_ret t := trm_inj true t. 39 | Definition tr_exn t := trm_inj false t. 40 | 41 | Definition tr_bind t' x k := 42 | trm_case t' (trm_abs x k) (trm_abs x (tr_exn (trm_var x))). 43 | 44 | Definition tr_cont t' := 45 | trm_abs x2 (tr_bind t' x3 (trm_app x3 x2)). 46 | 47 | Fixpoint tr_trm (t:trm) : trm := 48 | let s := tr_trm in 49 | match t with 50 | | trm_val v => tr_ret (tr_val v) 51 | | trm_var y => tr_ret t 52 | | trm_abs y t3 => tr_ret (trm_abs y (s t3)) 53 | | trm_app t1 t2 => 54 | tr_bind (s t1) x1 55 | (tr_bind (s t2) x2 56 | (trm_app x1 x2)) 57 | | trm_inj b t1 => 58 | tr_bind (s t1) x1 (tr_ret (trm_inj b x1)) 59 | | trm_case t1 t2 t3 => 60 | tr_bind (s t1) x1 61 | (trm_case x1 (tr_cont (s t2)) (tr_cont (s t3))) 62 | | trm_try t1 t2 => 63 | trm_case (s t1) (trm_abs x1 (tr_ret x1)) 64 | (tr_cont (s t2)) 65 | | trm_raise t1 => 66 | tr_bind (s t1) x1 (tr_exn x1) 67 | end 68 | 69 | with tr_val (v:val) : val := 70 | match v with 71 | | val_abs y t3 => val_abs y (tr_trm t3) 72 | | val_inj b v1 => val_inj b (tr_val v1) 73 | | _ => v 74 | end. 75 | 76 | 77 | 78 | (*==========================================================*) 79 | (* * Proofs *) 80 | 81 | 82 | (************************************************************) 83 | (* * Freshness *) 84 | 85 | (** Distribution of substitution over the translation *) 86 | 87 | Ltac imp x := 88 | try rewrite L_eq in *; 89 | asserts: (x \notin \{x}); [ auto | notin_false ]. 90 | 91 | Ltac imp_any := 92 | solve [ imp x1 | imp x2 | imp x3 ]. 93 | 94 | Ltac neq_any := 95 | solve [ false x1_neq_x2; assumption 96 | | false x1_neq_x3; assumption 97 | | false x2_neq_x3; assumption ]. 98 | 99 | Ltac simpl_subst := 100 | repeat (case_if; subst; try neq_any; try imp_any). 101 | 102 | Lemma tr_val_subst : forall x v t, 103 | fresh (trm_vars not_used t \u \{x}) 3 L -> 104 | tr_trm (subst x v t) = subst x (tr_val v) (tr_trm t). 105 | Proof. 106 | induction t; introv F; simpls. 107 | fequals. 108 | simpl_subst; fequals. 109 | simpl_subst; fequals. rewrite~ IHt. 110 | simpl_subst. rewrite~ IHt1. rewrite~ IHt2. 111 | simpl_subst. rewrite~ IHt. 112 | simpl_subst. rewrite~ IHt1. 113 | rewrite~ IHt2. rewrite~ IHt3. 114 | simpl_subst. rewrite~ IHt1. rewrite~ IHt2. 115 | simpl_subst. rewrite~ IHt. 116 | Qed. 117 | 118 | Lemma subst_tr_bind : forall t x k y v, 119 | x <> y -> 120 | subst y v (tr_bind t x k) 121 | = tr_bind (subst y v t) x (subst y v k). 122 | Proof. introv N. simpl. case_if. fequals. Qed. 123 | 124 | Lemma subst_tr_cont : forall t y v, 125 | fresh (\{y}) 2 (x2::x3::nil) -> 126 | subst y v (tr_cont t) 127 | = tr_cont (subst y v t). 128 | Proof. introv H. simpl. simpl_subst. fequals. Qed. 129 | 130 | Lemma tr_trm_vars : forall t, 131 | fresh (trm_vars not_used t) 3 L -> 132 | fresh (trm_vars not_free (tr_trm t)) 3 L 133 | with tr_val_vars : forall v, 134 | fresh (trm_vars not_used v) 3 L -> 135 | fresh (trm_vars not_free (tr_val v)) 3 L. 136 | Proof. 137 | (* trm *) 138 | induction t; introv F; simpls. 139 | apply~ tr_val_vars. 140 | auto. 141 | applys~ fresh_remove_weaken. 142 | specializes~ IHt1. specializes~ IHt2. fset_simpl. 143 | do 2 (rewrite union_remove; [ | apply~ notin_elim_single ]). 144 | auto. 145 | specializes~ IHt. fset_simpl. auto. 146 | specializes~ IHt1. specializes~ IHt2. specializes~ IHt3. 147 | fset_simpl. 148 | rewrite (@union_remove' _ \{x2}); [ | apply~ notin_elim_single ]. 149 | do 2 (rewrite union_remove; [ | apply~ notin_elim_single ]). 150 | rewrite union_remove'; [ | apply~ notin_elim_single ]. 151 | auto. 152 | specializes~ IHt1. specializes~ IHt2. fset_simpl. 153 | rewrite union_remove'; [ | apply~ notin_elim_single ]. 154 | rewrite union_remove; [ | apply~ notin_elim_single ]. 155 | auto. 156 | specializes~ IHt. fset_simpl. auto. 157 | (* val *) 158 | induction v; introv F; simpls. 159 | auto. 160 | applys fresh_remove_weaken. applys~ tr_trm_vars. 161 | auto. 162 | Qed. 163 | 164 | -------------------------------------------------------------------------------- /ln/STLC_Data_Soundness.v: -------------------------------------------------------------------------------- 1 | (*************************************************************************** 2 | * Safety for STLC with Datatypes - Proofs * 3 | * Arthur Chargueraud, July 2007 * 4 | ***************************************************************************) 5 | 6 | Set Implicit Arguments. 7 | From Coq Require Import List. 8 | From TLC Require Import LibLN. 9 | Require Import STLC_Data_Definitions STLC_Data_Infrastructure. 10 | 11 | (* ********************************************************************** *) 12 | (** * Proofs *) 13 | 14 | (** Typing is preserved by weakening. *) 15 | 16 | Lemma typing_weaken : forall G E F t T, 17 | (E & G) |= t ~: T -> 18 | ok (E & F & G) -> 19 | (E & F & G) |= t ~: T. 20 | Proof. 21 | introv Typ. gen_eq (E & G) as H. gen G. 22 | induction Typ; introv EQ Ok; subst. 23 | apply* typing_var. apply* binds_weaken. 24 | apply_fresh* typing_abs. intros y Fr. 25 | do_rew* concat_assoc (apply* H0). 26 | apply_fresh* typing_fix. intros y f Fr2. 27 | do_rew_2* concat_assoc (apply* H0). 28 | apply_fresh* (@typing_match T Us). intros xs Fr. 29 | do_rew* concat_assoc (apply* H1). 30 | autos*. 31 | autos*. 32 | autos*. 33 | autos*. 34 | autos*. 35 | Qed. 36 | 37 | (** Typing is preserved by substitution. *) 38 | 39 | Lemma typing_subst : forall F U E t T z u, 40 | (E & z ~ U & F) |= t ~: T -> 41 | E |= u ~: U -> 42 | (E & F) |= [z ~> u]t ~: T. 43 | Proof. 44 | introv Typt Typu. gen_eq (E & z ~ U & F) as G. gen F. 45 | induction Typt; introv Equ; subst; simpl subst. 46 | case_var. 47 | binds_get H0. apply_empty* typing_weaken. 48 | binds_cases H0; apply* typing_var. 49 | apply_fresh typing_abs. intros y Fr. 50 | rewrite* subst_open_vars. 51 | do_rew concat_assoc (apply* H0). 52 | apply_fresh typing_fix. intros y f Fr. 53 | rewrite* subst_open_vars. 54 | do_rew_2 concat_assoc (apply* H0). 55 | apply_fresh* (@typing_match T Us). intros xs Fr. 56 | rewrite* subst_open_vars. 57 | do_rew* concat_assoc (apply* H1). 58 | autos*. 59 | autos*. 60 | autos*. 61 | autos*. 62 | autos*. 63 | Qed. 64 | 65 | (** Typing is preserved by iterated substitution. *) 66 | 67 | Lemma typing_substs : forall Us E xs ts t T, 68 | length xs = length ts -> 69 | typings E ts Us -> 70 | E & (iter_push xs Us) |= t ~: T -> 71 | E |= substs xs ts t ~: T. 72 | Proof. 73 | intros Us E xs. gen Us E. 74 | induction xs; simpl; introv Le Typts Typt. auto. 75 | destruct ts; simpls; inversions Le. inversions Typts. 76 | rewrite iter_push_cons in Typt. 77 | rewrite <- concat_assoc in Typt. 78 | apply* (@IHxs Us0). 79 | apply* typing_subst. 80 | Qed. 81 | 82 | (** Typing the result of pattern matching. *) 83 | 84 | Lemma typing_pattern_match : forall p t T E ts Us, 85 | Some ts = pat_match p t -> 86 | E |= t ~: T -> 87 | Us \= p ~: T -> 88 | typings E ts Us. 89 | Proof. 90 | induction p; introv EQ Typt Typp; destruct t; 91 | inversion Typp; inversion EQ; auto; subst; inversions Typt; autos*. 92 | remember (pat_match p1 t1) as K1. 93 | remember (pat_match p2 t2) as K2. 94 | destruct K1 as [ts1|]; destruct K2 as [ts2|]; try discriminate. 95 | inversions H6. apply* typings_concat. 96 | Qed. 97 | 98 | (** Preservation (typing is preserved by reduction). *) 99 | 100 | Lemma preservation_result : preservation. 101 | Proof. 102 | introv Typ. gen t'. 103 | induction Typ; introv Red; inversions Red. 104 | pick_freshes (pat_arity p) xs. 105 | forward~ (@pat_match_terms p t1 ts) as K. 106 | rewrite (fresh_length _ _ _ Fr) in K. 107 | rewrite* (@substs_intro xs). 108 | apply~ (@typing_substs Us). unfolds terms. auto. 109 | apply~ (@typing_pattern_match p t1 T). 110 | autos*. 111 | autos*. 112 | inversions Typ1. pick_fresh x. 113 | rewrite* (@substs_intro (x::nil)). unfolds substs. 114 | apply_empty* typing_subst. 115 | inversions Typ1. pick_fresh f. pick_fresh x. 116 | rewrite* (@substs_intro (x::f::nil)). unfolds substs. 117 | apply_empty* typing_subst. 118 | apply_empty* typing_subst. 119 | apply_empty* typing_weaken. 120 | autos*. 121 | autos*. 122 | autos*. 123 | autos*. 124 | autos*. 125 | autos*. 126 | Qed. 127 | 128 | (** Progress (a well-typed term is either a value or it can 129 | take a step of reduction). *) 130 | 131 | Lemma progress_result : progress. 132 | Proof. 133 | introv Typ. gen_eq (empty : env) as E. poses Typ' Typ. 134 | induction Typ; intros; subst. 135 | contradictions. 136 | left*. 137 | left*. 138 | right. destruct~ IHTyp1 as [Val1 | [t1' Red1]]. 139 | remember (pat_match p t1) as r. symmetry in Heqr. destruct r as [ts|]. 140 | exists* (e ^^ ts). 141 | exists* t2. 142 | exists* (trm_match t1' p e t2). 143 | right. destruct~ IHTyp1 as [Val1 | [t1' Red1]]. 144 | destruct~ IHTyp2 as [Val2 | [t2' Red2]]. 145 | inversions Typ1; inversions Val1. 146 | exists* (t0 ^^ (t2::nil)). 147 | exists* (t0 ^^ (t2::(trm_fix t0)::nil)). 148 | exists* (trm_app t1 t2'). 149 | exists* (trm_app t1' t2). 150 | left*. 151 | destruct~ IHTyp1 as [Val1 | [t1' Red1]]. 152 | destruct~ IHTyp2 as [Val2 | [t2' Red2]]. 153 | right. exists* (trm_pair t1 t2'). 154 | right. exists* (trm_pair t1' t2). 155 | destruct~ IHTyp as [Val1 | [t1' Red1]]. 156 | right. exists* (trm_inj1 t1'). 157 | destruct~ IHTyp as [Val1 | [t1' Red1]]. 158 | right. exists* (trm_inj2 t1'). 159 | Qed. 160 | 161 | 162 | -------------------------------------------------------------------------------- /pretty/LambdaExn_PrettyErr_Typing_Sound.v: -------------------------------------------------------------------------------- 1 | (************************************************************ 2 | * Lambda-calculus with exceptions, * 3 | * Pretty-big-step semantics * 4 | *************************************************************) 5 | 6 | Set Implicit Arguments. 7 | Require Export LambdaExn_PrettyErr. 8 | 9 | 10 | (*==========================================================*) 11 | (* * Typing *) 12 | 13 | (************************************************************) 14 | (* ** Grammar of simple types *) 15 | 16 | CoInductive typ := 17 | | typ_int : typ 18 | | typ_arrow : typ -> typ -> typ. 19 | 20 | 21 | (************************************************************) 22 | (* ** Typing judgment *) 23 | 24 | Inductive trmtyping : env typ -> trm -> typ -> Prop := 25 | | trmtyping_var : forall E x T, 26 | binds x T E -> 27 | trmtyping E (trm_var x) T 28 | | trmtyping_abs : forall x E U T t1, 29 | trmtyping (E & x ~~ U) t1 T -> 30 | trmtyping E (trm_abs x t1) (typ_arrow U T) 31 | | trmtyping_app : forall T1 T2 E t1 t2, 32 | trmtyping E t1 (typ_arrow T1 T2) -> 33 | trmtyping E t2 T1 -> 34 | trmtyping E (trm_app t1 t2) T2 35 | | trmtyping_raise : forall E t1 T, 36 | trmtyping E t1 typ_int -> 37 | trmtyping E (trm_raise t1) T 38 | | trmtyping_try : forall E t1 x t2 T, 39 | trmtyping E t1 T -> 40 | trmtyping (E & x~~typ_int) t2 T -> 41 | trmtyping E (trm_try t1 x t2) T. 42 | 43 | 44 | Inductive valtyping : val -> typ -> Prop := 45 | | valtyping_int : forall k, 46 | valtyping (val_int k) typ_int 47 | | valtyping_clo : forall E s x T1 T2 t1, 48 | stacktyping E s -> 49 | trmtyping (E & x ~~ T1) t1 T2 -> 50 | valtyping (val_clo s x t1) (typ_arrow T1 T2) 51 | 52 | with stacktyping : env typ -> stack -> Prop := 53 | | stacktyping_intro : forall E s, 54 | (forall x T, binds x T E -> 55 | exists v, binds x v s /\ valtyping v T) -> 56 | stacktyping E s. 57 | 58 | (* Alternative definition: 59 | | stacktyping_empty : 60 | stacktyping empty 61 | | stacktyping_push : forall s x v T, 62 | stacktyping s -> 63 | valtyping v T -> 64 | stacktyping (s & x ~~ v). 65 | *) 66 | 67 | Inductive outtyping : out -> typ -> Prop := 68 | | outtyping_ter : forall v T, 69 | valtyping v T -> 70 | outtyping (out_beh v) T 71 | | outtyping_exn : forall v T, 72 | valtyping v typ_int -> 73 | outtyping (out_exn v) T 74 | | outtyping_div : forall T, 75 | outtyping out_div T. 76 | 77 | Inductive exttyping : env typ -> ext -> typ -> Prop := 78 | | extyping_trm : forall E t T, 79 | trmtyping E t T -> 80 | exttyping E t T 81 | | exttyping_app_1 : forall E T1 T2 o1 t2, 82 | outtyping o1 (typ_arrow T1 T2) -> 83 | trmtyping E t2 T1 -> 84 | exttyping E (ext_app_1 o1 t2) T2 85 | | exttyping_app_2 : forall E T1 T2 v1 o2, 86 | valtyping v1 (typ_arrow T1 T2) -> 87 | outtyping o2 T1 -> 88 | exttyping E (ext_app_2 v1 o2) T2 89 | | extyping_raise_1 : forall E T o1, 90 | outtyping o1 typ_int -> 91 | exttyping E (ext_raise_1 o1) T 92 | | extyping_try_1 : forall E T o1 x t2, 93 | outtyping o1 T -> 94 | trmtyping (E & x ~~ typ_int) t2 T -> 95 | exttyping E (ext_try_1 o1 x t2) T. 96 | 97 | 98 | (*==========================================================*) 99 | (* * Proofs *) 100 | 101 | Lemma stacktyping_push : forall E s x v T, 102 | stacktyping E s -> 103 | valtyping v T -> 104 | stacktyping (E & x ~~ T) (s & x ~~ v). 105 | Proof. 106 | introv M H. inverts M as M. 107 | constructors. introv B. binds_cases B. 108 | forwards* (v'&?&?): M. 109 | subst*. 110 | Qed. 111 | 112 | Lemma stacktyping_binds : forall E x s v T, 113 | stacktyping E s -> binds x v s -> binds x T E -> 114 | valtyping v T. 115 | Proof. 116 | introv M Bv BT. inverts M as M. 117 | forwards* (v'&Bv'&?): M. unfolds binds. 118 | asserts: (v = v'). congruence. subst*. 119 | Qed. 120 | 121 | Lemma stacktyping_elim_1 : forall E x s T, 122 | stacktyping E s -> binds x T E -> exists v, binds x v s. 123 | Proof. 124 | introv M B. inverts M as M. forwards* (?&?&?): M. 125 | Qed. 126 | 127 | Hint Resolve stacktyping_push stacktyping_binds. 128 | 129 | 130 | (************************************************************) 131 | (* ** Soundness *) 132 | 133 | Hint Constructors one abort outtyping exttyping valtyping. 134 | 135 | Lemma abort_outyping : forall o T T', 136 | abort o -> outtyping o T -> outtyping o T'. 137 | Proof. 138 | introv A M. inverts M; inverts A; auto. 139 | Qed. 140 | 141 | Lemma soundness_ind : forall E s e o T, 142 | red s e o -> 143 | stacktyping E s -> 144 | exttyping E e T -> 145 | outtyping o T. 146 | Proof. 147 | introv R. gen E T. induction R; introv S M. 148 | inverts M as M. inverts* M. 149 | inverts M as M. inverts* M. 150 | inverts M as M. inverts* M. 151 | inverts M as M1 M2. forwards*: abort_outyping H. 152 | inverts M as M. inverts* M. 153 | inverts M as M1 M2. forwards*: abort_outyping H. 154 | inverts M as M1 M2. inverts M2. inverts* M1. 155 | inverts M as M. inverts* M. 156 | inverts M as M. inverts* M. 157 | inverts M as M. inverts* M. 158 | inverts M as M. inverts* M. 159 | inverts M as M. inverts* M. 160 | inverts M as M1 M2. forwards*: abort_outyping H. 161 | inverts M as M. inverts* M. 162 | false (rm H). inverts M as. 163 | introv M. inverts* M. forwards* (?&?): stacktyping_elim_1. 164 | introv M1 M2. inverts* M1. 165 | introv M1 M2. inverts M1. inverts* M2. 166 | introv M1. inverts* M1. 167 | introv M1 M2. inverts* M1. 168 | Qed. 169 | -------------------------------------------------------------------------------- /ln/CoC_BetaStar.v: -------------------------------------------------------------------------------- 1 | (*************************************************************************** 2 | * Calculus of Constructions - Properties of Beta Star * 3 | * Arthur Chargueraud, April 2007 * 4 | ***************************************************************************) 5 | 6 | Set Implicit Arguments. 7 | From TLC Require Import LibLN. 8 | Require Import CoC_Definitions CoC_Infrastructure. 9 | 10 | 11 | (* ********************************************************************** *) 12 | (** ** Generalities on relations *) 13 | 14 | Lemma red_all_to_out : forall (R : relation), 15 | red_all R -> red_refl R -> red_out R. 16 | Proof. 17 | intros_all. autos*. 18 | Qed. 19 | 20 | Lemma red_out_to_rename : forall (R : relation), 21 | red_out R -> red_rename R. 22 | Proof. 23 | intros_all. 24 | rewrite* (@subst_intro x t). 25 | rewrite* (@subst_intro x t'). 26 | Qed. 27 | 28 | Lemma red_all_to_through : forall (R : relation), 29 | red_regular R -> red_all R -> red_through R. 30 | Proof. 31 | intros_all. lets: (H _ _ H4). 32 | rewrite* (@subst_intro x t1). 33 | rewrite* (@subst_intro x u1). 34 | Qed. 35 | 36 | 37 | (* ********************************************************************** *) 38 | (** ** Properties of beta relation *) 39 | 40 | Lemma beta_red_out : red_out beta. 41 | Proof. 42 | intros_all. induction H0; simpl. 43 | rewrite* subst_open. 44 | apply* beta_app1. 45 | apply* beta_app2. 46 | apply* beta_abs1. 47 | apply_fresh* beta_abs2 as y. cross*. 48 | apply* beta_prod1. 49 | apply_fresh* beta_prod2 as y. cross*. 50 | Qed. 51 | 52 | Lemma beta_red_rename : red_rename beta. 53 | Proof. 54 | apply* (red_out_to_rename beta_red_out). 55 | Qed. 56 | 57 | (* ********************************************************************** *) 58 | (** ** Properties of beta star relation *) 59 | 60 | Lemma beta_star_app1 : forall t1 t1' t2, 61 | (beta star) t1 t1' -> term t2 -> 62 | (beta star) (trm_app t1 t2) (trm_app t1' t2). 63 | Proof. 64 | intros. induction H. 65 | apply* star_refl. 66 | apply* (@star_trans beta (trm_app t0 t2)). 67 | apply* star_step. 68 | Qed. 69 | 70 | Lemma beta_star_app2 : forall t1 t2 t2', 71 | (beta star) t2 t2' -> term t1 -> 72 | (beta star) (trm_app t1 t2) (trm_app t1 t2'). 73 | Proof. 74 | intros. induction H. 75 | apply* star_refl. 76 | apply* (@star_trans beta (trm_app t1 t2)). 77 | apply* star_step. 78 | Qed. 79 | 80 | Lemma beta_star_abs1 : forall t1 t1' t2, 81 | (beta star) t1 t1' -> body t2 -> 82 | (beta star) (trm_abs t1 t2) (trm_abs t1' t2). 83 | Proof. 84 | intros. induction H. 85 | apply* star_refl. 86 | apply* (@star_trans beta (trm_abs t0 t2)). 87 | apply* star_step. 88 | Qed. 89 | 90 | Lemma beta_star_prod1 : forall t1 t1' t2, 91 | (beta star) t1 t1' -> body t2 -> 92 | (beta star) (trm_prod t1 t2) (trm_prod t1' t2). 93 | Proof. 94 | intros. induction H. 95 | apply* star_refl. 96 | apply* (@star_trans beta (trm_prod t0 t2)). 97 | apply* star_step. 98 | Qed. 99 | 100 | Lemma beta_star_abs2 : forall L t1 t2 t2', 101 | term t1 -> 102 | (forall x, x \notin L -> (beta star) (t2 ^ x) (t2' ^ x)) -> 103 | (beta star) (trm_abs t1 t2) (trm_abs t1 t2'). 104 | Proof. 105 | introv R1 R2. pick_fresh x. forwards~ Red: (R2 x). 106 | assert (body t2). 107 | exists L. intros y Fry. forwards*: (R2 y). 108 | assert (body t2'). 109 | exists L. intros y Fry. forwards*: (R2 y). 110 | gen_eq u: (t2 ^ x). gen_eq u': (t2' ^ x). 111 | clear R2. gen t2 t2'. 112 | induction Red; intros; subst. 113 | rewrite* (@open_var_inj x t2 t2'). 114 | destruct~ (@close_var_spec t2 x) as [u [P [Q R]]]. 115 | apply* (@star_trans beta (trm_abs t1 u)). 116 | apply star_step. 117 | apply_fresh* beta_abs2 as y. 118 | apply* (@beta_red_rename x). 119 | Qed. 120 | 121 | Lemma beta_star_prod2 : forall L t1 t2 t2', 122 | term t1 -> 123 | (forall x, x \notin L -> (beta star) (t2 ^ x) (t2' ^ x)) -> 124 | (beta star) (trm_prod t1 t2) (trm_prod t1 t2'). 125 | Proof. 126 | introv R1 R2. pick_fresh x. forwards~ Red: (R2 x). 127 | assert (body t2). 128 | exists L. intros y Fry. forwards*: (R2 y). 129 | assert (body t2'). 130 | exists L. intros y Fry. forwards*: (R2 y). 131 | gen_eq u: (t2 ^ x). gen_eq u': (t2' ^ x). 132 | clear R2. gen t2 t2'. 133 | induction Red; intros; subst. 134 | rewrite* (@open_var_inj x t2 t2'). 135 | destruct~ (@close_var_spec t2 x) as [u [P [Q R]]]. 136 | apply* (@star_trans beta (trm_prod t1 u)). 137 | apply star_step. 138 | apply_fresh* beta_prod2 as y. 139 | apply* (@beta_red_rename x). 140 | Qed. 141 | 142 | Lemma beta_star_red_in : red_in (beta star). 143 | Proof. 144 | introv Wf Red. lets: term. induction Wf; simpl. 145 | case_var*. 146 | apply~ (@star_trans beta (trm_app ([x ~> u']t1) ([x ~> u]t2))). 147 | apply* beta_star_app1. 148 | apply* beta_star_app2. 149 | autos*. 150 | apply~ (@star_trans beta (trm_abs ([x ~> u']t1) ([x ~> u]t2))). 151 | apply* beta_star_abs1. 152 | apply* (@beta_star_abs2 (L \u \{x})). intros y Fr. cross*. 153 | apply~ (@star_trans beta (trm_prod ([x ~> u']t1) ([x ~> u]t2))). 154 | apply* beta_star_prod1. 155 | apply* (@beta_star_prod2 (L \u \{x})). intros y Fr. cross*. 156 | Qed. 157 | 158 | Lemma beta_star_red_all : red_all (beta star). 159 | Proof. 160 | introv Redt. induction Redt; simpl; intros u u' Redu. 161 | apply* beta_star_red_in. 162 | apply* (@star_trans beta ([x ~> u]t2)). 163 | apply* (@star_trans beta ([x ~> u]t')). 164 | apply* star_step. apply* beta_red_out. 165 | apply* beta_star_red_in. 166 | Qed. 167 | 168 | Lemma beta_star_red_through : red_through (beta star). 169 | Proof. 170 | apply* (red_all_to_through red_regular_beta_star beta_star_red_all). 171 | Qed. 172 | 173 | -------------------------------------------------------------------------------- /omni/LibSepVar.v: -------------------------------------------------------------------------------- 1 | (**************************************************************** 2 | * Representation of Variables as Strings * 3 | * Utility Functions * 4 | ****************************************************************) 5 | 6 | Set Implicit Arguments. 7 | From TLC Require Export LibString LibList LibCore. 8 | Open Scope string_scope. 9 | 10 | 11 | (* ########################################################### *) 12 | (* ########################################################### *) 13 | (* ########################################################### *) 14 | (** * Representation of Program Variables *) 15 | 16 | (** This file contains definitions, lemmas, tactics and notations for 17 | manipulating program variables and list of program variables. *) 18 | 19 | 20 | (* ########################################################### *) 21 | (** ** Representation of Variables *) 22 | 23 | (** Variables are represented as strings *) 24 | 25 | Definition var : Type := string. 26 | 27 | (** The boolean function [var_eq s1 s2] compares two variables. *) 28 | 29 | Definition var_eq (s1:var) (s2:var) : bool := 30 | if String.string_dec s1 s2 then true else false. 31 | 32 | (** The boolean function [var_eq s1 s2] returns [true] iff the 33 | equality [v1 = v2] holds. *) 34 | 35 | Lemma var_eq_spec : forall s1 s2, 36 | var_eq s1 s2 = isTrue (s1 = s2). 37 | Proof using. 38 | intros. unfold var_eq. case_if; rew_bool_eq~. 39 | Qed. 40 | 41 | Global Opaque var. 42 | 43 | 44 | (* ########################################################### *) 45 | (** ** Tactic [case_var] *) 46 | 47 | (** The tactic [case_var] performs case analysis on expressions of the 48 | form [if var_eq x y then .. else ..] that appear in the goal. *) 49 | 50 | Tactic Notation "case_var" := 51 | repeat rewrite var_eq_spec in *; repeat case_if. 52 | 53 | Tactic Notation "case_var" "~" := 54 | case_var; auto_tilde. 55 | 56 | Tactic Notation "case_var" "*" := 57 | case_var; auto_star. 58 | 59 | 60 | (* ########################################################### *) 61 | (* ########################################################### *) 62 | (* ########################################################### *) 63 | (** * Representation of List of Variables *) 64 | 65 | (* ########################################################### *) 66 | (** ** Definition of Distinct Variables *) 67 | 68 | (** [vars] is the type of a list of variables *) 69 | 70 | Definition vars : Type := list var. 71 | 72 | (** [var_fresh y xs] asserts that [y] does not belong to the list [xs] *) 73 | 74 | Definition var_fresh (y:var) (xs:vars) : Prop := 75 | ~ mem y xs. 76 | 77 | (** The following lemma asserts that if [x] is a variable in the list [xs], 78 | and [y] is fresh from this list [xs], then [y] is not equal to [x]. *) 79 | 80 | Lemma var_fresh_mem_inv : forall y x xs, 81 | var_fresh x xs -> 82 | mem y xs -> 83 | x <> y. 84 | Proof using. introv H M N. unfolds var_fresh. subst*. Qed. 85 | 86 | 87 | (* ########################################################### *) 88 | (** ** Generation of [n] Distinct Variables *) 89 | 90 | (** [nat_to_var n] converts [nat] values into distinct [name] values. *) 91 | 92 | (* LATER: make the implementation more optimized by using more than one 93 | character. *) 94 | 95 | Definition dummy_char := 96 | Ascii.ascii_of_nat 0%nat. 97 | 98 | Fixpoint nat_to_var (n:nat) : var := 99 | match n with 100 | | O => String.EmptyString 101 | | S n' => String.String dummy_char (nat_to_var n') 102 | end. 103 | 104 | Lemma injective_nat_to_var : 105 | injective nat_to_var. 106 | Proof using. 107 | intros n. induction n as [|n']; intros m E; destruct m as [|m']; tryfalse. 108 | { auto. } 109 | { inverts E. fequals~. } 110 | Qed. 111 | 112 | (** [var_seq i n] generates a list of variables [x1;x2;..;xn] with [x1=i] and 113 | [xn=i+n-1]. The ability to start at a given offset is sometimes useful. *) 114 | 115 | Fixpoint var_seq (start:nat) (nb:nat) : vars := 116 | match nb with 117 | | O => nil 118 | | S nb' => (nat_to_var start) :: var_seq (S start) nb' 119 | end. 120 | 121 | (** The properties of [var_seq] are stated next. They assert that this 122 | function produce the expected number of variables, that the variables 123 | are pairwise distinct *) 124 | 125 | Section Var_seq. 126 | Implicit Types start nb : nat. 127 | 128 | Lemma var_fresh_var_seq_lt : forall (x:nat) start nb, 129 | (x < start)%nat -> 130 | var_fresh (nat_to_var x) (var_seq start nb). 131 | Proof using. 132 | intros. unfold var_fresh. gen start. induction nb; simpl; introv N; rew_listx. 133 | { auto. } 134 | { simpl. case_var. rew_logic. split. 135 | { intros E. lets: injective_nat_to_var E. math. } 136 | { applys IHnb. math. } } 137 | Qed. 138 | 139 | Lemma var_fresh_var_seq_ge : forall (x:nat) start nb, 140 | (x >= start+nb)%nat -> 141 | var_fresh (nat_to_var x) (var_seq start nb). 142 | Proof using. 143 | intros. unfold var_fresh. gen start. induction nb; simpl; introv N; rew_listx. 144 | { auto. } 145 | { simpl. case_var. rew_logic. split. 146 | { intros E. lets: injective_nat_to_var E. math. } 147 | { applys IHnb. math. } } 148 | Qed. 149 | 150 | Lemma noduplicates_var_seq : forall start nb, 151 | LibList.noduplicates (var_seq start nb). 152 | Proof using. 153 | intros. gen start. induction nb; intros; simpl; rew_listx. 154 | { auto. } 155 | { split. 156 | { applys var_fresh_var_seq_lt. math. } 157 | { auto. } } 158 | Qed. 159 | 160 | Lemma length_var_seq : forall start nb, 161 | length (var_seq start nb) = nb. 162 | Proof using. 163 | intros. gen start. induction nb; simpl; intros. 164 | { auto. } { rew_list. rewrite~ IHnb. } 165 | Qed. 166 | 167 | End Var_seq. 168 | 169 | -------------------------------------------------------------------------------- /ln/CPS_Definitions.v: -------------------------------------------------------------------------------- 1 | (*************************************************************************** 2 | * Correctness of the CPS-transformation - Definitions * 3 | * Arthur Chargueraud, January 2009 * 4 | ***************************************************************************) 5 | 6 | Set Implicit Arguments. 7 | From TLC Require Export LibLN LibLogic LibFix. 8 | Implicit Types x y z : var. 9 | 10 | (* ********************************************************************** *) 11 | (* ********************************************************************** *) 12 | (** * Syntax of lambda-terms with constants *) 13 | 14 | (* ********************************************************************** *) 15 | (** Grammar of terms *) 16 | 17 | Inductive trm : Set := 18 | | trm_bvar : nat -> trm 19 | | trm_fvar : var -> trm 20 | | trm_cst : nat -> trm 21 | | trm_app : trm -> trm -> trm 22 | | trm_abs : trm -> trm. 23 | 24 | Instance trm_inhab : Inhab trm. 25 | Proof. intros. apply (Inhab_of_val (trm_bvar 0)). Qed. 26 | 27 | 28 | (* ********************************************************************** *) 29 | (** Opening of terms *) 30 | 31 | Fixpoint open_rec (k : nat) (u : trm) (t : trm) {struct t} : trm := 32 | match t with 33 | | trm_bvar i => If k = i then u else (trm_bvar i) 34 | | trm_fvar x => t 35 | | trm_cst k => t 36 | | trm_app t1 t2 => trm_app (open_rec k u t1) (open_rec k u t2) 37 | | trm_abs t1 => trm_abs (open_rec (S k) u t1) 38 | end. 39 | 40 | Definition open t u := open_rec 0 u t. 41 | 42 | Notation "{ k ~> u } t" := (open_rec k u t) (at level 67). 43 | Notation "t ^^ u" := (open t u) (at level 67). 44 | Notation "t ^ x" := (open t (trm_fvar x)). 45 | 46 | 47 | (* ********************************************************************** *) 48 | (** Closing of term *) 49 | 50 | Fixpoint close_var_rec (k : nat) (z : var) (t : trm) {struct t} : trm := 51 | match t with 52 | | trm_bvar i => trm_bvar i 53 | | trm_fvar x => If x = z then (trm_bvar k) else t 54 | | trm_cst k => t 55 | | trm_app t1 t2 => trm_app (close_var_rec k z t1) (close_var_rec k z t2) 56 | | trm_abs t1 => trm_abs (close_var_rec (S k) z t1) 57 | end. 58 | 59 | Definition close_var z t := close_var_rec 0 z t. 60 | 61 | 62 | (* ********************************************************************** *) 63 | (** Local closure of terms *) 64 | 65 | Inductive term : trm -> Prop := 66 | | term_var : forall x, 67 | term (trm_fvar x) 68 | | term_cst : forall k, 69 | term (trm_cst k) 70 | | term_app : forall t1 t2, 71 | term t1 -> term t2 -> term (trm_app t1 t2) 72 | | term_abs : forall L t1, 73 | (forall x, x \notin L -> term (t1 ^ x)) -> 74 | term (trm_abs t1). 75 | 76 | 77 | (* ********************************************************************** *) 78 | (** Body of an abstraction *) 79 | 80 | Definition body t := 81 | exists L, forall x, x \notin L -> term (t ^ x). 82 | 83 | 84 | (* ********************************************************************** *) 85 | (** Free variables of a term *) 86 | 87 | Fixpoint fv (t : trm) {struct t} : vars := 88 | match t with 89 | | trm_bvar i => \{} 90 | | trm_fvar x => \{x} 91 | | trm_cst k => \{} 92 | | trm_app t1 t2 => (fv t1) \u (fv t2) 93 | | trm_abs t1 => (fv t1) 94 | end. 95 | 96 | 97 | (* ********************************************************************** *) 98 | (** Substitution for a name *) 99 | 100 | Fixpoint subst (z : var) (u : trm) (t : trm) {struct t} : trm := 101 | match t with 102 | | trm_bvar i => t 103 | | trm_fvar x => If x = z then u else (trm_fvar x) 104 | | trm_cst k => t 105 | | trm_app t1 t2 => trm_app (subst z u t1) (subst z u t2) 106 | | trm_abs t1 => trm_abs (subst z u t1) 107 | end. 108 | 109 | Notation "[ z ~> u ] t" := (subst z u t) (at level 68). 110 | 111 | 112 | (* ********************************************************************** *) 113 | (* ********************************************************************** *) 114 | (** * Semantics *) 115 | 116 | (* ********************************************************************** *) 117 | (** Values *) 118 | 119 | Inductive value : trm -> Prop := 120 | | value_cst : forall k, 121 | value (trm_cst k) 122 | | value_abs : forall t1, 123 | term (trm_abs t1) -> 124 | value (trm_abs t1). 125 | 126 | 127 | (* ********************************************************************** *) 128 | (** Big-step reduction relation *) 129 | 130 | Inductive eval : trm -> trm -> Prop := 131 | | eval_val : forall t1, 132 | value t1 -> 133 | eval t1 t1 134 | | eval_red : forall v2 t3 v3 t1 t2, 135 | eval t1 (trm_abs t3) -> 136 | eval t2 v2 -> 137 | eval (t3 ^^ v2) v3 -> 138 | eval (trm_app t1 t2) v3. 139 | 140 | 141 | (* ********************************************************************** *) 142 | (* ********************************************************************** *) 143 | (** * Transformation *) 144 | 145 | (* ********************************************************************** *) 146 | (** CPS transformation of terms *) 147 | 148 | Definition Cps (cps : trm -> trm) (t : trm) : trm := 149 | match t with 150 | | trm_bvar i => 151 | arbitrary 152 | | trm_fvar x => 153 | trm_abs (trm_app (trm_bvar 0) t) 154 | | trm_cst k => 155 | trm_abs (trm_app (trm_bvar 0) t) 156 | | trm_abs t1 => 157 | let x := var_gen (fv t1) in 158 | let t1' := close_var x (cps (t1 ^ x)) in 159 | trm_abs (trm_app (trm_bvar 0) (trm_abs t1')) 160 | | trm_app t1 t2 => 161 | let k := trm_abs (trm_app (trm_app (trm_bvar 1) (trm_bvar 0)) (trm_bvar 2)) in 162 | trm_abs (trm_app (cps t1) (trm_abs (trm_app (cps t2) k))) 163 | end. 164 | 165 | Definition cps := FixFun Cps. 166 | 167 | 168 | (* ********************************************************************** *) 169 | (** CPS transformation of values *) 170 | 171 | Definition cps_abs_body t1 := 172 | let x := var_gen (fv t1) in 173 | close_var x (cps (t1 ^ x)). 174 | 175 | Definition cpsval (t:trm) : trm := 176 | match t with 177 | | trm_cst k => t 178 | | trm_abs t1 => trm_abs (cps_abs_body t1) 179 | | _ => arbitrary 180 | end. 181 | 182 | 183 | (* ********************************************************************** *) 184 | (** Correctness of the CPS translation *) 185 | 186 | Definition trm_id := trm_abs (trm_bvar 0). 187 | 188 | Definition cps_correctness_statement := forall v t, 189 | eval t v -> value v -> 190 | eval (trm_app (cps t) trm_id) (cpsval v). 191 | 192 | 193 | 194 | -------------------------------------------------------------------------------- /ln/STLC_Core_Safety.v: -------------------------------------------------------------------------------- 1 | (*************************************************************************** 2 | * Safety for Simply Typed Lambda Calculus (CBV) - Alternative Proofs * 3 | * Arthur Chargueraud, Feb 2021 * 4 | ***************************************************************************) 5 | 6 | Set Implicit Arguments. 7 | From TLC Require Import LibLN. 8 | Require Import 9 | STLC_Core_Definitions 10 | STLC_Core_Infrastructure 11 | STLC_Core_Soundness. 12 | 13 | 14 | (* ********************************************************************** *) 15 | (** General statement of type soundness *) 16 | 17 | (** Transitive closure of the reduction relation *) 18 | 19 | Inductive reds : trm -> trm -> Prop := 20 | | reds_here : forall t, 21 | term t -> 22 | reds t t 23 | | reds_trans : forall t1 t2 t3, 24 | red t1 t2 -> 25 | reds t2 t3 -> 26 | reds t1 t3. 27 | 28 | (** A term [t] can reduce, written [canred t], if there exists 29 | at least one [t'] to which [t] may reduce, i.e. [t --> t']. *) 30 | 31 | Definition canred (t:trm) : Prop := 32 | exists t', t --> t'. 33 | 34 | (** A term is stuck if it is not a value and cannot reduce *) 35 | 36 | Definition stuck (t:trm) : Prop := 37 | ~ value t /\ ~ canred t. 38 | 39 | (** Statement of safety: terms never get stuck. *) 40 | 41 | Definition safe (t:trm) : Prop := 42 | forall t', reds t t' -> ~ stuck t'. 43 | 44 | (** Observe that "not being stuck" is equivalent to being either 45 | a value, or can take a step. This is the formulation used 46 | in the statement of the [progress] lemma. Note that proving 47 | the equivalence requires classical logic for eliminating a 48 | double negation. *) 49 | 50 | Lemma safe_iff : forall t, 51 | safe t <-> (forall t', reds t t' -> value t' \/ (exists t'', t' --> t'')). 52 | Proof using. 53 | unfolds safe. iff M. 54 | { introv R. lets S: M R. unfolds stuck. 55 | rew_logic in S. (* classical logic *) 56 | apply S. } 57 | { introv R (N1&N2). forwards [S|S]: M R. 58 | { false. } { unfolds canred. false. } } 59 | Qed. 60 | 61 | (** Type soundness asserts that all well-typed terms execute safely *) 62 | 63 | Definition soundness := 64 | forall t T, (empty |= t ~: T) -> safe t. 65 | 66 | (** Preservation for empty environments is a restricted form of 67 | preservation that suffices for establishing safety. *) 68 | 69 | Definition preservation_for_empty := forall t t' T, 70 | empty |= t ~: T -> 71 | t --> t' -> 72 | empty |= t' ~: T. 73 | 74 | Lemma preservation_for_empty_of_preservation : 75 | preservation -> 76 | preservation_for_empty. 77 | Proof using. introv Pre HT HR. applys Pre HT HR. Qed. 78 | 79 | (** From preservation (for empty environemnts) and progress, 80 | we can derive that all well-typed terms are safe, by induction 81 | on the reduction sequence. *) 82 | 83 | Lemma soundness_of_preservation_and_progress : 84 | preservation -> 85 | progress -> 86 | soundness. 87 | Proof using. 88 | introv Pre Pro HT. rewrite safe_iff. introv R. gen T. 89 | induction R. 90 | { intros. applys Pro HT. } 91 | { intros. applys IHR. applys* Pre HT. } 92 | Qed. 93 | 94 | 95 | (* ********************************************************************** *) 96 | (** Simpler proof technique for the particular case of deterministic languages *) 97 | 98 | (** Definition of the determinacy property *) 99 | 100 | Definition deterministic := 101 | forall t t1' t2', 102 | t --> t1' -> 103 | t --> t2' -> 104 | t1' = t2'. 105 | 106 | (** Statement of the preservation+progress combined into one, 107 | for deterministic language. *) 108 | 109 | Definition combined_deterministic_soundness := 110 | forall t T, 111 | empty |= t ~: T -> 112 | value t 113 | \/ (exists t', t --> t' /\ empty |= t' ~: T). 114 | 115 | (** Auxiliary lemma: values don't step. *) 116 | 117 | Lemma red_value_inv : forall t t', 118 | t --> t' -> 119 | ~ value t. 120 | Proof using. 121 | introv HR HV. inverts HV. inverts HR. 122 | Qed. 123 | 124 | (** Proof that this statement entails preservation (for empty environments) 125 | and progress. *) 126 | 127 | Lemma combined_deterministic_soundness_inv : 128 | combined_deterministic_soundness -> 129 | deterministic -> 130 | preservation_for_empty 131 | /\ progress. 132 | Proof using. 133 | introv Com Det. split. 134 | { introv HT HR. lets [HV|(t''&HR'&HT')]: Com HT. 135 | { false red_value_inv HR HV. } 136 | { lets E: Det HR HR'. subst t''. applys HT'. } } 137 | { introv HT. lets [HV|(t'&HR&HT')]: Com HT. { left*. } { right*. } } 138 | Qed. 139 | 140 | (** Proof of this result using a single induction, with a proof 141 | term of linear size in the number of language constructs. *) 142 | 143 | Hint Constructors typing. 144 | 145 | Lemma combined_deterministic_soundness_result : 146 | combined_deterministic_soundness. 147 | Proof. 148 | introv Typ. lets Typ': Typ. inductions Typ. 149 | false* binds_empty_inv. 150 | left*. 151 | right. destruct~ IHTyp1 as [Val1 | [t1' [Red1 Typ1']]]. 152 | destruct~ IHTyp2 as [Val2 | [t2' [Red2 Typ2']]]. 153 | inversions Typ1; inversions Val1. exists* (t0 ^^ t2). splits*. 154 | { pick_fresh x. rewrite* (@subst_intro x). apply_empty* typing_subst. } 155 | exists* (trm_app t1 t2'). 156 | exists* (trm_app t1' t2). 157 | Qed. 158 | 159 | 160 | (* ********************************************************************** *) 161 | (** Generic type soundness result for cps-small-step *) 162 | 163 | Implicit Type P : trm -> Prop. 164 | 165 | (** Axiomatization of a cps-small-step semantics *) 166 | 167 | Parameter cpssmall : trm -> (trm -> Prop) -> Prop. 168 | 169 | Parameter cpssmall_characterization : forall t P, 170 | cpssmall t P <-> 171 | ( (exists t', t --> t') 172 | /\ (forall t', t --> t' -> P t')). 173 | 174 | (** Statement of the soundness property using cps-small-step. *) 175 | 176 | Definition cpssmall_soundness := 177 | forall t T, 178 | empty |= t ~: T -> 179 | value t 180 | \/ cpssmall t (fun t' => empty |= t' ~: T). 181 | 182 | Lemma soundness_of_cpssmall_soundness : 183 | cpssmall_soundness -> 184 | soundness. 185 | Proof using. 186 | introv Sou. introv HT. rewrite safe_iff. introv HR. gen T. 187 | induction HR. 188 | { intros. lets [M|M]: Sou HT. 189 | { left*. } 190 | { right. rewrite* cpssmall_characterization in M. } } 191 | { introv HT. lets [HV|M]: Sou HT. 192 | { false* red_value_inv HV. } 193 | { rewrite cpssmall_characterization in M. destruct M as (M1&M2). 194 | applys IHHR. applys* M2. } } 195 | Qed. 196 | 197 | 198 | 199 | 200 | -------------------------------------------------------------------------------- /pretty/LambdaExn_Interp_CombiErr_Correct.v: -------------------------------------------------------------------------------- 1 | (************************************************************ 2 | * Lambda-calculus with exceptions * 3 | * Interpreter in combined pretty-big-step with error rules * 4 | *************************************************************) 5 | 6 | Set Implicit Arguments. 7 | Require Import LambdaExn_Interp LambdaExn_CombiErr. 8 | 9 | Implicit Types v : val. 10 | Implicit Types t : trm. 11 | Implicit Types e : ext. 12 | Implicit Types o : out. 13 | Implicit Types b : beh. 14 | Implicit Types r : res. 15 | 16 | 17 | (*==========================================================*) 18 | (* * Definitions *) 19 | 20 | (************************************************************) 21 | (* ** Statement of the theorem *) 22 | 23 | (** [result n r o] asserts that it is correct for 24 | the interpreter to return the result [r] when 25 | run with max-recursion depth [n] for a term 26 | whose real behavior is [o]. *) 27 | 28 | Definition result n r o := 29 | match o with 30 | | out_ter m b => r = b \/ (r = res_bottom /\ n <= m) 31 | | out_div => r = res_bottom 32 | end. 33 | 34 | Definition correct_and_complete := 35 | forall n t r o, 36 | run n t = r -> cred t o -> result n r o. 37 | 38 | 39 | (*==========================================================*) 40 | (* * Proofs *) 41 | 42 | Hint Unfold result. 43 | Hint Extern 1 (_ <= _) => math. 44 | Hint Constructors isclo. 45 | 46 | 47 | (************************************************************) 48 | (* ** Properties of monadic operators *) 49 | 50 | (** Monotonicity of [result] *) 51 | 52 | Lemma result_before : forall n r o1 o2, 53 | result n r o1 -> before o1 o2 -> result (S n) r o2. 54 | Proof. 55 | unfold result. introv R B. 56 | destruct o1; inverts B. 57 | destruct R as [?|[? ?]]; eauto. 58 | auto. 59 | Qed. 60 | 61 | (** Partial specification for [if_isclo] *) 62 | 63 | Lemma if_isclo_not : forall v k, 64 | ~ isclo v -> if_isclo v k = beh_err. 65 | Proof. 66 | introv V. destruct~ v. false~ V. 67 | Qed. 68 | 69 | (** Combined specification for 70 | [if_success] when taking [i=true], 71 | and [if_fault] when taking [i=false] *) 72 | 73 | Lemma if_result : forall (i:bool) n r o1 r1 o k, 74 | result n r1 o1 -> 75 | (if i then if_success else if_fault) r1 k = r -> 76 | faster o1 o -> 77 | (match o1 with 78 | | out_ter _ (beh_ret v1) => 79 | if i then result (S n) (k v1) o else before o1 o 80 | | out_ter _ (beh_exn v1) => 81 | if i then before o1 o else result (S n) (k v1) o 82 | | out_ter _ _ => before o1 o 83 | | out_div => o = out_div 84 | end) -> 85 | result (S n) r o. 86 | Proof. 87 | introv R I F M. unfold result in R. unfolds if_success. 88 | destruct o1. 89 | destruct R as [E|[E L]]. 90 | subst r1. destruct b. 91 | destruct i. subst~. inverts M. unfolds. left~. 92 | destruct i. inverts M. unfolds. left~. subst~. 93 | inverts M. unfolds. left. destruct~ i. 94 | subst r1 r. unfolds. destruct i; 95 | (destruct o; [ inverts~ F | auto ]). 96 | subst o r1 r. unfolds. destruct~ i. 97 | Qed. 98 | 99 | Definition if_success_result := @if_result true. 100 | Definition if_fault_result := @if_result false. 101 | 102 | 103 | (************************************************************) 104 | (* ** Correctness and completeness of the interpreter *) 105 | 106 | Lemma specification : correct_and_complete. 107 | Proof. 108 | unfolds. induction n using peano_induction. introv U R. 109 | destruct n; simpl in U. destruct~ o. 110 | lets~ IH: (rm H) n __. destruct t. 111 | inverts* R. 112 | inverts* R. 113 | inverts* R. 114 | inverts R as R1 R2 [L2 L1]. forwards~ M1: IH R1. 115 | applys~ if_success_result M1 U. inverts R2 as. 116 | introv A B. inverts A; inverts B; inverts L2; inverts~ L1. 117 | introv R3 R4 [L4 L3]. forwards~ M2: IH R3. 118 | applys if_success_result M2. auto. 119 | destruct o0; inverts L3; inverts~ L2. 120 | inverts R4 as. 121 | introv A B. inverts A; inverts B; 122 | inverts L4; inverts L2; inverts~ L1. 123 | introv R5 L5. simpl. forwards~ M3: IH R5. 124 | applys result_before M3. 125 | destruct o1; inverts L5; inverts L4; inverts~ L2. 126 | introv C. rewrite~ if_isclo_not. 127 | inverts L4; inverts~ L2. 128 | inverts R as R1 R2 [L2 L1]. forwards~ M1: IH R1. 129 | applys~ if_fault_result M1 U. inverts R2 as. 130 | inverts L2. inverts~ L1. 131 | introv R5 L5. forwards~ M2: IH R5. 132 | applys~ result_before M2. 133 | destruct o0; inverts L5; inverts~ L2. 134 | inverts~ L2. 135 | inverts L2. inverts~ L1. 136 | inverts R as R1 R2 [L2 L1]. forwards~ M1: IH R1. 137 | applys~ if_success_result M1 U. inverts R2 as. 138 | introv A B. inverts A; inverts B; inverts L2; inverts~ L1. 139 | inverts L2. inverts~ L1. 140 | inverts* R. 141 | Qed. 142 | 143 | 144 | (************************************************************) 145 | (* ** Corollaries, formulated as implications *) 146 | 147 | Corollary correct_ter : forall n t b, 148 | run n t = b -> credbeh t b. 149 | Proof. 150 | introv U. lets (o&R): (cred_full t). 151 | forwards M: specification U R. 152 | destruct o; tryfalse. 153 | destruct M as [E|[? ?]]; tryfalse. 154 | unfolds credbeh. inverts* E. 155 | Qed. 156 | 157 | Corollary complete_ter : forall t b, 158 | credbeh t b -> exists m, forall n, n > m -> run n t = b. 159 | Proof. 160 | introv (m&R). exists m. introv G. 161 | forwards~ [?|[? ?]]: specification (run n t) R. 162 | math. 163 | Qed. 164 | 165 | Corollary correct_div : forall t, 166 | (forall n, run n t = res_bottom) -> cdiverge t. 167 | Proof. 168 | introv H. unfold cdiverge. 169 | lets (o&R): (cred_full t). 170 | destruct o as [n b|]; [false|auto]. 171 | forwards [E|[? ?]]: specification (H (S n)) R. 172 | false. 173 | math. 174 | Qed. 175 | 176 | Corollary complete_div : forall t n, 177 | cdiverge t -> run n t = res_bottom. 178 | Proof. 179 | introv H. forwards~: specification (run n t) H. 180 | Qed. 181 | 182 | 183 | (************************************************************) 184 | (* ** Corollaries, formulated as equivalences *) 185 | 186 | Corollary specification_ter : forall t b, 187 | (exists m, forall n, n > m -> run n t = b) 188 | <-> credbeh t b. 189 | Proof. 190 | iff (n&?). 191 | applys* correct_ter (S n). applys* H. math. 192 | applys* complete_ter. exists* n. 193 | Qed. 194 | 195 | Corollary specification_div : forall t, 196 | (forall n, run n t = res_bottom) 197 | <-> cdiverge t. 198 | Proof. 199 | iff. 200 | applys* correct_div. 201 | intros. applys* complete_div. 202 | Qed. 203 | 204 | -------------------------------------------------------------------------------- /ln/STLC_Core_Adequacy.v: -------------------------------------------------------------------------------- 1 | (*************************************************************************** 2 | * Safety for Simply Typed Lambda Calculus (CBV) - Adequacy * 3 | * Brian Aydemir & Arthur Chargueraud, July 2007 * 4 | ***************************************************************************) 5 | 6 | Set Implicit Arguments. 7 | From TLC Require Import LibLN. 8 | 9 | Require Import 10 | STLC_Core_Definitions 11 | STLC_Core_Infrastructure 12 | STLC_Core_Soundness. 13 | 14 | (***************************************************************************) 15 | (** * Definitions with the exists-fresh quantification *) 16 | 17 | (** Terms are locally-closed pre-terms *) 18 | 19 | Inductive eterm : trm -> Prop := 20 | | eterm_var : forall x, 21 | eterm (trm_fvar x) 22 | | eterm_abs : forall x t1, 23 | x \notin fv t1 -> 24 | eterm (t1 ^ x) -> 25 | eterm (trm_abs t1) 26 | | eterm_app : forall t1 t2, 27 | eterm t1 -> 28 | eterm t2 -> 29 | eterm (trm_app t1 t2). 30 | 31 | (** Typing relation *) 32 | 33 | Reserved Notation "E |== t ~: T" (at level 69). 34 | 35 | Inductive etyping : env -> trm -> typ -> Prop := 36 | | etyping_var : forall E x T, 37 | ok E -> 38 | binds x T E -> 39 | E |== (trm_fvar x) ~: T 40 | | etyping_abs : forall x E U T t1, 41 | x \notin dom E \u fv t1 -> 42 | (E & x ~ U) |== (t1 ^ x) ~: T -> 43 | E |== (trm_abs t1) ~: (typ_arrow U T) 44 | | etyping_app : forall S T E t1 t2, 45 | E |== t1 ~: (typ_arrow S T) -> 46 | E |== t2 ~: S -> 47 | E |== (trm_app t1 t2) ~: T 48 | 49 | where "E |== t ~: T" := (etyping E t T). 50 | 51 | (** Definition of values (only abstractions are values) *) 52 | 53 | Inductive evalue : trm -> Prop := 54 | | evalue_abs : forall t1, 55 | eterm (trm_abs t1) -> evalue (trm_abs t1). 56 | 57 | (** Reduction relation - one step in call-by-value *) 58 | 59 | Inductive ered : trm -> trm -> Prop := 60 | | ered_beta : forall t1 t2, 61 | eterm (trm_abs t1) -> 62 | evalue t2 -> 63 | ered (trm_app (trm_abs t1) t2) (t1 ^^ t2) 64 | | ered_app_1 : forall t1 t1' t2, 65 | eterm t2 -> 66 | ered t1 t1' -> 67 | ered (trm_app t1 t2) (trm_app t1' t2) 68 | | ered_app_2 : forall t1 t2 t2', 69 | evalue t1 -> 70 | ered t2 t2' -> 71 | ered (trm_app t1 t2) (trm_app t1 t2'). 72 | 73 | Notation "t -->> t'" := (ered t t') (at level 68). 74 | 75 | (** Goal is to prove preservation and progress *) 76 | 77 | Definition epreservation := forall E t t' T, 78 | E |== t ~: T -> 79 | t -->> t' -> 80 | E |== t' ~: T. 81 | 82 | Definition eprogress := forall t T, 83 | empty |== t ~: T -> 84 | evalue t 85 | \/ exists t', t -->> t'. 86 | 87 | 88 | 89 | (***************************************************************************) 90 | (** * Detailed Proofs of Renaming Lemmas (without high automation) *) 91 | 92 | 93 | (* ********************************************************************** *) 94 | (** ** Proving the renaming lemma for [term]. *) 95 | 96 | Lemma term_rename : forall x y t, 97 | term (t ^ x) -> 98 | x \notin fv t -> 99 | y \notin fv t -> 100 | term (t ^ y). 101 | Proof. 102 | introv Wx Frx Fry. 103 | (* introduce a renaming *) 104 | rewrite (@subst_intro x). 105 | (* apply substitution result *) 106 | apply* subst_term. 107 | (* use the fact that x is fresh *) 108 | assumption. 109 | (* prove term (trm_fvar y) *) 110 | apply* term_var. 111 | Qed. 112 | 113 | (* ********************************************************************** *) 114 | (** ** Proving the renaming lemma for [typing]. *) 115 | 116 | Lemma typing_rename : forall x y E t U T, 117 | (E & x ~ U) |= (t ^ x) ~: T -> 118 | x \notin dom E \u fv t -> 119 | y \notin dom E \u fv t -> 120 | (E & y ~ U) |= (t ^ y) ~: T. 121 | Proof. 122 | introv Typx Frx Fry. 123 | (* ensure x <> y, so as to be able to build (E & y ~ U & x ~ U) *) 124 | tests: (x = y). subst*. 125 | (* assert that E is ok *) 126 | lets K: (proj1 (typing_regular Typx)). destruct (ok_concat_inv K). 127 | (* introduce substitution *) 128 | rewrite~ (@subst_intro x). 129 | (* apply substitution lemma *) 130 | apply_empty* typing_subst. 131 | (* apply weakening lemma *) 132 | lets P: (@typing_weaken (x ~ U) E (y ~ U)). 133 | simpls. apply* P. 134 | (* prove (E & y ~ U |= trm_fvar y ~: U) *) 135 | apply* typing_var. 136 | Qed. 137 | 138 | 139 | (***************************************************************************) 140 | (** * Proofs of equivalence. *) 141 | 142 | 143 | (* ********************************************************************** *) 144 | (** ** Proving the equivalence of [term] and [eterm] *) 145 | 146 | Hint Constructors term eterm. 147 | 148 | Lemma term_to_eterm : forall t, 149 | term t -> eterm t. 150 | Proof. 151 | induction 1; eauto. 152 | pick_fresh x. apply* (@eterm_abs x). 153 | Qed. 154 | 155 | Lemma eterm_to_term : forall t, 156 | eterm t -> term t. 157 | Proof. 158 | induction 1; eauto. 159 | apply_fresh* term_abs as y. apply* term_rename. 160 | Qed. 161 | 162 | (* ********************************************************************** *) 163 | (** ** Proving the equivalence of [value] and [evalue] *) 164 | 165 | Hint Constructors value evalue. 166 | 167 | Lemma value_to_evalue : forall t, 168 | value t -> evalue t. 169 | Proof. 170 | lets: term_to_eterm. induction 1; jauto. 171 | Qed. 172 | 173 | Lemma evalue_to_value : forall t, 174 | evalue t -> value t. 175 | Proof. 176 | lets: eterm_to_term. induction 1; jauto. 177 | Qed. 178 | 179 | (* ********************************************************************** *) 180 | (** ** Proving the equivalence of [red] and [ered] *) 181 | 182 | Hint Constructors red ered. 183 | 184 | Lemma red_to_ered : forall t t', 185 | red t t' -> ered t t'. 186 | Proof. 187 | lets: term_to_eterm. lets: value_to_evalue. induction 1; jauto. 188 | Qed. 189 | 190 | Lemma ered_to_red : forall t t', 191 | ered t t' -> red t t'. 192 | Proof. 193 | lets: eterm_to_term. lets: evalue_to_value. induction 1; jauto. 194 | Qed. 195 | 196 | (* ********************************************************************** *) 197 | (** ** Proving the equivalence of [typing] and [etyping] *) 198 | 199 | Hint Constructors typing etyping. 200 | 201 | Lemma typing_to_etyping : forall E t T, 202 | E |= t ~: T -> E |== t ~: T. 203 | Proof. 204 | induction 1; eauto. 205 | pick_fresh x. apply* (@etyping_abs x). 206 | Qed. 207 | 208 | Lemma etyping_to_typing : forall E t T, 209 | E |== t ~: T -> E |= t ~: T. 210 | Proof. 211 | induction 1; eauto. 212 | apply_fresh* typing_abs as y. apply* typing_rename. 213 | Qed. 214 | 215 | (* ********************************************************************** *) 216 | 217 | 218 | -------------------------------------------------------------------------------- /omni/SepLogicOmniBig.v: -------------------------------------------------------------------------------- 1 | (**************************************************************** 2 | * Imperative Lambda-calculus * 3 | * Separation Logic on Omni-Big-Step * 4 | *****************************************************************) 5 | 6 | Set Implicit Arguments. 7 | Require Export SepLogicCommon OmniBig. 8 | 9 | Implicit Types f : var. 10 | Implicit Types b : bool. 11 | Implicit Types p : loc. 12 | Implicit Types n : int. 13 | Implicit Types v w r vf vx : val. 14 | Implicit Types t : trm. 15 | Implicit Types s : state. 16 | Implicit Types h : heap. 17 | Implicit Types H : hprop. 18 | Implicit Types Q : val->hprop. 19 | 20 | 21 | (* ########################################################### *) 22 | (* ########################################################### *) 23 | (* ########################################################### *) 24 | (** * Proof of the Frame Property for Omni-Big-Step *) 25 | 26 | Lemma omnibig_frame : forall h1 h2 t Q, 27 | omnibig h1 t Q -> 28 | Fmap.disjoint h1 h2 -> 29 | omnibig (h1 \u h2) t (Q \*+ (= h2)). 30 | Proof using. 31 | introv M HD. gen h2. induction M; intros; 32 | try solve [ hint hstar_intro; constructors* ]. 33 | { rename M into M1, H into M2, IHM into IH1, H0 into IH2. 34 | specializes IH1 HD. applys omnibig_let IH1. introv HK. 35 | lets (h1'&h2'&K1'&K2'&KD&KU): HK. subst. applys* IH2. } 36 | { rename H into M. applys omnibig_ref. intros p Hp. 37 | rewrite indom_union_eq in Hp. rew_logic in Hp. 38 | destruct Hp as [Hp1 Hp2]. 39 | rewrite* update_union_not_r. applys hstar_intro. 40 | { applys* M. } { auto. } { applys* disjoint_update_not_r. } } 41 | { applys omnibig_get. { rewrite* indom_union_eq. } 42 | { rewrite* read_union_l. applys* hstar_intro. } } 43 | { applys omnibig_set. { rewrite* indom_union_eq. } 44 | { rewrite* update_union_l. applys hstar_intro. 45 | { auto. } { auto. } { applys* disjoint_update_l. } } } 46 | { applys omnibig_free. { rewrite* indom_union_eq. } 47 | { rewrite* remove_disjoint_union_l. applys hstar_intro. 48 | { auto. } { auto. } { applys* disjoint_remove_l. } } } 49 | Qed. 50 | 51 | 52 | (* ########################################################### *) 53 | (* ########################################################### *) 54 | (* ########################################################### *) 55 | (** * Construction of Separation Logic *) 56 | 57 | (* ########################################################### *) 58 | (** ** Definition of Separation Logic triples *) 59 | 60 | Definition triple (t:trm) (H:hprop) (Q:val->hprop) : Prop := 61 | forall s, H s -> omnibig s t Q. 62 | 63 | 64 | (* ########################################################### *) 65 | (** ** Structural Rules *) 66 | 67 | Lemma triple_conseq : forall t H' Q' H Q, 68 | triple t H' Q' -> 69 | H ==> H' -> 70 | Q' ===> Q -> 71 | triple t H Q. 72 | Proof using. unfolds triple. introv M MH MQ HF. applys* omnibig_conseq. Qed. 73 | 74 | Lemma triple_frame : forall t H Q H', 75 | triple t H Q -> 76 | triple t (H \* H') (Q \*+ H'). 77 | Proof. 78 | introv M. intros h HF. lets (h1&h2&M1&M2&MD&MU): (rm HF). 79 | subst. specializes M M1. applys omnibig_conseq. 80 | { applys omnibig_frame M MD. } { xsimpl. intros h' ->. applys M2. } 81 | Qed. 82 | 83 | Lemma triple_hexists : forall t (A:Type) (J:A->hprop) Q, 84 | (forall (x:A), triple t (J x) Q) -> 85 | triple t (hexists J) Q. 86 | Proof using. introv M. intros h (x&Hh). applys M Hh. Qed. 87 | 88 | Lemma triple_hpure : forall t (P:Prop) H Q, 89 | (P -> triple t H Q) -> 90 | triple t (\[P] \* H) Q. 91 | Proof using. 92 | introv M. intros h (h1&h2&M1&M2&D&U). destruct M1 as (M1&HP). 93 | inverts HP. subst. rewrite union_empty_l. applys~ M. 94 | Qed. 95 | 96 | 97 | (* ########################################################### *) 98 | (** ** Reasoning Rules for Terms *) 99 | 100 | Lemma triple_val : forall v H Q, 101 | H ==> Q v -> 102 | triple (trm_val v) H Q. 103 | Proof using. introv M Hs. applys* omnibig_val. Qed. 104 | 105 | Lemma triple_fix : forall f x t1 H Q, 106 | H ==> Q (val_fix f x t1) -> 107 | triple (trm_fix f x t1) H Q. 108 | Proof using. introv M Hs. applys* omnibig_fix. Qed. 109 | 110 | Lemma triple_if : forall (b:bool) t1 t2 H Q, 111 | triple (if b then t1 else t2) H Q -> 112 | triple (trm_if b t1 t2) H Q. 113 | Proof using. introv M Hs. applys* omnibig_if. Qed. 114 | 115 | Lemma triple_app_fix : forall v1 v2 f x t1 H Q, 116 | v1 = val_fix f x t1 -> 117 | triple (subst x v2 (subst f v1 t1)) H Q -> 118 | triple (trm_app v1 v2) H Q. 119 | Proof using. introv E M Hs. applys* omnibig_app_fix. Qed. 120 | 121 | Lemma triple_let : forall x t1 t2 Q1 H Q, 122 | triple t1 H Q1 -> 123 | (forall v1, triple (subst x v1 t2) (Q1 v1) Q) -> 124 | triple (trm_let x t1 t2) H Q. 125 | Proof using. introv M1 M2 Hs. applys* omnibig_let. Qed. 126 | 127 | 128 | (* ########################################################### *) 129 | (** ** Specification of Primitive Operations *) 130 | 131 | Lemma triple_div : forall n1 n2, 132 | n2 <> 0 -> 133 | triple (val_div n1 n2) 134 | \[] 135 | (fun r => \[r = val_int (Z.quot n1 n2)]). 136 | Proof using. 137 | introv Hn2 Hs. applys* omnibig_div. inverts Hs. exists*. hnfs*. 138 | Qed. 139 | 140 | Lemma triple_rand : forall n, 141 | n > 0 -> 142 | triple (val_rand n) 143 | \[] 144 | (fun r => \[exists n1, r = val_int n1 /\ 0 <= n1 < n]). 145 | Proof using. 146 | introv Hn2 Hs. applys* omnibig_rand. inverts Hs. 147 | intros n1 Hn1. hnfs. exists*. hnfs*. 148 | Qed. 149 | 150 | Lemma triple_ref : forall v, 151 | triple (val_ref v) 152 | \[] 153 | (fun r => \exists p, \[r = val_loc p] \* p ~~> v). 154 | Proof using. 155 | intros. intros s1 K. applys omnibig_ref. intros p D. 156 | inverts K. rewrite update_empty. exists p. 157 | rewrite hstar_hpure_l. split*. hnfs*. 158 | Qed. 159 | 160 | Lemma triple_get : forall v p, 161 | triple (val_get p) 162 | (p ~~> v) 163 | (fun r => \[r = v] \* (p ~~> v)). 164 | Proof using. 165 | intros. intros s K. inverts K. applys omnibig_get. 166 | { applys* indom_single. } 167 | { rewrite hstar_hpure_l. split*. rewrite* read_single. hnfs*. } 168 | Qed. 169 | 170 | Lemma triple_set : forall w p v, 171 | triple (val_set (val_loc p) v) 172 | (p ~~> w) 173 | (fun r => (p ~~> v)). 174 | Proof using. 175 | intros. intros s1 K. inverts K. applys omnibig_set. 176 | { applys* indom_single. } 177 | { rewrite update_single. hnfs*. } 178 | Qed. 179 | 180 | Lemma triple_free : forall p v, 181 | triple (val_free (val_loc p)) 182 | (p ~~> v) 183 | (fun r => \[]). 184 | Proof using. 185 | intros. intros s1 K. inverts K. applys omnibig_free. 186 | { applys* indom_single. } 187 | { rewrite* remove_single. hnfs*. } 188 | Qed. 189 | 190 | (** For example proofs in Separation Logic, see the course: 191 | Separation Logic Foundations, vol 6 of the Software Foundations series: 192 | https://softwarefoundations.cis.upenn.edu/slf-current/index.html *) 193 | -------------------------------------------------------------------------------- /pretty/LambdaExnSum_Syntax.v: -------------------------------------------------------------------------------- 1 | (************************************************************ 2 | * Lambda-calculus with exceptions and sums, * 3 | * Syntax * 4 | *************************************************************) 5 | 6 | Set Implicit Arguments. 7 | From TLC Require Export LibVar. 8 | Require Export Common. 9 | 10 | 11 | (*==========================================================*) 12 | (* * Definitions *) 13 | 14 | (************************************************************) 15 | (* ** Syntax *) 16 | 17 | (** Grammar of values and terms *) 18 | 19 | Inductive val : Type := 20 | | val_int : int -> val 21 | | val_abs : var -> trm -> val 22 | | val_inj : bool -> val -> val 23 | 24 | with trm : Type := 25 | | trm_val : val -> trm 26 | | trm_var : var -> trm 27 | | trm_abs : var -> trm -> trm 28 | | trm_app : trm -> trm -> trm 29 | | trm_inj : bool -> trm -> trm 30 | | trm_case : trm -> trm -> trm -> trm 31 | | trm_try : trm -> trm -> trm 32 | | trm_raise : trm -> trm. 33 | 34 | Coercion trm_val : val >-> trm. 35 | Implicit Types v : val. 36 | Implicit Types t : trm. 37 | 38 | (** Substitution *) 39 | 40 | Fixpoint subst (x:var) (v:val) (t:trm) : trm := 41 | let s := subst x v in 42 | match t with 43 | | trm_val v1 => trm_val v1 44 | | trm_var y => If x = y then v else t 45 | | trm_abs y t3 => trm_abs y (If x = y then t3 else s t3) 46 | | trm_app t1 t2 => trm_app (s t1) (s t2) 47 | | trm_inj b t1 => trm_inj b (s t1) 48 | | trm_case t1 t2 t3 => trm_case (s t1) (s t2) (s t3) 49 | | trm_try t1 t2 => trm_try (s t1) (s t2) 50 | | trm_raise t1 => trm_raise (s t1) 51 | end. 52 | 53 | 54 | (************************************************************) 55 | (* ** Freshness *) 56 | 57 | (** Two modes for freshness: "not used" and "not free" *) 58 | 59 | Inductive vars_opt := not_used | not_free. 60 | 61 | Definition add_bound f E (x:var) := 62 | match f with 63 | | not_used => E \u \{x} 64 | | not_free => E \- \{x} 65 | end. 66 | 67 | (** Set of free variables and used variables *) 68 | 69 | Fixpoint trm_vars (f:vars_opt) (t:trm) : vars := 70 | let r := trm_vars f in 71 | match t with 72 | | trm_val v1 => val_vars f v1 73 | | trm_var x => \{x} 74 | | trm_abs x t1 => add_bound f (r t1) x 75 | | trm_app t1 t2 => (r t1) \u (r t2) 76 | | trm_inj b t1 => (r t1) 77 | | trm_case t1 t2 t3 => (r t1) \u (r t2) \u (r t3) 78 | | trm_try t1 t2 => (r t1) \u (r t2) 79 | | trm_raise t1 => (r t1) 80 | end 81 | 82 | with val_vars (f:vars_opt) (v:val) : vars := 83 | match v with 84 | | val_int n => \{} 85 | | val_abs x t1 => add_bound f (trm_vars f t1) x 86 | | val_inj b v1 => val_vars f v1 87 | end. 88 | 89 | 90 | (*==========================================================*) 91 | (* * Proofs *) 92 | 93 | 94 | (************************************************************) 95 | (* ** Specific lemmas for reasoning on sets of variables *) 96 | 97 | Lemma notin_remove : forall A x (E F:fset A), 98 | x \notin (E \- F) = (x \notin E \/ x \in F). 99 | Proof. 100 | intros. unfolds notin. rewrite in_remove. 101 | unfolds notin. rew_logic*. 102 | Qed. 103 | 104 | Lemma notin_remove_l : forall A x (E F:fset A), 105 | x \notin (E \- F) -> x \notin E \/ x \in F. 106 | Proof. introv H. rewrite~ notin_remove in H. Qed. 107 | 108 | Lemma notin_remove_r : forall A x (E F:fset A), 109 | (x \notin E \/ x \in F) -> x \notin (E \- F). 110 | Proof. introv H. rewrite~ notin_remove. Qed. 111 | 112 | Lemma notin_remove_inv : forall A x (E F:fset A), 113 | x \notin (E \- F) -> x \notin F -> x \notin E. 114 | Proof. introv H1 H2. destruct~ (notin_remove_l H1). false. Qed. 115 | 116 | Lemma notin_remove_weaken : forall E F (x:var), 117 | x \notin E -> 118 | x \notin (E \- F). 119 | Proof. intros. applys~ notin_remove_r. Qed. 120 | 121 | Lemma notin_to_fresh : forall xs n E F, 122 | fresh E n xs -> 123 | (forall x, x \notin E -> x \notin F) -> 124 | fresh F n xs. 125 | Proof. 126 | induction xs; introv Fr H. 127 | auto. 128 | destruct n. false. simpls. destruct Fr. 129 | split~. applys* IHxs. 130 | Qed. 131 | 132 | Lemma fresh_remove_weaken : forall E F n xs, 133 | fresh E n xs -> 134 | fresh (E \- F) n xs. 135 | Proof. 136 | intros. applys* notin_to_fresh. applys* notin_remove_weaken. 137 | Qed. 138 | 139 | Lemma remove_self : forall A (E:fset A), 140 | E \- E = \{}. 141 | Proof. 142 | intros. applys fset_extens; intros x H. 143 | rewrite in_remove in H. false*. 144 | rewrite in_empty in H. false. 145 | Qed. 146 | 147 | Lemma union_remove : forall A (E F:fset A), 148 | (forall x, x \in E -> x \notin F) -> 149 | (E \u F) \- F = E. 150 | Proof. 151 | introv M. applys fset_extens; intros x H. 152 | rewrite in_remove, in_union in H. destruct H as [[?|?] ?]. 153 | auto. 154 | false*. 155 | rewrite in_remove, in_union. auto. 156 | Qed. 157 | 158 | Lemma union_remove' : forall A (E F:fset A), 159 | (forall x, x \in E -> x \notin F) -> 160 | (F \u E) \- F = E. 161 | Proof. 162 | introv M. applys fset_extens; intros x H. 163 | rewrite in_remove, in_union in H. destruct H as [[?|?] ?]. 164 | false*. 165 | auto. 166 | rewrite in_remove, in_union. auto. 167 | Qed. 168 | 169 | Hint Rewrite union_empty_l union_empty_r remove_self : fset_simpl. 170 | Ltac fset_simpl := autorewrite with fset_simpl. 171 | 172 | Lemma notin_elim_single : forall A (y:A) (E:fset A), 173 | y \notin E -> 174 | (forall x, x \in E -> x \notin \{y}). 175 | Proof. 176 | introv H M. rewrite notin_singleton. intro_subst. false. 177 | Qed. 178 | 179 | Lemma notin_remove_single_inv : forall A x y (E:fset A), 180 | x \notin (E \- \{y}) -> x <> y -> x \notin E. 181 | Proof. 182 | introv H1 H2. applys* notin_remove_inv. 183 | rewrite~ notin_singleton. 184 | Qed. 185 | 186 | 187 | (************************************************************) 188 | (* ** Freshness *) 189 | 190 | (** Properties of [add_bound] *) 191 | 192 | Lemma notin_add_bound : forall x f y E, 193 | x \notin add_bound f E y -> 194 | x \notin E \- \{y}. 195 | Proof. 196 | intros. destruct f; simpls. 197 | applys~ notin_remove_weaken. 198 | auto. 199 | Qed. 200 | 201 | (** Substitution is the identity function on fresh vars *) 202 | 203 | Lemma subst_id : forall f x v t, 204 | x \notin trm_vars f t -> 205 | subst x v t = t. 206 | Proof. 207 | induction t; introv F; simpls; fequals~. 208 | case_if*. subst. notin_false. 209 | case_if*. applys IHt. destruct f; simpls~. 210 | applys~ notin_remove_inv F. 211 | Qed. 212 | 213 | Lemma subst_notin : forall t x y v, 214 | x \notin (trm_vars not_used t) -> 215 | x \notin (val_vars not_used v) -> 216 | x \notin (trm_vars not_used (subst y v t)). 217 | Proof. induction t; introv Frt Frv; simpls~; try case_if*. Qed. 218 | 219 | Lemma fresh_subst : forall xs n t y v, 220 | fresh (trm_vars not_used t) n xs -> 221 | fresh (val_vars not_used v) n xs -> 222 | fresh (trm_vars not_used (subst y v t)) n xs. 223 | Proof. 224 | induction xs; introv Frt Frv. 225 | auto. 226 | destruct n. false. simpls. 227 | destruct Frt. destruct Frv. 228 | hint subst_notin. auto. 229 | Qed. 230 | 231 | -------------------------------------------------------------------------------- /pretty/LambdaExn_PrettyErr.v: -------------------------------------------------------------------------------- 1 | (************************************************************ 2 | * Lambda-calculus with exceptions, * 3 | * Pretty-big-step semantics * 4 | *************************************************************) 5 | 6 | Set Implicit Arguments. 7 | Require Export Common. 8 | 9 | (************************************************************) 10 | (* ** Syntax *) 11 | 12 | Inductive trm : Type := 13 | | trm_var : var -> trm 14 | | trm_abs : var -> trm -> trm 15 | | trm_app : trm -> trm -> trm 16 | | trm_try : trm -> var -> trm -> trm 17 | | trm_raise : trm -> trm. 18 | 19 | (** Grammar of values and terms *) 20 | 21 | Inductive val : Type := 22 | | val_int : int -> val 23 | | val_clo : env val -> var -> trm -> val 24 | | val_err : val. 25 | 26 | Definition stack := env val. 27 | 28 | Inductive beh := 29 | | beh_ret : val -> beh 30 | | beh_exn : val -> beh 31 | | beh_err : beh. 32 | 33 | Coercion beh_ret : val >-> beh. 34 | 35 | Implicit Types v : val. 36 | Implicit Types t : trm. 37 | Implicit Types b : beh. 38 | 39 | (*==========================================================*) 40 | (* * Definitions *) 41 | 42 | Notation "x ~~ a" := (single x a) 43 | (at level 27, left associativity) : env_scope. 44 | 45 | 46 | (************************************************************) 47 | (* ** Semantics *) 48 | 49 | Implicit Types s : stack. 50 | 51 | (** Grammar of outcomes, isomorphic to: 52 | Inductive out := 53 | | out_ret : val -> out 54 | | out_exn : val -> out 55 | | out_div : out. 56 | *) 57 | 58 | Inductive out := 59 | | out_beh : beh -> out 60 | | out_div : out. 61 | 62 | Coercion out_beh : beh >-> out. 63 | Implicit Types o : out. 64 | Notation "'out_exn' v" := (out_beh (beh_exn v)) (at level 60). 65 | Notation "'out_err'" := (out_beh (beh_err)) (at level 0). 66 | 67 | (** Grammar of extended terms *) 68 | 69 | Inductive ext : Type := 70 | | ext_trm : trm -> ext 71 | | ext_app_1 : out -> trm -> ext 72 | | ext_app_2 : val -> out -> ext 73 | | ext_try_1 : out -> var -> trm -> ext 74 | | ext_raise_1 : out -> ext. 75 | 76 | Coercion ext_trm : trm >-> ext. 77 | Implicit Types e : ext. 78 | 79 | (** Abort behavior *) 80 | 81 | Inductive abort : out -> Prop := 82 | | abort_exn : forall v, abort (out_exn v) 83 | | abort_div : abort out_div 84 | | abort_err : abort out_err. 85 | 86 | (** "One rule applies" judgment *) 87 | 88 | Inductive one : stack -> ext -> Prop := 89 | | one_var : forall s x v, 90 | binds x v s -> 91 | one s (trm_var x) 92 | | one_abs : forall s x t, 93 | one s (trm_abs x t) 94 | | one_app : forall s t1 t2, 95 | one s (trm_app t1 t2) 96 | | one_app_1_abort : forall s o1 t2, 97 | abort o1 -> 98 | one s (ext_app_1 o1 t2) 99 | | one_app_1 : forall s v1 t2, 100 | one s (ext_app_1 v1 t2) 101 | | one_app_2_abort : forall s v1 o2, 102 | abort o2 -> 103 | one s (ext_app_2 v1 o2) 104 | | one_app_2 : forall s' s x t3 v2, 105 | one s' (ext_app_2 (val_clo s x t3) v2) 106 | | one_try : forall s t1 x t2, 107 | one s (trm_try t1 x t2) 108 | | one_try_1_val : forall s v1 x t2, 109 | one s (ext_try_1 v1 x t2) 110 | | one_try_1_exn : forall s x t2 v, 111 | one s (ext_try_1 (out_exn v) x t2) 112 | | one_try_1_div : forall s x t2, 113 | one s (ext_try_1 out_div x t2) 114 | | one_raise : forall s t1, 115 | one s (trm_raise t1) 116 | | one_raise_1_abort : forall s o1, 117 | abort o1 -> 118 | one s (ext_raise_1 o1) 119 | | one_raise_1 : forall s v, 120 | one s (ext_raise_1 v). 121 | 122 | (** Evaluation judgment *) 123 | 124 | Inductive red : stack -> ext -> out -> Prop := 125 | | red_var : forall s x v, 126 | binds x v s -> 127 | red s (trm_var x) v 128 | | red_abs : forall s x t, 129 | red s (trm_abs x t) (val_clo s x t) 130 | | red_app : forall s t1 t2 o1 o, 131 | red s t1 o1 -> 132 | red s (ext_app_1 o1 t2) o -> 133 | red s (trm_app t1 t2) o 134 | | red_app_1_abort : forall s o1 t2, 135 | abort o1 -> 136 | red s (ext_app_1 o1 t2) o1 137 | | red_app_1 : forall s v1 t2 o o2, 138 | red s t2 o2 -> 139 | red s (ext_app_2 v1 o2) o -> 140 | red s (ext_app_1 v1 t2) o 141 | | red_app_2_abort : forall s v1 o2, 142 | abort o2 -> 143 | red s (ext_app_2 v1 o2) o2 144 | | red_app_2 : forall (s s':stack) x t3 v2 o, 145 | red (s' & x ~~ v2) t3 o -> 146 | red s (ext_app_2 (val_clo s' x t3) v2) o 147 | | red_try : forall s t1 x t2 o1 o, 148 | red s t1 o1 -> 149 | red s (ext_try_1 o1 x t2) o -> 150 | red s (trm_try t1 x t2) o 151 | | red_try_1_val : forall s v1 x t2, 152 | red s (ext_try_1 v1 x t2) v1 153 | | red_try_1_exn : forall s t2 o v x, 154 | red (s & x ~~ v) t2 o -> 155 | red s (ext_try_1 (out_exn v) x t2) o 156 | | red_try_1_div : forall s x t2, 157 | red s (ext_try_1 out_div x t2) out_div 158 | | red_raise : forall s t1 o1 o, 159 | red s t1 o1 -> 160 | red s (ext_raise_1 o1) o -> 161 | red s (trm_raise t1) o 162 | | red_raise_1_abort : forall s o1, 163 | abort o1 -> 164 | red s (ext_raise_1 o1) o1 165 | | red_raise_1 : forall s v, 166 | red s (ext_raise_1 v) (out_exn v) 167 | | red_err : forall s e, 168 | ~ one s e -> 169 | red s e out_err. 170 | 171 | (** Coevaluation judgment: 172 | copy-paste of the above definition, 173 | simply replacing [red] with [cored] *) 174 | 175 | Inductive cored : stack -> ext -> out -> Prop := 176 | | cored_var : forall s x v, 177 | binds x v s -> 178 | cored s (trm_var x) v 179 | | cored_abs : forall s x t, 180 | cored s (trm_abs x t) (val_clo s x t) 181 | | cored_app : forall s t1 t2 o1 o, 182 | cored s t1 o1 -> 183 | cored s (ext_app_1 o1 t2) o -> 184 | cored s (trm_app t1 t2) o 185 | | cored_app_1_abort : forall s o1 t2, 186 | abort o1 -> 187 | cored s (ext_app_1 o1 t2) o1 188 | | cored_app_1 : forall s v1 t2 o o2, 189 | cored s t2 o2 -> 190 | cored s (ext_app_2 v1 o2) o -> 191 | cored s (ext_app_1 v1 t2) o 192 | | cored_app_2_abort : forall s v1 o2, 193 | abort o2 -> 194 | cored s (ext_app_2 v1 o2) o2 195 | | cored_app_2 : forall (s s':stack) x t3 v2 o, 196 | cored (s' & x ~~ v2) t3 o -> 197 | cored s (ext_app_2 (val_clo s' x t3) v2) o 198 | | cored_try : forall s t1 x t2 o1 o, 199 | cored s t1 o1 -> 200 | cored s (ext_try_1 o1 x t2) o -> 201 | cored s (trm_try t1 x t2) o 202 | | cored_try_1_val : forall s v1 x t2, 203 | cored s (ext_try_1 v1 x t2) v1 204 | | cored_try_1_exn : forall s t2 o v x, 205 | cored (s & x ~~ v) t2 o -> 206 | cored s (ext_try_1 (out_exn v) x t2) o 207 | | cored_try_1_div : forall s x t2, 208 | cored s (ext_try_1 out_div x t2) out_div 209 | | cored_raise : forall s t1 o1 o, 210 | cored s t1 o1 -> 211 | cored s (ext_raise_1 o1) o -> 212 | cored s (trm_raise t1) o 213 | | cored_raise_1_abort : forall s o1, 214 | abort o1 -> 215 | cored s (ext_raise_1 o1) o1 216 | | cored_raise_1 : forall s v, 217 | cored s (ext_raise_1 v) (out_exn v) 218 | | cored_err : forall s e, 219 | ~ one s e -> 220 | cored s e out_err. 221 | -------------------------------------------------------------------------------- /ln/CPS_Correctness.v: -------------------------------------------------------------------------------- 1 | (*************************************************************************** 2 | * Correctness of the CPS-transformation - Correctness * 3 | * Arthur Chargueraud, January 2009 * 4 | ***************************************************************************) 5 | 6 | Set Implicit Arguments. 7 | Require Import CPS_Definitions CPS_Infrastructure. 8 | From Coq Require Lia. 9 | Implicit Types x y z : var. 10 | 11 | Opaque cps. 12 | Hint Constructors value. 13 | 14 | (* ********************************************************************** *) 15 | (** ** Properties of the big-step evaluation relation *) 16 | 17 | (** If a term [t] evaluates to [v], then [v] is a value *) 18 | 19 | Lemma eval_to_value : forall t v, 20 | eval t v -> value v. 21 | Proof. 22 | introv H. induction~ H. 23 | Qed. 24 | 25 | Hint Extern 1 (value ?v) => 26 | match goal with H: eval _ v |- _ => 27 | apply (eval_to_value H) end. 28 | 29 | (** If a value [v] evaluates to something, then it must be to [v] *) 30 | 31 | Lemma eval_value : forall v v', 32 | eval v v' -> value v -> v' = v. 33 | Proof. 34 | introv E V. inverts V; inverts~ E. 35 | Qed. 36 | 37 | Hint Resolve eval_val. 38 | 39 | (** Specialization of the reduction rule for the application of 40 | an abstraction to a value. *) 41 | 42 | Lemma eval_red_values : forall t1 v2 r, 43 | body t1 -> value v2 -> 44 | eval (t1 ^^ v2) r -> 45 | eval (trm_app (trm_abs t1) v2) r. 46 | Proof. 47 | intros. applys~ eval_red. 48 | Qed. 49 | 50 | (** Specialization of the reduction rule for the application of 51 | an abstraction to two values. *) 52 | 53 | Lemma eval_red_values_bis : forall t1 v2 v3 r, 54 | body t1 -> value v2 -> value v3 -> 55 | eval (trm_app (t1 ^^ v2) v3) r -> 56 | eval (trm_app (trm_app (trm_abs t1) v2) v3) r. 57 | Proof. 58 | introv T1 V2 V3 E. inverts E. inverts H. 59 | apply~ eval_red. 60 | apply* eval_red_values. 61 | rewrite~ <- (eval_value H2). 62 | Qed. 63 | 64 | Hint Resolve eval_red_values. 65 | 66 | 67 | (* ********************************************************************** *) 68 | (** Properties of the CPS transformation *) 69 | 70 | (** Relationship between [cps] and [cpsval] on values *) 71 | 72 | Lemma cps_of_value : forall v, 73 | value v -> 74 | cps v = trm_abs (trm_app (trm_bvar 0) (cpsval v)). 75 | Proof. 76 | introv V. inverts V; rewrite~ cps_fix. 77 | Qed. 78 | 79 | (** [cpsval] of a value is a value *) 80 | 81 | Lemma cpsval_value : forall v, 82 | value v -> 83 | value (cpsval v). 84 | Proof. 85 | introv V. inverts V; simple~. 86 | Qed. 87 | 88 | Hint Resolve cpsval_value. 89 | 90 | (** [cps] does not introduce any free variables *) 91 | 92 | Lemma cps_fv : forall t x, 93 | term t -> 94 | x \notin fv t -> 95 | x \notin fv (cps t). 96 | Proof. 97 | introv T. induction T using term_size; introv Fr; 98 | rewrite cps_fix; unfold Cps; simpls; notin_simpl; auto. 99 | name_var_gen y. tests: (x = y). 100 | subst. apply close_var_notin. 101 | apply~ close_var_notin_keep. 102 | Qed. 103 | 104 | (** (TODO) useful hack to work around a bug of "rewrite cps_fix at 2" *) 105 | 106 | Ltac protect_left := 107 | let x := fresh "left" in 108 | match goal with |- ?X = _ => sets x: X end. 109 | 110 | Ltac simpl_cps := 111 | rewrite cps_fix; unfold Cps. 112 | 113 | (** [cps] commutes with renaming on fresh names *) 114 | 115 | Lemma cps_rename : forall x y t, 116 | term t -> y \notin fv t -> 117 | cps ([[x~>y]]t) = [[x~>y]](cps t). 118 | Proof. 119 | introv T. gen x y. induction T using term_size; introv Fr; simpls. 120 | (* var *) 121 | protect_left. simpl_cps. subst left. simpl_cps. simpl. case_var~. 122 | (* cst *) 123 | simpl_cps. auto. 124 | (* app *) 125 | protect_left. simpl_cps. subst left. simpl_cps. 126 | simpl. fequals. rewrite~ IHT1. rewrite~ IHT2. 127 | (* abs *) 128 | simpl_cps. name_var_gen z. 129 | protect_left. simpl_cps. subst left. name_var_gen z'. 130 | simpl. fequals_rec. 131 | sets ta: ([[x~>y]]t1). 132 | pick_fresh a from (fv ta). 133 | rewrite~ (@subst_intro a). 134 | lets IH1: H0 ta a a z ___. 135 | auto. 136 | subst ta. rewrite~ trm_size_rename. 137 | subst ta. rewrite~ subst_open_var. 138 | auto. 139 | rewrite IH1; clear IH1. 140 | rewrite~ close_var_rename; [| 141 | apply~ cps_fv; subst ta; rewrite~ subst_open_var]. 142 | rewrite~ (@subst_intro a t1). 143 | subst ta. rewrite~ subst_open_var. 144 | do 2 rewrite~ H0. 145 | rewrite~ close_var_subst; [|simple~]. 146 | fequals. rewrite~ close_var_rename. apply~ cps_fv. 147 | Qed. 148 | 149 | (** [cps] does not depend on the named used to open a body *) 150 | 151 | Lemma cps_rename_body : forall y x t, 152 | y \notin fv t -> x \notin fv t -> body t -> 153 | close_var x (cps (t^x)) = close_var y (cps (t^y)). 154 | Proof. 155 | intros. tests: (x = y). subst~. 156 | rewrite~ (@subst_intro y). 157 | rewrite~ cps_rename. 158 | rewrite~ close_var_rename. 159 | apply~ cps_fv. 160 | Qed. 161 | 162 | (** [cps] commutes with substitution *) 163 | 164 | Lemma cps_subst : forall z v t, 165 | term t -> value v -> 166 | cps (subst z v t) = subst z (cpsval v) (cps t). 167 | Proof. 168 | introv T V. induction T; (protect_left; simpl_cps; subst left); simpl. 169 | case_var. 170 | apply~ cps_of_value. 171 | simpl_cps. auto. 172 | simpl_cps. auto. 173 | simpl_cps. rewrite IHT1. rewrite~ IHT2. 174 | simpl_cps. fequals_rec. 175 | name_var_gen y. name_var_gen y'. 176 | pick_fresh a from (fv ([z ~> v]t1) \u fv (cpsval v)). 177 | rewrite~ (@cps_rename_body a); [|apply* body_subst]. 178 | rewrite~ subst_open_var. rewrite~ (H0 a). 179 | rewrite* (@cps_rename_body a). 180 | rewrite~ close_var_subst. 181 | Qed. 182 | 183 | (** [cps] commutes with open *) 184 | 185 | Lemma cps_open : forall t1 v, 186 | value v -> body t1 -> 187 | cps (t1 ^^ v) = (cps_abs_body t1) ^^ cpsval v. 188 | Proof. 189 | introv V B. unfold cps_abs_body. name_var_gen y. 190 | rewrite~ (@subst_intro y). 191 | rewrite~ cps_subst. 192 | rewrite~ (@subst_intro y (close_var y (cps (t1^y)))). 193 | rewrite~ <- close_var_open. 194 | Qed. 195 | 196 | 197 | (* ********************************************************************** *) 198 | (** Prove of the semantic preservation of CPS *) 199 | 200 | Lemma cps_correct_ind : forall v t k r, 201 | eval t v -> 202 | eval (trm_app k (cpsval v)) r -> 203 | value k -> 204 | eval (trm_app (cps t) k) r. 205 | Proof. 206 | introv E. gen k r. induction E; introv EV VK. 207 | (* case: val *) 208 | rewrite~ cps_of_value. 209 | applys~ eval_red_values. calc_open~. 210 | (* case: red *) 211 | simpl_cps. 212 | apply~ eval_red_values. calc_open~. 213 | applys~ IHE1. clear IHE1. 214 | apply eval_red_values; auto. calc_open~. 215 | sets_eq t3': (trm_abs (cps_abs_body t3)). 216 | applys~ IHE2. clear IHE2. 217 | apply~ eval_red_values. calc_open~. 218 | subst t3'. applys~ eval_red_values_bis. 219 | forwards H: IHE3; clear IHE3. eauto. auto. 220 | inverts H as F1 F2 F3. inverts F1. 221 | rewrite~ (eval_value F2) in F3. 222 | rewrite~ <- cps_open. 223 | apply* eval_red. 224 | Qed. 225 | 226 | Lemma cps_correctness : cps_correctness_statement. 227 | Proof. 228 | introv E V. unfold trm_id. apply* cps_correct_ind. 229 | constructors~. calc_open~. 230 | Qed. 231 | 232 | -------------------------------------------------------------------------------- /ln/STLC_Exn_Infrastructure.v: -------------------------------------------------------------------------------- 1 | (*************************************************************************** 2 | * Safety for STLC with Exceptions - Infrastructure * 3 | * Arthur Chargueraud, July 2007 * 4 | ***************************************************************************) 5 | 6 | Set Implicit Arguments. 7 | From TLC Require Import LibLN. 8 | Require Import STLC_Exn_Definitions. 9 | 10 | (* ********************************************************************** *) 11 | (** ** Additional Definitions used in the Proofs *) 12 | 13 | (** Computing free variables of a term. *) 14 | 15 | Fixpoint fv (t : trm) {struct t} : vars := 16 | match t with 17 | | trm_bvar i => \{} 18 | | trm_fvar x => \{x} 19 | | trm_abs t1 => (fv t1) 20 | | trm_app t1 t2 => (fv t1) \u (fv t2) 21 | | trm_raise t1 => (fv t1) 22 | | trm_catch t1 t2 => (fv t1) \u (fv t2) 23 | end. 24 | 25 | (** Substitution for names *) 26 | 27 | Fixpoint subst (z : var) (u : trm) (t : trm) {struct t} : trm := 28 | match t with 29 | | trm_bvar i => trm_bvar i 30 | | trm_fvar x => If x = z then u else (trm_fvar x) 31 | | trm_abs t1 => trm_abs (subst z u t1) 32 | | trm_app t1 t2 => trm_app (subst z u t1) (subst z u t2) 33 | | trm_raise t1 => trm_raise (subst z u t1) 34 | | trm_catch t1 t2 => trm_catch (subst z u t1) (subst z u t2) 35 | end. 36 | 37 | Notation "[ z ~> u ] t" := (subst z u t) (at level 68). 38 | 39 | (** Definition of the body of an abstraction *) 40 | 41 | Definition body t := 42 | exists L, forall x, x \notin L -> term (t ^ x). 43 | 44 | (* ********************************************************************** *) 45 | (** ** Instantiation of Tactics *) 46 | 47 | (** Tactic [pick_fresh] is used to pick fresh names *) 48 | 49 | Ltac gather_vars := 50 | let A := gather_vars_with (fun x : vars => x) in 51 | let B := gather_vars_with (fun x : var => \{x}) in 52 | let C := gather_vars_with (fun x : env => dom x) in 53 | let D := gather_vars_with (fun x : trm => fv x) in 54 | constr:(A \u B \u C \u D). 55 | 56 | Ltac pick_fresh Y := 57 | let L := gather_vars in (pick_fresh_gen L Y). 58 | 59 | Tactic Notation "apply_fresh" constr(T) "as" ident(x) := 60 | apply_fresh_base T gather_vars x. 61 | 62 | Tactic Notation "apply_fresh" "*" constr(T) "as" ident(x) := 63 | apply_fresh T as x; autos*. 64 | 65 | Hint Constructors term value fails red. 66 | 67 | 68 | (* ********************************************************************** *) 69 | (** ** Properties of substitution *) 70 | 71 | (** Substitution on indices is identity on well-formed terms. *) 72 | 73 | Lemma open_rec_term_core :forall t j v i u, i <> j -> 74 | {j ~> v}t = {i ~> u}({j ~> v}t) -> t = {i ~> u}t. 75 | Proof. 76 | induction t; introv Neq Equ; 77 | simpl in *; inversion* Equ; f_equal*. 78 | case_nat*. case_nat*. 79 | Qed. 80 | 81 | Lemma open_rec_term : forall t u, 82 | term t -> forall k, t = {k ~> u}t. 83 | Proof. 84 | induction 1; intros; simpl; f_equal*. unfolds open. 85 | pick_fresh x. apply* (@open_rec_term_core t1 0 (trm_fvar x)). 86 | Qed. 87 | 88 | (** Substitution for a fresh name is identity. *) 89 | 90 | Lemma subst_fresh : forall x t u, 91 | x \notin fv t -> [x ~> u] t = t. 92 | Proof. 93 | intros. induction t; simpls; f_equal*. case_var*. 94 | Qed. 95 | 96 | (** Substitution distributes on the open operation. *) 97 | 98 | Lemma subst_open : forall x u t1 t2, term u -> 99 | [x ~> u] (t1 ^^ t2) = ([x ~> u]t1) ^^ ([x ~> u]t2). 100 | Proof. 101 | intros. unfold open. generalize 0. 102 | induction t1; intros; simpl; f_equal*. 103 | case_nat*. case_var*. apply* open_rec_term. 104 | Qed. 105 | 106 | (** Substitution and open_var for distinct names commute. *) 107 | 108 | Lemma subst_open_var : forall x y u t, y <> x -> term u -> 109 | ([x ~> u]t) ^ y = [x ~> u] (t ^ y). 110 | Proof. 111 | introv Neq Wu. rewrite* subst_open. 112 | simpl. case_var*. 113 | Qed. 114 | 115 | (** Opening up an abstraction of body t with a term u is the same as opening 116 | up the abstraction with a fresh name x and then substituting u for x. *) 117 | 118 | Lemma subst_intro : forall x t u, 119 | x \notin (fv t) -> term u -> 120 | t ^^ u = [x ~> u](t ^ x). 121 | Proof. 122 | introv Fr Wu. rewrite* subst_open. 123 | rewrite* subst_fresh. simpl. case_var*. 124 | Qed. 125 | 126 | 127 | (* ********************************************************************** *) 128 | (** ** Terms are stable through substitutions *) 129 | 130 | (** Terms are stable by substitution *) 131 | 132 | Lemma subst_term : forall t z u, 133 | term u -> term t -> term ([z ~> u]t). 134 | Proof. 135 | induction 2; simpls*. 136 | case_var*. 137 | apply_fresh term_abs as y. rewrite* subst_open_var. 138 | Qed. 139 | 140 | Hint Resolve subst_term. 141 | 142 | 143 | (* ********************************************************************** *) 144 | (** ** Terms are stable through open *) 145 | 146 | (** Conversion from locally closed abstractions and bodies *) 147 | 148 | Lemma term_abs_to_body : forall t1, 149 | term (trm_abs t1) -> body t1. 150 | Proof. 151 | intros. unfold body. inversion* H. 152 | Qed. 153 | 154 | Lemma body_to_term_abs : forall t1, 155 | body t1 -> term (trm_abs t1). 156 | Proof. 157 | intros. inversion* H. 158 | Qed. 159 | 160 | Hint Resolve term_abs_to_body body_to_term_abs. 161 | 162 | (** ** Opening a body with a term gives a term *) 163 | 164 | Lemma open_term : forall t u, 165 | body t -> term u -> term (t ^^ u). 166 | Proof. 167 | intros. destruct H. pick_fresh y. rewrite* (@subst_intro y). 168 | Qed. 169 | 170 | Hint Resolve open_term. 171 | 172 | 173 | (* ********************************************************************** *) 174 | (** ** Regularity of relations *) 175 | 176 | (** A typing relation holds only if the environment has no 177 | duplicated keys and the pre-term is locally-closed. *) 178 | 179 | Lemma typing_regular : forall E t T, 180 | typing E t T -> ok E /\ term t. 181 | Proof. 182 | split; induction H; autos*. 183 | pick_fresh y. forwards~ K: (H0 y). 184 | Qed. 185 | 186 | (** The value predicate only holds on locally-closed terms. *) 187 | 188 | Lemma value_regular : forall t, 189 | value t -> term t. 190 | Proof. 191 | induction 1; autos*. 192 | Qed. 193 | 194 | (** A fails relation only holds on pairs of locally-closed terms. *) 195 | 196 | Lemma fails_regular : forall t e, 197 | fails t e -> term t /\ term e. 198 | Proof. 199 | lets: value_regular. induction 1; jauto. 200 | Qed. 201 | 202 | (** A reduction relation only holds on pairs of locally-closed terms. *) 203 | 204 | Lemma red_regular : forall t t', 205 | red t t' -> term t /\ term t'. 206 | Proof. 207 | lets: value_regular. induction 1; jauto. 208 | lets: (fails_regular H1). jauto. 209 | Qed. 210 | 211 | (** Automation for reasoning on well-formedness. *) 212 | 213 | Hint Extern 1 (ok ?E) => 214 | match goal with 215 | | H: typing E _ _ |- _ => apply (proj1 (typing_regular H)) 216 | end. 217 | 218 | Hint Extern 1 (term ?t) => 219 | match goal with 220 | | H: typing _ t _ |- _ => apply (proj2 (typing_regular H)) 221 | | H: fails t _ |- _ => apply (proj1 (fails_regular H)) 222 | | H: fails _ t |- _ => apply (proj2 (fails_regular H)) 223 | | H: red t _ |- _ => apply (proj1 (red_regular H)) 224 | | H: red _ t |- _ => apply (proj2 (red_regular H)) 225 | | H: value t |- _ => apply (value_regular H) 226 | end. 227 | --------------------------------------------------------------------------------