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	abate	48	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	abate	52	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	abate	48
23	abate	52	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	abate	48	and print_record ppf = function
69			\| [] -> ()
70	abate	52	\| [f] -> Format.fprintf ppf " %a" print_field f
71			\| f :: rem -> Format.fprintf ppf " %a;%a" print_field f print_record rem
72	abate	48
73			and print_field ppf (l,v) =
74	abate	53	Format.fprintf ppf "%s=%a" (Types.label_name l) print v
75	abate	48
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	abate	52	let rec eval env e0 =
184			match e0.Typed.exp_descr with
185	abate	48	\| Typed.Var s -> Env.find s env
186	abate	52	\| Typed.Apply (f,arg) -> eval_apply (eval env f) (eval env arg)
187	abate	48	\| 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	abate	52	\| Typed.RecordLitt r -> Record (List.map (fun (l,e) -> (l, eval env e)) r)
199	abate	48	\| 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	abate	51	\| 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	abate	48
213	abate	51
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	abate	48	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	abate	51	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	abate	48
234	abate	51	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