Skip to content
This repository
Newer
Older
100644 434 lines (376 sloc) 14.698 kb
fccc6851 »
2011-06-21 Initial open-source release
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (* CF mli *)
19
20 (* depends *)
21 module Array = Base.Array
22 module Format = Base.Format
23 module List = Base.List
24
25 (* shorthands *)
26 module B = BslTypes
27 module Q = QmlAst
28 module QC = QmlAstCons.UntypedExpr
29 module V = OpaTopValue
30 module P = OpaTopProperties
31
32 (* debug *)
33 let debug fmt =
34 OManager.printf ("@{<cyan>[Eval]@}@ @[<2>"^^fmt^^"@]@.")
35
36 (* Error managment *)
37 let fail fmt = OManager.error ("@[<2>@{<bright>Eval@}:@\n"^^fmt^^"@]@\n")
38
39 (* template *)
40 (*
41 let _ =
42 #<If:OPATOP_EVAL $minlevel 1>
43 debug "do some %s of level %d@\n" "debug" 1
44 #<End>
45 in
46 *)
47
48 (* printer *)
49 let pp =
50 #<If:OPATOP_ANNOT>
51 QmlPrint.pp_annotation
52 #<Else>
53 (QmlPrint.pp :> QmlPrint.base_printer_with_sugared_types)
54 #<End>
55
56 type env = V.t IdentMap.t
57
58 type ('a, 'b) ignored_directive = [
59 | QmlAst.type_directive
43a556ef »
2011-07-06 [cleanup] garbage: collecting some directives
60 | `async
fccc6851 »
2011-06-21 Initial open-source release
61 | `atomic
62 | `fun_action of 'a
63 | `nonexpansive
64 | `spawn
65 | `tracker of 'b
66 | `unsafe_cast
67 | `may_cps
68 | `wait
69 ]
70
71 let rec traverse_ignore expr =
72 match expr with
43a556ef »
2011-07-06 [cleanup] garbage: collecting some directives
73 | Q.Directive (_, #ignored_directive, [expr], _)
fccc6851 »
2011-06-21 Initial open-source release
74 | Q.Coerce (_, expr, _) -> traverse_ignore expr
75 | _ -> expr
76
77 let make_bypass skey = QC.bypass (BslKey.normalize skey)
78
79 (* global annotmaps *)
80 let valueOfAnnot = ref AnnotMap.empty
81 let getValueOfAnnot x = AnnotMap.find_opt x !valueOfAnnot
82 let setValueOfAnnot x t = valueOfAnnot := AnnotMap.add x t !valueOfAnnot; ()
83 let resetAnnot () = valueOfAnnot := AnnotMap.empty
84
85 let (!!) pat fmt =
86 (* FIXME: get pos from expr *)
87 OManager.printf "@[<2>@{<bright>RuntimeError@}:@\nFIXME: citation instead of AST printing@\n";
88 OManager.printf "In the pattern %a@]@\n" pp#pat pat;
89 OManager.error fmt
90
91 (*
92 The function [match_pattern] returns an option of a new env, by adding the
93 bindings introduced by the pattern
94
95 If the match is unsuccessfull, the function returns [None]
96 *)
97 let rec match_pattern env pat value =
98 match pat, value with
99 | Q.PatCoerce (_, pat, _), _ -> match_pattern env pat value
100
101 | Q.PatConst (_, pc), V.V_const (_, vc) ->
102 if pc = vc (* Q.const_expr, Pervasives.compare *)
103 then Some env
104 else None
105
106 | Q.PatVar (_, ident), _ -> Some (IdentMap.add ident value env)
107
108 | Q.PatAny _, _ -> Some env
109
110 | Q.PatAs (_, alias_pat, ident), _ -> (
111 let new_env_opt = match_pattern env alias_pat value in
112 match new_env_opt with
113 | None ->
114 (* The aliased pattern didn't match the value, so the ident alias
115 is not bound. *)
116 None
117 | Some new_env ->
118 (* The aliased pattern matched the value. May be this induced some
119 bindings we must keep and we also must add a binding for the ident
120 alias. *)
121 Some (IdentMap.add ident value new_env)
122 )
123 | Q.PatRecord (_, [], rowvar), V.V_record (_, fields,_) ->
124 if rowvar = `open_ || StringMap.is_empty fields
125 then Some env
126 else None
127
128 | Q.PatRecord (_, pfields, rowvar), V.V_record (_, vfields, _) ->
129 let rec check_fields env present = function
130 | [] -> (
131 match rowvar with
132 | `open_ -> Some env
133
134 (* The pattern matching is closed. We must check if we have matched all the fields *)
135 | `closed -> (
136 let surjective =
137 StringMap.fold (fun key _ bool -> bool && StringSet.mem key present) vfields true
138 in
139 if surjective then Some env else None
140 )
141 )
142
143 | (field, p1) :: tl -> (
144 match StringMap.find_opt field vfields with
145 | None -> None
146 | Some value -> (
147 match match_pattern env p1 (Lazy.force value) with
148 | None -> None
149 | Some env -> check_fields env (StringSet.add field present) tl
150 )
151 )
152
153 in check_fields env StringSet.empty pfields
154
155 | _ -> None
156
157 let nopos = FilePos.nopos "OpaTopEval.eval"
158
159 let (!!) expr fmt =
160 (* FIXME: get pos from expr *)
161 OManager.printf "@[<2>@{<bright>RuntimeError@}:@\nFIXME: citation instead of AST printing@\n";
162 OManager.printf "In the expression %a@]@\n" pp#expr expr;
163 OManager.error fmt
164
165 let rec eval env expr =
166
167 let _ =
168 #<If:OPATOP_EXPR>
169 OManager.printf "eval(expr): %a@." pp#expr expr
170 #<End>
171 in
172
173 let main_expr = expr in
174 let value =
175 if P.noeval_get() then V.t_null ~pos:nopos ()
176 else match expr with
177 | Q.Const (label, e) -> V.V_const (Annot.pos label, e)
178
179 | Q.Ident (_, id) -> (
180 try
181 (* must be mem by type checking, but typer may be off *)
182 IdentMap.find id env
183 with
184 | Not_found -> !! expr "unbound value %S@\n" (Ident.to_string id)
185 )
186
187 | Q.LetIn (_, lets, in_) ->
188 let seen = ref IdentSet.empty in
189 let fold env (id, expr) =
190 if IdentSet.mem id !seen
191 then !! main_expr "Variable %S is bound several times in this let and@\n" (Ident.to_string id)
192 else (
193 seen := IdentSet.add id !seen ;
194 let value = eval env expr in
195 let env = IdentMap.add id value env in
196 env
197 )
198 in
199 let env = List.fold_left fold env lets in
200 eval env in_
201
202 | Q.LetRecIn (_, lets, in_) ->
203 let env =
204 let tmp = ref IdentMap.empty in
205 let fold env (id, expr) =
206 let value =
207 let lambda =
208 match traverse_ignore expr with
209 | Q.Lambda _ as expr -> expr
210 | _ -> !! main_expr "This kind of expression is not allowed as right-hand side of `let rec'@\n"
211 in
212 V.V_closure (Q.Pos.expr lambda, tmp, lambda)
213 in
214 setValueOfAnnot (Q.QAnnot.expr expr) value;
215 IdentMap.add id value env
216 in
217 let env = List.fold_left fold env lets in
218 tmp := env;
219 env
220 in
221 eval env in_
222
223 | Q.Lambda (label, _, _) -> V.V_closure (Annot.pos label, ref env, expr)
224
225 (* Apply : Be carrefully with this lines, the main idea of this version of interpreter is here *)
226 (* The magie is just here in case of specialisation of high functional mixity between qml & ocaml *)
227 (* In a simplier version (for example : no functionnal qml value of type 'a -> 'b can be passed
228 as an argument of type 'a of a bypass-function) the hack would be not necessary *)
229 | Q.Apply (_, f, args) -> (
230 let vf = eval env f in
231 let fail_arity i j =
232 fail "arity mismatch (expected %d, get %d), cannot apply %a in %a." i j
233 OpaTopValue.pp vf pp#expr main_expr in
234 match vf with
235 | V.V_closure (_, clot_env, Q.Lambda (_, ids, body)) ->
236 (* classic_apply : apply beta-redex with closure *)
237 let update_env1 clot_env id arg = IdentMap.add id (eval env arg) clot_env in
238 let update_env clot_env ids args =
239 try List.fold_left2 update_env1 clot_env ids args
240 with Invalid_argument "List.fold_left2" -> fail_arity (List.length ids) (List.length args);
241 in
242 eval (update_env (!clot_env) ids args) body
243
244 (* The followings line are interresting, that allow partial application of bypass,
245 and a shorter code for the initial binding builtins *)
246 | V.V_bypass (_, targs , ret, oof) -> (
247 let lenargsapp = List.length targs in
248 let lenargsty = List.length args in
249 if lenargsapp <> lenargsty then fail_arity lenargsapp lenargsty;
250 let mls = List.map2 (fun ty qml -> V.Proj.ocaml_of_t ~eval ty (eval env qml)) targs args in
251 let ml =
252 match mls with
253 | [] ->
254 let _ =
255 #<If:OPATOP_HOOK>
256 prerr_endline "eval: HOOK-03";
257 #<End>
258 in
259 (Obj.obj oof) ()
260 | _ ->
261 let _ =
262 #<If:OPATOP_HOOK>
263 prerr_endline "eval: HOOK-04";
264 #<End>
265 in
266 List.fold_left (fun func arg -> (Obj.magic func) arg) (Obj.obj oof) mls
267 in
268 let _ =
269 #<If:OPATOP_HOOK>
270 prerr_endline "eval: HOOK-05";
271 #<End>
272 in
273 V.Proj.t_of_ocaml ret (Obj.repr ml)
274 )
275
276 | _ ->
277 !! expr "cannot apply %a on %a. This value is not a function@\n"
278 V.pp vf (Format.pp_list "@ " pp#expr) args
279 )
280
281 | Q.Match (_, expr, pat_expr_list) ->
282 let v_expr = eval env expr in
283 let rec aux = function
284 | [] ->
285 !! main_expr "pattern match failure. the value is %a@\n" V.pp v_expr
286 | (pat, expr) :: tl -> (
287 match match_pattern env pat v_expr with
288 | Some env ->
289 eval env expr
290 | None -> aux tl
291 )
292 in aux pat_expr_list
293
294 | Q.Record (label, fields) ->
295 let fold fields (field, expr) =
296 let value = eval env expr in
297 let fields = StringMap.add field (Lazy.lazy_from_val value) fields in
298 fields
299 in
300 let fields = List.fold_left fold StringMap.empty fields in
301 V.V_record (Annot.pos label, fields, ref None)
302
303 | Q.Dot (_, expr, field) -> (
304 let v_expr = eval env expr in
305 match v_expr with
306 | V.V_record (_, fields, _) -> (
307 let lazy_value =
308 try
309 StringMap.find field fields
310 with
311 | Not_found ->
312 !! expr "this record has no field %S\n(maybe the typer is off)@\n" field
313 in
314 Lazy.force lazy_value
315 )
316 | v ->
317 !! main_expr "in dot field %S : expected a record@ but got %a@\n" field V.pp v
318 )
319
320 (* { field = expr } :: expr *)
321 | Q.ExtendRecord (_, field, expr, record) -> (
322 let v_expr = eval env expr in
323 let v_record = eval env record in
324 match v_record with
325 | V.V_record (pos, fields, _) ->
326 let value = Lazy.lazy_from_val v_expr in
327 let fields = StringMap.add field value fields in
328 (* FIXME: merge with the pos from the main_expr *)
329 V.V_record (pos, fields, ref None)
330 | _ ->
331 !! main_expr "extend record { %s = %a } :: %a@ expected a record@\n"
332 field V.pp v_expr V.pp v_record
333 )
334
335 (* FIXME: remove this directive, change the type of the Bypass node *)
336 (* TODO: and get back the check of restriction in this case *)
337 | Q.Directive (_, `restricted_bypass _, [Q.Bypass (_, key)], _)
338 | Q.Bypass (_, key) -> (
339 (* get the cached bypass map *)
340 let bypass_map = OpaTopBsl.bypass_map () in
341 match OpaTopBsl.find_opt key bypass_map with
342 | Some bypass -> (
343 match OpaTopBsl.eval bypass with
344 | Some value -> value
345 | None -> (
346 !! expr "This external primitive is not available in opatop@\n"
347 )
348 )
349
350 | None ->
351 !! expr "Unknow external primitive. Maybe do you want to use a plugin ?@\n"
352 )
353
354 | Q.Path _ ->
355 !! expr "Presence of a raw database reading node not resolved by DbGen@\n"
356
357 | Q.Directive (_, `fail, message, _) -> (
358 match message with
359 | [] ->
360 !! expr "@@fail@\n"
361
362 | message :: _ ->
363 let message =
364 match eval env message with
365 | V.V_const (_, Q.String message) -> message
366 | v -> !! expr "@@fail expects one argument of type string but got: %a@\n" V.pp v
367 in
368 !! expr "@@fail: %s@\n" message
369 )
370
371 | Q.Directive (_, `assert_, [cond], _) -> (
372 let void = V.Proj.t_void () in
373 if not (P.assert_get ()) then void else
374 let v_cond = eval env cond in
375 match v_cond with
376 | V.V_record (_, fields, _) ->
377 (* Keep in sync with qml semantic *)
378 if (StringMap.mem "true" fields) && not (StringMap.mem "false" fields) then void
379 else !! expr "assert failure"
380 | _ ->
381 !! expr "assert condition not a bool value: %a@\n"
382 V.pp v_cond
383 )
384
385 | Q.Directive (_, `create_lazy_record, exprs, _) -> (
386 let expr, o = QmlDirectives.create_lazy_record_arguments exprs in
387 match expr with
388 | Q.Record (_, fields) ->
389 let embed_data = Option.map (eval env) o in
390 let fold fields (field, expr) =
391 let lazy_value = lazy (eval env expr) in
392 StringMap.add field lazy_value fields in
393 let fields = List.fold_left fold StringMap.empty fields in
394 V.V_record (nopos, fields, ref embed_data)
395 | _ -> assert false
396 )
397
398 | Q.Directive (_, `callcc, [expr], _) ->
399 let fake_bypass = make_bypass "bslcps.notcps_compatibility.callcc_directive" in
400 let expr = QC.apply fake_bypass [expr] in
401 eval env expr
402
403 | Q.Directive (label, `llarray, exprs, _) ->
404 let len = ref 0 in
405 let rev_exprs = List.rev_map (fun e -> incr(len); eval env e) exprs in
406 let array = Array.unsafe_create !len in
407 let pred_len = pred !len in
408 let iteri v i = let i = pred_len - i in array.(i) <- v in
409 List.iteri iteri rev_exprs ;
410 let string = "llarray" in
411 let args = [ B.TypeVar (Annot.pos label, B.TypeVar.next()) ] in
412 OpaTopValue.Proj.t_extern string args array
413
414 (* ignored nodes *)
415 | Q.Directive (_, #ignored_directive, [expr], _)
416 | Q.Coerce (_, expr, _) -> eval env expr
417
418 | Q.Directive (_, d, e, t) ->
419 !! expr "Directive %a is not available in qmltop"
420 (fun fmt () -> pp#directive fmt d e t) ()
421 in
422
423 let annot = Q.QAnnot.expr main_expr in
424
425 let _ =
426 #<If:OPATOP_EXPR>
427 OManager.printf "value: (%a : § %d)@." OpaTopValue.pp value (Annot.to_int annot)
428 #<End>
429 in
430
431 (* Store the value in the map *)
432 setValueOfAnnot annot value;
433 value
Something went wrong with that request. Please try again.