Skip to content
Browse files

[enhance] libbsl: each bsl implementation registers its own type.

  • Loading branch information...
1 parent 8b58cb9 commit 4f663115fd22daeabdaf5d1c0c77fccba4cecad0 @arthuraa arthuraa committed
View
4 compiler/libbsl/bslJs.ml
@@ -509,7 +509,7 @@ let fold_source_elt_classic ~dynloader_interface ~filename ~lang
assert (not injected);
env_rp_implementation env skey
in
- let rp_ips = [ lang, filename, parsed_t, implementation ] in
+ let rp_ips = [ lang, filename, parsed_t, rp_ty, implementation ] in
let rp = { BslPluginInterface.
rp_ks = rp_ks ;
rp_ty = rp_ty ;
@@ -713,7 +713,7 @@ let fold_source_elt_doc_like ~dynloader_interface ~filename ~lang
contains an identifier which will be renamed. *)
source, renaming
in
- let rp_ips = [ lang, filename, parsed_t, keyed_implementation ] in
+ let rp_ips = [ lang, filename, parsed_t, rp_ty, keyed_implementation ] in
let rp = { BslPluginInterface.
rp_ks = rp_ks ;
rp_ty = rp_ty ;
View
23 compiler/libbsl/bslLib.ml
@@ -1141,12 +1141,12 @@ struct
let fold_bypass key bypass ((building, map) as env) =
if not (filter bypass) then env
else
- let input, output =
- match bypass.ByPass.def_type with
- | BslTypes.Fun (_, input, output) -> Some input, output
- | t -> None, t
- in
let fold_map building impl =
+ let input, output =
+ match Implementation.trans_type impl with
+ | BslTypes.Fun (_, input, output) -> Some input, output
+ | t -> None, t
+ in
match impl with
| Compiled compiled ->
begin
@@ -1398,14 +1398,13 @@ struct
| [] -> assert false
| last::tl -> Some (List.rev tl, last)
in
- let type_ = ty in
let impl = ips in
let do_obj = true in (* remove if not needed *)
let skey = String.concat_map "_" BslKey.normalize_string ks in
let key = BslKey.normalize skey in
(* END OF HACK *)
let ml_dirtags = ref BslTags.default in
- let fold_impl (accu, langs) (lang, file, dirtags, impl_fun) =
+ let fold_impl (accu, langs) (lang, file, dirtags, type_, impl_fun) =
let dirtags =
try
BslTags.parse dirtags
@@ -1444,7 +1443,7 @@ struct
| false, _
| _, None -> maped_impl
| _, Some obj ->
- let interpretedML = { i_lang = BslLanguage.mli; obj = obj; i_type = type_ ; i_tags = !ml_dirtags } in
+ let interpretedML = { i_lang = BslLanguage.mli; obj = obj; i_type = ty ; i_tags = !ml_dirtags } in
(Interpreted interpretedML)::maped_impl in
let name =
(
@@ -1454,7 +1453,7 @@ struct
| Some (lk, sk) -> lk, sk
in
let strlink = String.concat "." link in
- let infos = Format.sprintf "link=%S@ key=%a@ fun=%S@ type=%a" strlink BslKey.pp key short_key BslTypes.pp type_ in
+ let infos = Format.sprintf "link=%S@ key=%a@ fun=%S@ type=%a" strlink BslKey.pp key short_key BslTypes.pp ty in
(* #<< debug browserstructure (Printf.sprintf "imperative_module_table : %s" infos); >>#; *)
(* If there is a previous binding of this key, we will produce an error *)
(
@@ -1463,17 +1462,17 @@ struct
else ()
);
try
- inspection_register_type type_ ;
+ inspection_register_type ty ;
register_imperative_hierarchy _imperative_module_table link (short_key, key);
short_key
with
- | RegisterError e -> error (List [e; FailureKeyType (key, type_)])
+ | RegisterError e -> error (List [e; FailureKeyType (key, ty)])
) in
(* We add the register in the table *)
let bypass = { ByPass.
key = key;
name = name;
- def_type = type_;
+ def_type = ty;
impl = maped_impl ;
plugin_name = !current_plugin_name ;
} in
View
2 compiler/libbsl/bslOcaml.ml
@@ -584,7 +584,7 @@ let fold_source_elt ~dynloader_interface ~filename env source_elt =
let rp_ty = env_map_ty_reference_for_opa env pos skey bslty in
let parsed_t = BslTags.parsed_t tags in
let implementation = env_rp_implementation env implementation injected in
- let rp_ips = [ L.ml, filename, parsed_t, implementation ] in
+ let rp_ips = [ L.ml, filename, parsed_t, rp_ty, implementation ] in
let rp_obj = None in
let rp = { BPI.
rp_ks = rp_ks ;
View
27 compiler/libbsl/bslPluginInterface.ml
@@ -70,29 +70,34 @@ type ocaml_env
+ [ks] the hieararchy path until this primitive. The final bslkey will be
built by lowercase all the path, and separated items with an underscore.
- + [ty] the type of the primitive
+ + [ty] the type of the primitive, purged from opa value tags.
+ [ips] all informations about the implementations in all target languages
+ [language] the extension of the language
+ [filename] the complete filname with dirname where is the file
+ [parsed_t] the row tags.
+ + [t] the type of this implementation, which can differ from the
+ others on the subtypes tagged as "opa[]".
+ [implementation] the complete identifier for the implementation.
["OpabslMLRuntime.Foo.Bar.function"]
+ [obj] optional, a pointer to the function (in this case, the code is linked
with the runtime, this is no more just a plugin, but a loader for the interpreter)
+
+ Notice that we don't check whether the types of each implementation
+ are compatible with the main type.
*)
type register_primitive =
ks:skey list ->
ty:BslTypes.t ->
- ips:(language * filename * BslTags.parsed_t * implementation) list ->
+ ips:(language * filename * BslTags.parsed_t * BslTypes.t * implementation) list ->
?obj:Obj.t ->
unit -> unit
type register_primitive_arguments = {
- rp_ks : skey list ;
- rp_ty : BslTypes.t ;
- rp_ips : ( language * filename * BslTags.parsed_t * implementation ) list ;
- rp_obj : Obj.t option ;
+ rp_ks : skey list;
+ rp_ty : BslTypes.t;
+ rp_ips : (language * filename * BslTags.parsed_t * BslTypes.t * implementation) list;
+ rp_obj : Obj.t option;
}
@@ -143,9 +148,13 @@ let meta_register_primitive buf ~ks ~ty ~ips ?obj () =
let b = ~>b "~ty:(%a) " BslTypes.pp_meta ty in
let b =
let pp_impl fmt impl =
- let lang, filename, parsed_t, implementation = impl in
- Format.fprintf fmt "(%a, %S, %a, %S)"
- BslLanguage.pp_meta lang filename BslTags.pp_meta parsed_t implementation
+ let lang, filename, parsed_t, ty, implementation = impl in
+ Format.fprintf fmt "(%a, %S, %a, %a, %S)"
+ BslLanguage.pp_meta lang
+ filename
+ BslTags.pp_meta parsed_t
+ BslTypes.pp_meta ty
+ implementation
in
~>b "~ips:[ %a ] " (pp_ml_list pp_impl) ips
in
View
21 compiler/libbsl/bslRegisterLib.ml
@@ -112,6 +112,7 @@ type identification = {
type rp_impl = {
c_rpi_filename : filename ;
c_rpi_tags : BslTags.parsed_t ;
+ c_rpi_type : BslTypes.t ;
c_rpi_implementation : implementation ;
}
@@ -119,7 +120,7 @@ type collecting_rp_ips = rp_impl BslLanguageMap.t
type rp_call = {
c_rp_ks : skey list ;
- c_rp_ty : BslTypes.t ;
+ c_rp_ty : BslTypes.t ; (* purged from opa values *)
c_rp_ips : collecting_rp_ips ;
c_rp_obj : implementation option ;
}
@@ -574,8 +575,7 @@ let register_primitive session ~ks ~ty ~ips ?obj:_ () =
(* checking the type *)
(* We do not take opa value declarations into account *)
let purged_ty = BslTypes.purge_opavalue ty in
- let purged_c_rp_ty = BslTypes.purge_opavalue c_rp_ty in
- if (BslTypes.compare ~normalize:true purged_ty purged_c_rp_ty) <> 0
+ if (BslTypes.compare ~normalize:true purged_ty c_rp_ty) <> 0
then (
OManager.printf "%a" FilePos.pp_citation pos ;
OManager.error "##register: @{<bright>conflicting primitive definitions@} for key '@{<brigth>%a@}'@\n" BslKey.pp key
@@ -585,7 +585,7 @@ let register_primitive session ~ks ~ty ~ips ?obj:_ () =
let c_rp_ty = BslTypes.reset_pos c_rp_ty pos in
let c_rp_ips = List.fold_left
- (fun c_rp_ips (lang, filename, parsed_t, implementation) ->
+ (fun c_rp_ips (lang, filename, parsed_t, type_, implementation) ->
(* redefinition in the same language is not allowed *)
match BslLanguageMap.find_opt lang c_rp_ips with
| Some _ -> (
@@ -598,6 +598,7 @@ let register_primitive session ~ks ~ty ~ips ?obj:_ () =
let rp_impl = {
c_rpi_filename = filename ;
c_rpi_tags = parsed_t ;
+ c_rpi_type = type_ ;
c_rpi_implementation = implementation ;
}
in
@@ -610,7 +611,7 @@ let register_primitive session ~ks ~ty ~ips ?obj:_ () =
| Some _ -> c_rp_obj
| None ->
List.find_map
- (fun (ml, _, _, imp) -> if BslLanguage.is_ml ml then Some imp else None) ips
+ (fun (ml, _, _, _, imp) -> if BslLanguage.is_ml ml then Some imp else None) ips
in
let rp_call = {
@@ -634,13 +635,14 @@ let register_primitive session ~ks ~ty ~ips ?obj:_ () =
| None ->
(* This is the first time this primitive is defined, collect it *)
let c_rp_obj = List.find_map
- (fun (ml, _, _, imp) -> if BslLanguage.is_ml ml then Some imp else None) ips
+ (fun (ml, _, _, _, imp) -> if BslLanguage.is_ml ml then Some imp else None) ips
in
let c_rp_ips = List.fold_left
- (fun c_rp_ips (lang, filename, parsed_t, implementation) ->
+ (fun c_rp_ips (lang, filename, parsed_t, type_, implementation) ->
let rp_impl = {
c_rpi_filename = filename ;
c_rpi_tags = parsed_t ;
+ c_rpi_type = type_ ;
c_rpi_implementation = implementation ;
}
in
@@ -649,7 +651,7 @@ let register_primitive session ~ks ~ty ~ips ?obj:_ () =
in
let rp_call = {
c_rp_ks = ks ;
- c_rp_ty = ty ;
+ c_rp_ty = BslTypes.purge_opavalue ty ;
c_rp_ips = c_rp_ips ;
c_rp_obj = c_rp_obj ;
}
@@ -758,9 +760,10 @@ let f_collecting_rp_ips c_rp_ips =
let fold lang rp_impl acc =
let filename = rp_impl.c_rpi_filename in
let tags = rp_impl.c_rpi_tags in
+ let type_ = rp_impl.c_rpi_type in
let implementation = rp_impl.c_rpi_implementation in
let item =
- lang, filename, tags, implementation
+ lang, filename, tags, type_, implementation
in
item :: acc
in

0 comments on commit 4f66311

Please sign in to comment.
Something went wrong with that request. Please try again.