%---------------------------------------------------------------------------% % vim: ft=mercury ts=4 sw=4 et %---------------------------------------------------------------------------% % Copyright (C) 2000-2011 The University of Melbourne. % Copyright (C) 2013-2026 The Mercury team. % This file may only be copied under the terms of the GNU General % Public License - see the file COPYING in the Mercury distribution. %---------------------------------------------------------------------------% % % File: foreign.m. % Main authors: trd, dgj. % % This module defines predicates for interfacing with foreign languages. % In particular, this module supports interfacing with languages % other than the target of compilation. % % Parts of this code were originally written by dgj, and have since been moved % here. % %---------------------------------------------------------------------------% :- module backend_libs.foreign. :- interface. :- import_module hlds. :- import_module hlds.hlds_data. :- import_module hlds.hlds_module. :- import_module libs. :- import_module libs.globals. :- import_module mdbcomp. :- import_module mdbcomp.sym_name. :- import_module parse_tree. :- import_module parse_tree.prog_data. :- import_module parse_tree.prog_foreign. :- import_module bool. :- import_module list. :- import_module maybe. %---------------------------------------------------------------------------% :- type foreign_type_and_assertions ---> foreign_type_and_assertions(sym_name, foreign_type_assertions). % A type defined by a pragma foreign_type, and the assertions % on that foreign_type. % Given an arbitrary mercury type, get the exported_type representation % of that type on the current backend. % :- func is_this_a_foreign_type(module_info, mer_type) = maybe(foreign_type_and_assertions). % Given a type, determine the string which corresponds to that type % in the specified foreign language, for use with foreign language % interfacing (`pragma export' or `pragma foreign_proc'). % :- func exported_type_to_string(module_info, foreign_language, mer_type) = string. :- func exported_type_to_c_string(module_info, mer_type) = string. :- func maybe_foreign_type_to_string(foreign_language, mer_type, maybe(foreign_type_and_assertions)) = string. :- func maybe_foreign_type_to_c_string(mer_type, maybe(foreign_type_and_assertions)) = string. :- func foreign_type_to_c_string(foreign_type_and_assertions) = string. :- func maybe_foreign_type_to_csharp_string(mer_type, maybe(foreign_type_and_assertions)) = string. :- func maybe_foreign_type_to_java_string(mer_type, maybe(foreign_type_and_assertions)) = string. :- func exported_builtin_type_to_c_string(builtin_type) = string. :- func exported_builtin_type_to_csharp_string(builtin_type) = string. :- func exported_builtin_type_to_java_string(builtin_type) = string. %---------------------------------------------------------------------------% % Find the current target backend from the module_info, and given % a foreign_type_body, return the name of the foreign language type % the identity of any user-defined unify/compare predicates, and the % assertions applicable to that backend. % :- pred foreign_type_body_to_exported_type(module_info::in, foreign_type_body::in, sym_name::out, maybe_canonical::out, foreign_type_assertions::out) is det. % Does the foreign_type_body contain a definition usable % when compiling to the given target. % :- pred have_foreign_type_for_backend(compilation_target::in, foreign_type_body::in, bool::out) is det. % Does the implementation of the given foreign type body on % the current backend use a user-defined comparison predicate. % :- pred foreign_type_body_has_user_defined_eq_comp_pred(module_info::in, foreign_type_body::in, noncanonical::out) is semidet. %---------------------------------------------------------------------------% % Filter the decls for the given foreign language. % The first return value is the list of matches, the second is % the list of mis-matches. % :- pred filter_decls(foreign_language::in, list(foreign_decl_code)::in, list(foreign_decl_code)::out, list(foreign_decl_code)::out) is det. % Filter the bodys for the given foreign language. % The first return value is the list of matches, the second is % the list of mis-matches. % :- pred filter_bodys(foreign_language::in, list(foreign_body_code)::in, list(foreign_body_code)::out, list(foreign_body_code)::out) is det. % Filter the foreign exports for the given foreign language. % The first return value is the list of matches, the second is % the list of mis-matches. % :- pred filter_exports(foreign_language::in, list(pragma_exported_proc)::in, list(pragma_exported_proc)::out, list(pragma_exported_proc)::out) is det. %---------------------------------------------------------------------------% % foreign_code_to_identifiers(Lang, Code, Identifiers, Comments): % % Break up Code into words that meet the rules for identifiers. % Some of these may actually be language keywords. % :- pred foreign_code_to_identifiers(foreign_language::in, string::in, list(string)::out, list(string)::out) is det. % comments_to_identifiers(Comments, Identifiers): % % Given a list of comment strings, break them up into words % that meet the rules for identifiers. % :- pred comments_to_identifiers(list(string)::in, list(string)::out) is det. %---------------------------------------------------------------------------% % The name of the #define which can be used to guard declarations with % to prevent entities being declared twice. % :- func decl_guard(sym_name) = string. %---------------------------------------------------------------------------% %---------------------------------------------------------------------------% :- implementation. :- import_module mdbcomp.prim_data. :- import_module parse_tree.prog_data_foreign. :- import_module parse_tree.prog_type. :- import_module char. :- import_module cord. :- import_module require. :- import_module string. :- import_module term. %---------------------------------------------------------------------------% is_this_a_foreign_type(ModuleInfo, Type) = MaybeForeignTypeAssertions :- module_info_get_type_table(ModuleInfo, TypeTable), ( if type_to_ctor(Type, TypeCtor), search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn) then hlds_data.get_type_defn_body(TypeDefn, TypeBody), ( TypeBody = hlds_foreign_type(ForeignTypeBody), foreign_type_body_to_exported_type(ModuleInfo, ForeignTypeBody, ForeignTypeName, _, Assertions), MaybeForeignTypeAssertions = yes(foreign_type_and_assertions(ForeignTypeName, Assertions)) ; ( TypeBody = hlds_du_type(_) ; TypeBody = hlds_eqv_type(_) ; TypeBody = hlds_solver_type(_) ; TypeBody = hlds_abstract_type(_) ), MaybeForeignTypeAssertions = no ) else MaybeForeignTypeAssertions = no ). exported_type_to_string(ModuleInfo, Lang, Type) = String :- MaybeForeignType = is_this_a_foreign_type(ModuleInfo, Type), String = maybe_foreign_type_to_string(Lang, Type, MaybeForeignType). exported_type_to_c_string(ModuleInfo, Type) = String :- MaybeForeignType = is_this_a_foreign_type(ModuleInfo, Type), String = maybe_foreign_type_to_c_string(Type, MaybeForeignType). maybe_foreign_type_to_string(Lang, Type, MaybeForeignType) = String :- ( Lang = lang_c, String = maybe_foreign_type_to_c_string(Type, MaybeForeignType) ; Lang = lang_csharp, String = maybe_foreign_type_to_csharp_string(Type, MaybeForeignType) ; Lang = lang_java, String = maybe_foreign_type_to_java_string(Type, MaybeForeignType) ). maybe_foreign_type_to_c_string(Type, MaybeForeignType) = String :- ( MaybeForeignType = yes(ForeignTypeAndAssertions), String = foreign_type_to_c_string(ForeignTypeAndAssertions) ; MaybeForeignType = no, % With --high-level-code, the value we return here should agree % with what happens is generated (indirectly) through % mercury_type_to_mlds_type. % % XXX I don't think this is yet true in all cases. -zs % % It is possible that in some cases, the right type name may depend % on whether --high-level-code is set. ( Type = builtin_type(BuiltinType), String = exported_builtin_type_to_c_string(BuiltinType) ; Type = tuple_type(_, _), String = "MR_Tuple" ; % XXX Is MR_Word the right thing for any of these kinds of % types for high level code, with or without high level data? ( Type = defined_type(_, _, _) ; Type = higher_order_type(_, _, _, _) ; Type = apply_n_type(_, _, _) ), String = "MR_Word" ; Type = type_variable(_, _), String = "MR_Word" ; Type = kinded_type(_, _), unexpected($pred, "kinded type") ) ). foreign_type_to_c_string(ForeignTypeAndAssertions) = String :- ForeignTypeAndAssertions = foreign_type_and_assertions(ForeignType, _), ( ForeignType = unqualified(String) ; ForeignType = qualified(_, _), unexpected($pred, "qualified C type") ). maybe_foreign_type_to_csharp_string(Type, MaybeForeignType) = String :- ( MaybeForeignType = yes(foreign_type_and_assertions(ForeignType, _)), String = sym_name_to_string(ForeignType) ; MaybeForeignType = no, ( Type = builtin_type(BuiltinType), String = exported_builtin_type_to_csharp_string(BuiltinType) ; ( Type = tuple_type(_, _) ; Type = defined_type(_, _, _) ; Type = higher_order_type(_, _, _, _) ; Type = apply_n_type(_, _, _) ; Type = type_variable(_, _) ; Type = kinded_type(_, _) ), % This is here so we can share some code between C/C#/Java % backends. This is not the correct type to use in general. String = "object" ) ). maybe_foreign_type_to_java_string(Type, MaybeForeignType) = String :- ( MaybeForeignType = yes(foreign_type_and_assertions(ForeignType, _)), String = sym_name_to_string(ForeignType) ; MaybeForeignType = no, ( Type = builtin_type(BuiltinType), String = exported_builtin_type_to_java_string(BuiltinType) ; ( Type = tuple_type(_, _) ; Type = defined_type(_, _, _) ; Type = higher_order_type(_, _, _, _) ; Type = apply_n_type(_, _, _) ; Type = type_variable(_, _) ; Type = kinded_type(_, _) ), % This is here so we can share some code between C/C#/Java % backends. This is not the correct type to use in general. String = "java.lang.Object" ) ). exported_builtin_type_to_c_string(BuiltinType) = CTypeName :- ( BuiltinType = builtin_type_int(IntType), ( IntType = int_type_int, CTypeName = "MR_Integer" ; IntType = int_type_uint, CTypeName = "MR_Unsigned" ; IntType = int_type_int8, CTypeName = "int8_t" ; IntType = int_type_uint8, CTypeName = "uint8_t" ; IntType = int_type_int16, CTypeName = "int16_t" ; IntType = int_type_uint16, CTypeName = "uint16_t" ; IntType = int_type_int32, CTypeName = "int32_t" ; IntType = int_type_uint32, CTypeName = "uint32_t" ; IntType = int_type_int64, CTypeName = "int64_t" ; IntType = int_type_uint64, CTypeName = "uint64_t" ) ; BuiltinType = builtin_type_float, CTypeName = "MR_Float" ; BuiltinType = builtin_type_string, CTypeName = "MR_String" ; BuiltinType = builtin_type_char, CTypeName = "MR_Char" ). exported_builtin_type_to_csharp_string(BuiltinType) = CsharpTypeName :- ( BuiltinType = builtin_type_int(IntType), ( IntType = int_type_int, CsharpTypeName = "int" ; IntType = int_type_uint, CsharpTypeName = "uint" ; IntType = int_type_int8, CsharpTypeName = "sbyte" ; IntType = int_type_uint8, CsharpTypeName = "byte" ; IntType = int_type_int16, CsharpTypeName = "short" ; IntType = int_type_uint16, CsharpTypeName = "ushort" ; IntType = int_type_int32, CsharpTypeName = "int" ; IntType = int_type_uint32, CsharpTypeName = "uint" ; IntType = int_type_int64, CsharpTypeName = "long" ; IntType = int_type_uint64, CsharpTypeName = "ulong" ) ; BuiltinType = builtin_type_float, CsharpTypeName = "double" ; BuiltinType = builtin_type_string, CsharpTypeName = "string" ; BuiltinType = builtin_type_char, CsharpTypeName = "char" ). exported_builtin_type_to_java_string(BuiltinType) = JavaTypeName :- ( BuiltinType = builtin_type_int(IntType), ( IntType = int_type_int, JavaTypeName = "int" ; IntType = int_type_uint, JavaTypeName = "int" ; IntType= int_type_int8, JavaTypeName = "byte" ; IntType = int_type_uint8, JavaTypeName = "byte" ; IntType = int_type_int16, JavaTypeName = "short" ; IntType = int_type_uint16, JavaTypeName = "short" ; IntType = int_type_int32, JavaTypeName = "int" ; IntType = int_type_uint32, JavaTypeName = "int" ; IntType = int_type_int64, JavaTypeName = "long" ; IntType = int_type_uint64, JavaTypeName = "long" ) ; BuiltinType = builtin_type_float, JavaTypeName = "double" ; BuiltinType = builtin_type_string, JavaTypeName = "java.lang.String" ; BuiltinType = builtin_type_char, JavaTypeName = "char" ). %---------------------------------------------------------------------------% foreign_type_body_to_exported_type(ModuleInfo, ForeignTypeBody, Name, MaybeUserEqComp, Assertions) :- % The body of this function is very similar to the function % foreign_type_to_mlds_type in mlds.m. % Any changes here may require changes there as well. ForeignTypeBody = foreign_type_body(MaybeC, MaybeJava, MaybeCSharp), module_info_get_globals(ModuleInfo, Globals), globals.get_target(Globals, Target), ( Target = target_c, ( MaybeC = yes(Data), Data = type_details_foreign(c_type(NameStr), MaybeUserEqComp, Assertions), Name = unqualified(NameStr) ; MaybeC = no, unexpected($pred, "no C type") ) ; Target = target_csharp, ( MaybeCSharp = yes(Data), Data = type_details_foreign(csharp_type(NameStr), MaybeUserEqComp, Assertions), Name = unqualified(NameStr) ; MaybeCSharp = no, unexpected($pred, "no C# type") ) ; Target = target_java, ( MaybeJava = yes(Data), Data = type_details_foreign(java_type(NameStr), MaybeUserEqComp, Assertions), Name = unqualified(NameStr) ; MaybeJava = no, unexpected($pred, "no Java type") ) ). have_foreign_type_for_backend(Target, ForeignTypeBody, Have) :- ( Target = target_c, Have = ( if ForeignTypeBody ^ c = yes(_) then yes else no ) ; Target = target_java, Have = ( if ForeignTypeBody ^ java = yes(_) then yes else no ) ; Target = target_csharp, Have = ( if ForeignTypeBody ^ csharp = yes(_) then yes else no ) ). foreign_type_body_has_user_defined_eq_comp_pred(ModuleInfo, Body, NonCanonical) :- foreign_type_body_to_exported_type(ModuleInfo, Body, _, MaybeCanonical, _), MaybeCanonical = noncanon(NonCanonical). %---------------------------------------------------------------------------% filter_decls(WantedLang, Decls0, LangDecls, NotLangDecls) :- IsWanted = ( pred(foreign_decl_code(Lang, _, _, _)::in) is semidet :- WantedLang = Lang ), list.filter(IsWanted, Decls0, LangDecls, NotLangDecls). filter_bodys(WantedLang, Bodys0, LangBodys, NotLangBodys) :- IsWanted = ( pred(foreign_body_code(Lang, _, _)::in) is semidet :- WantedLang = Lang ), list.filter(IsWanted, Bodys0, LangBodys, NotLangBodys). filter_exports(WantedLang, Exports0, LangExports, NotLangExports) :- IsWanted = ( pred(pragma_exported_proc(Lang, _, _, _, _)::in) is semidet :- WantedLang = Lang ), list.filter(IsWanted, Exports0, LangExports, NotLangExports). %---------------------------------------------------------------------------% foreign_code_to_identifiers(Lang, Code, Identifiers, CommentStrs) :- string.to_char_list(Code, Chars), % This one arm switch ensures that we will get a warning % if and when we add another target language (which may have % different rules for what is a comment). ( ( Lang = lang_c ; Lang = lang_java ; Lang = lang_csharp ), % We use cords to ensure tail recursion in the loop over Code, % because it may be big. We do not do try to ensure tail recursion % for loops over identifiers, since (for cultural reasons) % they will effectively never be long enough for this to be a problem. foreign_code_to_c_j_cs_identifiers_loop(Chars, cord.init, IdentifierCord, cord.init, CommentStrCord), Identifiers = cord.list(IdentifierCord), CommentStrs = cord.list(CommentStrCord) ). :- pred foreign_code_to_c_j_cs_identifiers_loop(list(char)::in, cord(string)::in, cord(string)::out, cord(string)::in, cord(string)::out) is det. foreign_code_to_c_j_cs_identifiers_loop(Chars0, !IdentifierCord, !CommentStrCord) :- get_next_c_j_cs_identifier(Chars0, IdentifierChars, Chars1, !CommentStrCord), ( IdentifierChars = [] % There are no identifiers left. ; IdentifierChars = [_ | _], string.from_char_list(IdentifierChars, Identifier), cord.snoc(Identifier, !IdentifierCord), foreign_code_to_c_j_cs_identifiers_loop(Chars1, !IdentifierCord, !CommentStrCord) ). :- pred get_next_c_j_cs_identifier(list(char)::in, list(char)::out, list(char)::out, cord(string)::in, cord(string)::out) is det. get_next_c_j_cs_identifier([], [], [], !CommentStrCord). get_next_c_j_cs_identifier([Char0 | Chars0], IdentifierChars, LeftOverChars, !CommentStrCord) :- ( if char.is_alnum_or_underscore(Char0) then get_rest_of_identifier(Chars0, TailIdentifierChars, LeftOverChars), IdentifierChars = [Char0 | TailIdentifierChars] else if Char0 = ('/') then ( Chars0 = [], IdentifierChars = [], LeftOverChars = [] ; Chars0 = [Char1 | Chars1], ( if ( Char1 = ('/'), ignore_rest_of_line(Chars1, Chars2, cord.init, CommentCharCord) ; Char1 = ('*'), ignore_rest_of_slash_star_comment(Chars1, Chars2, cord.init, CommentCharCord) ) then CommentChars = cord.list(CommentCharCord), CommentStr = string.from_char_list(CommentChars), cord.snoc(CommentStr, !CommentStrCord), get_next_c_j_cs_identifier(Chars2, IdentifierChars, LeftOverChars, !CommentStrCord) else % Ignore Char0, since it does not start a comment, and % cannot be part of an identifier. get_next_c_j_cs_identifier(Chars0, IdentifierChars, LeftOverChars, !CommentStrCord) ) ) else % Ignore Char0, since it does not start a comment, and % cannot be part of an identifier. get_next_c_j_cs_identifier(Chars0, IdentifierChars, LeftOverChars, !CommentStrCord) ). :- pred ignore_rest_of_slash_star_comment(list(char)::in, list(char)::out, cord(char)::in, cord(char)::out) is det. ignore_rest_of_slash_star_comment([], [], !CommentCharCord). ignore_rest_of_slash_star_comment([Char0 | Chars0], LeftOverChars, !CommentCharCord) :- ( if Char0 = ('*'), Chars0 = [Char1 | Chars1], Char1 = ('/') then LeftOverChars = Chars1 else cord.snoc(Char0, !CommentCharCord), ignore_rest_of_slash_star_comment(Chars0, LeftOverChars, !CommentCharCord) ). :- pred ignore_rest_of_line(list(char)::in, list(char)::out, cord(char)::in, cord(char)::out) is det. ignore_rest_of_line([], [], !CommentCharCord). ignore_rest_of_line([Char0 | Chars0], LeftOverChars, !CommentCharCord) :- ( if Char0 = ('\n') then LeftOverChars = Chars0 else cord.snoc(Char0, !CommentCharCord), ignore_rest_of_line(Chars0, LeftOverChars, !CommentCharCord) ). %---------------------% comments_to_identifiers(Comments, Identifiers) :- list.foldl(acc_identifiers_in_comment, Comments, cord.init, IdentifierCord), Identifiers = cord.list(IdentifierCord). :- pred acc_identifiers_in_comment(string::in, cord(string)::in, cord(string)::out) is det. acc_identifiers_in_comment(Comment, !IdentifierCord) :- string.to_char_list(Comment, Chars), % We use cords to ensure tail recursion in the loop over Code, % because it may be big. We do not do try to ensure tail recursion % for loops over identifiers, since (for cultural reasons) % they will effectively never be long enough for this to be a problem. comment_to_identifiers_loop(Chars, !IdentifierCord). :- pred comment_to_identifiers_loop(list(char)::in, cord(string)::in, cord(string)::out) is det. comment_to_identifiers_loop(Chars0, !IdentifierCord) :- get_next_identifier(Chars0, IdentifierChars, Chars1), ( IdentifierChars = [] % There are no identifiers left. ; IdentifierChars = [_ | _], string.from_char_list(IdentifierChars, Identifier), cord.snoc(Identifier, !IdentifierCord), comment_to_identifiers_loop(Chars1, !IdentifierCord) ). :- pred get_next_identifier(list(char)::in, list(char)::out, list(char)::out) is det. get_next_identifier([], [], []). get_next_identifier([Char0 | Chars0], IdentifierChars, LeftOverChars) :- ( if char.is_alnum_or_underscore(Char0) then get_rest_of_identifier(Chars0, TailIdentifierChars, LeftOverChars), IdentifierChars = [Char0 | TailIdentifierChars] else % Ignore Char0, since it cannot be part of an identifier. get_next_identifier(Chars0, IdentifierChars, LeftOverChars) ). %---------------------% :- pred get_rest_of_identifier(list(char)::in, list(char)::out, list(char)::out) is det. get_rest_of_identifier([], [], []). get_rest_of_identifier([Char0 | Chars0], IdentifierChars, LeftOverChars) :- ( if char.is_alnum_or_underscore(Char0) then % There may be more characters in the identifier. get_rest_of_identifier(Chars0, TailIdentifierChars, LeftOverChars), IdentifierChars = [Char0 | TailIdentifierChars] else % The word is finished. IdentifierChars = [], LeftOverChars = Chars0 ). %---------------------------------------------------------------------------% decl_guard(ModuleName) = UppercaseModuleName ++ "_DECL_GUARD" :- MangledModuleName = sym_name_mangle(ModuleName), string.to_upper(MangledModuleName, UppercaseModuleName). %---------------------------------------------------------------------------% :- end_module backend_libs.foreign. %---------------------------------------------------------------------------%