Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 235 lines (204 sloc) 8.006 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 Format = Base.Format
20
21 (* alias *)
22 module FieldSet = StringSet
23
24 (* shorthand *)
25 module J = JsAst
26 module Q = QmlAst
27
28 (* -- *)
29
30 let pp_esc fmt s = Format.fprintf fmt "%S" s
31 let pp_path fmt list = Format.pp_list " ; " pp_esc fmt list
32 let pp_fieldset fmt set =
33 let sep = ref false in
34 FieldSet.iter (
35 fun field ->
36 (if !sep then Format.fprintf fmt " ; " ; sep := true) ;
37 Format.pp_print_string fmt field
38 ) set
39
40
f2ce0c4 [doc] qmljsimp: adding, removing, updating comments
Valentin Gatien-Baron authored
41 (* contains all the calls to the runtime (except the bsl which is called with
42 * bypasses) *)
fccc685 Initial open-source release
MLstate authored
43 module ClientLib =
44 struct
45 let (!!) s = JsCons.Expr.native_global s
46
47 let build_true = !! "build_true"
48 let build_false = !! "build_false"
49 let build_bool b = if b then build_true else build_false
50
51 let dot_true = !! "dot_true"
52 let dot_false = !! "dot_false"
53 let dot_bool b = if b then dot_true else dot_false
54
9176810 @OpaOnWindowsNow [feature] closure serialisation: adding the runtime to implement closure...
OpaOnWindowsNow authored
55 let env_apply_with_ty = !! "_env_apply_with_ty"
56
fccc685 Initial open-source release
MLstate authored
57 let error = !! "error"
58 let extend_record = !! "extend_record"
59
60 let match_failure pos =
61 let message = JsCons.Expr.string (Format.sprintf "%a: Match failure" FilePos.pp_pos pos) in
62 JsCons.Expr.call ~pure:false error [ message ]
63
64 let size = !! "size"
65
66 let void = !! "js_void"
67
68 let type_string = !! "type_string"
69 let type_char = !! "type_char"
70 let type_int = !! "type_int"
71 let type_float = !! "type_float"
72 let type_fun = !! "type_fun"
73 let type_fun_arity = !! "type_fun_arity"
74 let type_var = !! "type_var"
75 let type_option = !! "type_option"
76 let type_void = !! "type_void"
77 let type_native_option = !! "type_native_option"
78 let type_native_void = !! "type_native_void"
79 let type_bool = !! "type_bool"
80 let type_extern = !! "type_extern"
81 let type_opavalue = !! "type_opavalue"
82 let assert_length = !! "assert_length"
83 end
84
f2ce0c4 [doc] qmljsimp: adding, removing, updating comments
Valentin Gatien-Baron authored
85 (* a very conservative approximation of which expressions do observable side
86 * effects *)
fccc685 Initial open-source release
MLstate authored
87 let does_side_effects e =
88 JsWalk.OnlyExpr.exists
89 (function
90 | J.Je_hole _
300cb88 [fix] js cleaning: 'new' expression wasn't considered as a potential sid...
Mathieu Barbin authored
91 | J.Je_new _
fccc685 Initial open-source release
MLstate authored
92 | J.Je_call (_,_,_,false) -> true
93 | J.Je_unop (_, ( J.Ju_delete
94 | J.Ju_add2_pre
95 | J.Ju_sub2_pre
96 | J.Ju_add2_post
97 | J.Ju_sub2_post), _) -> true
98 | J.Je_binop (_, ( J.Jb_assign
99 | J.Jb_mul_assign
100 | J.Jb_div_assign
101 | J.Jb_mod_assign
102 | J.Jb_add_assign
103 | J.Jb_sub_assign
104 | J.Jb_lsl_assign
105 | J.Jb_lsr_assign
106 | J.Jb_asr_assign
107 | J.Jb_and_assign
108 | J.Jb_xor_assign
109 | J.Jb_or_assign ), _, _) -> true
110
111 | J.Je_runtime (_, e) -> (
112 match e with
113 | JsAstRuntime.SetDistant _ -> true
114 | JsAstRuntime.TaggedString _ -> false
115 )
116 | _ -> false
117 ) e
118
119 (* ************************************************************************** *)
120 (** {b Descr}: Returns [true] if the type has some values that may be evaluated
121 into false in JS. The following types are considered "dangerous" because
122 the specified value is evaluated into false in JS:
123 - int : 0
124 - float : 0.0
125 - string : ""
126 - char : ''
127 - bool : false
128 - type variable since we do not know what it will finally be, perhaps
129 especially one of the above "dangerous" type.
130 - abstract type since we don't known what it is really.
131 - named type that remain named type after expansion since, if this
132 happens this means that we have no explicit representation of them
133 in term of basic types combinations, hence this probably corresponds
134 to an abstract type. Note that currently, with the way QML represents
135 abstract types, I'm really not sure that this can happen.
136 {b Visibility}: Not exported outside this module. *)
137 (* ************************************************************************** *)
138 let maybe_void gamma ty =
139 let rec do_job ~already_expanded = function
140 | Q.TypeRecord (Q.TyRow ([], _)) -> true
141 | Q.TypeSum (Q.TyCol (list, colvar)) ->
142 Option.is_some colvar
143 || List.exists (function [] -> true | _ -> false) list
144 | Q.TypeRecord _ | Q.TypeArrow _ | Q.TypeConst _ -> false
145 | Q.TypeAbstract | Q.TypeVar _ -> true
146 | Q.TypeSumSugar _ ->
147 (* There should not remain such type at this point. *)
148 assert false
149 | Q.TypeForall (_, _, _, t) -> do_job ~already_expanded t
150 | (Q.TypeName _) as t ->
151 if already_expanded then true
152 else (
153 (* The type has not already been expanded, hence we are allowed to
154 expand it. *)
155 let t = QmlTypesUtils.Inspect.follow_alias_noopt_private gamma t in
156 (* And now it has been expanded, we are not allowed to expand it
157 again forever. *)
158 do_job ~already_expanded: true t
159 )
160 in
161 do_job ~already_expanded: false ty
162
163 let maybe_js_false gamma ty =
164 (* Local function processing the type. We only expand the type if it appears
165 to be a named type.
166 This saves time in case the type is not a named one. The flag
167 [~already_expanded] tells if the type has been expanded, hence must not
168 be again. *)
169 let rec do_job ~already_expanded = function
170
171 (*
172 Special case for boolean.
173 Do not call Inspect.is_type_bool, because it would perform a expansion
174 everytime, and is not exactly what we need there.
175 We are caring about value that are potentially [false], which includes
176 bool value, but not only (e.g. with an open col, or row variable)
177 *)
178 | Q.TypeRecord (Q.TyRow (["false", ty], _)) ->
179 maybe_void gamma ty
180
181 | Q.TypeRecord (Q.TyRow ([], Some _)) -> true
182
183 | Q.TypeSum (Q.TyCol (cols, colvar)) ->
184 let void = ref true in
185 let exists case =
186 match case with
187 | [ "false", tyf ] ->
188 void := maybe_void gamma tyf ;
189 !void
190
191 | _ -> false
192 in
193 List.exists exists cols
194 || (Option.is_some colvar && !void)
195
196 (*
197 From there, sum and record may not be bool
198 *)
199 | Q.TypeRecord _ | Q.TypeArrow _ -> false
200 | Q.TypeAbstract | Q.TypeVar _ -> true
201 | Q.TypeConst ct -> (
202 (* In fact, all basic types are "dangerous". *)
203 match ct with
0ab80d5 @fpessaux [cleanup] remove chars: compiler
fpessaux authored
204 | Q.TyFloat | Q.TyInt | Q.TyString -> true
fccc685 Initial open-source release
MLstate authored
205 | Q.TyNull -> assert false
206 )
207 | Q.TypeSumSugar _ ->
208 (* There should not remain such type at this point. *)
209 assert false
210 | Q.TypeForall (_, _, _, t) -> do_job ~already_expanded t
211 | (Q.TypeName _) as t ->
212 if already_expanded then true
213 else (
214 (* The type has not already been expanded, hence we are allowed to
215 expand it. *)
216 let t = QmlTypesUtils.Inspect.follow_alias_noopt_private gamma t in
217 (* And now it has been expanded, we are not allowed to expand it
218 again forever. *)
219 do_job ~already_expanded: true t
220 )
221 in
222 (* Now, really do the job. Effective body of the function [maybe_js_false]. *)
223 do_job ~already_expanded: false ty
224
225
226
227 let const const =
228 match const with
229 | Q.Int i ->
230 JsCons.Expr.int i
231 | Q.Float f ->
232 JsCons.Expr.float f
233 | Q.String s ->
234 JsCons.Expr.string s
Something went wrong with that request. Please try again.