value.ml 6.54 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
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 print ppf = function
  | 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_record ppf = function
  | [] -> ()
  | [f] -> print_field ppf 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 e = 
  match e.Typed.exp_descr with
    | Typed.Var s -> Env.find s env
    | Typed.Apply (f,arg) ->
151
	eval_apply (eval env f) (eval env arg)
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
    | 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)
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
    | 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
183
184
185
186
187
188
189
190
191

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

192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
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
223