Commit e67bc044 authored by charguer's avatar charguer

compile_mlv

parent aaad917b
......@@ -43,6 +43,13 @@ let infix_aux x y = x + y
let (---) = infix_aux
(********************************************************************)
(* ** Inlined total functions *)
let f () =
1 - 1/(-1) + (2 / 2) mod 3
(********************************************************************)
(* ** Return *)
......
This diff is collapsed.
......@@ -66,7 +66,8 @@ type coqtop =
| Coqtop_module_type of var * mod_bindings * mod_def
| Coqtop_module_type_include of var
| Coqtop_end of var
| Coqtop_custom of string
and coqtops = coqtop list
(** Modules and signatures *)
......@@ -96,6 +97,7 @@ and mod_bindings = mod_binding list
and coqind = {
coqind_name : var;
coqind_constructor_name : var;
coqind_targs : typed_vars;
coqind_ret : coq;
coqind_branches : typed_vars; }
......
This diff is collapsed.
......@@ -75,6 +75,13 @@ type cftop =
and cftops = cftop list
(*#########################################################################*)
(** Abstract datatype for dynamic values *)
val coq_dyn_at : Coq.coq
(** Abstract datatype for functions (func) *)
val val_type : Coq.coq
......@@ -166,14 +173,3 @@ val heap_existss : (Coq.var * Coq.coq) list -> Coq.coq -> Coq.coq
(** Lifted propositions [ [P] ] *)
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 _ =
(*---------------------------------------------------*)
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";
......
......@@ -201,4 +201,4 @@ let warning s =
let unsupported s =
failwith ("Unsupported language construction : " ^ s)
(* TODO: report location *)
......@@ -6,13 +6,14 @@ open Mytools
open Longident
open Location
open Primitives
open Renaming
(** This file takes as input an abstract syntax tree and produces
an abstract syntax tree in "normal form", i.e. where intermediate
expressions have been bound to a name. *)
(*#########################################################################*)
(* ** Management of fresh identifiers *)
(* ** Management of identifiers *)
let name_of_lident idt =
let words = Longident.flatten idt in
......@@ -23,15 +24,6 @@ let fullname_of_lident idt =
let words = Longident.flatten idt in
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 =
check_var loc (name_of_lident idt)
......@@ -39,12 +31,11 @@ let check_lident loc idt =
(*#########################################################################*)
(* ** Detection of primitive functions and exception-raising *)
(* --todo: forbid the rebinding of primitive names *)
let is_inlined_primitive e largs =
let args = List.map snd largs in (* todo: check no labels*)
match e.pexp_desc, args with
| 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 = "/" ->
is_inlined_primitive_hack (fullname_of_lident f) primitive_special
| Pexp_ident f,_ ->
......@@ -55,6 +46,7 @@ let is_failwith_function e =
match e.pexp_desc with
| Pexp_ident li ->
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")
| _ -> false
end
......@@ -67,7 +59,7 @@ let is_failwith_function e =
let normalize_pattern p =
let i = ref (-1) in
let next_name () =
incr i; ("_p" ^ string_of_int !i) in
incr i; (pattern_generated_name !i) in
let rec aux p =
let loc = p.ppat_loc in
{ 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
(* -- todo: check evaluation order for tuples and records *)
let normalize_expression named e =
let i = ref (-1) in
let i = ref (-1) in (* TODO: use a gensym function *)
let next_var () =
incr i; ("_x" ^ string_of_int !i) in
incr i; (variable_generated_name !i) in
let j = ref (-1) in
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 loc = e.pexp_loc in
let return edesc' =
......
......@@ -148,11 +148,16 @@ let builtin_constructors_table =
(*#########################################################################*)
(* ** 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] *)
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
| None -> None
| Some (n,y) -> if n = arity then Some y else None
......@@ -165,10 +170,11 @@ let is_inlined_primitive p arity =
(** Temporary: test only base on the last part of the name *)
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
match list_assoc_option p t with
let p = add_pervasives_prefix_if_needed p in
match list_assoc_option p inlined_primitives_table with
| None -> false
| 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
returns an option. *)
......
......@@ -166,10 +166,10 @@ and expr1 = function
app (expr1 e1) (expr0 e2)
| Coq_tag (tag, l, e) ->
apps [
string "@CFPrint.tag";
string "CFPrint.tag"; (* @ *)
string tag;
(* FUTURE USE: label l;*)
string "_";
(* string "_"; *)
expr0 e
]
| e ->
......@@ -326,7 +326,7 @@ let parameter x d1 =
let record_rhs r =
space ^^
string (r.coqind_name ^ "_of") ^^ space ^^
string (r.coqind_constructor_name) ^^ space ^^
braces (fields r.coqind_branches)
(* The right-hand side of a sum declaration. [| x1 : T1 | x2 : T2 ...]. *)
......
......@@ -12,11 +12,13 @@ open Asttypes
open Btype
open Printtyp
open Outcometree
open Renaming
(** This file contains a data structure for representing types in an
explicit form, as well as an algorithm for extracting such types
from the representation used by OCaml's compiler. *)
(*#########################################################################*)
(* ** Simple representation of types, called [btyp] *)
......@@ -61,7 +63,7 @@ let mark_loops = mark_loops
let name_of_type ty =
let ty = proxy ty in
let x = name_of_type ty in
(String.uppercase x) ^ "_"
type_constr_name (String.uppercase x)
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" :=
(************************************************************)
(* ** [xmatch] *)
(* TODO: permettre de choisir tous les noms *)
(** [xmatch] applies to a pattern-matching goal of the form
[(Match Case x = p1 Then Q1
Else Case x = p2 Then Alias y := v in Q2
......
# TODO: should the files from this folder be in lowercase?
......@@ -8,7 +9,7 @@
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.
CFML := ..
CFML := ../..
# Absolute path to CFML.
CFML := $(shell $(READLINK) -f $(CFML))
......@@ -66,6 +67,13 @@ vio: $(MLVIO)
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
......
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