-
Notifications
You must be signed in to change notification settings - Fork 125
/
bslPervasives.ml
225 lines (164 loc) · 7.44 KB
/
bslPervasives.ml
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
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
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
223
224
225
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(**
Core of the BSL.
Values exported by this module must appear both on the client and on the server.
@author David Rajchenbach-Teller (Review, clean-up)
*)
(** before printing somewhere, we can indicate that we will,
all printing with such indication will respectfully flush correctly stdout stderr output to avoid mixed outputs
take stdout or stderr in parameter
*)
let sync_to_print_on =
let need_to_flush = ref stdout in
fun std ->
if not (!need_to_flush == std) then (
flush !need_to_flush;
need_to_flush := std
)
(* used to be set to false at startup of server, disabled for now *)
let tokill = ref false;;
(**
* {1 Arithmetic operations}
*)
##register int_add \ `Pervasives.( + )` : int, int -> int
##register float_add \ `Pervasives.( +. )` : float, float -> float
##register int_sub \ `Pervasives.( - )` : int, int -> int
##register float_sub \ `Pervasives.( -. )` : float, float -> float
##register int_mul \ `Pervasives.( * )` : int, int -> int
##register float_mul \ `Pervasives.( *. )` : float, float -> float
##register int_div \ `Pervasives.( / )` : int, int -> int
##register float_div \ `Pervasives.( /. )` : float, float -> float
##register int_mod \ `Pervasives.( mod )` : int, int -> int
##register mod \ `Pervasives.( mod )` : int, int -> int
##register int_rem : int, int -> int
let int_rem l r =
let r_pos = abs r in
let l_pos = abs l in
let res = l_pos - (r_pos * (l_pos / r_pos)) in
if (r > 0) then res else (-res)
##register int_neg \ `Pervasives.( ~- )` : int -> int
##register float_neg \ `Pervasives.( ~-. )` : float -> float
##register int_of_first_char : string -> int
let int_of_first_char c = Pervasives.int_of_char (String.get c 0)
(**
* Physical equality between OCaml objects
*)
##register areSameObject : 'a, 'b -> bool
let areSameObject x y = Obj.magic x == Obj.magic y
(**
* Comparison functions
*
* The results of these functions is normalized to always return -1, 0 or 1 -- it's an important invariant
* Caml has this invariant, even if it is unspecified
* we rely on it, and check that it really holds in reftester
*)
(* BE AWARE THAT THESE BYPASS ARE MANUALLY REGISTERED IN QMLEFFECT
SO YOU SHOULD SYNCHRONISE THE TWO FILE FOR ANY NAME CHANGE*)
(* to trigger Ocaml optimisation for comparing ints/float/strings,
3x faster than compare for int *)
##register compare_int \ `(Pervasives.compare : int -> int -> int)` : int, int -> int
##register compare_float \ `(Pervasives.compare : float -> float -> int)` : float, float -> int
##register compare_string \ `String.compare` : string, string -> int
##register [opacapi] compare_raw \ `ServerLib.compare` : 'a, 'a -> int
##register int_cmp_neq \ `(Pervasives.(!=) : int -> int -> bool)` : int, int -> bool
##register int_cmp_eq \ `(Pervasives.(==) : int -> int -> bool)` : int, int -> bool
##register int_cmp_lneq \ `(Pervasives.(<) : int -> int -> bool)` : int, int -> bool
##register int_cmp_leq \ `(Pervasives.(<=) : int -> int -> bool)` : int, int -> bool
##register int_cmp_gneq \ `(Pervasives.(>) : int -> int -> bool)` : int, int -> bool
##register int_cmp_geq \ `(Pervasives.(>=) : int -> int -> bool)` : int, int -> bool
##register stop: -> 'a
let stop () =
Logger.warning "BslSyslog.stop has been called : shutting down application ...";
ServerLib.do_exit 1
(* this function is used by the pass that discard slicer directives *)
##register never_do_anything : 'a -> 'b
(* could take a string and display it so that we can see if something goes wrong *)
let rec never_do_anything _ = Obj.magic never_do_anything
##register warning : string -> void
let warning s =
sync_to_print_on stderr;
Logger.warning "%s" s
##register jlog : string -> void
let jlog s =
sync_to_print_on stderr;
Logger.notice "%s" s
(**
* Type-unsafe identity.
* Not for casual user.
* For bypassing only the Opa typer, use rather [\@unsafe_cast]
**)
##module Magic
##register [opacapi] id \ `Obj.magic` : 'a -> 'b
##endmodule
module OpaExc = BslNativeLib.OpaExc
(**
Bypass used in the compilation of the directive {[\@fail]}.
*)
##register [opacapi, cps-bypass] fail_cps : string, string, continuation('a) -> void
let fail_cps message position k =
Logger.error "%s@\n@{<bright>@@fail@}: %s" position message ;
let exc = OpaExc.fail ~message ~position in
let k = QmlCpsServerLib.handler_cont k in
QmlCpsServerLib.return k exc
(**
Primitive used in the projection of function which may raise an ocaml exception
*)
##extern-type ocaml_exception = exn
##register [opacapi, no-projection] return_exc : string, ocaml_exception, continuation('a) -> void
let return_exc bslkey exc k =
let exc = OpaExc.ocaml_exc bslkey exc in
let k = QmlCpsServerLib.handler_cont k in
QmlCpsServerLib.return k exc
(*
This function is used only in non cps mode.
In this case, this is an Ocaml exception
*)
##register [opacapi] fail : string, string -> 'a
let fail message position =
Logger.error "%s@\n@{<bright>@@fail@}: %s" position message ;
let exc = OpaExc.fail ~message ~position in
raise (Failure (DebugPrint.print exc))
##register get_stack : -> string
let get_stack = Printexc.get_backtrace
##register print_string : string -> void
let print_string s = sync_to_print_on stdout ; Pervasives.print_string s
##register print_endline \ println_string: string -> void
let println_string s = sync_to_print_on stdout ; Pervasives.print_endline s
##register prerr_string : string -> void
let prerr_string s = sync_to_print_on stderr ; Pervasives.prerr_string s
##register prerr_endline : string -> void
let prerr_endline s = sync_to_print_on stdout ; Pervasives.prerr_endline s
##register print_int : int -> void
let print_int i = print_string (string_of_int i)
##register flush_stdout : -> void
let flush_stdout () = Pervasives.flush stdout
##register flush_all : -> void
let flush_all () = Pervasives.flush_all ()
##extern-type black = unit
(**
* Attempt to convert an arbitrary value to string.
*)
##register dump : 'a -> string
let dump x =
DebugPrint.print x
##opa-type Order.comparison
##opa-type Order.ordering
let ord_result_lt = wrap_opa_order_ordering (ServerLib.make_simple_record (ServerLib.static_field_of_name "lt"))
let ord_result_eq = wrap_opa_order_ordering (ServerLib.make_simple_record (ServerLib.static_field_of_name "eq"))
let ord_result_gt = wrap_opa_order_ordering (ServerLib.make_simple_record (ServerLib.static_field_of_name "gt"))
let comp_result_lt = wrap_opa_order_comparison (ServerLib.make_simple_record (ServerLib.static_field_of_name "lt"))
let comp_result_eq = wrap_opa_order_comparison (ServerLib.make_simple_record (ServerLib.static_field_of_name "eq"))
let comp_result_gt = wrap_opa_order_comparison (ServerLib.make_simple_record (ServerLib.static_field_of_name "gt"))
let comp_result_neq = wrap_opa_order_comparison (ServerLib.make_simple_record (ServerLib.static_field_of_name "neq"))