Commit b1305345 authored by Andrei Paskevich's avatar Andrei Paskevich
Browse files

accept partially applied symbols in logic

Will be supported in programs as soon, as we enable lambdas.
parent 006726b2
......@@ -38,15 +38,13 @@ end
let floc_ij i j = Loc.extract (loc_ij i j)
*)
let mk_ppl loc d = { pp_loc = loc; pp_desc = d }
let mk_pp d = mk_ppl (floc ()) d
let mk_pat p = { pat_loc = floc (); pat_desc = p }
let mk_pp_l loc d = { pp_loc = loc; pp_desc = d }
let mk_pp d = { pp_loc = floc (); pp_desc = d }
let infix_ppl loc a i b = mk_ppl loc (PPbinop (a, i, b))
let infix_pp a i b = infix_ppl (floc ()) a i b
let mk_pat p = { pat_loc = floc (); pat_desc = p }
let prefix_ppl loc p a = mk_ppl loc (PPunop (p, a))
let prefix_pp p a = prefix_ppl (floc ()) p a
let infix_pp a i b = mk_pp (PPbinop (a, i, b))
let prefix_pp p a = mk_pp (PPunop (p, a))
let infix s = "infix " ^ s
let prefix s = "prefix " ^ s
......@@ -56,10 +54,6 @@ end
let add_lab id l = { id with id_lab = l }
let mk_l_apply f a =
let loc = Loc.join f.pp_loc a.pp_loc in
{ pp_loc = loc; pp_desc = PPapply (f,a) }
let mk_l_prefix op e1 =
let id = mk_id (prefix op) (floc_i 1) in
mk_pp (PPidapp (Qident id, [e1]))
......@@ -81,14 +75,9 @@ end
| Parsing.Parse_error -> Format.fprintf fmt "syntax error"
| _ -> raise exn)
let mk_expr_l loc d = { expr_loc = loc; expr_desc = d }
let mk_expr d = { expr_loc = floc (); expr_desc = d }
let mk_expr_i i d = { expr_loc = floc_i i; expr_desc = d }
let mk_apply f a =
let loc = Loc.join f.expr_loc a.expr_loc in
{ expr_loc = loc; expr_desc = Eapply (f,a) }
let mk_prefix op e1 =
let id = mk_id (prefix op) (floc_i 1) in
mk_expr (Eidapp (Qident id, [e1]))
......@@ -609,12 +598,10 @@ lexpr:
{ mk_l_infix $1 $2 $3 }
| prefix_op lexpr %prec prec_prefix_op
{ mk_l_prefix $1 $2 }
| qualid list1_lexpr_arg
{ mk_pp (PPidapp ($1, $2)) }
| lexpr_arg_noid list1_lexpr_arg
{ match $1.pp_desc with
| PPidapp (id,al) -> mk_pp (PPidapp (id, al @ $2))
| _ -> List.fold_left mk_l_apply $1 $2 }
| lexpr_arg list1_lexpr_arg /* FIXME/TODO: "lexpr lexpr_arg" */
{ let b = rhs_start_pos 1 in
List.fold_left (fun f (e,a) ->
mk_pp_l (Loc.extract (b,e)) (PPapply (f,a))) $1 $2 }
| IF lexpr THEN lexpr ELSE lexpr
{ mk_pp (PPif ($2, $4, $6)) }
| quant list1_quant_vars triggers DOT lexpr
......@@ -650,8 +637,8 @@ field_value:
;
list1_lexpr_arg:
| lexpr_arg { [$1] }
| lexpr_arg list1_lexpr_arg { $1::$2 }
| lexpr_arg { [rhs_end_pos 1, $1] }
| lexpr_arg list1_lexpr_arg { (rhs_end_pos 1, $1) :: $2 }
;
constant:
......@@ -661,10 +648,6 @@ constant:
lexpr_arg:
| qualid { mk_pp (PPident $1) }
| lexpr_arg_noid { $1 }
;
lexpr_arg_noid:
| constant { mk_pp (PPconst $1) }
| TRUE { mk_pp PPtrue }
| FALSE { mk_pp PPfalse }
......@@ -1194,12 +1177,10 @@ expr:
{ mk_expr (Enot $2) }
| prefix_op expr %prec prec_prefix_op
{ mk_prefix $1 $2 }
| qualid list1_expr_arg
{ mk_expr (Eidapp ($1, $2)) }
| expr_arg_noid list1_expr_arg
{ match $1.expr_desc with
| Eidapp (id,al) -> mk_expr (Eidapp (id, al @ $2))
| _ -> List.fold_left mk_apply $1 $2 }
| expr_arg list1_expr_arg /* FIXME/TODO: "expr expr_arg" */
{ let b = rhs_start_pos 1 in
List.fold_left (fun f (e,a) ->
mk_expr_l (Loc.extract (b,e)) (Eapply (f,a))) $1 $2 }
| IF final_expr THEN expr ELSE expr
{ mk_expr (Eif ($2, $4, $6)) }
| IF final_expr THEN expr %prec prec_no_else
......@@ -1247,7 +1228,7 @@ expr:
| fun_expr
{ mk_expr (Elam $1) }
| VAL top_ghost lident_rich labels tail_type_c IN expr
{ mk_expr (Elet (add_lab $3 $4, $2, mk_expr_i 5 (Eany $5), $7)) }
{ mk_expr (Elet (add_lab $3 $4, $2, mk_expr_l (floc_i 5) (Eany $5), $7)) }
| MATCH final_expr WITH bar_ program_match_cases END
{ mk_expr (Ematch ($2, $5)) }
| MATCH list2_expr_sep_comma WITH bar_ program_match_cases END
......@@ -1287,10 +1268,6 @@ final_expr:
expr_arg:
| qualid { mk_expr (Eident $1) }
| expr_arg_noid { $1 }
;
expr_arg_noid:
| constant { mk_expr (Econst $1) }
| TRUE { mk_expr Etrue }
| FALSE { mk_expr Efalse }
......@@ -1337,8 +1314,8 @@ field_expr:
;
list1_expr_arg:
| expr_arg { [$1] }
| expr_arg list1_expr_arg { $1 :: $2 }
| expr_arg { [rhs_end_pos 1, $1] }
| expr_arg list1_expr_arg { (rhs_end_pos 1, $1) :: $2 }
;
list2_expr_sep_comma:
......
......@@ -203,39 +203,59 @@ let chainable_op uc op =
type global_vs = Ptree.qualid -> vsymbol option
let mk_closure loc ls =
let mk dt = Dterm.dterm ~loc dt in
let id = id_user "fc" loc and dty = dty_fresh () in
let mk_v i _ =
id_user ("y" ^ string_of_int i) loc, dty_fresh () in
let mk_t (id, dty) = mk (DTvar (id.pre_name, dty)) in
let vl = Lists.mapi mk_v ls.ls_args in
let tl = List.map mk_t vl in
let app e1 e2 = DTapp (fs_func_app, [mk e1; e2]) in
let e = List.fold_left app (DTvar ("fc", dty)) tl in
let f = DTapp (ps_equ, [mk e; mk (DTapp (ls, tl))]) in
DTeps (id, dty, mk (DTquant (Tforall, vl, [], mk f)))
let rec dterm uc gvars denv {pp_desc = desc; pp_loc = loc} =
let func_app loc e el =
let app (loc, e) e1 = Loc.join loc e1.pp_loc,
DTfapp (Dterm.dterm ~loc e, dterm uc gvars denv e1) in
snd (List.fold_left app (loc, e) el)
let func_app e el =
List.fold_left (fun e1 (loc, e2) ->
DTfapp (Dterm.dterm ~loc e1, e2)) e el
in
let rec take loc al l el = match l, el with
| (_::l), (e::el) ->
take (Loc.join loc e.pp_loc) (dterm uc gvars denv e :: al) l el
| _, _ -> loc, List.rev al, el
let rec apply_ls loc ls al l el = match l, el with
| (_::l), (e::el) -> apply_ls loc ls (e::al) l el
| [], _ -> func_app (DTapp (ls, List.rev_map snd al)) el
| _, [] -> func_app (mk_closure loc ls) (List.rev_append al el)
in
let qualid_app loc q el = match gvars q with
| Some vs ->
func_app loc (DTgvar vs) el
let qualid_app q el = match gvars q with
| Some vs -> func_app (DTgvar vs) el
| None ->
let ls = find_lsymbol uc q in
let loc, al, el = take loc [] ls.ls_args el in
func_app loc (DTapp (ls,al)) el
apply_ls (qloc q) ls [] ls.ls_args el
in
let qualid_app loc q el = match q with
let qualid_app q el = match q with
| Qident {id = n} ->
(match denv_get_opt denv n with
| Some d -> func_app loc d el
| None -> qualid_app loc q el)
| _ -> qualid_app loc q el
| Some d -> func_app d el
| None -> qualid_app q el)
| _ -> qualid_app q el
in
let rec unfold_app e1 e2 el = match e1.pp_desc with
| PPapply (e11,e12) ->
let e12 = dterm uc gvars denv e12 in
unfold_app e11 e12 ((e1.pp_loc, e2)::el)
| PPident q ->
qualid_app q ((e1.pp_loc, e2)::el)
| _ ->
func_app (DTfapp (dterm uc gvars denv e1, e2)) el
in
Dterm.dterm ~loc (match desc with
| PPident q ->
qualid_app loc q []
qualid_app q []
| PPidapp (q, tl) ->
qualid_app (qloc q) q tl
let tl = List.map (dterm uc gvars denv) tl in
DTapp (find_lsymbol uc q, tl)
| PPapply (e1, e2) ->
DTfapp (dterm uc gvars denv e1, dterm uc gvars denv e2)
unfold_app e1 (dterm uc gvars denv e2) []
| PPtuple tl ->
let tl = List.map (dterm uc gvars denv) tl in
DTapp (fs_tuple (List.length tl), tl)
......
......@@ -380,41 +380,71 @@ let chainable_op uc denv op =
| Some _ -> false (* can never happen *)
| None -> chainable_qualid uc (Qident op)
let mk_closure loc _ls =
Loc.errorm ~loc "Partial@ application@ of@ logical@ symbols@ \
is@ currently@ not@ supported@ in@ programs."
(*
let mk dt = Dterm.dterm ~loc dt in
let id = id_user "fc" loc and dty = dty_fresh () in
let mk_v i _ =
id_user ("y" ^ string_of_int i) loc, dty_fresh () in
let mk_t (id, dty) = mk (DTvar (id.pre_name, dty)) in
let vl = Lists.mapi mk_v ls.ls_args in
let tl = List.map mk_t vl in
let app e1 e2 = DTapp (fs_func_app, [mk e1; e2]) in
let e = List.fold_left app (DTvar ("fc", dty)) tl in
let f = DTapp (ps_equ, [mk e; mk (DTapp (ls, tl))]) in
DTeps (id, dty, mk (DTquant (Tforall, vl, [], mk f)))
*)
let rec dexpr ({uc = uc} as lenv) denv {expr_desc = desc; expr_loc = loc} =
let expr_app loc e el =
let app (loc, e) e1 = Opt.fold Loc.join loc e1.de_loc,
DEapply (Mlw_dexpr.dexpr ~loc e, e1) in
snd (List.fold_left app (loc, e) el)
let expr_app e el =
List.fold_left (fun e1 (loc, e2) ->
DEapply (Mlw_dexpr.dexpr ~loc e1, e2)) e el
in
let rec apply_pl loc pl al l el = match l, el with
| (_::l), (e::el) -> apply_pl loc pl (e::al) l el
| [], _ -> expr_app (DEplapp (pl, List.rev_map snd al)) el
| _, [] -> expr_app (mk_closure loc pl) (List.rev_append al el)
in
let rec take loc al l el = match l, el with
| (_::l), (e::el) ->
take (Opt.fold Loc.join loc e.de_loc) (e::al) l el
| _, _ -> loc, List.rev al, el
let rec apply_ls loc ls al l el = match l, el with
| (_::l), (e::el) -> apply_ls loc ls (e::al) l el
| [], _ -> expr_app (DElsapp (ls, List.rev_map snd al)) el
| _, [] -> expr_app (mk_closure loc ls) (List.rev_append al el)
in
let qualid_app loc q el = match uc_find_ps uc q with
| PV pv -> expr_app loc (DEgpvar pv) el
| PS ps -> expr_app loc (DEgpsym ps) el
| PL pl -> let loc,al,el = take loc [] pl.pl_args el in
expr_app loc (DEplapp (pl, al)) el
| LS ls -> let loc,al,el = take loc [] ls.ls_args el in
expr_app loc (DElsapp (ls, al)) el
let qualid_app q el = match uc_find_ps uc q with
| PV pv -> expr_app (DEgpvar pv) el
| PS ps -> expr_app (DEgpsym ps) el
| PL pl -> apply_pl (qloc q) pl [] pl.pl_args el
| LS ls -> apply_ls (qloc q) ls [] ls.ls_args el
| XS xs -> Loc.errorm ~loc:(qloc q)
"unexpected exception symbol %a" print_xs xs
in
let qualid_app loc q el = match q with
let qualid_app q el = match q with
| Qident {id = n} ->
(match denv_get_opt denv n with
| Some d -> expr_app loc d el
| None -> qualid_app loc q el)
| _ -> qualid_app loc q el
| Some d -> expr_app d el
| None -> qualid_app q el)
| _ -> qualid_app q el
in
let rec unfold_app e1 e2 el = match e1.expr_desc with
| Ptree.Eapply (e11,e12) ->
let e12 = dexpr lenv denv e12 in
unfold_app e11 e12 ((e1.expr_loc, e2)::el)
| Ptree.Eident q ->
qualid_app q ((e1.expr_loc, e2)::el)
| _ ->
expr_app (DEapply (dexpr lenv denv e1, e2)) el
in
Mlw_dexpr.dexpr ~loc (match desc with
| Ptree.Eident q ->
qualid_app loc q []
qualid_app q []
| Ptree.Eidapp (q, tl) ->
qualid_app (qloc q) q (List.map (dexpr lenv denv) tl)
(* FIXME: qloc q is wrong for the 2nd and later arguments *)
let loc = qloc q in
qualid_app q (List.map (fun t -> loc, dexpr lenv denv t) tl)
| Ptree.Eapply (e1, e2) ->
DEapply (dexpr lenv denv e1, dexpr lenv denv e2)
unfold_app e1 (dexpr lenv denv e2) []
| Ptree.Etuple el ->
let el = List.map (dexpr lenv denv) el in
DElsapp (fs_tuple (List.length el), el)
......@@ -422,10 +452,11 @@ let rec dexpr ({uc = uc} as lenv) denv {expr_desc = desc; expr_loc = loc} =
| Ptree.Einnfix (e12, op2, e3) ->
let make_app de1 op de2 = if op.id = "infix <>" then
let oq = Qident { op with id = "infix =" } in
let dt = qualid_app op.id_loc oq [de1;de2] in
(* FIXME: op.id_loc is wrong for the 2nd argument *)
let dt = qualid_app oq [(op.id_loc, de1); (op.id_loc, de2)] in
DEnot (Mlw_dexpr.dexpr ~loc dt)
else
qualid_app op.id_loc (Qident op) [de1;de2]
qualid_app (Qident op) [(op.id_loc, de1); (op.id_loc, de2)]
in
let rec make_chain n1 n2 de1 = function
| [op,de2] ->
......
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