Commit 450e1b90 authored by charguer's avatar charguer

compiles

parent ef3b2492
......@@ -22,7 +22,6 @@ SANITY
- restriction on not binding "min" and "max" could be a bit restrictive..
LATER
- in print_tast and print_past, protect with parenth the infix names being bound
......@@ -39,7 +38,7 @@ LATER
- make systematic use of || (rm -f $@; exit 1) in cfml calls
- currently type annotations in pattern get lost
DEPRECATED?
......
......@@ -220,6 +220,10 @@ let top_val_poly_list = []
let top_val_poly_list_pair = ([],[])
let (top_val_pair_int_1,top_val_pair_int_2) = (1,2)
let (top_val_pair_fun_1,top_val_pair_fun_2) = (fun x -> x), (fun x -> x)
(********************************************************************)
(* ** Polymorphic let bindings *)
......@@ -278,14 +282,28 @@ let exn_raise () =
(* ** Assertions *)
let assert_true () =
assert true; 3
assert true;
3
let assert_pos x =
assert (x > 0); 3
assert (x > 0);
3
let assert_same (x:int) (y:int) =
assert (x = y); 3
assert (x = y);
3
let assert_let () =
assert (let x = true in true);
3
let assert_seq () =
let r = ref 0 in
assert (incr r; true);
!r
let assert_in_seq () =
(assert (true); 3) + 1
(********************************************************************)
......@@ -382,19 +400,18 @@ let order_record () =
{ nb = f(); items = g() }
*)
(* not yet supported : array initializers
let order_array () =
let r = ref 0 in
let f () = incr r; 1 in
let g () = assert (!r = 1); 1 in
[| g() ; f() |]
*)
(********************************************************************)
(* ** Arrays *)
let array_ops () =
let u = [||] in
let t = Array.make 3 0 in
let _x = t.(1) in
t.(2) <- 4;
......
......@@ -10,7 +10,7 @@ Print TLC.LibOrder.ge_from_le.
Definition f := (fun x_ y_ : int => TLC.LibReflect.isTrue (x_ >= y_)).
Print f.
Locate list.
Definition g := .
(fun x_ y_ : int => TLC.LibReflect.isTrue (TLC.LibOrder.lt (TLC.LibOrder.ge_from_le TLC.LibInt.le) x_ y_)).
......@@ -625,6 +625,18 @@ Proof using.
Qed.
let assert_let () =
assert (let x = true in true);
3
let assert_seq () =
let r = ref 0 in
assert (incr r; true);
!r
let assert_in_seq () =
(assert (true); 3) + 1
(********************************************************************)
(* ** Assertions *)
......@@ -879,4 +891,9 @@ Proof using. intros. xcf. xval as p Hp. subst p. xrets. auto. Qed.
*)
(*
let (top_val_pair_int_1,top_val_pair_int_2) = (1,2)
let (top_val_pair_fun_1,top_val_pair_fun_2) = (fun x -> x), (fun x -> x)
*)
......@@ -97,7 +97,7 @@ 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 --no-print-directory quick
@$(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
proof:cf
......
......@@ -478,8 +478,6 @@ let rec lift_val env e =
coq_apps (Coq_var f) (List.map aux args)
| Texp_lazy e ->
aux e
| Texp_array [] ->
Coq_var "array_empty"
| Texp_constraint (e,_,_) ->
aux e
......@@ -749,7 +747,20 @@ let rec cfg_exp env e =
| Downto -> unsupported loc "for-downto expressions" (* later *)
end
| Texp_array expr_list -> unsupported loc "array expressions" (* later *)
| Texp_array args ->
let ccons = Coq_var (get_builtin_constructor "::") in
let cnil = Coq_var (get_builtin_constructor "[]") in
let arg = List.fold_right (fun arg acc ->
coq_apps ccons [lift arg; acc]) args cnil in
let targ = (* ['a], obtained by extraction from ['a array]. *)
match btyp_of_typ_exp e.exp_type with
| Btyp_constr (id,[t]) when Path.name id = "array" -> lift_btyp t
| _ -> failwith "Texp_array should always have type ['a array]"
in
let ts = coq_apps (Coq_var "Coq.Init.Datatypes.list") [targ] in
let tr = coq_typ e in (* 'a array *)
let func = Coq_var "STDLIB.Array.make_empty" in
Cf_app ([ts], tr, func, [arg])
| Texp_field (arg, p, lbl) ->
let tr = coq_typ e in
......
This diff is collapsed.
......@@ -79,14 +79,21 @@ let builtin_constructors_table =
(* --todo: add [Pervasives] as prefix *)
(** [find_builtin_constructor] finds the primitive data-constructor associated
with the argument, and return an optional result.
(** [find_builtin_constructor p] finds the primitive data-constructor associated
with the argument [p], and return an optional result.
For example, given "::" it gives "Coq.Lists.List.cons" and 1,
where 1 is the number of type arguments to cons in Coq. *)
let find_builtin_constructor p =
list_assoc_option p builtin_constructors_table
(** [get_builtin_constructor p] finds the primitive data-constructor associated
with the argument [p], and return the Coq name associated with it. *)
let get_builtin_constructor p =
match find_builtin_constructor p with
| Some (coq_name, arity) -> coq_name
| _ -> failwith ("get_builtin_constructor could not find: " ^ p)
(*#########################################################################*)
......
(* Temporary: because [||] is not supported. *)
external make_empty : unit -> 'a array = "%array_make_empty"
(* Special construction for [|v1; .. ; vN|], encoded as
Array.make_from_list [v1; .. ; vN]. *)
external make_from_list : 'a list -> 'a array = "%array_make_from_list"
(* Special case for [||], needed to implement this file. *)
let make_empty () = make_from_list []
(* Alternative:
external make_empty : unit -> 'a array = "%array_make_empty"
*)
external make : int -> 'a -> 'a array = "%array_make"
......
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