viewcvs.cgi/runtime/value.ml

module Env = Map.Make (struct type t = string let compare = compare end)
let empty_env = Env.empty

type t =
  | Pair of t * t
  | Record of (Types.label,t) SortedMap.t
  | Atom of Types.atom
  | Integer of Big_int.big_int
  | Char of Chars.Unichar.t
  | Fun of abstr
and env = t Env.t
and abstr = { 
  fun_iface : (Types.descr * Types.descr) list;
  mutable fun_env   : env;
  fun_body  : Typed.branches;
}

let rec is_seq = function
  | Pair (_, y) when is_seq y -> true
  | Atom a when a = Sequence.nil_atom -> true
  | _ -> false

let is_xml = function
  | Pair (Atom _, Pair (Record _, s)) when is_seq s -> true
  | _ -> false

let rec is_str = function
  | Pair (Char _, y) when is_str y -> true
  | Atom a when a = Sequence.nil_atom -> true
  | _ -> false

let rec print ppf v =
  if is_str v then Format.fprintf ppf "\"%a\"" print_quoted_str v
  else if is_xml v then print_xml ppf v
  else if is_seq v then Format.fprintf ppf "[ %a]" print_seq v
  else match v with
    | Pair (x,y) -> Format.fprintf ppf "(%a,%a)" print x print y
    | Record l -> Format.fprintf ppf "{%a }" print_record l
    | Atom a -> Format.fprintf ppf "`%s" (Types.atom_name a)
    | Integer i -> Format.fprintf ppf "%s" (Big_int.string_of_big_int i)
    | Char c -> Chars.Unichar.print ppf c
    | Fun c -> Format.fprintf ppf "<fun>"
and print_quoted_str ppf = function
  | Pair (Char c, y) -> 
      Chars.Unichar.print_in_string ppf c; 
      print_quoted_str ppf y
  | _ -> ()
and print_seq ppf = function
  | Pair (Char _, _) as s -> Format.fprintf ppf "'%a" print_str s
  | Pair (x,y) -> Format.fprintf ppf "@[%a@]@ %a" print x print_seq y
  | _ -> ()
and print_str ppf = function
  | Pair (Char c,y) ->
      Chars.Unichar.print_in_string ppf c; 
      print_str ppf y
  | v ->
      Format.fprintf ppf "\' ";
      print_seq ppf v

and print_xml ppf = function
  | Pair(Atom tag, Pair (Record attr,content)) ->
      Format.fprintf ppf "@[<hv2><%s%a>[@ %a@]]" 
      (Types.atom_name tag)
      print_record attr
      print_seq content
  | _ -> assert false

and print_record ppf = function
  | [] -> ()
  | [f] -> Format.fprintf ppf " %a" print_field f
  | f :: rem -> Format.fprintf ppf " %a;%a" print_field f print_record rem

and print_field ppf (l,v) = 
  Format.fprintf ppf "%s=%a" (Types.label_name l) print v  


(* Running dispatchers *)

let const = function
  | Types.Integer i -> Integer i
  | Types.Atom a -> Atom a
  | Types.Char c -> Char c

let make_result_prod r1 r2 v (code,r) = 
  let ret = Array.map
    (function
       | `Catch -> v
       | `Const c -> const c
       | `Left i -> r1.(i)
       | `Right j -> r2.(j)
       | `Recompose (i,j) -> Pair (r1.(i), r2.(j))
       | _ -> assert false
    ) r in
  (code,ret)

let make_result_record v fields (code,r) =
  let ret = Array.map
    (function
       | `Catch -> v
       | `Const c -> const c
       | `Field (l,i) -> (List.assoc l fields).(i)
       | _ -> assert false
    ) r in
  (code,ret)

let make_result_basic v (code,r) = 
  let ret = Array.map
    (function
       | `Catch -> v
       | `Const c -> const c
       | _ -> assert false
    ) r in
  (code,ret)

let dummy_r = [||]

