Skip to content
Newer
Older
100644 66 lines (52 sloc) 2.3 KB
fccc685 Initial open-source release
MLstate authored Jun 21, 2011
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 String = Base.String
20 module Random = Base.Random
21
22 (* shorthands *)
23 module Q = QmlAst
24 module Cons = QmlAstCons.TypedExpr
25
26
27 let () = Random.ensure_init ()
28
29 let set_executable_id = Opacapi.Opabsl.BslInit.set_executable_id
30 let set_cleaning_default_value = Opacapi.Opabsl.BslJsIdent.set_cleaning_default_value
31
32 let add_bypass_application bypass_typer gamma annotmap bypass arguments code =
33 let annotmap, bypass =
34 Cons.bypass annotmap bypass (Option.get (bypass_typer bypass)) in
35 let annotmap, app =
36 Cons.apply gamma annotmap bypass arguments in
37 let ident = Ident.next "__dummy" in
38 let gamma = QmlTypes.Env.Ident.add ident (QmlTypes.Scheme.id (Q.TypeRecord (Q.TyRow ([],None)))) gamma in
39 let label = Annot.nolabel "pass_InitializeBslValues" in
40 gamma, annotmap, Q.NewVal (label, [ident, app]) :: code
41
42 let process_code bypass_typer gamma annotmap code =
43
44 (* generating the server id *)
45 let annotmap, id =
46 Cons.string annotmap (
47 #<If:DIFFING>
48 "the_executable_id_is_not_supported_in_diffing_mode"
49 #<Else>
50 String.random 32
51 #<End>
52 ) in
53 let gamma, annotmap, code = add_bypass_application bypass_typer gamma annotmap set_executable_id [id] code in
54
55 (* setting the default value of cleaning *)
56 let gamma, annotmap, code =
57 try
58 let annotmap, cleaning =
59 Cons.bool (annotmap,gamma) (ObjectFiles.Arg.is_fully_separated ()) in
60 add_bypass_application bypass_typer gamma annotmap set_cleaning_default_value [cleaning] code
61 with QmlTyperException.Exception _ ->
62 (* if bool is not defined, we are in --no-stdlib, so we don't care about cleaning *)
63 gamma, annotmap, code in
64
65 gamma, annotmap, code
Something went wrong with that request. Please try again.