(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)
(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*  Mini_ML.v                                                               *)
(*                                                                          *)
(*  This file contains the definitions of the Mini-ML and the               *)
(*  Categorical Abstract Machine (C.A.M) natural semantics                  *)
(*  It also contains the definition of the translation from                 *)
(*  Mini-ML to the CAM and the proof that this translation is               *)
(*  correct                                                                 *)
(*                                                                          *)
(*                                                                          *)
(*  Samuel Boutin                                                           *)
(*  Coq V5.10                                                               *)
(*  December  1994                                                          *)
(*                                                                          *)
(*                                                                          *)
(****************************************************************************)
(*                                Mini_ML.v                                 *)
(****************************************************************************)
(*****************************************************************************)
(*                CORRECTNESS PROOF OF A MINI_ML COMPILER                    *)
(*                             Samuel Boutin                                 *)
(*                             December 1994                                 *)
(*                              Coql  V5.10                                  *)
(*****************************************************************************)
(*****************************************************************************)
(* First we define a Set "OP" of variable which is a representation of the   *)
(* arithmetic functions *,+,-... that we will not describe explicitely       *)
(* We take the natural numbers to code the variables (but of course it has no*)
(* relation with the De bruijn indexes)                                      *)
(*****************************************************************************)
Parameter OP : Set.
Parameter eval_op : OP -> nat -> nat -> nat.
Definition Pat := nat.
(*****************************************************************************)
(*              Defining the syntax of ML expressions                        *)
(*****************************************************************************)
Inductive MLexp : Set :=
| Bool : bool -> MLexp
| Num : nat -> MLexp
| op : OP -> MLexp
| id : Pat -> MLexp
| appl : MLexp -> MLexp -> MLexp
| mlpair : MLexp -> MLexp -> MLexp
| lambda : Pat -> MLexp -> MLexp
| let' : Pat -> MLexp -> MLexp -> MLexp
| letrec : Pat -> Pat -> MLexp -> MLexp -> MLexp
| ite : MLexp -> MLexp -> MLexp -> MLexp.
(*****************************************************************************)
(*     ML values and environment are defined with the following mutual       *)
(*     recursive definition                                                  *)
(*****************************************************************************)
Inductive MLval : Set :=
| num : nat -> MLval
| boolean : bool -> MLval
| valpair : MLval -> MLval -> MLval
| OP_clos : OP -> MLval
| Clos : Pat -> MLexp -> MLenv -> MLval
| Clos_rec : Pat -> MLexp -> Pat -> MLenv -> MLval
with MLenv : Set :=
| Enil : MLenv
| Econs : Pat -> MLval -> MLenv -> MLenv.
(*****************************************************************************)
(* Definition of VAL_OF which decide if a variable belongs to an environment *)
(*****************************************************************************)
Inductive VAL_OF : MLenv -> Pat -> MLval -> Prop :=
| ELT : forall (e : MLenv) (I : Pat) (a : MLval), VAL_OF (Econs I a e) I a
| CHG :
forall (e : MLenv) (X I : Pat) (a b : MLval),
VAL_OF e I a -> X <> I :>Pat -> VAL_OF (Econs X b e) I a.
(*****************************************************************************)
(*         The following lemma shows us that VAL_OF is deterministic         *)
(*****************************************************************************)
simple induction 1.
intros.
inversion_clear H0; auto.
elim H2; auto.
intros.
apply H1.
inversion H3.
elim H2.
exact H4.
auto.
(* Injection H4. Intros. Try Rewrite <- H5. Elim H9;Auto. Intros;Auto. *)
Qed.
(*****************************************************************************)
(*                   We define now the Mini-ML semantics                     *)
(*In this semantics we want to distinguish the places where application is   *)
(*used in a recursive scheme from the other places.                          *)
(*That's why we have a special rule for application in the case where the    *)
(*function applied has as value a recursive closure (this correspond in fact *)
(*to a test during application                                               *)
(*****************************************************************************)
Inductive ML_DS : MLenv -> MLexp -> MLval -> Prop :=
| BOOL : forall (b : bool) (e : MLenv), ML_DS e (Bool b) (boolean b)
| NUM : forall (n : nat) (e : MLenv), ML_DS e (Num n) (num n)
| Sem_OP : forall (c : OP) (e : MLenv), ML_DS e (op c) (OP_clos c)
| LAMBDA :
forall (e : MLenv) (P : Pat) (E : MLexp),
ML_DS e (lambda P E) (Clos P E e)
| IDENT :
forall (e : MLenv) (v : MLval) (I : Pat),
VAL_OF e I v -> ML_DS e (id I) v
| ITE1 :
forall (e : MLenv) (E1 E2 E3 : MLexp) (v : MLval),
ML_DS e E1 (boolean true) -> ML_DS e E2 v -> ML_DS e (ite E1 E2 E3) v
| ITE2 :
forall (e : MLenv) (E1 E2 E3 : MLexp) (v : MLval),
ML_DS e E1 (boolean false) -> ML_DS e E3 v -> ML_DS e (ite E1 E2 E3) v
| MLPAIR :
forall (e : MLenv) (E1 E2 : MLexp) (u v : MLval),
ML_DS e E1 u -> ML_DS e E2 v -> ML_DS e (mlpair E1 E2) (valpair u v)
| APPml1 :
forall (e e1 : MLenv) (P : Pat) (E E1 E2 : MLexp) (u v : MLval),
ML_DS e E1 (Clos P E e1) ->
ML_DS e E2 u -> ML_DS (Econs P u e1) E v -> ML_DS e (appl E1 E2) v
| APPml2 :
forall (e e1 : MLenv) (x P : Pat) (E E1 E2 : MLexp) (u v : MLval),
ML_DS e E1 (Clos_rec x E P e1) ->
ML_DS e E2 u ->
ML_DS (Econs x u (Econs P (Clos_rec x E P e1) e1)) E v ->
ML_DS e (appl E1 E2) v
| APPml_op :
forall (e : MLenv) (E1 E2 : MLexp) (n m : nat) (c : OP),
ML_DS e E1 (OP_clos c) ->
ML_DS e E2 (valpair (num n) (num m)) ->
ML_DS e (appl E1 E2) (num (eval_op c n m))
| Sem_let :
forall (e : MLenv) (P : Pat) (E1 E2 : MLexp) (u v : MLval),
ML_DS e E2 u -> ML_DS (Econs P u e) E1 v -> ML_DS e (let' P E2 E1) v
| Sem_letrec :
forall (e : MLenv) (P x : Pat) (E E2 : MLexp) (u : MLval),
ML_DS (Econs P (Clos_rec x E P e) e) E2 u ->
ML_DS e (letrec P x E E2) u.
(*****************************************************************************)
(* This predicate can be seen as an injective partial function associating a *)
(*  value to an environment and an expression:                               *)
(*****************************************************************************)
simple induction 1; intros.
inversion_clear H0; auto.
inversion_clear H0; auto.
inversion_clear H0; auto.
inversion_clear H0; auto.
inversion_clear H1; auto. apply (determ_VAL_OF e0 I); auto.
inversion_clear H4. exact (H3 V' H6).
cut (boolean true = boolean false).
intro HH; discriminate HH.
exact (H1 (boolean false) H5).
inversion_clear H4.
cut (boolean false = boolean true).
intro HH; discriminate HH.
exact (H1 (boolean true) H5).
exact (H3 V' H6).
inversion_clear H4.
elim (H1 u0 H5); elim (H3 v0 H6); trivial.
inversion_clear H6.
cut (Clos P E0 e1 = Clos P0 E3 e3).
intro HH; injection HH.
intros.
cut (u = u0).
intro.
apply H5.
try rewrite H6; try rewrite H10; try rewrite H11; try rewrite H12.
exact H9.
exact (H3 u0 H8).
exact (H1 (Clos P0 E3 e3) H7).
cut (Clos P E0 e1 = Clos_rec x E3 P0 e3).
intro HH; discriminate HH.
exact (H1 (Clos_rec x E3 P0 e3) H7).
cut (Clos P E0 e1 = OP_clos c).
intro HH; discriminate HH.
exact (H1 (OP_clos c) H7).
inversion_clear H6.
cut (Clos_rec x E0 P e1 = Clos P0 E3 e3).
intro HH; discriminate HH.
exact (H1 (Clos P0 E3 e3) H7).
cut (Clos_rec x E0 P e1 = Clos_rec x0 E3 P0 e3).
intro HH; injection HH.
cut (u = u0).
intros.
apply H5.
try rewrite H6; try rewrite H10; try rewrite H11; try rewrite H12;
try rewrite H13.
exact H9.
exact (H3 u0 H8).
exact (H1 (Clos_rec x0 E3 P0 e3) H7).
cut (Clos_rec x E0 P e1 = OP_clos c).
intro HH; discriminate HH.
exact (H1 (OP_clos c) H7).
inversion_clear H4.
cut (OP_clos c = Clos P E0 e2).
intro HH; discriminate HH.
exact (H1 (Clos P E0 e2) H5).
cut (OP_clos c = Clos_rec x E0 P e2).
intro HH; discriminate HH.
exact (H1 (Clos_rec x E0 P e2) H5).
cut (valpair (num n) (num m) = valpair (num n0) (num m0)).
intro HH; injection HH.
intros.
cut (OP_clos c = OP_clos c0).
intro HH1; injection HH1.
intro.
try rewrite H4; try rewrite H7; try rewrite H8.
trivial.
exact (H1 (OP_clos c0) H5).
exact (H3 (valpair (num n0) (num m0)) H6).
inversion_clear H4.
cut (u = u0).
intro.
apply H3.
try rewrite H4.
exact H6.
exact (H1 u0 H5).
inversion_clear H2.
apply H1.
exact H3.
Qed.
(*****************************************************************************)
(*We present now the definitions that concerns the Categorical Abstract      *)
(*Machine. The Set Commande defines its syntax                               *)
(*****************************************************************************)
Inductive Value : Set :=
| null : Value
| elem : bool -> Value
| int : nat -> Value
| def_op : OP -> Value.
(*****************************************************************************)
Inductive Commande : Set :=
| quote : Value -> Commande
| car : Commande
| cdr : Commande
| cons : Commande
| push : Commande
| swap : Commande
| branch : Commande -> Commande -> Commande
| cur : Commande -> Commande
| cur_rec : Commande -> Commande
| app : Commande
| o : Commande -> Commande -> Commande.
(*****************************************************************************)
Inductive CSem_val : Set :=
| val : Value -> CSem_val
| Cam_pair : CSem_val -> CSem_val -> CSem_val
| Cam_clos : Commande -> CSem_val -> CSem_val
| Cam_clos_rec : Commande -> CSem_val -> CSem_val
| Cam_nil : CSem_val.
(*****************************************************************************)
Inductive Etat : Set :=
| nil : Etat
| ETcons : CSem_val -> Etat -> Etat.
(*****************************************************************************)
(*               We provide now the Semantics of the CAM                     *)
(*****************************************************************************)
Inductive CAM_DS : Etat -> Commande -> Etat -> Prop :=
| QUO :
forall (s : Etat) (a : CSem_val) (b : Value),
CAM_DS (ETcons a s) (quote b) (ETcons (val b) s)
| CAR :
forall (s : Etat) (a b : CSem_val),
CAM_DS (ETcons (Cam_pair a b) s) car (ETcons a s)
| CDR :
forall (s : Etat) (a b : CSem_val),
CAM_DS (ETcons (Cam_pair a b) s) cdr (ETcons b s)
| CONS :
forall (s : Etat) (a b : CSem_val),
CAM_DS (ETcons b (ETcons a s)) cons (ETcons (Cam_pair a b) s)
| PUSH :
forall (s : Etat) (a : CSem_val),
CAM_DS (ETcons a s) push (ETcons a (ETcons a s))
| SWAP :
forall (s : Etat) (a b : CSem_val),
CAM_DS (ETcons a (ETcons b s)) swap (ETcons b (ETcons a s))
| BRANCHT :
forall (s s1 : Etat) (c1 c2 : Commande),
CAM_DS s c1 s1 -> CAM_DS (ETcons (val (elem true)) s) (branch c1 c2) s1
| BRANCHF :
forall (s s2 : Etat) (c1 c2 : Commande),
CAM_DS s c2 s2 ->
CAM_DS (ETcons (val (elem false)) s) (branch c1 c2) s2
| CUR :
forall (s : Etat) (a : CSem_val) (c : Commande),
CAM_DS (ETcons a s) (cur c) (ETcons (Cam_clos c a) s)
| APPcam1 :
forall (s s1 : Etat) (a b : CSem_val) (c : Commande),
CAM_DS (ETcons (Cam_pair a b) s) c s1 ->
CAM_DS (ETcons (Cam_pair (Cam_clos c a) b) s) app s1
| APPcam2 :
forall (s s1 : Etat) (a b : CSem_val) (c : Commande),
CAM_DS (ETcons (Cam_pair (Cam_pair b (Cam_clos_rec c b)) a) s) c s1 ->
CAM_DS (ETcons (Cam_pair (Cam_clos_rec c b) a) s) app s1
| APPcam_op :
forall (s : Etat) (n m : nat) (oper : OP),
CAM_DS
(ETcons
(Cam_pair (val (def_op oper))
(Cam_pair (val (int n)) (val (int m)))) s) app
(ETcons (val (int (eval_op oper n m))) s)
| CUR_REC :
forall (s : Etat) (a : CSem_val) (c : Commande),
CAM_DS (ETcons a s) (cur_rec c) (ETcons (Cam_clos_rec c a) s)
| o_DS :
forall (s s1 s2 : Etat) (c1 c2 : Commande),
CAM_DS s c1 s1 -> CAM_DS s1 c2 s2 -> CAM_DS s (o c1 c2) s2.
(*****************************************************************************)
(*We now define the "Squelette"of an environment which is the intuitive      *)
(*corresponding list of Debruijn indexes of an environment                   *)
(*****************************************************************************)
Inductive Squelette : Set :=
| nil_squelette : Squelette
| cons_squelette : Pat -> Squelette -> Squelette.
(*****************************************************************************)
Inductive Habite : MLenv -> Squelette -> Prop :=
| triv_habite : Habite Enil nil_squelette
| cons_habite :
forall (x : Pat) (u : MLval) (e : MLenv) (s : Squelette),
Habite e s -> Habite (Econs x u e) (cons_squelette x s).
(*****************************************************************************)
(*                Habite is an injective w.r.t the Squelette argument        *)
(*****************************************************************************)
simple induction e.
intros.
inversion_clear H; inversion_clear H0; trivial.
intros.
inversion_clear H0; inversion_clear H1.
elim (H s s0 H2 H0); trivial.
Qed.
(*****************************************************************************)
(*  The Acces predicate is defined using the notion of Squelette             *)
(* It describes how to reach an identifier in an environment                 *)
(*****************************************************************************)
Inductive Access : Pat -> Squelette -> Commande -> Prop :=
| Rule1 :
forall (P : Pat) (s : Squelette), Access P (cons_squelette P s) cdr
| Rule2 :
forall (P T : Pat) (s : Squelette) (C : Commande),
P <> T -> Access P s C -> Access P (cons_squelette T s) (o car C).
(*****************************************************************************)
(*   The following small lemma shows that Access is injective                *)
(*****************************************************************************)
intro.
simple induction s; intros.
inversion_clear H0.
simple inversion H0.
simple inversion H1.
elim H4; elim H7; trivial.
injection H8; injection H3.
intros.
elim H12.
try rewrite H7; try rewrite <- H2; try rewrite H6; try rewrite <- H11; auto.
try rewrite H4.
simple inversion H1.
intros.
elim H8.
injection H5; injection H3; intros.
try rewrite <- H2; try rewrite H11; try rewrite <- H13; auto.
try rewrite H7.
injection H8; injection H5.
intros HH1 HH2 HH3.
try rewrite HH1; try rewrite HH3.
try rewrite <- H6; try rewrite <- H9.
intros.
elim (H C1 C0 H12 H10).
trivial.
Qed.
(*****************************************************************************)

Lemma Squelet : forall e : MLenv, exists s : Squelette, Habite e s.