let rec run_dispatcher d v = 
  let actions = Patterns.Compile.actions d in
  match v with
  | Pair (v1,v2) -> run_disp_prod v v1 v2 actions.Patterns.Compile.prod
  | Record r -> run_disp_record v [] r actions.Patterns.Compile.record
  | Atom a -> 
      run_disp_basic v (fun t -> Types.Atom.has_atom t a) 
        actions.Patterns.Compile.basic
  | Char c ->
      run_disp_basic v (fun t -> Types.Char.has_char t c) 
        actions.Patterns.Compile.basic
  | Integer i ->
      run_disp_basic v (fun t -> Types.Int.has_int t i) 
        actions.Patterns.Compile.basic
  | Fun f ->
      run_disp_basic v (fun t -> Types.Arrow.check_iface f.fun_iface t) 
        actions.Patterns.Compile.basic

and run_disp_basic v f = function
  | [(_,r)] -> make_result_basic v r
  | (t,r)::rem -> if f t then make_result_basic v r else run_disp_basic v f rem
  | _ -> assert false
  

and run_disp_prod v v1 v2 = function
  | `None -> assert false
  | `TailCall d1 -> run_dispatcher d1 v1
  | `Ignore d2 -> run_disp_prod2 dummy_r v v2 d2
  | `Dispatch (d1,b1) ->
      let (code1,r1) = run_dispatcher d1 v1 in
      run_disp_prod2 r1 v v2 b1.(code1)

and run_disp_prod2 r1 v v2 = function
  | `None -> assert false
  | `Ignore r -> make_result_prod r1 dummy_r v r
  | `TailCall d2 -> run_dispatcher d2 v2
  | `Dispatch (d2,b2) ->
      let (code2,r2) = run_dispatcher d2 v2 in
      make_result_prod r1 r2 v b2.(code2)
            
and run_disp_record v bindings fields = function
  | None -> assert false
  | Some record -> run_disp_record' v bindings fields record

and run_disp_record' v bindings fields = function
  | `Result r -> make_result_record v bindings r
  | `Label (l, present, absent) ->
      let rec aux = function
        | (l1,_) :: rem when l1 < l -> aux rem
        | (l1,vl) :: rem when l1 = l -> 
            run_disp_field v bindings rem l vl present
        | _ -> run_disp_record v bindings fields absent
      in
      aux fields

and run_disp_field v bindings fields l vl = function
  | `None -> assert false
  | `Ignore r -> run_disp_record' v bindings fields r
  | `TailCall d -> run_dispatcher d vl
  | `Dispatch (dl,bl) ->
      let (codel,rl) = run_dispatcher dl vl in
      run_disp_record' v ((l,rl)::bindings) fields bl.(codel)

(* Evaluation of expressions *)


let rec eval env e0 = 
  match e0.Typed.exp_descr with
    | Typed.Var s -> Env.find s env
    | Typed.Apply (f,arg) ->  eval_apply (eval env f) (eval env arg)
    | Typed.Abstraction a ->
        let a' = { 
          fun_env = env;
          fun_iface = a.Typed.fun_iface;
          fun_body = a.Typed.fun_body
        } in
        let self = Fun a' in
        (match a.Typed.fun_name with
           | Some f -> a'.fun_env <- Env.add f self a'.fun_env
           | None -> ());
        self
    | Typed.RecordLitt r -> Record (List.map (fun (l,e) -> (l, eval env e)) r)
    | Typed.Pair (e1,e2) -> Pair (eval env e1, eval env e2)
    | Typed.Cst c -> const c
    | Typed.Match (arg,brs) -> eval_branches env brs (eval env arg)
    | Typed.Map (arg,brs) -> eval_map env brs (eval env arg)
    | Typed.Op ("flatten", [e]) -> eval_flatten (eval env e)
    | Typed.Op ("@", [e1; e2]) -> eval_concat (eval env e1) (eval env e2)
    | Typed.Op ("+", [e1; e2]) -> eval_add (eval env e1) (eval env e2)
    | Typed.Op ("*", [e1; e2]) -> eval_mul (eval env e1) (eval env e2)
    | Typed.Op ("-", [e1; e2]) -> eval_sub (eval env e1) (eval env e2)
    | Typed.Op ("/", [e1; e2]) -> eval_div (eval env e1) (eval env e2)
    | Typed.Dot (e, l) -> eval_dot l (eval env e)
    | Typed.DebugTyper t -> failwith "Evaluating a ! expression"
    | _ -> failwith "Unknown expression"


