/
flat_BypassGeneration.ml
78 lines (71 loc) · 2.93 KB
/
flat_BypassGeneration.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
(*
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/>.
*)
(* CF mli *)
(* depends *)
module Format = Base.Format
(* alias *)
module ByPassMap = Flat_Bsl.FlatBSL.ByPassMap
module Implementation = Flat_Bsl.FlatBSL.Implementation
module ByPass = Flat_Bsl.FlatBSL.ByPass
module FCons = Flat_Common.FCons
let compile ~context ~bymap ?restriction key =
let skey = BslKey.to_string key in
let compiler_repr =
match ByPassMap.find_opt bymap key with
| None ->
QmlError.error context (
"unknown primitive @{<bright>%s@}"
)
skey
| Some bypass -> (
match ByPass.implementation bypass ~lang:BslLanguage.ml with
| Some ((Implementation.Compiled compiled) as implementation) ->
let bsltags = Implementation.bsltags implementation in
(* Check if this bypass is authorized *)
let _ =
let authorized = BslTags.authorized_bypass ~restriction bsltags in
if not authorized
then
QmlError.error context (
"bypass @{<bright>%s@} is not authorized in this context@\n"^^
"there are some restrictions : << %s >>"
)
skey (BslTags.string_of_restricted bsltags.BslTags.restricted)
else ()
in (
(* Check if this is in the segfault *)
match Flat_Bsl.is_segfault key (ByPassMap.ml_ctrans_env bymap) with
| None ->
let repr = Implementation.CompiledFunction.compiler_repr compiled in
if Implementation.CompiledFunction.is_transtype compiled
then Printf.sprintf "%s.%s" (Qml2ocaml.bsl_init_module ()) repr
else repr
| Some message ->
(* TODO Let the possibility to have dirtags here (ctrans_env maybe contains a BSL.ByPassMap.t) *)
QmlError.error context (
"%s"
)
message
)
| _ ->
QmlError.error context (
"The primitive @{<bright>%s@} has been found@\n"^^
"but there is no ocaml implementation@\n"^^
"%a"
) skey
(Format.pp_list "@\n" Implementation.pp)
(ByPass.all_implementations bypass)
)
in
Ocaml.make_Var compiler_repr