Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 142 lines (129 sloc) 5.965 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 *)
4692879 @OpaOnWindowsNow [feature] Internationalisation: add @i18n directive and start support…
OpaOnWindowsNow authored
18 module P = SurfaceAstPassesTypes
fccc685 Initial open-source release
MLstate authored
19 module S = SurfaceAst
20 module CS = SurfaceAstCons.StringCons
21 module C = SurfaceAstCons.ExprIdentCons
22 module List = Base.List
23
24 (* could be put after renaming and then the toplevel map would give the answer
25 * without having to go throught all the toplevel names *)
26 let server_appears code =
27 OpaWalk.CodeTopPattern.exists_nonrec (OpaWalk.Pattern.appears_str "server") code
28
29 module S1 =
30 struct
31 type t = bool (* no_server *)
32 let pass = "check_server_entry_point"
33 let pp f _ = Format.pp_print_string f "<dummy>"
34 end
35 module R1 = ObjectFiles.Make(S1)
36
37 let pass_check_server_entry_point ~options env =
38 let warn, no_server, env =
39 match options.OpaEnv.no_server with
40 | Some no_server -> false, no_server, env
41 | None ->
42 begin
43 (* check stdlib *)
44 if server_appears env.P.lcodeNotUser then (
45 OManager.error "I found a @{<bright>server@} declaration at toplevel on the @{<bright>stdlib@}@\n"
46 );
47
48 (* walk throught the code and replace server declarations *)
49 let make_entry_point ~label e =
50 let entry_point_dir = CS.D.server_entry_point ~label e in
51 CS.C.newval_ignore ~label entry_point_dir in
52 let fun_fl (has_server, acc) = function
46769f1 @OpaOnWindowsNow [feature] surfaceAst: create bind_ident (and use in pattern) node to …
OpaOnWindowsNow authored
53 | S.NewVal ([(S.PatVar {S.ident="server";_}, _), e],_), label ->
fccc685 Initial open-source release
MLstate authored
54 (* [server = $e$] becomes [_ = add_server(e)] *)
55 (* this special case makes the code a little more readable *)
56 (true, make_entry_point ~label e :: acc)
57 | S.NewVal (pel,b), label ->
58 (* [(server,mlk) = $e$] becomes [(fresh,mlk) = $e$ _ = add_server(fresh)]
59 * [(server,server) = e] won't generate the error "non linear pattern" *)
60 let gen () = SurfaceAstCons.Fresh.name "server" in
61 let new_names, pel =
62 List.fold_left_map
63 (fun acc (p,e) ->
64 let acc, p =
65 OpaWalk.Pattern.foldmap
66 (fun acc -> function
46769f1 @OpaOnWindowsNow [feature] surfaceAst: create bind_ident (and use in pattern) node to …
OpaOnWindowsNow authored
67 | (S.PatVar ({S.ident="server";_} as id),label) ->
fccc685 Initial open-source release
MLstate authored
68 let fresh = gen () in
46769f1 @OpaOnWindowsNow [feature] surfaceAst: create bind_ident (and use in pattern) node to …
OpaOnWindowsNow authored
69 let id = {id with S.ident=gen()} in
70 fresh :: acc, (S.PatVar id, label)
71 | (S.PatAs (p,({S.ident="server";_} as id)), label) ->
fccc685 Initial open-source release
MLstate authored
72 let fresh = gen () in
46769f1 @OpaOnWindowsNow [feature] surfaceAst: create bind_ident (and use in pattern) node to …
OpaOnWindowsNow authored
73 let id = {id with S.ident=gen()} in
74 fresh :: acc, (S.PatAs (p, id), label)
fccc685 Initial open-source release
MLstate authored
75 | p -> acc, p)
76 acc p in
77 acc, (p,e))
78 [] pel in
79 let new_declarations =
80 List.rev_map (fun name -> make_entry_point ~label (CS.E.var ~label name)) new_names in
81 (has_server || new_names <> [], List.rev_append new_declarations ((S.NewVal (pel,b),label) :: acc))
82 | v -> (has_server, v :: acc) in
83 let has_server,rev_code_parcouru = List.fold_left fun_fl (false,[]) env.P.lcodeUser in
84 let code_parcouru = List.rev rev_code_parcouru in
85
86 if has_server then
87 true, false, {env with P.lcodeUser = code_parcouru}
88 else
89 true, true, env
90 end in
91 R1.save no_server;
92 let no_server =
93 match ObjectFiles.compilation_mode () with
94 | `init ->
95 true
96 | `linking ->
97 (* no server if no packages defines a server *)
98 let no_server = R1.fold ~packages:true ~deep:true (&&) no_server in
99 if no_server && warn then OManager.unquiet "@{<red>WARNING : The \"server\" value is MISSING, the executable will NOT start a server@}";
100 no_server
101 | `prelude -> no_server
102 | `compilation -> no_server in
103 {options with OpaEnv.no_server = Some no_server}, env
104
105 let pass_resolve_server_entry_point ~options lcode =
106 if options.OpaEnv.no_server = Some true then
107 lcode
108 else
109 let aux ((e,label) as v) =
110 match e with
111 | S.Directive (`server_entry_point, [apply_service], _) ->
112 SurfaceAstCons.with_label label (fun () ->
113 let id_addser = OpaMapToIdent.val_ Opacapi.Server_private.add_service in
114 let add_ser = C.E.ident id_addser in
115 C.E.apply add_ser apply_service
116 )
117 | _ -> v in
118 OpaWalk.Code.map_down aux lcode
119
120
121 let pass_adding_server ~options lcode =
122 if Option.get options.OpaEnv.no_server
123 || not options.OpaEnv.stdlib
124 || (match ObjectFiles.compilation_mode () with
125 | `compilation | `init -> true
126 | `linking | `prelude -> false)
127 then (* it allows us to use --force-server and --no-stdlib
128 * for example to call the slicer even in --no-stdlib
129 * even without server *)
130 lcode
131 else
132 let final =
133 SurfaceAstCons.with_builtin_position (fun () ->
134 let run_server_id = OpaMapToIdent.val_ Opacapi.Server_private.run_services in
135 let run_server = C.E.ident run_server_id in
136 let app = C.E.applys run_server [] in
137 let start_server = OpaMapToIdent.val_start_server_add () in
138 let declaration_toplevel = C.C.newval start_server app in
139 declaration_toplevel
140 ) in
141 lcode @ [final]
Something went wrong with that request. Please try again.