and eval_apply f arg = match f with
  | Fun a -> eval_branches a.fun_env a.fun_body arg
  | _ -> assert false

and eval_branches env brs arg =
  let (disp, rhs) = Typed.dispatcher brs in
  let (code, bindings) = run_dispatcher disp arg in
  let (bind, e) = rhs.(code) in
  let env = 
    List.fold_left (fun env (x,i) -> Env.add x bindings.(i) env) env bind in
  eval env e

and eval_map env brs = function
  | Pair (x,y) -> Pair (eval_branches env brs x, eval_map env brs y)
  | q -> q
  
and eval_flatten = function
  | Pair (x,y) -> eval_concat x (eval_flatten y)
  | q -> q

and eval_concat l1 l2 = match l1 with
  | Pair (x,y) -> Pair (x, eval_concat y l2)
  | q -> l2

and eval_dot l = function
  | Record r -> List.assoc l r
  | _ -> assert false

and eval_add x y = match (x,y) with
  | (Integer x, Integer y) -> Integer (Big_int.add_big_int x y)
  | _ -> assert false

and eval_mul x y = match (x,y) with
  | (Integer x, Integer y) -> Integer (Big_int.mult_big_int x y)
  | _ -> assert false

and eval_sub x y = match (x,y) with
  | (Integer x, Integer y) -> Integer (Big_int.sub_big_int x y)
  | _ -> assert false

and eval_div x y = match (x,y) with
  | (Integer x, Integer y) -> Integer (Big_int.div_big_int x y)
  | _ -> assert false

