Commit 99c20669 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2002-11-08 22:16:27 by cvscast] Empty log message

Original author: cvscast
Date: 2002-11-08 22:16:27+00:00
parent cd828a15
......@@ -69,7 +69,7 @@ let rec eval env e0 =
and eval_apply f arg = match f with
| Abstraction (_,clos) -> clos arg
| _ -> assert false
| _ -> eval_concat f arg
and eval_branches' env_ref brs arg =
eval_branches !env_ref brs arg
......
......@@ -565,6 +565,44 @@ and type_check' loc env e constr precise = match e with
let res = Sequence.concat t1 t2 in
check loc res constr "";
if precise then res else constr
| Apply (e1,e2) ->
let constr' = Sequence.star
(Sequence.approx (Types.cap Sequence.any constr)) in
let t1 = type_check env e1 (Types.cup Types.Arrow.any constr') true in
let t1_fun = Types.Arrow.get t1 in
let has_fun = not (Types.Arrow.is_empty t1_fun)
and has_seq = not (Types.subtype t1 Types.Arrow.any) in
let constr' =
Types.cap
(if has_fun then Types.Arrow.domain t1_fun else Types.any)
(if has_seq then constr' else Types.any)
in
let need_arg = has_fun && Types.Arrow.need_arg t1_fun in
let precise = need_arg || has_seq in
let t2 = type_check env e2 constr' precise in
let res = Types.cup
(if has_fun then
if need_arg then Types.Arrow.apply t1_fun t2
else Types.Arrow.apply_noarg t1_fun
else Types.empty)
(if has_seq then Sequence.concat t1 t2
else Types.empty)
in
check loc res constr "";
res
(*
let t1 = type_check env e1 Types.Arrow.any true in
let t1 = Types.Arrow.get t1 in
let dom = Types.Arrow.domain t1 in
if Types.Arrow.need_arg t1 then
let t2 = type_check env e2 dom true in
Types.Arrow.apply t1 t2
else
(ignore (type_check env e2 dom false); Types.Arrow.apply_noarg t1)
*)
| Op ("flatten", [e]) ->
let constr' = Sequence.star
(Sequence.approx (Types.cap Sequence.any constr)) in
......@@ -592,15 +630,6 @@ and compute_type' loc env = function
(try Env.find s env
with Not_found -> raise_loc loc (UnboundId s)
)
| Apply (e1,e2) ->
let t1 = type_check env e1 Types.Arrow.any true in
let t1 = Types.Arrow.get t1 in
let dom = Types.Arrow.domain t1 in
if Types.Arrow.need_arg t1 then
let t2 = type_check env e2 dom true in
Types.Arrow.apply t1 t2
else
(ignore (type_check env e2 dom false); Types.Arrow.apply_noarg t1)
| Cst c -> Types.constant c
| Dot (e,l) ->
let t = type_check env e Types.Record.any true in
......
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