Une MAJ de sécurité est nécessaire sur notre version actuelle. Elle sera effectuée lundi 02/08 entre 12h30 et 13h. L'interruption de service devrait durer quelques minutes (probablement moins de 5 minutes).

Commit c4743ffc authored by charguer's avatar charguer
Browse files

compiles

parent 2c287e3c
...@@ -37,6 +37,7 @@ LATER ...@@ -37,6 +37,7 @@ LATER
- support float - support float
- make systematic use of || (rm -f $@; exit 1) in cfml calls
DEPRECATED? DEPRECATED?
......
...@@ -346,13 +346,7 @@ let order_constr () = ...@@ -346,13 +346,7 @@ let order_constr () =
let r = ref 0 in let r = ref 0 in
let f () = incr r; 1 in let f () = incr r; 1 in
let g () = assert (!r = 1); 1 in let g () = assert (!r = 1); 1 in
(g() :: f() :: nil) (g() :: f() :: [])
let order_array () =
let r = ref 0 in
let f () = incr r; 1 in
let g () = assert (!r = 1); 1 in
[| g() ; f() |]
let order_list () = let order_list () =
let r = ref 0 in let r = ref 0 in
...@@ -366,12 +360,31 @@ let order_tuple () = ...@@ -366,12 +360,31 @@ let order_tuple () =
let g () = assert (!r = 1); 1 in let g () = assert (!r = 1); 1 in
(g(), f()) (g(), f())
let order_record () : 'a sitems =
let r = ref 0 in
let g () : 'a list = incr r; [] in
let f () = assert (!r = 1); 1 in
{ nb = f(); items = g() }
(* not yet supported : relaxed value restriction;
(below, the call to g() results in a fresh type variable).
The work around is to annotate a bit more, as done above;
this avoids having a type for [g] that is too general.
let order_record () = let order_record () =
let r = ref 0 in let r = ref 0 in
let g () = incr r; [] in let g () = incr r; [] in
let f () = assert (!r = 1); 1 in let f () = assert (!r = 1); 1 in
{ nb = f(); items = g() } { 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() |]
*)
(********************************************************************) (********************************************************************)
...@@ -392,7 +405,7 @@ let array_ops () = ...@@ -392,7 +405,7 @@ let array_ops () =
let while_decr () = let while_decr () =
let n = ref 3 in let n = ref 3 in
let c = ref 0 in let c = ref 0 in
while !n > 0 do while !n > 0 do
incr c; incr c;
decr n; decr n;
done; done;
...@@ -425,7 +438,7 @@ let rec rec_partial_half x = ...@@ -425,7 +438,7 @@ let rec rec_partial_half x =
let rec rec_mutual_f x = let rec rec_mutual_f x =
if x <= 0 then x else 1 + rec_mutual_g (x-2) if x <= 0 then x else 1 + rec_mutual_g (x-2)
and rec rec_mutual g x = and rec_mutual_g x =
rec_mutual_f (x+1) rec_mutual_f (x+1)
......
...@@ -97,7 +97,7 @@ cf: $(ML) ...@@ -97,7 +97,7 @@ cf: $(ML)
@$(MAKE) -C $(CFML)/lib/tlc --no-print-directory quick @$(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_cf
@$(MAKE) -C $(CFML) --no-print-directory tools coqlib_quick @$(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 @$(MAKE) CFML=$(CFML) OCAML_FLAGS=$(OCAML_FLAGS) COQINCLUDE="$(COQINCLUDE)" ML="$(ML)" --no-print-directory -f $(CFML)/lib/make/Makefile.cf all
proof:cf proof:cf
......
...@@ -598,8 +598,8 @@ let rec cfg_exp env e = ...@@ -598,8 +598,8 @@ let rec cfg_exp env e =
let aux = cfg_exp env in let aux = cfg_exp env in
let lift e = lift_val env e in let lift e = lift_val env e in
let ret e = Cf_ret (lift e) in let ret e = Cf_ret (lift e) in
let not_normal () = let not_normal ?s:(s="") () =
not_in_normal_form loc (Print_tast.string_of_expression false e) in not_in_normal_form loc (s ^ Print_tast.string_of_expression false e) in
match e.exp_desc with match e.exp_desc with
| Texp_ident (x,d) -> ret e | Texp_ident (x,d) -> ret e
| Texp_open (p, {exp_desc = Texp_ident _}) -> assert false | Texp_open (p, {exp_desc = Texp_ident _}) -> assert false
...@@ -624,8 +624,7 @@ let rec cfg_exp env e = ...@@ -624,8 +624,7 @@ let rec cfg_exp env e =
| Texp_apply (funct, oargs) when exp_is_inlined_primitive funct oargs -> ret e | Texp_apply (funct, oargs) when exp_is_inlined_primitive funct oargs -> ret e
| Texp_function (_, pat_expr_list, partial) -> assert false; (*not_normal () todo:better message*) | Texp_function (_, pat_expr_list, partial) -> not_normal ~s:"The function involved has not been lifted properly during normalization;\n check the normalized file in _output folder.\n" ()
| Texp_let(rf, fvs, pat_expr_list, body) -> | Texp_let(rf, fvs, pat_expr_list, body) ->
...@@ -687,8 +686,9 @@ let rec cfg_exp env e = ...@@ -687,8 +686,9 @@ let rec cfg_exp env e =
end else begin end else begin
if fvs_strict <> [] || fvs_others <> [] if fvs_strict <> [] || fvs_others <> []
then not_in_normal_form loc ("(unsatisfied value restriction) " then unsupported loc "relaxed value restriction";
^ (Print_tast.string_of_expression false e)); (* not_in_normal_form loc ("(un value restriction) "
^ (Print_tast.string_of_expression false e));*)
let cf1 = cfg_exp env bod in let cf1 = cfg_exp env bod in
let env' = Ident.add (pattern_ident pat) (List.length fvs_strict) env in let env' = Ident.add (pattern_ident pat) (List.length fvs_strict) env in
let cf2 = cfg_exp env' body in let cf2 = cfg_exp env' body in
......
...@@ -267,15 +267,16 @@ let normalize_expression named e = ...@@ -267,15 +267,16 @@ let normalize_expression named e =
let e1',b1 = aux true e1 in let e1',b1 = aux true e1 in
let e' = create_let loc b1 ( let e' = create_let loc b1 (
create_let loc [normalize_pattern p1, e1'] ( create_let loc [normalize_pattern p1, e1'] (
protect named e2)) in protect false e2)) in
assign_var e' [] assign_var e' []
| _ -> | _ ->
let e1',b1 = aux false e1 in let e1',b1 = aux false e1 in
let e' = create_let loc b1 ( let e' = create_let loc b1 (
create_match_one loc e1' (normalize_pattern p1) (protect named e2)) in create_match_one loc e1' (normalize_pattern p1) (protect false e2)) in
assign_var e' [] assign_var e' []
end end
| Pexp_let (rf, l, e) -> | Pexp_let (rf, l, e) -> unsupported loc "non-recursive let-and construct"
(* DEPRECATED --seems buggous
let check_is_named_pat p = let check_is_named_pat p =
match p.ppat_desc with match p.ppat_desc with
| Ppat_var x | Ppat_var x
...@@ -285,6 +286,7 @@ let normalize_expression named e = ...@@ -285,6 +286,7 @@ let normalize_expression named e =
if not (List.for_all check_is_named_pat (List.map fst l)) if not (List.for_all check_is_named_pat (List.map fst l))
then unsupported loc "let-rec with patterns not reduced to names"; then unsupported loc "let-rec with patterns not reduced to names";
aux true (List.fold_right (fun (pi,ei) eacc -> create_let loc [pi,ei] eacc) l e) aux true (List.fold_right (fun (pi,ei) eacc -> create_let loc [pi,ei] eacc) l e)
*)
| Pexp_function (lab, None, [_]) -> | Pexp_function (lab, None, [_]) ->
let rec protect_func (ms : (expression * pattern) list) (e : expression) = let rec protect_func (ms : (expression * pattern) list) (e : expression) =
match e.pexp_desc with match e.pexp_desc with
...@@ -327,7 +329,10 @@ let normalize_expression named e = ...@@ -327,7 +329,10 @@ let normalize_expression named e =
| Pexp_apply (e0, [(l1,e1); (l2,e2)]) when is_lazy_binary_op e0 -> | Pexp_apply (e0, [(l1,e1); (l2,e2)]) when is_lazy_binary_op e0 ->
(* TODO: assert that the labels are irrelevant here *) (* TODO: assert that the labels are irrelevant here *)
let e0',b0 = aux false e0 in let e0',b0 = aux false e0 in
let name = match e0.pexp_desc with Pexp_ident f -> name_of_lident f in let name = match e0.pexp_desc with
| Pexp_ident f -> name_of_lident f
| _ -> assert false (* could not be a lazy op otherwise *)
in
assert (b0 = []); (* since e0 should be "&&" or "||" *) assert (b0 = []); (* since e0 should be "&&" or "||" *)
let e1',b1 = aux false e1 in let e1',b1 = aux false e1 in
let e2',b2 = aux false e2 in let e2',b2 = aux false e2 in
...@@ -424,7 +429,7 @@ let normalize_expression named e = ...@@ -424,7 +429,7 @@ let normalize_expression named e =
let e1', b = aux true e1 in let e1', b = aux true e1 in
let tunit = Some { ptyp_desc = Ptyp_constr (Lident "unit", []); ptyp_loc = loc } in let tunit = Some { ptyp_desc = Ptyp_constr (Lident "unit", []); ptyp_loc = loc } in
let e1'' = return (Pexp_constraint (e1', tunit, None)) in let e1'' = return (Pexp_constraint (e1', tunit, None)) in
assign_var (return (Pexp_sequence (e1'', protect named e2))) b assign_var (return (Pexp_sequence (e1'', protect false e2))) b
| Pexp_while (e1,e2) -> | Pexp_while (e1,e2) ->
assign_var (return (Pexp_while (protect named e1, protect named e2))) [] assign_var (return (Pexp_while (protect named e1, protect named e2))) []
| Pexp_for (s,e1,e2,d,e3) -> | Pexp_for (s,e1,e2,d,e3) ->
......
...@@ -12,7 +12,11 @@ open Format ...@@ -12,7 +12,11 @@ open Format
(* ** Printing of base values *) (* ** Printing of base values *)
let parent_if_infix s = let parent_if_infix s =
if Renaming.is_infix_name s then sprintf "(%s)" s else s if Renaming.is_infix_name s then begin
if s.[0] = '*' || s.[String.length s - 1] = '*'
then sprintf "( %s )" s
else sprintf "(%s)" s
end else s
let string_of_ident s = let string_of_ident s =
parent_if_infix (Ident.name s) parent_if_infix (Ident.name s)
......
...@@ -129,7 +129,7 @@ endif ...@@ -129,7 +129,7 @@ endif
# Only the %.cmj target is known to "make". # Only the %.cmj target is known to "make".
%.cmj: %.ml $(CFML_MLV) %.cmj: %.ml $(CFML_MLV)
$(CFML_MLV) $(OCAML_FLAGS) -nostdlib -I $(CFML)/lib/stdlib -I . $< $(CFML_MLV) $(OCAML_FLAGS) -nostdlib -I $(CFML)/lib/stdlib -I . $< || (rm -f $@; exit 1)
# We use Coq to produce a .vio file out of a .v file. # We use Coq to produce a .vio file out of a .v file.
......
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