1	module Env = Map.Make (struct type t = string let compare = compare end)
2	let empty_env = Env.empty
3
4	type t =
5	\| Pair of t * t
6	\| Record of (Types.label,t) SortedMap.t
7	\| Atom of Types.atom
8	\| Integer of Big_int.big_int
9	\| Char of Chars.Unichar.t
10	\| Fun of abstr
11	and env = t Env.t
12	and abstr = {
13	fun_iface : (Types.descr * Types.descr) list;
14	mutable fun_env : env;
15	fun_body : Typed.branches;
16	}
17
18	let rec is_seq = function
19	\| Pair (_, y) when is_seq y -> true
20	\| Atom a when a = Sequence.nil_atom -> true
21	\| _ -> false
22
23	let is_xml = function
24	\| Pair (Atom _, Pair (Record _, s)) when is_seq s -> true
25	\| _ -> false
26
27	let rec is_str = function
28	\| Pair (Char _, y) when is_str y -> true
29	\| Atom a when a = Sequence.nil_atom -> true
30	\| _ -> false
31
32	let rec print ppf v =
33	if is_str v then Format.fprintf ppf "\"%a\"" print_quoted_str v
34	else if is_xml v then print_xml ppf v
35	else if is_seq v then Format.fprintf ppf "[ %a]" print_seq v
36	else match v with
37	\| Pair (x,y) -> Format.fprintf ppf "(%a,%a)" print x print y
38	\| Record l -> Format.fprintf ppf "{%a }" print_record l
39	\| Atom a -> Format.fprintf ppf "`%s" (Types.atom_name a)
40	\| Integer i -> Format.fprintf ppf "%s" (Big_int.string_of_big_int i)
41	\| Char c -> Chars.Unichar.print ppf c
42	\| Fun c -> Format.fprintf ppf "<fun>"
43	and print_quoted_str ppf = function
44	\| Pair (Char c, y) ->
45	Chars.Unichar.print_in_string ppf c;
46	print_quoted_str ppf y
47	\| _ -> ()
48	and print_seq ppf = function
49	\| Pair (Char _, _) as s -> Format.fprintf ppf "'%a" print_str s
50	\| Pair (x,y) -> Format.fprintf ppf "@[%a@]@ %a" print x print_seq y
51	\| _ -> ()
52	and print_str ppf = function
53	\| Pair (Char c,y) ->
54	Chars.Unichar.print_in_string ppf c;
55	print_str ppf y
56	\| v ->
57	Format.fprintf ppf "\' ";
58	print_seq ppf v
59
60	and print_xml ppf = function
61	\| Pair(Atom tag, Pair (Record attr,content)) ->
62	Format.fprintf ppf "@[<hv2><%s%a>[@ %a@]]"
63	(Types.atom_name tag)
64	print_record attr
65	print_seq content
66	\| _ -> assert false
67
68	and print_record ppf = function
69	\| [] -> ()
70	\| [f] -> Format.fprintf ppf " %a" print_field f
71	\| f :: rem -> Format.fprintf ppf " %a;%a" print_field f print_record rem
72
73	and print_field ppf (l,v) =
74	Format.fprintf ppf "%s=%a" (Types.label_name l) print v
75
76
77	(* Running dispatchers *)
78
79	let const = function
80	\| Types.Integer i -> Integer i
81	\| Types.Atom a -> Atom a
82	\| Types.Char c -> Char c
83
84	let make_result_prod r1 r2 v (code,r) =
85	let ret = Array.map
86	(function
87	\| `Catch -> v
88	\| `Const c -> const c
89	\| `Left i -> r1.(i)
90	\| `Right j -> r2.(j)
91	\| `Recompose (i,j) -> Pair (r1.(i), r2.(j))
92	\| _ -> assert false
93	) r in
94	(code,ret)
95
96	let make_result_record v fields (code,r) =
97	let ret = Array.map
98	(function
99	\| `Catch -> v
100	\| `Const c -> const c
101	\| `Field (l,i) -> (List.assoc l fields).(i)
102	\| _ -> assert false
103	) r in
104	(code,ret)
105
106	let make_result_basic v (code,r) =
107	let ret = Array.map
108	(function
109	\| `Catch -> v
110	\| `Const c -> const c
111	\| _ -> assert false
112	) r in
113	(code,ret)
114
115	let dummy_r = [\|\|]
116
117	let rec run_dispatcher d v =
118	let actions = Patterns.Compile.actions d in
119	match v with
120	\| Pair (v1,v2) -> run_disp_prod v v1 v2 actions.Patterns.Compile.prod
121	\| Record r -> run_disp_record v [] r actions.Patterns.Compile.record
122	\| Atom a ->
123	run_disp_basic v (fun t -> Types.Atom.has_atom t a)
124	actions.Patterns.Compile.basic
125	\| Char c ->
126	run_disp_basic v (fun t -> Types.Char.has_char t c)
127	actions.Patterns.Compile.basic
128	\| Integer i ->
129	run_disp_basic v (fun t -> Types.Int.has_int t i)
130	actions.Patterns.Compile.basic
131	\| Fun f ->
132	run_disp_basic v (fun t -> Types.Arrow.check_iface f.fun_iface t)
133	actions.Patterns.Compile.basic
134
135	and run_disp_basic v f = function
136	\| [(_,r)] -> make_result_basic v r
137	\| (t,r)::rem -> if f t then make_result_basic v r else run_disp_basic v f rem
138	\| _ -> assert false
139
140
141	and run_disp_prod v v1 v2 = function
142	\| `None -> assert false
143	\| `TailCall d1 -> run_dispatcher d1 v1
144	\| `Ignore d2 -> run_disp_prod2 dummy_r v v2 d2
145	\| `Dispatch (d1,b1) ->
146	let (code1,r1) = run_dispatcher d1 v1 in
147	run_disp_prod2 r1 v v2 b1.(code1)
148
149	and run_disp_prod2 r1 v v2 = function
150	\| `None -> assert false
151	\| `Ignore r -> make_result_prod r1 dummy_r v r
152	\| `TailCall d2 -> run_dispatcher d2 v2
153	\| `Dispatch (d2,b2) ->
154	let (code2,r2) = run_dispatcher d2 v2 in
155	make_result_prod r1 r2 v b2.(code2)
156
157	and run_disp_record v bindings fields = function
158	\| None -> assert false
159	\| Some record -> run_disp_record' v bindings fields record
160
161	and run_disp_record' v bindings fields = function
162	\| `Result r -> make_result_record v bindings r
163	\| `Label (l, present, absent) ->
164	let rec aux = function
165	\| (l1,_) :: rem when l1 < l -> aux rem
166	\| (l1,vl) :: rem when l1 = l ->
167	run_disp_field v bindings rem l vl present
168	\| _ -> run_disp_record v bindings fields absent
169	in
170	aux fields
171
172	and run_disp_field v bindings fields l vl = function
173	\| `None -> assert false
174	\| `Ignore r -> run_disp_record' v bindings fields r
175	\| `TailCall d -> run_dispatcher d vl
176	\| `Dispatch (dl,bl) ->
177	let (codel,rl) = run_dispatcher dl vl in
178	run_disp_record' v ((l,rl)::bindings) fields bl.(codel)
179
180	(* Evaluation of expressions *)
181
182
183	let rec eval env e0 =
184	match e0.Typed.exp_descr with
185	\| Typed.Var s -> Env.find s env
186	\| Typed.Apply (f,arg) -> eval_apply (eval env f) (eval env arg)
187	\| Typed.Abstraction a ->
188	let a' = {
189	fun_env = env;
190	fun_iface = a.Typed.fun_iface;
191	fun_body = a.Typed.fun_body
192	} in
193	let self = Fun a' in
194	(match a.Typed.fun_name with
195	\| Some f -> a'.fun_env <- Env.add f self a'.fun_env
196	\| None -> ());
197	self
198	\| Typed.RecordLitt r -> Record (List.map (fun (l,e) -> (l, eval env e)) r)
199	\| Typed.Pair (e1,e2) -> Pair (eval env e1, eval env e2)
200	\| Typed.Cst c -> const c
201	\| Typed.Match (arg,brs) -> eval_branches env brs (eval env arg)
202	\| Typed.Map (arg,brs) -> eval_map env brs (eval env arg)
203	\| Typed.Op ("flatten", [e]) -> eval_flatten (eval env e)
204	\| Typed.Op ("@", [e1; e2]) -> eval_concat (eval env e1) (eval env e2)
205	\| Typed.Op ("+", [e1; e2]) -> eval_add (eval env e1) (eval env e2)
206	\| Typed.Op ("*", [e1; e2]) -> eval_mul (eval env e1) (eval env e2)
207	\| Typed.Op ("-", [e1; e2]) -> eval_sub (eval env e1) (eval env e2)
208	\| Typed.Op ("/", [e1; e2]) -> eval_div (eval env e1) (eval env e2)
209	\| Typed.Dot (e, l) -> eval_dot l (eval env e)
210	\| Typed.DebugTyper t -> failwith "Evaluating a ! expression"
211	\| _ -> failwith "Unknown expression"
212
213
214	and eval_apply f arg = match f with
215	\| Fun a -> eval_branches a.fun_env a.fun_body arg
216	\| _ -> assert false
217
218	and eval_branches env brs arg =
219	let (disp, rhs) = Typed.dispatcher brs in
220	let (code, bindings) = run_dispatcher disp arg in
221	let (bind, e) = rhs.(code) in
222	let env =
223	List.fold_left (fun env (x,i) -> Env.add x bindings.(i) env) env bind in
224	eval env e
225
226	and eval_map env brs = function
227	\| Pair (x,y) -> Pair (eval_branches env brs x, eval_map env brs y)
228	\| q -> q
229
230	and eval_flatten = function
231	\| Pair (x,y) -> eval_concat x (eval_flatten y)
232	\| q -> q
233
234	and eval_concat l1 l2 = match l1 with
235	\| Pair (x,y) -> Pair (x, eval_concat y l2)
236	\| q -> l2
237
238	and eval_dot l = function
239	\| Record r -> List.assoc l r
240	\| _ -> assert false
241
242	and eval_add x y = match (x,y) with
243	\| (Integer x, Integer y) -> Integer (Big_int.add_big_int x y)
244	\| _ -> assert false
245
246	and eval_mul x y = match (x,y) with
247	\| (Integer x, Integer y) -> Integer (Big_int.mult_big_int x y)
248	\| _ -> assert false
249
250	and eval_sub x y = match (x,y) with
251	\| (Integer x, Integer y) -> Integer (Big_int.sub_big_int x y)
252	\| _ -> assert false
253
254	and eval_div x y = match (x,y) with
255	\| (Integer x, Integer y) -> Integer (Big_int.div_big_int x y)
256	\| _ -> assert false
257