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

Diff of /typing/typer.ml

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

revision 315 by abate, Tue Jul 10 17:24:30 2007 UTC revision 316 by abate, Tue Jul 10 17:24:41 2007 UTC
# Line 484  Line 484 
484  (* IDEA: introduce a node Loc in the AST to override nolocs  (* IDEA: introduce a node Loc in the AST to override nolocs
485     in sub-expressions *)     in sub-expressions *)
486    
487  let rec expr loc' { loc = loc; descr = d } =  let exp loc fv e =
488    let loc =  if loc = noloc then loc' else loc in    fv,
489    let (fv,td) =    { Typed.exp_loc = loc;
490      match d with      Typed.exp_typ = Types.empty;
491        Typed.exp_descr = e;
492      }
493    
494    
495    let rec expr loc = function
496      | LocatedExpr (loc,e) -> expr loc e
497        | Forget (e,t) ->        | Forget (e,t) ->
498            let (fv,e) = expr loc e and t = typ t in            let (fv,e) = expr loc e and t = typ t in
499            (fv, Typed.Forget (e,t))        exp loc fv (Typed.Forget (e,t))
500        | Var s -> (Fv.singleton s, Typed.Var s)    | Var s ->
501          exp loc (Fv.singleton s) (Typed.Var s)
502        | Apply (e1,e2) ->        | Apply (e1,e2) ->
503            let (fv1,e1) = expr loc e1 and (fv2,e2) = expr loc e2 in            let (fv1,e1) = expr loc e1 and (fv2,e2) = expr loc e2 in
504            (Fv.cup fv1 fv2, Typed.Apply (e1,e2))        exp loc (Fv.cup fv1 fv2) (Typed.Apply (e1,e2))
505        | Abstraction a ->        | Abstraction a ->
506            let iface = List.map (fun (t1,t2) -> (typ t1, typ t2))            let iface = List.map (fun (t1,t2) -> (typ t1, typ t2))
507                          a.fun_iface in                          a.fun_iface in
# Line 504  Line 511 
511            let iface = List.map            let iface = List.map
512                          (fun (t1,t2) -> (Types.descr t1, Types.descr t2))                          (fun (t1,t2) -> (Types.descr t1, Types.descr t2))
513                          iface in                          iface in
514            let (fv0,body) = branches loc a.fun_body in        let (fv0,body) = branches a.fun_body in
515            let fv = match a.fun_name with            let fv = match a.fun_name with
516              | None -> fv0              | None -> fv0
517              | Some f -> Fv.remove f fv0 in              | Some f -> Fv.remove f fv0 in
518            (fv,        let e = Typed.Abstraction
            Typed.Abstraction  
519               { Typed.fun_name = a.fun_name;               { Typed.fun_name = a.fun_name;
520                 Typed.fun_iface = iface;                 Typed.fun_iface = iface;
521                 Typed.fun_body = body;                 Typed.fun_body = body;
522                 Typed.fun_typ = t;                 Typed.fun_typ = t;
523                 Typed.fun_fv = fv                 Typed.fun_fv = fv
524               }                  } in
525            )        exp loc fv e
526        | Cst c -> (Fv.empty, Typed.Cst c)    | Cst c ->
527          exp loc Fv.empty (Typed.Cst c)
528        | Pair (e1,e2) ->        | Pair (e1,e2) ->
529            let (fv1,e1) = expr loc e1 and (fv2,e2) = expr loc e2 in            let (fv1,e1) = expr loc e1 and (fv2,e2) = expr loc e2 in
530            (Fv.cup fv1 fv2, Typed.Pair (e1,e2))        exp loc (Fv.cup fv1 fv2) (Typed.Pair (e1,e2))
531        | Xml (e1,e2) ->        | Xml (e1,e2) ->
532            let (fv1,e1) = expr loc e1 and (fv2,e2) = expr loc e2 in            let (fv1,e1) = expr loc e1 and (fv2,e2) = expr loc e2 in
533            (Fv.cup fv1 fv2, Typed.Xml (e1,e2))        exp loc (Fv.cup fv1 fv2) (Typed.Xml (e1,e2))
534        | Dot (e,l) ->        | Dot (e,l) ->
535            let (fv,e) = expr loc e in            let (fv,e) = expr loc e in
536            (fv,  Typed.Dot (e,l))        exp loc fv (Typed.Dot (e,l))
537        | RemoveField (e,l) ->        | RemoveField (e,l) ->
538            let (fv,e) = expr loc e in            let (fv,e) = expr loc e in
539            (fv,  Typed.RemoveField (e,l))        exp loc fv (Typed.RemoveField (e,l))
540        | RecordLitt r ->        | RecordLitt r ->
541            let fv = ref Fv.empty in            let fv = ref Fv.empty in
542            let r = LabelMap.map            let r = LabelMap.map
# Line 537  Line 544 
544                         let (fv2,e) = expr loc e                         let (fv2,e) = expr loc e
545                         in fv := Fv.cup !fv fv2; e)                         in fv := Fv.cup !fv fv2; e)
546                      r in                      r in
547            (!fv, Typed.RecordLitt r)        exp loc !fv (Typed.RecordLitt r)
548        | Op (op,le) ->        | Op (op,le) ->
549            let (fvs,ltes) = List.split (List.map (expr loc) le) in            let (fvs,ltes) = List.split (List.map (expr loc) le) in
550            let fv = List.fold_left Fv.cup Fv.empty fvs in            let fv = List.fold_left Fv.cup Fv.empty fvs in
551            (fv, Typed.Op (op,ltes))        exp loc fv (Typed.Op (op,ltes))
552        | Match (e,b) ->        | Match (e,b) ->
553            let (fv1,e) = expr loc e            let (fv1,e) = expr loc e
554            and (fv2,b) = branches loc b in        and (fv2,b) = branches b in
555            (Fv.cup fv1 fv2, Typed.Match (e, b))        exp loc (Fv.cup fv1 fv2) (Typed.Match (e, b))
556        | Map (e,b) ->        | Map (e,b) ->
557            let (fv1,e) = expr loc e            let (fv1,e) = expr loc e
558            and (fv2,b) = branches loc b in        and (fv2,b) = branches b in
559            (Fv.cup fv1 fv2, Typed.Map (e, b))        exp loc (Fv.cup fv1 fv2) (Typed.Map (e, b))
560        | Ttree (e,b) ->        | Ttree (e,b) ->
561            let b = b @ [ (mknoloc (Internal Types.any)), mknoloc MatchFail ] in        let b = b @ [ mknoloc (Internal Types.any), MatchFail ] in
562            let (fv1,e) = expr loc e            let (fv1,e) = expr loc e
563            and (fv2,b) = branches loc b in        and (fv2,b) = branches b in
564            (Fv.cup fv1 fv2, Typed.Ttree (e, b))        exp loc (Fv.cup fv1 fv2) (Typed.Ttree (e, b))
565        | MatchFail -> (Fv.empty, Typed.MatchFail)    | MatchFail ->
566          exp loc (Fv.empty) Typed.MatchFail
567        | Try (e,b) ->        | Try (e,b) ->
568            let (fv1,e) = expr loc e            let (fv1,e) = expr loc e
569            and (fv2,b) = branches loc b in        and (fv2,b) = branches b in
570            (Fv.cup fv1 fv2, Typed.Try (e, b))        exp loc (Fv.cup fv1 fv2) (Typed.Try (e, b))
571    in  
   fv,  
   { Typed.exp_loc = loc;  
     Typed.exp_typ = Types.empty;  
     Typed.exp_descr = td;  
   }  
572    
573    and branches loc b =    and branches b =
574      let fv = ref Fv.empty in      let fv = ref Fv.empty in
575      let accept = ref Types.empty in      let accept = ref Types.empty in
576      let branch (p,e) =      let branch (p,e) =
577        let br_loc = merge_loc p.loc e.loc in        let (fv2,e) = expr noloc e in
578        let (fv2,e) = expr loc e in        let br_loc = merge_loc p.loc e.Typed.exp_loc in
579        let p = pat p in        let p = pat p in
580        let fv2 = Fv.diff fv2 (Patterns.fv p) in        let fv2 = Fv.diff fv2 (Patterns.fv p) in
581        fv := Fv.cup !fv fv2;        fv := Fv.cup !fv fv2;
Legend:
Removed from v.315  
changed lines
  Added in v.316
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5