Commit 661c16eb authored by charguer's avatar charguer

cp

parent 386e3bfd
MAJOR TODAY
patterns
let f () =
let r : '_a ref = ref [] in
!r
let f () =
let r : int ref = ref [] in
!r
let f () : 'a list =
let r : 'a ref = ref [] in
!r
xwhile: error reporting when arguments don't have the right types.
rename xextract to xpull; and xgen to xpush.
......@@ -34,29 +21,30 @@ infix_eq_
- when clauses
- open no scope in CF.
- add support for pure records
- inline CFHeader.pred as -1
- xchanges
TopVal check brackets
MAJOR NEXT
MAJOR NEXT
- partial/over application
- xabstract => reimplement and rename as xgen
- eliminate notations for tags
MAJOR NEXT NEXT
- xwhile: error reporting when arguments don't have the right types.
- eliminate notations for tags
- record single field and array single cell notation
Notation "x `. f '~>' S" :=
Notation "x `[ i ] '~>' S" :=
......@@ -65,9 +53,12 @@ MAJOR NEXT NEXT
- see if we can get rid of make_cmj
- mutually recursive polymorhpic functions have too many type variables
quantified: we need one set of fvs for each def in the recursion.
MAJOR POSTPONED
- support char
- support float
- implement the work around for type abbreviations:
......
......@@ -11,36 +11,46 @@ open Pervasives
(********************************************************************)
(* ** Value restriction *)
(* -- accepted program: even though the internal type-checking
involves a ['_a ref] type, the result type is ['a list]. *)
(* -- rejected program: the internal type-checking involves a
['_a ref] type, even though the result type is ['a list].
let value_restriction_0 () =
let r = ref [] in
!r
*)
(* TODO: how to make this program accepted?
=> it is not currently because ocaml typechecker does not
propagate the information downwards in the term.
let value_restriction_1 () : 'a list =
let r = ref ([] : 'a list) in
!r
*)
(* -- rejected program: use of ['_a ref] type annotation is not supported.
let value_restriction_1 () =
let value_restriction_2 () =
let r : '_a ref = ref [] in
!r
*)
(* -- accepted program: monomorphic annotation on the let-bindings *)
let value_restriction_2 () =
let value_restriction_3 () =
let r : (int list) ref = ref [] in
!r
(* -- accepted program: monomorphic annotation on the empty list *)
let value_restriction_3 () =
let value_restriction_4 () =
let r = ref ([] : int list) in
!r
(* -- accepted program: the polymorphic type annotation is accepted,
but it fact it is refined by the type-checker as [(int list) ref]. *)
let value_restriction_4 () =
let value_restriction_5 () =
let r : ('a list) ref = ref [] in
r := [4];
!r
......@@ -48,7 +58,7 @@ let value_restriction_4 () =
(* -- accepted program: likewise, the list [[5]] is accepted at type
['a list], but it comes out at type [int list] from the type-checker. *)
let value_restriction_5 () : 'a list =
let value_restriction_6 () : 'a list =
let r = ref [] in
r := [5];
!r
......@@ -93,6 +103,20 @@ let ret_int_pair () =
let ret_poly () =
[]
(* --Not yet supported:
Error is: Cannot infer this placeholder of type Type
let ret_poly_internal () =
let x = ignore None in
()
*)
(* --TODO: BUG
The reference A_ was not found in the current environment.*)
let ret_poly_internal () =
let x = ignore (None : 'a option) in
()
(********************************************************************)
(* ** Sequence *)
......@@ -246,10 +270,42 @@ let compare_int () =
let compare_min () =
(min 0 1)
(*
(* not yet supported
let compare_float () =
(1. <> 0. && 1. <= 2.) || (0. = 1. && 1. >= 2. && 1. < 2. && 2. > 1.)
*)
let compare_poly () =
let _r1 = (None = None) in
let _r2 = (Some 3 = None) in
let _r3 = ((Some 3, None) = (Some 3, None)) in
let _r4 = (true = false) in
()
(* -- not yet supported (does not seem very useful)
let f () = 4 in
let _r5 = ((Some f, None) = (None, Some f)) in *)
let compare_physical_loc_func () =
let r1a = ref 1 in
let r1b = ref 1 in
let _r1 = (r1a == r1b) in
let _r2 = (r1a != r1b) in
let f () = 1 in
let _r3 = if (f == f) then f() else 1 in
()
let compare_physical_algebraic () =
let rec replace (k:int) (v:int) (l:(int*int) list) =
match l with
| [] -> l
| (k2,v2)::t2 ->
let t = replace k v t2 in
if k = k2 then (k,v)::t
else if t != t2 then (k2,v2)::t
else l (* no change *)
in
replace 1 9 [(1,3); (4,2); (2,5)]
(********************************************************************)
(* ** List operators *)
......@@ -354,13 +410,21 @@ let match_nested () =
| _::(0,0)::q -> q
| _ -> [(2,2)]
(* not yet supported when clauses
(* TODO
let match_term_when () =
let f x = x + 1 in
match f 3 with
| 0 -> 1
| n when n > 0 -> 2
| _ -> 3
let match_or_clauses p =
(* captures (Some x, _) or (_, Some x) with x > 0 *)
match p with
| (None, None) -> false
| ((Some x, _) | (_, Some x)) when x > 0 -> true
| (Some x, _) | (_, Some x) -> false
*)
......
......@@ -5,9 +5,27 @@ Require Import Demo_ml.
Require Import Stdlib.
let compare_options =
let _r1 = (None = None) in
let _r2 = (Some 3 = None) in
let _r3 = ((Some 3, None) = (None, Some 3)) in
let _r4 = ((Some 3, None) = (Some 3, None)) in
let _r5 = (true = false) in
()
let match_term_when () =
let f x = x + 1 in
match f 3 with
| 0 -> 1
| n when n > 0 -> 2
| _ -> 3
let match_or_clauses p =
(* captures (Some x, _) or (_, Some x) with x > 0 *)
match p with
| (None, None) -> false
| ((Some x, _) | (_, Some x)) when x > 0 -> true
| (Some x, _) | (_, Some x) -> false
......
# Possible to define "ML" to be the list of source files to consider
# Uncomment next line to compile only Test.ml
ML := Test.ml
CFDEBUG := 1
include ../Makefile.example
......@@ -91,6 +91,8 @@ code: ocamllib $(ML)
##############################################################
# Characteristic formula generation
ifndef CFDEBUG
cf: $(ML)
# Make sure TLC and CFML itself are up-to-date.
# Needed only when developing TLC and CFML. Ideally, should be removed.
......@@ -100,6 +102,21 @@ cf: $(ML)
@$(MAKE) -C $(CFML)/lib/stdlib --no-print-directory quick
@$(MAKE) CFML=$(CFML) OCAML_FLAGS=$(OCAML_FLAGS) COQINCLUDE="$(COQINCLUDE)" ML="$(ML)" --no-print-directory -f $(CFML)/lib/make/Makefile.cf all
else
#----------------FOR DIRECT TEST----------------------
cf: $(ML)
@$(MAKE) -C $(CFML)/lib/tlc --no-print-directory quick
@$(MAKE) -C $(CFML) --no-print-directory tools coqlib_quick_cf
# @$(MAKE) -C $(CFML) --no-print-directory tools coqlib_quick
@$(MAKE) -C $(CFML)/lib/stdlib CFDEBUG=$(CFDEBUG) --no-print-directory cmj
@$(MAKE) CFML=$(CFML) EXTRA="-debug" OCAML_FLAGS="$(OCAML_FLAGS)" COQINCLUDE="$(COQINCLUDE)" ML="$(ML)" --no-print-directory -f $(CFML)/lib/make/Makefile.cf all
endif
proof:cf
......
This diff is collapsed.
......@@ -13,6 +13,8 @@ let trace s =
let ppf = Format.std_formatter
let only_cmj = ref false
let only_normalize = ref false
let no_mystd_include = ref false
......@@ -34,7 +36,8 @@ let spec =
("-nostdlib", Arg.Set no_mystd_include, " do not include standard library");
("-nopervasives", Arg.Set Clflags.nopervasives, " do not include standard pervasives file");
("-o", Arg.String (fun s -> outputfile := Some s), " set the output file name");
("-only_normalize", Arg.Set only_normalize, " only generate the .cmj file, not the .v file");
("-only_cmj", Arg.Set only_cmj, " only generate the .cmj file, not the .v file");
("-only_normalize", Arg.Set only_normalize, " only generate the .cmj file, and attempt normalization, not the .v file");
("-debug", Arg.Set is_tracing, " trace the various steps");
("-width", Arg.Set_int Print_coq.width, " set pretty-printing width for the .v file");
]
......@@ -103,6 +106,11 @@ let _ =
in
file_put_contents (debugdirBase ^ "_original.ml") (Print_past.string_of_structure parsetree1);
if !only_cmj then begin
trace "3) exiting since -only_cmj";
exit 0;
end;
(*---------------------------------------------------*)
trace "3) normalizing source code";
let parsetree2 : Parsetree.structure = normalize_structure parsetree1 in
......
......@@ -68,7 +68,7 @@ let exp_is_inlined_primitive e largs =
that values_variables won't fail *)
| [e1; e2]
when List.mem shortname ["="; "<>"; "<="; ">="; "<"; ">"; "min"; "max"] -> true
when List.mem shortname ["<="; ">="; "<"; ">"; "min"; "max"] -> true
(* Remark: here we don't check that the types of the arguments are numbers;
we will catch this later in the characteristic formula generation *)
......
......@@ -19,6 +19,8 @@ open Renaming
from the representation used by OCaml's compiler. *)
(*#########################################################################*)
(* ** Simple representation of types, called [btyp] *)
......@@ -27,7 +29,7 @@ type btyp =
| Btyp_arrow of btyp * btyp
| Btyp_constr of Path.t * btyp list
| Btyp_tuple of btyp list
| Btyp_var of bool * string
| Btyp_var of bool * string * type_expr
| Btyp_poly of string list * btyp
| Btyp_val
......@@ -41,6 +43,23 @@ type btyp =
| Btyp_sum of (string * out_type list) list
*)
(*#########################################################################*)
(* ** Used variables *)
let used_level = 11111111111
(** Mark a variable as used at least once. *)
let typvar_mark_used ty =
ty.level <- used_level
(** Test if a variable has been used at least once. *)
let typvar_is_used ty =
ty.level = used_level
(*#########################################################################*)
(* ** Helper functions *)
......@@ -80,13 +99,13 @@ let rec btree_of_typexp sch ty =
let mark = is_non_gen sch ty in
if is_aliased px && aliasable ty
then Btyp_val (* todo: hack ok ? *)
else Btyp_var (mark, name_of_type px) else
else Btyp_var (mark, name_of_type px, ty) else
let pr_typ () =
match ty.desc with
| Tvar ->
add_occured (Occ_gen ty);
Btyp_var (is_non_gen sch ty, name_of_type ty)
Btyp_var (is_non_gen sch ty, name_of_type ty, ty)
| Tarrow(l, ty1, ty2, _) ->
(* with labels
let pr_arrow l ty1 ty2 =
......@@ -117,7 +136,7 @@ let rec btree_of_typexp sch ty =
| Tsubst ty ->
btree_of_typexp sch ty
| Tlink _ | Tnil | Tfield _ ->
fatal_error "Printtyp.btree_of_typexp"
fatal_error "Printtyp.btree_of_typexp link/nil/field unsupported"
| Tpoly (ty, []) ->
btree_of_typexp sch ty
| Tpoly (ty, tyl) ->
......@@ -131,7 +150,8 @@ let rec btree_of_typexp sch ty =
delayed := old_delayed; tr
end
| Tunivar ->
Btyp_var (false, name_of_type ty)
fatal_error "Printtyp.btree_of_typexp univar unsupported"
(* Btyp_var (false, name_of_type ty, ty) *)
| Tpackage _ ->
unsupported_noloc "packaged types"
in
......@@ -233,7 +253,7 @@ and print_simple_out_type =
function
| Btyp_constr (id, tyl) ->
sprintf "@[%a%a@]" (ign print_typargs) tyl (ign print_path) id
| Btyp_var (ng, s) -> sprintf "'%s%s" (if ng then "_" else "") s
| Btyp_var (ng, s, ty) -> sprintf "'%s%s" (if ng then "_" else "") s
| Btyp_val | Btyp_alias _ | Btyp_poly _ | Btyp_arrow _ | Btyp_tuple _ as ty ->
sprintf "@[<1>(%a)@]" (ign print_out_type) ty
(*| Btyp_abstract -> ""
......
......@@ -6,10 +6,21 @@ type btyp =
| Btyp_arrow of btyp * btyp
| Btyp_constr of Path.t * btyp list
| Btyp_tuple of btyp list
| Btyp_var of bool * string
| Btyp_var of bool * string * Types.type_expr
(* - bool: indicates whether generalizable (ie ['a] vs ['_a] type)
- string: name of variable
- type_expr: for internal use to track which variables are used *)
| Btyp_poly of string list * btyp
| Btyp_val
(** Mark a variable as used at least once. *)
val typvar_mark_used : Types.type_expr -> unit
(** Test if a variable has been used at least once. *)
val typvar_is_used : Types.type_expr -> bool
(** Translates a type expression [t] into a [btyp]. *)
val btyp_of_typ_exp : Types.type_expr -> btyp
......
......@@ -72,7 +72,7 @@ let coq_keywords =
"mod"; "return"; "Set"; "then"; "Type"; "using"; "where"; "with"; ]
let builtin_type_constructors =
[ "int"; "unit"; "bool"; "float"; "list"; "string"; "array"; "option" ]
[ "int"; "char"; "unit"; "bool"; "float"; "list"; "string"; "array"; "option" ]
let non_rebindable_names =
["mod"; "/"; "&&"; "||"; "="; "<>"; "<="; ">="; "<"; ">" ]
......@@ -272,6 +272,8 @@ let builtin_constructors_table =
"()", ("Coq.Init.Datatypes.tt", 0);
"true", ("Coq.Init.Datatypes.true", 0);
"false", ("Coq.Init.Datatypes.false", 0);
"None", ("Coq.Init.Datatypes.None", 0);
"Some", ("Coq.Init.Datatypes.Some", 1);
]
(* --todo: add [Pervasives] as prefix *)
......
......@@ -16,6 +16,8 @@
open Types
(**** Type level management ****)
let generic_level = 100000000
......@@ -25,12 +27,13 @@ let lowest_level = 0
let pivot_level = 2 * lowest_level - 1
(* pivot_level - lowest_level < lowest_level *)
(**** Some type creators ****)
let new_id = ref (-1)
let newty2 level desc =
incr new_id; { desc = desc; level = level; id = !new_id }
incr new_id; { desc = desc; level = level; id = !new_id }
let newgenty desc = newty2 generic_level desc
let newgenvar () = newgenty Tvar
(*
......@@ -41,6 +44,7 @@ let newmarkedgenvar () =
{ desc = Tvar; level = pivot_level - generic_level; id = !new_id }
*)
(**** Representative of a type ****)
let rec field_kind_repr =
......@@ -161,6 +165,75 @@ let is_row_name s =
if l < 4 then false else String.sub s (l-4) 4 = "#row"
(**********************************)
(* CFML hooks *)
(**********************************)
(* DEPRECATED
(* CFML *)
let debug_generic = true
let hook_generic : (((type_expr list) ref) list) ref = ref []
let open_hook () =
if debug_generic then Format.printf "open hook %d\n" (1+List.length !hook_generic);
let r : (type_expr list) ref = ref [] in
hook_generic := r :: !hook_generic
let close_hook () =
match !hook_generic with
| [] -> failwith "close_hook called while hook list is empty"
| h::hs ->
if debug_generic then
Format.printf "close hook %d of length %d\n"
(List.length !hook_generic)
(List.length !h);
hook_generic := hs; !h
let add_generic t =
if debug_generic then Format.printf "traverse from generic root\n" ;
(* cannot access printer...
Printtyp.type_expr err t;
Format.fprintf err "\n" ;
*)
match !hook_generic with
| [] -> Printf.printf "warning: no hook\n" ;
(* TODO *)
failwith "add_generic: no hook registered!"
| tys::_ ->
let max_depth = 100 in (* TODO: how to prevent traversing cycles? *)
let rec aux n t =
Format.printf "call to aux\n";
if n = 0 then Printf.printf "warning:add_generic traversing cyclic type; approximating the result.\n" else begin
let aux = aux (n-1) in
let t = repr t in (* TODO: might want to use proxy if objects are supported *)
match t.desc with
| Tvar | Tunivar ->
if debug_generic then Format.printf "add generic var\n" ;
if not (List.memq t !tys)
then tys := t :: !tys
| Tarrow (_,t1,t2,_) -> aux t1; aux t2
| Ttuple ts ->
Format.printf "traverse tuple of length %d\n" (List.length ts);
List.iter aux ts
| Tconstr (_,ts,_) ->
Format.printf "traverse constr of length %d\n" (List.length ts);
List.iter aux ts
| Tobject _ -> failwith "unsupported Tobject type"
| Tfield _ -> failwith "unsupported Tfield type"
| Tnil -> failwith "unsupported Tnil type"
| Tvariant _ -> failwith "unsupported Tvariant type"
| Tunivar -> failwith "unsupported Tunivar type"
| Tpoly _ -> failwith "unsupported Tpoly type"
| Tpackage _ -> failwith "unsupported Tpackage type"
| Tlink _ -> failwith "unsupported Tlink type"
| Tsubst _ -> failwith "unsupported Tsubst type"
end in
aux max_depth t
(* END CFML *)
*)
(**********************************)
(* Utilities for type traversal *)
(**********************************)
......@@ -470,29 +543,8 @@ let link_type ty ty' = log_type ty; ty.desc <- Tlink ty'
(* ; check_expans [] ty' *)
(* CFML *)
let hook_generic : (((type_expr list) ref) list) ref = ref []
let open_hook () =
let r : (type_expr list) ref = ref [] in
hook_generic := r :: !hook_generic
let close_hook () =
match !hook_generic with
| [] -> failwith "close_hook called while hook list is empty"
| h::hs -> hook_generic := hs; !h
let add_generic t =
if !hook_generic <> [] then begin (*failwith "hook to catch generic variables : no hook registered !";*)
let list = List.hd !hook_generic in
let t = proxy t in
match t.desc with
| Tvar | Tunivar -> (* TODO: ARTHUR est-ce bien a ? *)
if not (List.memq t !list)
then list := t :: !list
| _ -> ()
end
let set_level ty level =
if level = generic_level then add_generic ty; (* CFML *)
(* DEPRECATED if level = generic_level then add_generic ty; (* CFML *) *)
if ty.id <= !last_snapshot then log_change (Clevel (ty, ty.level));
ty.level <- level
let set_univar rty ty =
......
......@@ -153,7 +153,3 @@ val set_commu: commutable ref -> commutable -> unit
(* Set references, logging the old value *)
val log_type: type_expr -> unit
(* Log the old value of a type, before modifying it by hand *)
(* CFML *)
val open_hook : unit -> unit
val close_hook : unit -> type_expr list
......@@ -143,9 +143,81 @@ let proper_abbrevs path tl abbrev =
(**** Some type creators ****)
(**********************************)
(* CFML hooks *)
(**********************************)
(* CFML *)
let debug_generic = false
let hook_generic : (((type_expr list) ref) list) ref = ref []
let open_hook () =
if debug_generic
then Format.fprintf Format.err_formatter "open hook %d at level %d\n" (1+List.length !hook_generic) !current_level;
let r : (type_expr list) ref = ref [] in
hook_generic := r :: !hook_generic
let hook_fresh_var t =
(* cannot access printer...
Printtyp.type_expr err t;
Format.fprintf err "\n" ;
*)
match !hook_generic with
| [] -> () (* At global level, we don't trace anything *)
| tys::_ ->
let t = repr t in (* TODO: might want to use proxy if objects are supported *)
match t.desc with
| Tvar | Tunivar -> (* TODO: what is univar for? *)
if debug_generic then Format.fprintf Format.err_formatter "hook fresh var\n" ;
tys := t :: !tys
| _ -> () (* not added because t certainly won't generalize *)
(* DEPRECATED
let max_depth = 100 in (* TODO: how to prevent traversing cycles? *)
let rec aux n t =
Format.fprintf Format.err_formatter "call to aux\n";
if n = 0 then Printf.printf "warning:hook_fresh_var traversing cyclic type; approximating the result.\n" else begin
let aux = aux (n-1) in
let t = repr t in (* TODO: might want to use proxy if objects are supported *)
match t.desc with
| Tvar | Tunivar ->
if debug_generic then Format.printf "add generic var\n" ;
if not (List.memq t !tys)
then tys := t :: !tys
| Tarrow (_,t1,t2,_) -> aux t1; aux t2
| Ttuple ts ->
Format.printf "traverse tuple of length %d\n" (List.length ts);
List.iter aux ts
| Tconstr (_,ts,_) ->
Format.printf "traverse constr of length %d\n" (List.length ts);