/[svn]/typing/typer.ml
ViewVC logotype

Diff of /typing/typer.ml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 85 by abate, Tue Jul 10 17:04:23 2007 UTC revision 86 by abate, Tue Jul 10 17:05:01 2007 UTC
# Line 565  Line 565 
565          let res = Sequence.concat t1 t2 in          let res = Sequence.concat t1 t2 in
566          check loc res constr "";          check loc res constr "";
567          if precise then res else constr          if precise then res else constr
568      | Apply (e1,e2) ->
569          let constr' = Sequence.star
570                          (Sequence.approx (Types.cap Sequence.any constr)) in
571          let t1 = type_check env e1 (Types.cup Types.Arrow.any constr') true in
572          let t1_fun = Types.Arrow.get t1 in
573    
574          let has_fun = not (Types.Arrow.is_empty t1_fun)
575          and has_seq = not (Types.subtype t1 Types.Arrow.any) in
576    
577          let constr' =
578            Types.cap
579              (if has_fun then Types.Arrow.domain t1_fun else Types.any)
580              (if has_seq then constr' else Types.any)
581          in
582          let need_arg = has_fun && Types.Arrow.need_arg t1_fun in
583          let precise  = need_arg || has_seq in
584          let t2 = type_check env e2 constr' precise in
585          let res = Types.cup
586                      (if has_fun then
587                         if need_arg then Types.Arrow.apply t1_fun t2
588                         else Types.Arrow.apply_noarg t1_fun
589                       else Types.empty)
590                      (if has_seq then Sequence.concat t1 t2
591                       else Types.empty)
592          in
593          check loc res constr "";
594          res
595    (*
596          let t1 = type_check env e1 Types.Arrow.any true in
597          let t1 = Types.Arrow.get t1 in
598          let dom = Types.Arrow.domain t1 in
599          if Types.Arrow.need_arg t1 then
600            let t2 = type_check env e2 dom true in
601            Types.Arrow.apply t1 t2
602          else
603            (ignore (type_check env e2 dom false); Types.Arrow.apply_noarg t1)
604    *)
605    
606    | Op ("flatten", [e]) ->    | Op ("flatten", [e]) ->
607        let constr' = Sequence.star        let constr' = Sequence.star
608                        (Sequence.approx (Types.cap Sequence.any constr)) in                        (Sequence.approx (Types.cap Sequence.any constr)) in
# Line 592  Line 630 
630        (try Env.find s env        (try Env.find s env
631         with Not_found -> raise_loc loc (UnboundId s)         with Not_found -> raise_loc loc (UnboundId s)
632        )        )
   | 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)  
633    | Cst c -> Types.constant c    | Cst c -> Types.constant c
634    | Dot (e,l) ->    | Dot (e,l) ->
635        let t = type_check env e Types.Record.any true in        let t = type_check env e Types.Record.any true in
Legend:
Removed from v.85  
changed lines
  Added in v.86
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5