Commit e67bc044 authored by charguer's avatar charguer

compile_mlv

parent aaad917b
...@@ -43,6 +43,13 @@ let infix_aux x y = x + y ...@@ -43,6 +43,13 @@ let infix_aux x y = x + y
let (---) = infix_aux let (---) = infix_aux
(********************************************************************)
(* ** Inlined total functions *)
let f () =
1 - 1/(-1) + (2 / 2) mod 3
(********************************************************************) (********************************************************************)
(* ** Return *) (* ** Return *)
......
This diff is collapsed.
...@@ -66,7 +66,8 @@ type coqtop = ...@@ -66,7 +66,8 @@ type coqtop =
| Coqtop_module_type of var * mod_bindings * mod_def | Coqtop_module_type of var * mod_bindings * mod_def
| Coqtop_module_type_include of var | Coqtop_module_type_include of var
| Coqtop_end of var | Coqtop_end of var
| Coqtop_custom of string
and coqtops = coqtop list and coqtops = coqtop list
(** Modules and signatures *) (** Modules and signatures *)
...@@ -96,6 +97,7 @@ and mod_bindings = mod_binding list ...@@ -96,6 +97,7 @@ and mod_bindings = mod_binding list
and coqind = { and coqind = {
coqind_name : var; coqind_name : var;
coqind_constructor_name : var;
coqind_targs : typed_vars; coqind_targs : typed_vars;
coqind_ret : coq; coqind_ret : coq;
coqind_branches : typed_vars; } coqind_branches : typed_vars; }
......
This diff is collapsed.
...@@ -75,6 +75,13 @@ type cftop = ...@@ -75,6 +75,13 @@ type cftop =
and cftops = cftop list and cftops = cftop list
(*#########################################################################*)
(** Abstract datatype for dynamic values *)
val coq_dyn_at : Coq.coq
(** Abstract datatype for functions (func) *) (** Abstract datatype for functions (func) *)
val val_type : Coq.coq val val_type : Coq.coq
...@@ -166,14 +173,3 @@ val heap_existss : (Coq.var * Coq.coq) list -> Coq.coq -> Coq.coq ...@@ -166,14 +173,3 @@ val heap_existss : (Coq.var * Coq.coq) list -> Coq.coq -> Coq.coq
(** Lifted propositions [ [P] ] *) (** Lifted propositions [ [P] ] *)
val heap_pred : Coq.coq -> Coq.coq val heap_pred : Coq.coq -> Coq.coq
(** Convert a characteristic formula to a coq expression
(internal function) *)
val coqtops_of_imp_cf : cf -> Coq.coq
(** Convert a list of top-level characteristic formulae into a
list of coqtop declarations *)
val coqtops_of_cftops : cftop list -> Coq.coqtops
This diff is collapsed.
open Coq
open Formula
(** Convert a characteristic formula to a coq expression
(internal function) *)
val coqtops_of_imp_cf : cf -> Coq.coq
(** Convert a list of top-level characteristic formulae into a
list of coqtop declarations *)
val coqtops_of_cftops : cftop list -> Coq.coqtops
...@@ -126,7 +126,7 @@ let _ = ...@@ -126,7 +126,7 @@ let _ =
(*---------------------------------------------------*) (*---------------------------------------------------*)
trace "6) converting caracteristic formula ast to coq ast"; trace "6) converting caracteristic formula ast to coq ast";
let coqtops = Formula.coqtops_of_cftops cftops in let coqtops = Formula_to_coq.coqtops_of_cftops cftops in
(*---------------------------------------------------*) (*---------------------------------------------------*)
trace "7) dumping debug formula file"; trace "7) dumping debug formula file";
......
...@@ -201,4 +201,4 @@ let warning s = ...@@ -201,4 +201,4 @@ let warning s =
let unsupported s = let unsupported s =
failwith ("Unsupported language construction : " ^ s) failwith ("Unsupported language construction : " ^ s)
(* TODO: report location *)
...@@ -6,13 +6,14 @@ open Mytools ...@@ -6,13 +6,14 @@ open Mytools
open Longident open Longident
open Location open Location
open Primitives open Primitives
open Renaming
(** This file takes as input an abstract syntax tree and produces (** This file takes as input an abstract syntax tree and produces
an abstract syntax tree in "normal form", i.e. where intermediate an abstract syntax tree in "normal form", i.e. where intermediate
expressions have been bound to a name. *) expressions have been bound to a name. *)
(*#########################################################################*) (*#########################################################################*)
(* ** Management of fresh identifiers *) (* ** Management of identifiers *)
let name_of_lident idt = let name_of_lident idt =
let words = Longident.flatten idt in let words = Longident.flatten idt in
...@@ -23,15 +24,6 @@ let fullname_of_lident idt = ...@@ -23,15 +24,6 @@ let fullname_of_lident idt =
let words = Longident.flatten idt in let words = Longident.flatten idt in
String.concat "." words String.concat "." words
let check_var loc x =
(* Reject program containing variables with a trailing underscore,
as we use such an underscore to disambiguate with type variables *)
let n = String.length x in
if n > 0 && x.[n-1] = '_'
then unsupported ("variables names should not end with an underscore: " ^ x)
(* --is this line needed? if loc.loc_ghost then () else *)
let check_lident loc idt = let check_lident loc idt =
check_var loc (name_of_lident idt) check_var loc (name_of_lident idt)
...@@ -39,12 +31,11 @@ let check_lident loc idt = ...@@ -39,12 +31,11 @@ let check_lident loc idt =
(*#########################################################################*) (*#########################################################################*)
(* ** Detection of primitive functions and exception-raising *) (* ** Detection of primitive functions and exception-raising *)
(* --todo: forbid the rebinding of primitive names *)
let is_inlined_primitive e largs = let is_inlined_primitive e largs =
let args = List.map snd largs in (* todo: check no labels*) let args = List.map snd largs in (* todo: check no labels*)
match e.pexp_desc, args with match e.pexp_desc, args with
| Pexp_ident f, [n; {pexp_desc = Pexp_constant (Const_int m)}] | Pexp_ident f, [n; {pexp_desc = Pexp_constant (Const_int m)}]
(* TODO: check that mod and "/" are actually coming from pervasives *)
when m > 0 && let x = name_of_lident f in x = "mod" || x = "/" -> when m > 0 && let x = name_of_lident f in x = "mod" || x = "/" ->
is_inlined_primitive_hack (fullname_of_lident f) primitive_special is_inlined_primitive_hack (fullname_of_lident f) primitive_special
| Pexp_ident f,_ -> | Pexp_ident f,_ ->
...@@ -55,6 +46,7 @@ let is_failwith_function e = ...@@ -55,6 +46,7 @@ let is_failwith_function e =
match e.pexp_desc with match e.pexp_desc with
| Pexp_ident li -> | Pexp_ident li ->
begin match Longident.flatten li with begin match Longident.flatten li with
(* TODO: check that failwith/invalide_arg/raise indeed come from Pervasives *)
| f::[] -> (f = "failwith") || (f = "invalid_arg") || (f = "raise") | f::[] -> (f = "failwith") || (f = "invalid_arg") || (f = "raise")
| _ -> false | _ -> false
end end
...@@ -67,7 +59,7 @@ let is_failwith_function e = ...@@ -67,7 +59,7 @@ let is_failwith_function e =
let normalize_pattern p = let normalize_pattern p =
let i = ref (-1) in let i = ref (-1) in
let next_name () = let next_name () =
incr i; ("_p" ^ string_of_int !i) in incr i; (pattern_generated_name !i) in
let rec aux p = let rec aux p =
let loc = p.ppat_loc in let loc = p.ppat_loc in
{ p with ppat_desc = match p.ppat_desc with { p with ppat_desc = match p.ppat_desc with
...@@ -168,12 +160,12 @@ let get_assign_fct loc already_named new_name : expression -> bindings -> expres ...@@ -168,12 +160,12 @@ let get_assign_fct loc already_named new_name : expression -> bindings -> expres
(* -- todo: check evaluation order for tuples and records *) (* -- todo: check evaluation order for tuples and records *)
let normalize_expression named e = let normalize_expression named e =
let i = ref (-1) in let i = ref (-1) in (* TODO: use a gensym function *)
let next_var () = let next_var () =
incr i; ("_x" ^ string_of_int !i) in incr i; (variable_generated_name !i) in
let j = ref (-1) in let j = ref (-1) in
let next_func () = let next_func () =
incr j; ("_f" ^ string_of_int !j) in incr j; (function_generated_name !j) in
let rec aux named (e:expression) : expression * bindings = let rec aux named (e:expression) : expression * bindings =
let loc = e.pexp_loc in let loc = e.pexp_loc in
let return edesc' = let return edesc' =
......
...@@ -148,11 +148,16 @@ let builtin_constructors_table = ...@@ -148,11 +148,16 @@ let builtin_constructors_table =
(*#########################################################################*) (*#########################################################################*)
(* ** Accessor functions *) (* ** Accessor functions *)
(** Auxiliary function for the special case of compiling pervasives *)
let add_pervasives_prefix_if_needed p =
if !Clflags.nopervasives then "Pervasives." ^ p else p
(** Find the inlined primitive associated with [p] of arity [arity] *) (** Find the inlined primitive associated with [p] of arity [arity] *)
let find_inlined_primitive p arity = let find_inlined_primitive p arity =
Printf.printf "find_inlined_primitive: %s %d\n" p arity; (* Printf.printf "find_inlined_primitive: %s %d\n" p arity; *)
let p = add_pervasives_prefix_if_needed p in
match list_assoc_option p inlined_primitives_table with match list_assoc_option p inlined_primitives_table with
| None -> None | None -> None
| Some (n,y) -> if n = arity then Some y else None | Some (n,y) -> if n = arity then Some y else None
...@@ -165,10 +170,11 @@ let is_inlined_primitive p arity = ...@@ -165,10 +170,11 @@ let is_inlined_primitive p arity =
(** Temporary: test only base on the last part of the name *) (** Temporary: test only base on the last part of the name *)
let is_inlined_primitive_hack p arity = let is_inlined_primitive_hack p arity =
let t = List.map (fun (x,(n,y)) -> name_of_mlpath x, (n,y)) inlined_primitives_table in let p = add_pervasives_prefix_if_needed p in
match list_assoc_option p t with match list_assoc_option p inlined_primitives_table with
| None -> false | None -> false
| Some (n,y) -> (arity = n) | Some (n,y) -> (arity = n)
(* old: let inlined_primitives_table = List.map (fun (x,(n,y)) -> name_of_mlpath x, (n,y)) inlined_primitives_table in *)
(** Find the primitive associated with [p]. This partial function (** Find the primitive associated with [p]. This partial function
returns an option. *) returns an option. *)
......
...@@ -166,10 +166,10 @@ and expr1 = function ...@@ -166,10 +166,10 @@ and expr1 = function
app (expr1 e1) (expr0 e2) app (expr1 e1) (expr0 e2)
| Coq_tag (tag, l, e) -> | Coq_tag (tag, l, e) ->
apps [ apps [
string "@CFPrint.tag"; string "CFPrint.tag"; (* @ *)
string tag; string tag;
(* FUTURE USE: label l;*) (* FUTURE USE: label l;*)
string "_"; (* string "_"; *)
expr0 e expr0 e
] ]
| e -> | e ->
...@@ -326,7 +326,7 @@ let parameter x d1 = ...@@ -326,7 +326,7 @@ let parameter x d1 =
let record_rhs r = let record_rhs r =
space ^^ space ^^
string (r.coqind_name ^ "_of") ^^ space ^^ string (r.coqind_constructor_name) ^^ space ^^
braces (fields r.coqind_branches) braces (fields r.coqind_branches)
(* The right-hand side of a sum declaration. [| x1 : T1 | x2 : T2 ...]. *) (* The right-hand side of a sum declaration. [| x1 : T1 | x2 : T2 ...]. *)
......
...@@ -12,11 +12,13 @@ open Asttypes ...@@ -12,11 +12,13 @@ open Asttypes
open Btype open Btype
open Printtyp open Printtyp
open Outcometree open Outcometree
open Renaming
(** This file contains a data structure for representing types in an (** This file contains a data structure for representing types in an
explicit form, as well as an algorithm for extracting such types explicit form, as well as an algorithm for extracting such types
from the representation used by OCaml's compiler. *) from the representation used by OCaml's compiler. *)
(*#########################################################################*) (*#########################################################################*)
(* ** Simple representation of types, called [btyp] *) (* ** Simple representation of types, called [btyp] *)
...@@ -61,7 +63,7 @@ let mark_loops = mark_loops ...@@ -61,7 +63,7 @@ let mark_loops = mark_loops
let name_of_type ty = let name_of_type ty =
let ty = proxy ty in let ty = proxy ty in
let x = name_of_type ty in let x = name_of_type ty in
(String.uppercase x) ^ "_" type_constr_name (String.uppercase x)
let reset_names = reset_names let reset_names = reset_names
......
open Mytools
(*#########################################################################*)
(* ** Checking of variables names *)
let check_var loc x =
(* Reject program containing variables with a trailing underscore,
as we use such an underscore to disambiguate with type variables *)
let n = String.length x in
if n > 0 && x.[n-1] = '_'
then unsupported ("variables names should not end with an underscore: " ^ x)
(* --is this line needed? if loc.loc_ghost then () else *)
(* TODO: also reject programs with variables that may clash with these! *)
(* TODO: make sure that check_var is called where needed *)
(* TODO: need to prevent double-underscore in the names? *)
(* TODO: should check that constructor names don't end with "_"
because these are used by type variables, e.g. "A_" *)
(*#########################################################################*)
(* ** Fresh name generation *)
(** Fresh pattern variable name *)
let pattern_generated_name i =
"_p" ^ string_of_int i
(** Fresh function variable name *)
let function_generated_name i =
"_f" ^ string_of_int i
(** Fresh variable name *)
let variable_generated_name i =
"_x" ^ string_of_int i
(*#########################################################################*)
(* ** Identifier renaming conventions *)
(** Convention for naming module names*)
let module_name name =
name ^ "_ml"
(** Convention for naming type constructors *)
let type_constr_name name =
name ^ "_"
(** Convention for naming record types,
i.e. the one that is bound to "loc" *)
let record_type_name name =
type_constr_name name (* TODO: inline *)
(** Convention for naming the coq record structure
used to describe a record in the heap *)
let record_structure_name name =
name ^ "__struct" (* TODO: inline *)
(** Convention for naming record constructors,
in the coq record structure *)
let record_constructor_name name =
name ^ "__of"
let record_constructor_name_from_type type_name =
type_name ^ "_of"
(* should be consistent with the above:
type_name = name ^ "_"
*)
(** Convention for naming record constructors through representation predicate *)
let record_make_name name =
name ^ "__make"
(** Convention for naming record field *)
let record_field_name name =
name (* ^ "__" *) (* TODO: modify? *)
(** Convention for naming record accessor function *)
let record_field_get_name name =
name ^ "__get"
let record_field_set_name name =
name ^ "__set"
(** Convention for naming record accessor function specifications *)
let record_get_name_spec name =
name ^ "__get_spec"
let record_set_name_spec name =
name ^ "__set_spec"
(* TODO: use above, and also focus/unfocus etc *)
(** Convention for naming the representation predicate for a record *)
let record_repr_name name =
str_capitalize_1 name
(*#########################################################################*)
(* ** Axioms naming conventions *)
let cf_axiom_name name =
name ^ "__cf"
(*#########################################################################*)
(* ** Renaming of infix function names *)
(** Auxiliary function for encoding infix function names *)
let infix_name_symbols =
['!', 'a';
'$', 'b';
'%', 'c';
'&', 'd';
'*', 'e';
'+', 'f';
'-', 'g';
'.', 'h';
'/', 'i';
':', 'j';
'<', 'k';
'=', 'l';
'>', 'm';
'?', 'n';
'@', 'o';
'^', 'p';
'|', 'q';
'~', 'r']
let infix_name_encode name =
let gen = String.map (fun c ->
try List.assoc c infix_name_symbols
with Not_found -> failwith ("infix_name_encode: cannot encode name: " ^ name))
name in
"infix_" ^ gen ^ "_"
(** Convention for renaming infix function names *)
let protect_infix name =
let n = String.length name in
let r = if n > 0 && List.mem_assoc name.[0] infix_name_symbols
then infix_name_encode name
else name in
r
(* debug: Printf.printf "protect %s as %s\n" name r;*)
...@@ -2298,6 +2298,8 @@ Tactic Notation "xpat" := ...@@ -2298,6 +2298,8 @@ Tactic Notation "xpat" :=
(************************************************************) (************************************************************)
(* ** [xmatch] *) (* ** [xmatch] *)
(* TODO: permettre de choisir tous les noms *)
(** [xmatch] applies to a pattern-matching goal of the form (** [xmatch] applies to a pattern-matching goal of the form
[(Match Case x = p1 Then Q1 [(Match Case x = p1 Then Q1
Else Case x = p2 Then Alias y := v in Q2 Else Case x = p2 Then Alias y := v in Q2
......
# TODO: should the files from this folder be in lowercase?
...@@ -8,7 +9,7 @@ ...@@ -8,7 +9,7 @@
READLINK = $(shell if hash greadlink 2>/dev/null ; then echo greadlink ; else echo readlink ; fi) READLINK = $(shell if hash greadlink 2>/dev/null ; then echo greadlink ; else echo readlink ; fi)
# Path to CFML relative to immediate subfolders of $(CFML)/examples. # Path to CFML relative to immediate subfolders of $(CFML)/examples.
CFML := .. CFML := ../..
# Absolute path to CFML. # Absolute path to CFML.
CFML := $(shell $(READLINK) -f $(CFML)) CFML := $(shell $(READLINK) -f $(CFML))
...@@ -66,6 +67,13 @@ vio: $(MLVIO) ...@@ -66,6 +67,13 @@ vio: $(MLVIO)
tools: tools:
@$(MAKE) -C $(CFML) --no-print-directory tools @$(MAKE) -C $(CFML) --no-print-directory tools
force:
perv: tools force
$(CFML_MLV) $(OCAML_FLAGS) -nostdlib -nopervasives -I . Pervasives.ml
$(COQC) $(COQINCLUDE) Pervasives_ml.v
############################################################## ##############################################################
# CMJ/MLV generation rules # CMJ/MLV generation rules
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment