Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 307 lines (247 sloc) 8.446 kb
fccc685 Initial open-source release
MLstate authored
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 (* depends *)
19 module Lazy = Base.Lazy
20
21 (* alias *)
22 module Proj = OpaTopValue.Proj
23
24 (* shorthands *)
25 module Q = QmlAst
26 module B = BslTypes
27 module V = OpaTopValue
28
29 (* -- *)
30 let debug fmt =
31 OManager.printf ("@[<2>@{<cyan>[SL]@} "^^fmt^^"@]@.")
32
33 let fail value fmt =
34 OManager.printf "RuntimeError:@\n";
35 OManager.printf "%a" FilePos.pp_citation (V.pos value);
36 OManager.printf "Value: %a" V.pp value;
37 OManager.error fmt
38
39 (* template
40 let _ =
41 #<If:BSL_SL $minlevel 1>
42 debug "do some %s of level %d@\n" "debug" 1
43 #<End>
44 in
45 *)
46
47 let compare x y = V.compare ~strong:true (Obj.magic x : V.t) (Obj.magic y : V.t)
48
49 type ty_record = V.t
50 type 'a ty_info = 'a constraint 'a = [> ]
51
52 let empty_record = Proj.shared_void
53
54 let has_lazy_data r = match r with
55 | V.V_record (_ , _, o) ->
56 !o <> None
57
58 | _ ->
59 fail r "SL.has_lazy_data, expecting a record@\n"
60
61 let get_lazy_data_opt r = match r with
62 | V.V_record (_, _, o) -> (
63 match !o with
64 | Some (V.V_extern (_, _, _, o)) -> Some (Obj.obj o)
65 | Some x ->
66 let _ =
67 #<If:BSL_SL $minlevel 1>
68 debug "get_lazy_data_opa, Found unexpected format for embedded data in a lazy DB record";
69 debug "I'll probably @{<bright>segfault@} now. Pray for my soul.";
70 debug "Value: %a@\n" V.pp r
71 #<End>
72 in
73 Some (Obj.magic x)
74 | None -> None
75 )
76 | _ ->
77 fail r "SL.get_lazy_data_opt, expecting a record@\n"
78
79 (*
80 Mathieu: Thu Aug 19 15:15:53 CEST 2010
81 I found the following question there about the 2 following functions (embed & inject) lazy data
82
83 What is the status of the "o" we get here ?
84
85 Element of answer:
86 The 'o' value is not projected, so it depends on its utilisation in the ml bsl.
87 If it is manipulated via the server lib, it can be an opa value,
88 if not, this is an ocaml value.
89 *)
90
91 let build_internal_path_t pos o = V.V_extern (pos, "internal_path_t", [], Obj.repr o)
92
93 let embed_lazy_data r o = match r with
94 | V.V_record (pos, m,_) ->
95 V.V_record (pos, m, ref (Option.map (build_internal_path_t pos) o))
96 | _ ->
97 fail r "SL.embed_lazy_data, expecting a record@\n"
98
99 let inject_lazy_data r o = match r with
100 | V.V_record (pos, _, oref) ->
101 oref := Option.map (build_internal_path_t pos) o
102
103 | _ ->
104 fail r "SL.embed_lazy_data, expecting a record@\n"
105
106 (*
107 FIXME: add a documentation about the exception Exit,
108 why it is used there, and who does catch it,
109 and what does the program do by catching it.
110 *)
111 let at_exit, do_exit, get_exit =
112 let at_exit_fun = ref (fun () -> ()) in
113 (fun f -> at_exit_fun := f),
114 (fun _ -> !at_exit_fun (); raise Exit),
115 (fun _ -> !at_exit_fun)
116
117 type field = string
118
119 let compare_field = String.compare
120
121 let get_map = function
122 | V.V_record (_, map, _) -> map
123 | r ->
124 fail r "SL.record-manipulation, expecting a record@\n"
125
126 type field_index = field
127 type fields_indexes = field array
128 type patterns_indexes = fields_indexes array
129 type 'a rt_record = ty_record
130
131 let fields_indexes x = x
132 let field_index _ f = f
133 let patterns_indexes x = x
134 let dot_with_field_index (rt_record: 'a rt_record) (field_index:field_index) =
135 (Obj.magic ( Lazy.force (StringMap.find field_index (get_map rt_record))) : 'a)
136
137 let compare_structure pattern_index (r1:'a rt_record) (r2:'a rt_record) =
138 (* common code between qmlflat/serverLib
139 keep synchronised (bug fix, improvement) until dictionnary is used *)
140 let (===) fields map = (* TODO slow should be a dictionnary *)
141 fst (StringMap.fold (fun k _v (bool,pos) ->
142 (bool && (k==fields.(pos)) ), pos+1
143 ) map (true,0))
144 in
145 let gt = -1 in
146 let lt = -2 in
147 let rec search v1 v2 i=
148 let i = i-1 in
149 let fields = pattern_index.(i) in
150 if fields === v1 then
151 (
152 if fields === v2 then i
153 else gt (* v1 is has bigger index *)
154 )
155 else if fields === v2 then
156 lt (* v2 is has bigger index *)
157 else if i != 0 then
158 search v1 v2 (i-1)
159 else
160 fail r1 "serverLib.compare_structure : pattern_index is not compatible with record"
161 in
162 let v1 = get_map r1 in
163 let v2 = get_map r2 in
164 let n = Array.length pattern_index in
165 search v1 v2 n
166
167
168 let fold_record folder record =
169 StringMap.fold
170 (fun field value ->
171 folder field (Obj.magic value))
172 (get_map (Obj.magic record))
173
174 let fold_2_record folder r1 r2 acc =
175 let map2 = get_map (Obj.magic r2) in
176 StringMap.fold
177 (fun field value ->
178 folder field (Obj.magic value) (Obj.magic (StringMap.find field map2)))
179 (get_map (Obj.magic r1)) acc
180
181 let name_of_field field = Some field
182 let field_of_name = name_of_field
183
184 let static_name_of_field field = field
185 let static_field_of_name = static_name_of_field
186
187 type record_constructor = V.t Lazy.t StringMap.t
188
189 let empty_record_constructor = StringMap.empty
190
191 let add_field cons field value =
192 StringMap.add field (Lazy.lazy_from_val (Obj.magic value)) cons
193
194 let make_record cons = Obj.magic (V.V_record (V.nopos, cons, ref None))
195 let make_simple_record field = make_record (add_field empty_record_constructor field empty_record)
196
197 let dot r field = match r with
198 | V.V_record (_ , map, _) -> (
199 match StringMap.find_opt field map with
200 | None -> None
201 | Some lazy_val -> (
202 let value = Obj.magic (Lazy.force lazy_val) in
203 Some value
204 )
205 )
206 | _ ->
207 fail r "SL.dot, expecting a record@\n"
208
209 let unsafe_dot r field =
210 match dot r field with
211 | Some value -> value
212 | None ->
213 fail r "SL.unsafe_dot, runtime error, no field %S@\n" field
214
215 let is_present r field =
216 match r with
217 | V.V_record (_ , map, _) -> (
218 StringMap.mem field map
219 )
220 | _ ->
221 fail r "SL.is_present, expecting a record@\n"
222
223 (* Explicit projection API *)
224
225 (* standard bsl types *)
226 (* in qmltop, everything is boxed, so that catchable RuntimeErrors can replace seg faults *)
227 type ty_char = V.t
228 type ty_float = V.t
229 type ty_int = V.t
230 type ty_null = V.t
231 type ty_string = V.t
232
233 let wrap_float c = V.Proj.t_float c
234 let unwrap_float = function
235 | V.V_const (_, Q.Float f) -> f
236 | t ->
237 fail t "SL.unwrap_float, expecting a float@\n"
238
239 let wrap_int c = V.Proj.t_int c
240 let unwrap_int = function
241 | V.V_const (_, Q.Int i) -> i
242 | t ->
243 fail t "SL.unwrap_int, expecting an int@\n"
244
245 let null = V.t_null ~pos:(FilePos.nopos "SL.null") ()
246
247 let wrap_string c = V.Proj.t_string c
248 let unwrap_string = function
249 | V.V_const (_, Q.String s) -> s
250 | t ->
251 fail t "SL.unwrap_string, expecting an string@\n"
252
253 type ty_void = V.t
254 let void = empty_record
255
256 type ty_bool = V.t
257
258 let shared_true = V.Proj.t_bool true
259 let shared_false = V.Proj.t_bool false
260 let wrap_bool b =
261 if b then shared_true else shared_false
262
263 let true_ = shared_true
264 let false_ = shared_false
265
266 let unwrap_bool = function
267 | V.V_record (_, fields, _) ->
268 let semantic_bool = (StringMap.mem "true" fields) && not (StringMap.mem "false" fields) in
269 Obj.magic semantic_bool
270 | t ->
271 fail t "SL.unwrap_bool, expecting a bool@\n"
272
273 type 'a ty_option = V.t
274
275 let none = V.Proj.t_none ()
276 let some a = V.Proj.t_some (Obj.magic a)
277
278 let wrap_option = function
279 | None -> none
280 | Some a -> some a
281
282 let unwrap_option t =
283 let clash () =
284 fail t "SL.unwrap_option, expecting an option@\n"
285 in
286 match t with
287 | V.V_record (_, fields, _) ->
288 let semantic_option =
289 match StringMap.find_opt "some" fields with
290 | None ->
291 if not (StringMap.mem "none" fields)
292 then clash ()
293 else None
294 | Some v -> Some (Lazy.force v)
295 in
296 Obj.magic semantic_option
297 | _ -> clash ()
298
299
300 (* support for marshaling *)
301 let deep_force_eval a = Obj.obj (Lazy.deep_force (Obj.repr a))
302
303 (*
304 No sharing in opatop
305 *)
306 external sharing_refresh : 'a -> 'a = "%identity"
Something went wrong with that request. Please try again.