/[svn]/compile/compile.ml
ViewVC logotype

Diff of /compile/compile.ml

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

revision 691 by abate, Tue Jul 10 17:55:19 2007 UTC revision 692 by abate, Tue Jul 10 17:55:30 2007 UTC
# Line 8  Line 8 
8    
9  let empty = { vars = Env.empty; stack_size = 0 }  let empty = { vars = Env.empty; stack_size = 0 }
10    
11  let rec compile env e = compile_aux env e.Typed.exp_descr  let find x env =
12  and compile_aux env = function    try Env.find x env.vars
13    | Typed.Forget (e,_) -> compile env e    with Not_found ->
14    | Typed.Var x -> Var (Env.find x env.vars)      failwith ("Compile: cannot find " ^ (Ident.to_string x))
15    | Typed.Apply (e1,e2) -> Apply (compile env e1, compile env e2)  
16    let rec compile env tail e = compile_aux env tail e.Typed.exp_descr
17    and compile_aux env tail = function
18      | Typed.Forget (e,_) -> compile env tail e
19      | Typed.Var x -> Var (find x env)
20      | Typed.Apply (e1,e2) -> Apply (tail, compile env false e1, compile env tail e2)
21    | Typed.Abstraction a -> compile_abstr env a    | Typed.Abstraction a -> compile_abstr env a
22    | Typed.Cst c -> Const c    | Typed.Cst c -> Const c
23    | Typed.Pair (e1,e2) -> Pair(compile env e1, compile env e2)    | Typed.Pair (e1,e2) -> Pair(compile env false e1, compile env tail e2)
24    | Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }) ->    | Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }) ->
25        let env' = env in        Xml (compile env false e1, compile env false e2, compile env tail e3)
       Xml (compile env e1, compile env' e2, compile env' e3)  
26    | Typed.Xml (_,_) -> assert false    | Typed.Xml (_,_) -> assert false
27    | Typed.RecordLitt r -> Record (LabelMap.map (compile env) r)    | Typed.RecordLitt r -> Record (LabelMap.map (compile env false) r)
28    | Typed.String (i,j,s,q) -> String (i,j,s,compile env q)    | Typed.String (i,j,s,q) -> String (i,j,s,compile env tail q)
29    | Typed.Match (e,brs) -> Match (compile env e, compile_branches env brs)    | Typed.Match (e,brs) -> Match (compile env false e, compile_branches env tail brs)
30    | _ -> assert false    | Typed.Map (e,brs) -> Map (compile env false e, compile_branches env false brs)
31      | Typed.Transform (e,brs) -> Transform
32          (compile env false e, compile_branches env false brs)
33      | Typed.Xtrans (e,brs) -> Xtrans (compile env false e, compile_branches env false brs)
34      | Typed.Validate (e,sch,t) -> Validate (compile env tail e, sch, t)
35      | Typed.RemoveField (e,l) -> RemoveField (compile env tail e,l)
36      | Typed.Dot (e,l) -> Dot (compile env tail e, l)
37      | Typed.Try (e,brs) -> Try (compile env false e, compile_branches env tail brs)
38      | Typed.UnaryOp (op,e) -> UnaryOp (op, compile env tail e)
39      | Typed.BinaryOp (op,e1,e2) -> BinaryOp (op, compile env false e1, compile env tail e2)
40      | Typed.Ref (e,t) ->  Ref (compile env tail e, t)
41    
42  and compile_abstr env a =  and compile_abstr env a =
43      let fun_env =
44        match a.Typed.fun_name with
45          | Some x -> Env.add x (Env 0) Env.empty
46          | None -> Env.empty in
47    
48    let (slots,nb_slots,fun_env) =    let (slots,nb_slots,fun_env) =
49      List.fold_left      List.fold_left
50        (fun (slots,nb_slots,fun_env) x ->        (fun (slots,nb_slots,fun_env) x ->
51           match Env.find x env.vars with           match find x env with
52             | (Stack _ | Env _) as p ->             | (Stack _ | Env _) as p ->
53                 p::slots,                 p::slots,
54                 succ nb_slots,                 succ nb_slots,
# Line 42  Line 59 
59                 Env.add x p fun_env                 Env.add x p fun_env
60             | Dummy -> assert false             | Dummy -> assert false
61        )        )
62        ([],0,Env.empty) (IdSet.get a.Typed.fun_fv) in        ([Dummy],1,fun_env) (IdSet.get a.Typed.fun_fv) in
63    
64    
   let recurs,fun_env,slots = match a.Typed.fun_name with  
     | Some x when IdSet.mem a.Typed.fun_fv x ->  
         true, Env.add x (Env 0) fun_env, Dummy::slots  
     | _ -> false, fun_env, slots in  
65    let slots = Array.of_list (List.rev slots) in    let slots = Array.of_list (List.rev slots) in
66    let env = { vars = fun_env; stack_size = 0 } in    let env = { vars = fun_env; stack_size = 0 } in
67    let body = compile_branches env a.Typed.fun_body in    let body = compile_branches env true a.Typed.fun_body in
68    Abstraction (recurs, slots, a.Typed.fun_iface, body)    Abstraction (slots, a.Typed.fun_iface, body)
69    
70  and compile_branches env (brs : Typed.branches) =  and compile_branches env tail (brs : Typed.branches) =
71    {    {
72      brs = List.map (compile_branch env) brs.Typed.br_branches;      brs = List.map (compile_branch env tail) brs.Typed.br_branches;
73        brs_tail = tail;
74        brs_accept_chars = not (Types.Char.is_empty brs.Typed.br_accept);
75      brs_input = brs.Typed.br_typ;      brs_input = brs.Typed.br_typ;
76      brs_compiled = None      brs_compiled = None
77    }    }
78    
79  and compile_branch env br =  and compile_branch env tail br =
80    let env =    let env =
81      List.fold_left      List.fold_left
82        (fun env x ->        (fun env x ->
83           { vars = Env.add x (Stack env.stack_size) env.vars;           { vars = Env.add x (Stack env.stack_size) env.vars;
84             stack_size = env.stack_size + 1 }             stack_size = env.stack_size + 1 }
85    
86        ) env (IdSet.get (Patterns.fv br.Typed.br_pat)) in        ) env (IdSet.get (Patterns.fv br.Typed.br_pat)) in
87    (br.Typed.br_pat, compile env br.Typed.br_body)    (br.Typed.br_pat, compile env tail br.Typed.br_body)
88    
89    
90    let enter_global env x =
91      { vars = Env.add x (Global env.stack_size) env.vars;
92        stack_size = env.stack_size + 1 }
93    
94    let enter_globals = List.fold_left enter_global
95    
96    let compile_let_decl env decl =
97      let pat = decl.Typed.let_pat in
98      let decl = { let_pat = pat; let_expr = compile env false (decl.Typed.let_body) } in
99      let names = IdSet.get (Patterns.fv pat) in
100      let env = enter_globals env names in
101      (names, env, decl)
102    
103    
104    let compile_rec_funs env funs =
105      let fun_name = function
106        | { Typed.exp_descr=Typed.Abstraction{Typed.fun_name = Some x}} -> x
107        | _ -> assert false in
108      let fun_a = function
109        | { Typed.exp_descr=Typed.Abstraction a } -> a
110        | _ -> assert false in
111      let names = List.map fun_name funs in
112      let env = enter_globals env names in
113      let exprs = List.map (compile_abstr env) (List.map fun_a funs) in
114      (names, env, exprs)
Legend:
Removed from v.691  
changed lines
  Added in v.692
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5