[m-rev.] diff: Erlang TypeCtorInfo RTTI implementation
Peter Ross
pro at missioncriticalit.com
Wed May 30 17:32:27 AEST 2007
Hi,
===================================================================
Estimated hours taken: 16
Branches: main
Implement the TypeCtorInfo RTTI so that generic compare
and unify work via rtti_implementation.
However after discussion with zs, this current design of
RTTI has to be adapted to become more erlang specific, due
to the different data representation on the erlang backend.
The current code will serve as a template for this new design
though, which is why it is being checked in.
Add various erlang library implementations which are
needed to run useful programs when testing the erlang backend.
compiler/elds.m:
Add a type_info_id.
compiler/elds_to_erlang.m:
We now generate type_ctor_info's so call them.
compiler/erl_rtti.m:
After discussions with zs, type_info and pseudo_type_infos
should never occur on the erlang backend as they are needed
for gc and the debugger so throw an exception for them.
Add an implementation of creating a static type_info, but which
isn't used in case we need it again later.
Create type_ctor_info with all the fields except the
TypeFunctors, the TypeLayout and the FunctorNumberMap
compiler/special_pred.m:
Make sure we generate RTTI for the builtin types.
library/builtin.m:
library/char.m:
library/exception.m:
library/float.m:
library/int.m:
library/io.m:
library/lexer.m:
library/math.m:
library/mutvar.m:
library/ops.m:
library/par_builtin.m:
library/private_builtin.m:
library/rtti_implementation.m:
library/solutions.m:
library/store.m:
library/string.m:
library/table_builtin.m:
library/thread.semaphore.m:
library/time.m:
library/type_desc.m:
Erlang implementations of std library functions.
Index: compiler/elds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/elds.m,v
retrieving revision 1.5
diff -u -r1.5 elds.m
--- compiler/elds.m 30 May 2007 05:15:03 -0000 1.5
+++ compiler/elds.m 30 May 2007 07:18:46 -0000
@@ -99,12 +99,18 @@
string,
arity
)
+ ; elds_rtti_type_info_id(
+ module_name,
+ string,
+ arity
+ )
; elds_rtti_base_typeclass_id(
tc_name, % identifies the type class
module_name, % module containing instance decl.
string % encodes the names and arities of the
% types in the instance declaration
- ).
+ )
+ .
:- type elds_clause
---> elds_clause(
Index: compiler/elds_to_erlang.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/elds_to_erlang.m,v
retrieving revision 1.5
diff -u -r1.5 elds_to_erlang.m
--- compiler/elds_to_erlang.m 30 May 2007 05:15:03 -0000 1.5
+++ compiler/elds_to_erlang.m 30 May 2007 07:18:46 -0000
@@ -352,16 +352,8 @@
io.write_string(")", !IO)
;
Expr = elds_rtti_ref(RttiId),
- (
- RttiId = elds_rtti_type_ctor_id(_, _, _),
- % XXX we don't yet generate functions for type ctors so don't
- % make calls to them
- output_atom(string(RttiId), !IO)
- ;
- RttiId = elds_rtti_base_typeclass_id(_, _, _),
- output_rtti_id(ModuleInfo, RttiId, !IO),
- io.write_string("()", !IO)
- )
+ output_rtti_id(ModuleInfo, RttiId, !IO),
+ io.write_string("()", !IO)
;
Expr = elds_foreign_code(Code),
nl(!IO),
@@ -517,14 +509,20 @@
output_rtti_id(ModuleInfo, RttiId, !IO) :-
module_info_get_name(ModuleInfo, CurModuleName),
(
- RttiId = elds_rtti_type_ctor_id(ModuleName, String, Arity),
+ (
+ RttiId = elds_rtti_type_ctor_id(ModuleName, TypeName, Arity),
+ Prefix = "TypeCtorInfo_"
+ ;
+ RttiId = elds_rtti_type_info_id(ModuleName, TypeName, Arity),
+ Prefix = "TypeInfo_"
+ ),
% The only things with an empty module name should be the builtins.
( ModuleName = unqualified("") ->
InstanceModule = mercury_public_builtin_module
;
InstanceModule = ModuleName
),
- Atom = "TypeCtorInfo_" ++ String ++ "_" ++ string.from_int(Arity)
+ Atom = Prefix ++ TypeName ++ "_" ++ string.from_int(Arity)
;
RttiId = elds_rtti_base_typeclass_id(TCName, InstanceModule,
InstanceStr),
Index: compiler/erl_rtti.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/erl_rtti.m,v
retrieving revision 1.1
diff -u -r1.1 erl_rtti.m
--- compiler/erl_rtti.m 28 May 2007 03:13:51 -0000 1.1
+++ compiler/erl_rtti.m 30 May 2007 07:18:46 -0000
@@ -41,12 +41,14 @@
:- import_module hlds.hlds_pred.
:- import_module hlds.hlds_rtti.
:- import_module libs.compiler_util.
+:- import_module mdbcomp.prim_data.
:- import_module parse_tree.prog_data.
:- import_module bool.
:- import_module int.
:- import_module maybe.
:- import_module svvarset.
+:- import_module univ.
:- import_module varset.
%-----------------------------------------------------------------------------%
@@ -83,15 +85,19 @@
elds_clause([], elds_term(BaseTypeClassInfoData))).
rtti_data_to_elds(_ModuleInfo, RttiData, []) :-
- RttiData = rtti_data_type_info(_TypeInfo).
+ RttiData = rtti_data_type_info(_TypeInfo),
+ unexpected(this_file, "rtti_data_to_elds: rtti_data_type_info").
rtti_data_to_elds(_ModuleInfo, RttiData, []) :-
- RttiData = rtti_data_pseudo_type_info(_PseudoTypeInfo).
+ RttiData = rtti_data_pseudo_type_info(_PseudoTypeInfo),
+ unexpected(this_file, "rtti_data_to_elds: rtti_data_pseudo_type_info").
rtti_data_to_elds(_ModuleInfo, RttiData, []) :-
RttiData = rtti_data_type_class_decl(_TCDecl).
rtti_data_to_elds(_ModuleInfo, RttiData, []) :-
- RttiData = rtti_data_type_class_instance(_Instance).
-rtti_data_to_elds(_ModuleInfo, RttiData, []) :-
- RttiData = rtti_data_type_ctor_info(_TypeCtorData).
+ RttiData = rtti_data_type_class_instance(_Instance),
+ unexpected(this_file, "rtti_data_to_elds: rtti_data_type_class_instance").
+rtti_data_to_elds(ModuleInfo, RttiData, RttiDefns) :-
+ RttiData = rtti_data_type_ctor_info(TypeCtorData),
+ type_ctor_data_to_elds(ModuleInfo, TypeCtorData, RttiDefns).
%-----------------------------------------------------------------------------%
@@ -193,6 +199,140 @@
% Erlang's `element' builtin counts from 1.
ExtractStatement = elds_eq(expr_from_var(Var),
elds_call_element(TCIVar, 1 + Index)).
+
+%-----------------------------------------------------------------------------%
+
+ % XXX This code is dead, but I've left it in until I am sure
+ % that we don't need it.
+:- pred rtti_type_info_to_elds(module_info::in, rtti_type_info::in,
+ list(elds_rtti_defn)::out) is det.
+
+rtti_type_info_to_elds(_ModuleInfo, TypeInfo, RttiDefns) :-
+ TypeInfo = plain_arity_zero_type_info(RttiTypeCtor),
+ RttiTypeCtor = rtti_type_ctor(ModuleName, TypeName, Arity),
+ TypeCtorRttiId = elds_rtti_type_ctor_id(ModuleName, TypeName, Arity),
+
+ ELDSTypeInfo = elds_tuple([elds_rtti_ref(TypeCtorRttiId)]),
+
+
+ RttiId = elds_rtti_type_info_id(ModuleName, TypeName, Arity),
+ IsExported = yes,
+ RttiDefn = elds_rtti_defn(RttiId, IsExported, varset.init,
+ elds_clause([], elds_term(ELDSTypeInfo))),
+
+ RttiDefns = [RttiDefn].
+rtti_type_info_to_elds(_ModuleInfo, TypeInfo, RttiDefns) :-
+ TypeInfo = plain_type_info(_, _),
+ RttiDefns = [].
+rtti_type_info_to_elds(_ModuleInfo, TypeInfo, RttiDefns) :-
+ TypeInfo = var_arity_type_info(_, _),
+ RttiDefns = [].
+
+%-----------------------------------------------------------------------------%
+
+ % See MR_TypeCtorInfo_Struct in runtime/mercury_type_info.h
+ %
+:- pred type_ctor_data_to_elds(module_info::in, type_ctor_data::in,
+ list(elds_rtti_defn)::out) is det.
+
+type_ctor_data_to_elds(ModuleInfo, TypeCtorData, RttiDefns) :-
+ TypeCtorData = type_ctor_data(Version, ModuleName, TypeName, Arity,
+ UnifyUniv, CompareUniv, Flags, Details),
+ NumPtags = type_ctor_details_num_ptags(Details),
+ type_ctor_rep_to_string(TypeCtorData, TypeCtorRep),
+ NumFunctors = type_ctor_details_num_functors(Details),
+
+ some [!VarSet] (
+ varset.init(!:VarSet),
+ gen_init_special_pred(ModuleInfo, UnifyUniv, UnifyExpr, !VarSet),
+ gen_init_special_pred(ModuleInfo, CompareUniv, CompareExpr, !VarSet),
+ VarSet = !.VarSet
+ ),
+
+ ELDSTypeCtorData = elds_tuple([
+ elds_term(elds_int(Arity)),
+ elds_term(elds_int(Version)),
+ elds_term(elds_int(NumPtags)),
+ elds_term(elds_atom_raw(TypeCtorRep)),
+ UnifyExpr,
+ CompareExpr,
+ elds_term(elds_string(sym_name_to_string(ModuleName))),
+ elds_term(elds_string(TypeName)),
+ elds_term(elds_atom_raw("XXX TypeFunctors")),
+ elds_term(elds_atom_raw("XXX TypeLayout")),
+ elds_term(elds_int(NumFunctors)),
+ elds_term(elds_int(encode_type_ctor_flags(Flags))),
+ elds_term(elds_atom_raw("XXX FunctorNumberMap"))
+ ]),
+ RttiId = elds_rtti_type_ctor_id(ModuleName, TypeName, Arity),
+ IsExported = yes,
+ RttiDefn = elds_rtti_defn(RttiId, IsExported, VarSet,
+ elds_clause([], elds_term(ELDSTypeCtorData))),
+ RttiDefns = [RttiDefn].
+
+:- pred gen_init_special_pred(module_info::in,
+ univ::in, elds_expr::out, prog_varset::in, prog_varset::out) is det.
+
+gen_init_special_pred(ModuleInfo, RttiProcIdUniv, Expr, !VarSet) :-
+ ( univ_to_type(RttiProcIdUniv, RttiProcId) ->
+ erl_gen_special_pred_wrapper(ModuleInfo, RttiProcId, Expr, !VarSet)
+ ;
+ unexpected(this_file,
+ "gen_init_special_pred: cannot extract univ value")
+ ).
+
+:- pred erl_gen_special_pred_wrapper(module_info::in, rtti_proc_label::in,
+ elds_expr::out, prog_varset::in, prog_varset::out) is det.
+
+erl_gen_special_pred_wrapper(ModuleInfo, RttiProcId, WrapperFun, !VarSet) :-
+ PredId = RttiProcId ^ pred_id,
+ ProcId = RttiProcId ^ proc_id,
+ ArgTypes = RttiProcId ^ proc_arg_types,
+ ArgModes = RttiProcId ^ proc_arg_modes,
+ Detism = RttiProcId ^ proc_interface_detism,
+
+ % Create the variable list.
+ svvarset.new_vars(list.length(ArgTypes), Ws, !VarSet),
+
+ % Figure out the input and output variables for the call to the actual
+ % special pred implementation.
+ erl_gen_arg_list_arg_modes(ModuleInfo, opt_dummy_args,
+ Ws, ArgTypes, ArgModes, CallInputArgs, CallOutputArgs),
+
+ % Figure out the input variables and output variables for this wrapper
+ % function.
+ erl_gen_arg_list_arg_modes(ModuleInfo, no_opt_dummy_args,
+ Ws, ArgTypes, ArgModes,
+ WrapperInputVars, WrapperOutputVars),
+
+ determinism_to_code_model(Detism, CodeModel),
+ WrapperOutputVarsExprs = exprs_from_vars(WrapperOutputVars),
+ (
+ ( CodeModel = model_det
+ ; CodeModel = model_semi
+ ),
+ % On success we return a tuple of the output arguments of the call.
+ SuccessExpr0 = elds_term(elds_tuple(WrapperOutputVarsExprs))
+ ;
+ CodeModel = model_non,
+ unexpected(this_file,
+ "erl_gen_special_pred_wrapper: model_non code_model")
+ ),
+
+ % Any variables which are outputs of the wrapper function but not of the
+ % method need to be materialised by the wrapper.
+ DummyOutputVars = list.delete_elems(WrapperOutputVars, CallOutputArgs),
+ MaterialiseDummyOutputVars = list.map(var_eq_false, DummyOutputVars),
+ SuccessExpr = join_exprs(elds_block(MaterialiseDummyOutputVars),
+ SuccessExpr0),
+
+ % Make the call to the underlying method implementation.
+ CallTarget = elds_call_plain(proc(PredId, ProcId)),
+ erl_make_call(CodeModel, CallTarget, CallInputArgs,
+ CallOutputArgs, yes(SuccessExpr), DoCall),
+
+ WrapperFun = elds_fun(elds_clause(terms_from_vars(WrapperInputVars),
+ DoCall)).
%-----------------------------------------------------------------------------%
Index: compiler/special_pred.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/special_pred.m,v
retrieving revision 1.68
diff -u -r1.68 special_pred.m
--- compiler/special_pred.m 1 Dec 2006 15:04:20 -0000 1.68
+++ compiler/special_pred.m 30 May 2007 07:18:46 -0000
@@ -300,7 +300,7 @@
compiler_generated_rtti_for_builtins(ModuleInfo) :-
module_info_get_globals(ModuleInfo, Globals),
globals.get_target(Globals, Target),
- ( Target = target_il ; Target = target_java ).
+ ( Target = target_il ; Target = target_java ; Target = target_erlang ).
%-----------------------------------------------------------------------------%
Index: library/builtin.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/builtin.m,v
retrieving revision 1.127
diff -u -r1.127 builtin.m
--- library/builtin.m 10 May 2007 04:15:34 -0000 1.127
+++ library/builtin.m 30 May 2007 07:18:47 -0000
@@ -505,6 +505,18 @@
"
Y = X;
").
+:- pragma foreign_proc("Erlang",
+ cc_cast(X :: (pred(out) is cc_multi)) = (Y :: out(pred(out) is det)),
+ [will_not_call_mercury, thread_safe],
+"
+ Y = X
+").
+:- pragma foreign_proc("Erlang",
+ cc_cast(X :: (pred(out) is cc_nondet)) = (Y :: out(pred(out) is semidet)),
+ [will_not_call_mercury, thread_safe],
+"
+ Y = X
+").
:- pragma promise_pure(promise_only_solution_io/4).
promise_only_solution_io(Pred, X, !IO) :-
@@ -540,6 +552,13 @@
"
Y = X;
").
+:- pragma foreign_proc("Erlang",
+ cc_cast_io(X :: (pred(out, di, uo) is cc_multi)) =
+ (Y :: out(pred(out, di, uo) is det)),
+ [will_not_call_mercury, thread_safe],
+"
+ Y = X
+").
%-----------------------------------------------------------------------------%
%
@@ -783,6 +802,55 @@
}
").
+:- pragma foreign_code("Erlang", "
+
+ '__Compare____c_pointer_0'(_, _) ->
+ throw(""called compare/3 for type `c_pointer'"").
+
+ '__Unify____c_pointer_0'(_, _) ->
+ throw(""called unify for type `c_pointer'"").
+
+ % XXX TypeInfo ignored
+ compare_3_p_0(TypeInfo, X, Y) ->
+ mercury__rtti_implementation:generic_compare_3_p_0(TypeInfo, X, Y).
+
+ compare_3_p_1(TypeInfo, X, Y) ->
+ compare_3_p_0(TypeInfo, X, Y).
+
+ compare_3_p_2(TypeInfo, X, Y) ->
+ compare_3_p_0(TypeInfo, X, Y).
+
+ compare_3_p_3(TypeInfo, X, Y) ->
+ compare_3_p_0(TypeInfo, X, Y).
+
+ % XXX what is this supposed to do?
+ compare_representation_3_p_0(TypeInfo, X, Y) ->
+ compare_3_p_0(TypeInfo, X, Y).
+
+ unify_2_p_0(TypeInfo, X, Y) ->
+ mercury__rtti_implementation:generic_unify_2_p_0(TypeInfo, X, Y).
+
+ '__Unify____tuple_0'(X, Y) ->
+ mercury__require:error_1_p_0(""call to unify for tuple/0"").
+
+ '__Compare____tuple_0'(X, Y) ->
+ mercury__require:error_1_p_0(""call to compare for tuple/0"").
+
+ '__Unify____void_0'(X, Y) ->
+ mercury__require:error_1_p_0(""call to unify for void/0"").
+
+ '__Compare____void_0'(X, Y) ->
+ mercury__require:error_1_p_0(""call to compare for void/0"").
+
+ '__Unify____func_0'(X, Y) ->
+ mercury__require:error_1_p_0(""call to unify for func/0"").
+
+ '__Compare____func_0'(X, Y) ->
+ mercury__require:error_1_p_0(""call to compare for func/0"").
+
+").
+
+
%-----------------------------------------------------------------------------%
% unsafe_promise_unique is a compiler builtin.
@@ -837,6 +905,20 @@
Y = deep_copy(X);
").
+:- pragma foreign_proc("Erlang",
+ copy(X::ui, Y::uo),
+ [may_call_mercury, thread_safe, promise_pure, terminates],
+"
+ Y = X
+").
+
+:- pragma foreign_proc("Erlang",
+ copy(X::in, Y::uo),
+ [may_call_mercury, thread_safe, promise_pure, terminates],
+"
+ Y = X
+").
+
%-----------------------------------------------------------------------------%
%
@@ -1044,6 +1126,19 @@
SUCCESS_INDICATOR = false;
").
+:- pragma foreign_proc("Erlang",
+ semidet_succeed,
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
+ SUCCESS_INDICATOR = true
+").
+:- pragma foreign_proc("Erlang",
+ semidet_fail,
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
+ SUCCESS_INDICATOR = false
+").
+
% We can't just use "true" and "fail" here, because that provokes warnings
% from determinism analysis, and the library is compiled with --halt-at-warn.
% So instead we use 0+0 = (or \=) 0.
@@ -1108,6 +1203,19 @@
Y = X;
").
+:- pragma foreign_proc("Erlang",
+ cc_multi_equal(X::in, Y::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
+ Y = X
+").
+:- pragma foreign_proc("Erlang",
+ cc_multi_equal(X::di, Y::uo),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
+ Y = X
+").
+
:- pragma promise_pure(cc_multi_equal/2).
cc_multi_equal(X, X).
@@ -1141,6 +1249,13 @@
[promise_pure, will_not_call_mercury, thread_safe, will_not_modify_trail],
"
Y = X;
+").
+
+:- pragma foreign_proc("Erlang",
+ unsafe_cast_any_to_ground(X::ia) = (Y::out),
+ [promise_pure, will_not_call_mercury, thread_safe, will_not_modify_trail],
+"
+ Y = X
").
%-----------------------------------------------------------------------------%
Index: library/char.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/char.m,v
retrieving revision 1.57
diff -u -r1.57 char.m
--- library/char.m 18 Mar 2007 23:34:59 -0000 1.57
+++ library/char.m 30 May 2007 07:18:47 -0000
@@ -557,6 +557,36 @@
succeeded = ((int) Character == Int);
").
+:- pragma foreign_proc("Erlang",
+ char.to_int(Character::in, Int::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Int = Character
+").
+
+:- pragma foreign_proc("Erlang",
+ char.to_int(Character::in, Int::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ SUCCESS_INDICATOR = (Character =:= Int)
+").
+
+:- pragma foreign_proc("Erlang",
+ char.to_int(Character::out, Int::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ case
+ Int >= 0 andalso Int < 256
+ of
+ true ->
+ SUCCESS_INDICATOR = true,
+ Character = Int;
+ false ->
+ SUCCESS_INDICATOR = false,
+ Character = -1
+ end
+").
+
% We used unsigned character codes, so the minimum character code
% is always zero.
char.min_char_value(0).
@@ -586,6 +616,13 @@
[will_not_call_mercury, promise_pure, thread_safe],
"
Max = (int) java.lang.Character.MAX_VALUE;
+").
+:- pragma foreign_proc("Erlang",
+ char.max_char_value(Max::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ % XXX actually Erlang doesn't have chars so there should be no maximum
+ Max = 255
").
%-----------------------------------------------------------------------------%
Index: library/exception.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/exception.m,v
retrieving revision 1.124
diff -u -r1.124 exception.m
--- library/exception.m 21 Mar 2007 18:28:15 -0000 1.124
+++ library/exception.m 30 May 2007 07:18:47 -0000
@@ -418,6 +418,10 @@
use(_T::in),
[will_not_call_mercury, thread_safe],
";").
+:- pragma foreign_proc("Erlang",
+ use(_T::in),
+ [will_not_call_mercury, thread_safe],
+ "void").
%-----------------------------------------------------------------------------%
@@ -645,6 +649,8 @@
[will_not_call_mercury, thread_safe], "").
:- pragma foreign_proc("Java", make_io_state(_IO::uo),
[will_not_call_mercury, thread_safe], "").
+:- pragma foreign_proc("Erlang", make_io_state(_IO::uo),
+ [will_not_call_mercury, thread_safe], "void").
:- impure pred consume_io_state(io::di) is det.
:- pragma foreign_proc("C",
@@ -656,6 +662,9 @@
:- pragma foreign_proc("Java",
consume_io_state(_IO::di),
[will_not_call_mercury, thread_safe], "").
+:- pragma foreign_proc("Erlang",
+ consume_io_state(_IO::di),
+ [will_not_call_mercury, thread_safe], "void").
:- pred wrap_exception(univ::in, exception_result(T)::out) is det.
@@ -1380,6 +1389,80 @@
")
).
*/
+
+:- pragma foreign_proc("Erlang",
+ throw_impl(T::in),
+ [will_not_call_mercury, promise_pure],
+"
+ throw({'ML_exception', T})
+").
+
+:- pragma foreign_proc("Erlang",
+ catch_impl(Pred::pred(out) is det, Handler::in(handler), T::out),
+ [will_not_call_mercury, promise_pure],
+"
+ T = try
+ Pred()
+ catch
+ throw: {'ML_exception', Excp} ->
+ Handler(Excp)
+ end
+").
+
+:- pragma foreign_proc("Erlang",
+ catch_impl(Pred::pred(out) is semidet, Handler::in(handler), T::out),
+ [will_not_call_mercury, promise_pure],
+"
+ case
+ try
+ Pred()
+ catch
+ throw: {'ML_exception', Excp} ->
+ Handler(Excp)
+ end
+ of
+ {T} ->
+ SUCCESS_INDICATOR = true;
+ _ ->
+ SUCCESS_INDICATOR = false,
+ T = null
+ end
+").
+
+:- pragma foreign_code("Erlang", "
+
+ % XXX not sure about any of this
+
+ builtin_catch_3_p_2(TypeInfo, WrappedGoal, Handler) ->
+ try
+ WrappedGoal()
+ catch
+ throw: {'ML_exception', Excp} ->
+ Handler(Excp)
+ end.
+
+ builtin_catch_3_p_4(_TypeInfo_for_T, Pred, Handler, Succeed) ->
+ try
+ Pred()
+ of
+ T ->
+ Succeed(T)
+ catch
+ throw: {'ML_exception', Excp} ->
+ Handler(Excp, Succeed)
+ end.
+
+ builtin_catch_3_p_5(_TypeInfo_for_T, Pred, Handler, Succeed) ->
+ try
+ Pred()
+ of
+ T ->
+ Succeed(T)
+ catch
+ throw: {'ML_exception', Excp} ->
+ Handler(Excp, Succeed)
+ end.
+").
:- pred call_goal(pred(T), T).
:- mode call_goal(pred(out) is det, out) is det.
Index: library/float.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/float.m,v
retrieving revision 1.72
diff -u -r1.72 float.m
--- library/float.m 6 Mar 2007 13:17:13 -0000 1.72
+++ library/float.m 30 May 2007 07:18:47 -0000
@@ -289,6 +289,13 @@
succeeded = true;
").
+:- pragma foreign_proc("Erlang",
+ float_domain_checks,
+ [thread_safe, promise_pure],
+"
+ SUCCESS_INDICATOR = true
+").
+
%---------------------------------------------------------------------------%
%
% Conversion functions
@@ -319,6 +326,13 @@
FloatVal = (double) IntVal;
").
+:- pragma foreign_proc("Erlang",
+ float(IntVal::in) = (FloatVal::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ FloatVal = IntVal
+").
+
:- pragma foreign_proc("C",
float.ceiling_to_int(X :: in) = (Ceil :: out),
[will_not_call_mercury, promise_pure, thread_safe,
@@ -345,6 +359,18 @@
Ceil = (int) java.lang.Math.ceil(X);
}
").
+:- pragma foreign_proc("Erlang",
+ float.ceiling_to_int(X :: in) = (Ceil :: out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ T = erlang:trunc(X),
+ case (X - T) > 0 of
+ true ->
+ Ceil = T + 1;
+ false ->
+ Ceil = T
+ end
+").
:- pragma foreign_proc("C",
float.floor_to_int(X :: in) = (Floor :: out),
@@ -372,6 +398,18 @@
Floor = (int) java.lang.Math.floor(X);
}
").
+:- pragma foreign_proc("Erlang",
+ float.floor_to_int(X :: in) = (Floor :: out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ T = erlang:trunc(X),
+ case (X - T) < 0 of
+ true ->
+ Floor = T - 1;
+ false ->
+ Floor = T
+ end
+").
:- pragma foreign_proc("C",
float.round_to_int(X :: in) = (Round :: out),
@@ -399,6 +437,14 @@
Round = (int) java.lang.Math.round(X);
}
").
+:- pragma foreign_proc("Erlang",
+ float.round_to_int(X :: in) = (Round :: out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ % XXX erlang:round returns the closest integer to x, rounding to even when
+ % x is halfway between two integers.
+ Round = erlang:round(X)
+").
:- pragma foreign_proc("C",
float.truncate_to_int(X :: in) = (Trunc :: out),
@@ -426,6 +472,12 @@
Trunc = (int) X;
}
").
+:- pragma foreign_proc("Erlang",
+ float.truncate_to_int(X :: in) = (Trunc :: out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Trunc = erlang:trunc(X)
+").
%---------------------------------------------------------------------------%
%
@@ -537,6 +589,12 @@
H = Code;
}
").
+:- pragma foreign_proc("Erlang",
+ float.hash(F::in) = (H::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ H = erlang:phash2(F)
+").
%---------------------------------------------------------------------------%
@@ -566,6 +624,14 @@
"
succeeded = java.lang.Double.isNaN(Flt);
").
+:- pragma foreign_proc("Erlang",
+ is_nan(_Flt::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ % XXX NYI
+ SUCCESS_INDICATOR = false
+").
+
:- pragma foreign_proc("C",
is_inf(Flt::in),
@@ -588,6 +654,13 @@
"
succeeded = java.lang.Double.isInfinite(Flt);
").
+:- pragma foreign_proc("Erlang",
+ is_inf(_Flt::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ % XXX NYI
+ SUCCESS_INDICATOR = false
+").
%---------------------------------------------------------------------------%
%
@@ -645,6 +718,13 @@
[will_not_call_mercury, promise_pure, thread_safe],
"
Max = java.lang.Double.MAX_VALUE;
+").
+:- pragma foreign_proc("Erlang",
+ float.max = (Max::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ % XXX NYI
+ Max = 100000000.0
").
:- pragma foreign_proc("C",
Index: library/int.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/int.m,v
retrieving revision 1.119
diff -u -r1.119 int.m
--- library/int.m 15 Jan 2007 02:23:59 -0000 1.119
+++ library/int.m 30 May 2007 07:18:47 -0000
@@ -459,6 +459,12 @@
"
succeeded = true;
").
+:- pragma foreign_proc("Erlang",
+ int_domain_checks,
+ [thread_safe, promise_pure],
+"
+ SUCCESS_INDICATOR = true
+").
:- pragma inline(floor_to_multiple_of_bits_per_int/1).
@@ -713,6 +719,30 @@
"
// Java ints are 32 bits.
Bits = 32;
+").
+
+:- pragma foreign_proc("Erlang",
+ int.max_int(Max::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ % XXX Erlang ints are actually arbitrary precision.
+ Max = (1 bsl 31) - 1
+").
+
+:- pragma foreign_proc("Erlang",
+ int.min_int(Min::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ % XXX Erlang ints are actually arbitrary precision.
+ Min = -(1 bsl 31)
+").
+
+:- pragma foreign_proc("Erlang",
+ int.bits_per_int(Bits::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ % XXX Erlang ints are actually arbitrary precision.
+ Bits = 32
").
int.quot_bits_per_int(Int::in) = (Result::out) :-
Index: library/io.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/io.m,v
retrieving revision 1.384
diff -u -r1.384 io.m
--- library/io.m 30 May 2007 05:15:07 -0000 1.384
+++ library/io.m 30 May 2007 07:18:47 -0000
@@ -1805,6 +1805,7 @@
:- pragma foreign_type("il", io.stream,
"class [mercury]mercury.io__csharp_code.MR_MercuryFileStruct").
:- pragma foreign_type("Java", io.stream, "mercury.io.MR_MercuryFileStruct").
+:- pragma foreign_type("Erlang", io.stream, "").
% A unique identifier for an I/O stream.
%
@@ -4688,6 +4689,29 @@
ML_io_stream_db = StreamDb;
").
+% XXX the following Erlang implementation doesn't work with multiple threads
+
+:- pragma foreign_proc("Erlang",
+ io.get_stream_db_with_locking(StreamDb::out),
+ [will_not_call_mercury, tabled_for_io],
+"
+ StreamDb = get('ML_io_stream_db')
+").
+
+:- pragma foreign_proc("Erlang",
+ io.get_stream_db(StreamDb::out, _IO0::di, _IO::uo),
+ [will_not_call_mercury, promise_pure, tabled_for_io],
+"
+ StreamDb = get('ML_io_stream_db')
+").
+
+:- pragma foreign_proc("Erlang",
+ io.set_stream_db(StreamDb::in, _IO0::di, _IO::uo),
+ [will_not_call_mercury, promise_pure, tabled_for_io],
+"
+ put('ML_io_stream_db', StreamDb)
+").
+
%-----------------------------------------------------------------------------%
:- pred io.insert_stream_info(io.stream::in, stream_info::in,
@@ -4879,6 +4903,22 @@
ML_io_user_globals = Globals;
").
+% XXX the following Erlang implementation doesn't work with multiple threads
+
+:- pragma foreign_proc("Erlang",
+ io.unsafe_get_globals(Globals::out, _IOState0::di, _IOState::uo),
+ [will_not_call_mercury, promise_pure, tabled_for_io],
+"
+ Globals = get('ML_io_user_globals')
+").
+
+:- pragma foreign_proc("Erlang",
+ io.unsafe_set_globals(Globals::in, _IOState0::di, _IOState::uo),
+ [will_not_call_mercury, promise_pure, tabled_for_io],
+"
+ put('ML_io_user_globals', Globals)
+").
+
%-----------------------------------------------------------------------------%
io.progname_base(DefaultName, PrognameBase, !IO) :-
@@ -4918,6 +4958,13 @@
Id = Stream.id;
").
+:- pragma foreign_proc("Erlang",
+ io.get_stream_id(Stream::in) = (Id::out),
+ [will_not_call_mercury, promise_pure],
+"
+ {'ML_stream', Id, _} = Stream
+").
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -6697,6 +6744,17 @@
File.ungetc(Byte);
").
+/*
+:- pragma foreign_proc("Erlang",
+ io.read_char_code_2(Stream::in, CharCode::out, _IO0::di, _IO::uo),
+ [will_not_call_mercury, promise_pure, tabled_for_io,
+ does_not_affect_liveness],
+"
+ % XXX this seems pretty horrible
+ [CharCode] = io:get_chars('', 1)
+").
+*/
+
%-----------------------------------------------------------------------------%
%
% Output predicates (with output to mercury_current_text_output)
@@ -6933,6 +6991,36 @@
mercury_current_binary_output.flush();
").
+:- pragma foreign_proc("Erlang",
+ io.write_string(Message::in, _IO0::di, _IO::uo),
+ [may_call_mercury, promise_pure, thread_safe, tabled_for_io, terminates],
+"
+ % XXX current stream
+ io:put_chars(Message)
+").
+:- pragma foreign_proc("Erlang",
+ io.write_char(Character::in, _IO0::di, _IO::uo),
+ [may_call_mercury, promise_pure, thread_safe, tabled_for_io, terminates],
+"
+ % XXX current stream
+ io:put_chars([Character])
+").
+:- pragma foreign_proc("Erlang",
+ io.write_int(Val::in, _IO0::di, _IO::uo),
+ [may_call_mercury, promise_pure, thread_safe, tabled_for_io, terminates],
+"
+ % XXX current stream
+ io:format(""~B"", [Val])
+").
+:- pragma foreign_proc("Java",
+ io.write_float(Val::in, _IO0::di, _IO::uo),
+ [may_call_mercury, promise_pure, thread_safe, tabled_for_io, terminates],
+"
+ % XXX current stream
+ % XXX precision
+ io:format(""~f"", [Val])
+").
+
io.write_float(Float, !IO) :-
io.write_string(string.float_to_string(Float), !IO).
@@ -7331,6 +7419,22 @@
Stream.flush();
").
+:- pragma foreign_proc("Erlang",
+ io.write_char_2(Stream::in, Character::in, _IO0::di, _IO::uo),
+ [may_call_mercury, promise_pure, thread_safe, tabled_for_io, terminates],
+"
+ {'ML_stream', _Id, IoDevice} = Stream,
+ io:put_chars(IoDevice, [Character])
+").
+
+:- pragma foreign_proc("Erlang",
+ io.write_string_2(Stream::in, Message::in, _IO0::di, _IO::uo),
+ [may_call_mercury, promise_pure, thread_safe, tabled_for_io, terminates],
+"
+ {'ML_stream', _Id, IoDevice} = Stream,
+ io:put_chars(IoDevice, Message)
+").
+
io.write_float_2(Stream, Float, !IO) :-
io.write_string_2(Stream, string.float_to_string(Float), !IO).
@@ -7459,6 +7563,15 @@
MR_update_io(IO0, IO);
").
+:- pragma foreign_proc("Erlang",
+ io.input_stream_2(Stream::out, _IO0::di, _IO::uo),
+ [will_not_call_mercury, promise_pure, tabled_for_io,
+ does_not_affect_liveness],
+"
+ % XXX
+ Stream = {'ML_stream', 'ML_standard_input_id', standard_io}
+").
+
io.output_stream(output_stream(Stream), !IO) :-
io.output_stream_2(Stream, !IO).
@@ -7472,6 +7585,15 @@
MR_update_io(IO0, IO);
").
+:- pragma foreign_proc("Erlang",
+ io.output_stream_2(Stream::out, _IO0::di, _IO::uo),
+ [will_not_call_mercury, promise_pure, tabled_for_io,
+ does_not_affect_liveness],
+"
+ % XXX
+ Stream = {'ML_stream', 'ML_standard_output_id', standard_io}
+").
+
io.binary_input_stream(binary_input_stream(Stream), !IO) :-
io.binary_input_stream_2(Stream, !IO).
@@ -8103,6 +8225,66 @@
}
").
+:- pragma foreign_proc("Erlang",
+ io.do_open_text(FileName::in, Mode::in, ResultCode::out,
+ StreamId::out, Stream::out, _IO0::di, _IO::uo),
+ [will_not_call_mercury, promise_pure, tabled_for_io, thread_safe],
+"
+ case Mode of
+ [$r | _] ->
+ ModeList = [read];
+ [$w | _] ->
+ ModeList = [write];
+ [$a | _] ->
+ ModeList = [append]
+ end,
+ case file:open(FileName, ModeList) of
+ {ok, IoDevice} ->
+ StreamId = make_ref(),
+ Stream = {'ML_stream', StreamId, IoDevice},
+ ResultCode = 0;
+ {error, _Reason} ->
+ % XXX MR_io_exception = e
+ StreamId = -1,
+ Stream = null,
+ ResultCode = -1
+ end
+").
+
+:- pragma foreign_proc("Erlang",
+ io.do_open_binary(FileName::in, Mode::in, ResultCode::out,
+ StreamId::out, Stream::out, _IO0::di, _IO::uo),
+ [will_not_call_mercury, promise_pure, tabled_for_io, thread_safe],
+"
+ %
+ % XX in older versions, only the functions `read/2' and `write/2' may be
+ % used on binary streams. None of the functions from the Erlang `io'
+ % module can be used.
+ %
+ % XXX the documentation in `file' suggests that `raw' is required as well,
+ % but that has some limitations and maybe the documentation is out of date
+ %
+ case Mode of
+ [$r | _] ->
+ ModeList = [read, binary];
+ [$w | _] ->
+ ModeList = [write, binary];
+ [$a | _] ->
+ ModeList = [append, binary]
+ end,
+ case file:open(FileName, ModeList) of
+ {ok, IoDevice} ->
+ StreamId = make_ref(),
+ Stream = {'ML_stream', StreamId, IoDevice},
+ ResultCode = 0;
+ {error, _Reason} ->
+ % XXX MR_io_exception = e
+ StreamId = -1,
+ Stream = null,
+ ResultCode = -1
+ end
+").
+
io.close_input(input_stream(Stream), !IO) :-
io.maybe_delete_stream_info(Stream, !IO),
io.close_stream(Stream, !IO).
@@ -8144,6 +8326,15 @@
Stream.close();
").
+:- pragma foreign_proc("Erlang",
+ io.close_stream(Stream::in, _IO0::di, _IO::uo),
+ [may_call_mercury, promise_pure, tabled_for_io, thread_safe, terminates],
+"
+ {'ML_stream', _Id, IoDevice} = Stream,
+ file:close(IoDevice)
+ % XXX delete ref?
+").
+
% Miscellaneous predicates.
:- pragma foreign_proc("C",
@@ -8218,6 +8409,26 @@
MR_update_io(IO0, IO);
").
+:- pragma foreign_proc("Erlang",
+ io.call_system_code(Command::in, Status::out, Msg::out,
+ _IO0::di, _IO::uo),
+ [will_not_call_mercury, promise_pure, tabled_for_io, thread_safe,
+ does_not_affect_liveness],
+"
+ % XXX this is shit
+ OutputCode = os:cmd(Command ++ ""; echo -n $?""),
+ NL = string:rchr(OutputCode, $\\n),
+ {Output, [$\\n, Code]} = lists:split(NL - 1, OutputCode),
+ io:put_chars(Output),
+ {Status, []} = string:to_integer(Code),
+ case Status =:= 0 of
+ true ->
+ Msg = """";
+ false ->
+ Msg = ""error invoking system command""
+ end
+").
+
io.progname(DefaultProgName::in, ProgName::out, IO::di, IO::uo) :-
% This is a fall-back for back-ends which don't support the C interface.
ProgName = DefaultProgName.
@@ -8357,6 +8568,13 @@
mercury.runtime.JavaInternal.exit_status = ExitStatus;
").
+:- pragma foreign_proc("Erlang",
+ io.command_line_arguments(Args::out, _IO0::di, _IO::uo),
+ [will_not_call_mercury, promise_pure, tabled_for_io, thread_safe],
+"
+ Args = init:get_plain_arguments()
+").
+
io.command_line_arguments(Args, IO, IO) :-
build_command_line_args(0, Args).
@@ -8488,6 +8706,19 @@
}
").
+:- pragma foreign_proc("Erlang",
+ io.getenv(Var::in, Value::out),
+ [will_not_call_mercury, tabled_for_io],
+"
+ case os:getenv(Var) of
+ false ->
+ SUCCESS_INDICATOR = false,
+ Value = """";
+ Value ->
+ SUCCESS_INDICATOR = true
+ end
+").
+
io.setenv(Var, Value) :-
impure io.putenv(Var ++ "=" ++ Value).
@@ -8544,6 +8775,25 @@
""io.putenv/1 not implemented for Java: "" + VarAndValue);
").
+:- pragma foreign_proc("Erlang",
+ io.setenv(Var::in, Value::in),
+ [will_not_call_mercury, tabled_for_io],
+"
+ os:putenv(Var, Value),
+ SUCCESS_INDICATOR = true
+").
+
+:- pragma foreign_proc("Erlang",
+ io.putenv(VarAndValue::in),
+ [will_not_call_mercury, tabled_for_io],
+"
+ % This procedure should never be called, as io.setenv/2 has been
+ % implemented directly for Erlang.
+ % This implementation is included only to suppress warnings.
+
+ throw({""io.putenv/1 not implemented for Erlang: "" ++ VarAndValue})
+").
+
%-----------------------------------------------------------------------------%
% We need to do an explicit check of TMPDIR because not all
@@ -8955,6 +9205,21 @@
}
").
+:- pragma foreign_proc("Erlang",
+ io.remove_file_2(FileName::in, RetVal::out, RetStr::out,
+ _IO0::di, _IO::uo),
+ [will_not_call_mercury, promise_pure, tabled_for_io, thread_safe,
+ does_not_affect_liveness],
+"
+ case file:delete(FileName) of
+ ok ->
+ RetVal = 0,
+ RetStr = """";
+ {error, RetStr} ->
+ RetVal = -1
+ end
+").
+
remove_file_recursively(FileName, Res, !IO) :-
FollowSymLinks = no,
io.file_type(FollowSymLinks, FileName, ResFileType, !IO),
@@ -9068,6 +9333,23 @@
}
").
+:- pragma foreign_proc("Erlang",
+ io.rename_file_2(OldFileName::in, NewFileName::in, RetVal::out,
+ RetStr::out, _IO0::di, _IO::uo),
+ [will_not_call_mercury, promise_pure, tabled_for_io, thread_safe],
+"
+ % XXX it is not enough to specify destination directory
+ % see erl -man file
+ case file:rename(OldFileName, NewFileName) of
+ ok ->
+ RetVal = 0,
+ RetStr = """";
+ {error, Reason} ->
+ RetVal = -1,
+ RetStr = ""rename_file failed: "" ++ Reason
+ end
+").
+
io.have_symlinks :- semidet_fail.
:- pragma foreign_proc("C",
@@ -9082,6 +9364,15 @@
#endif
").
+:- pragma foreign_proc("Erlang",
+ io.have_symlinks,
+ [will_not_call_mercury, promise_pure, thread_safe,
+ does_not_affect_liveness],
+"
+ % XXX how do we check without actually trying to make one?
+ SUCCESS_INDICATOR = true
+").
+
io.make_symlink(FileName, LinkFileName, Result, !IO) :-
( io.have_symlinks ->
io.make_symlink_2(FileName, LinkFileName, Status, !IO),
@@ -9113,6 +9404,20 @@
MR_update_io(IO0, IO);
}").
+:- pragma foreign_proc("Erlang",
+ io.make_symlink_2(FileName::in, LinkFileName::in, Status::out,
+ _IO0::di, _IO::uo),
+ [will_not_call_mercury, promise_pure, tabled_for_io, thread_safe,
+ does_not_affect_liveness],
+"
+ case file:make_symlink(FileName, LinkFileName) of
+ ok ->
+ Status = 0;
+ {error, _Reason} ->
+ Status = -1
+ end
+").
+
io.read_symlink(FileName, Result, !IO) :-
( io.have_symlinks ->
io.read_symlink_2(FileName, TargetFileName, Status, Error, !IO),
@@ -9184,6 +9489,22 @@
#endif
MR_update_io(IO0, IO);
}").
+
+:- pragma foreign_proc("Erlang",
+ io.read_symlink_2(FileName::in, TargetFileName::out,
+ Status::out, Error::out, _IO0::di, _IO::uo),
+ [will_not_call_mercury, promise_pure, tabled_for_io, thread_safe,
+ does_not_affect_liveness],
+"
+ case file:read_link(FileName) of
+ {ok, TargetFileName} ->
+ Status = 1,
+ Error = """";
+ {error, Error} ->
+ Status = 0,
+ TargetFileName = """"
+ end
+").
% Since io.have_symlinks will fail for Java, these procedures should never be
% called:
Index: library/lexer.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/lexer.m,v
retrieving revision 1.54
diff -u -r1.54 lexer.m
--- library/lexer.m 21 Mar 2007 22:30:26 -0000 1.54
+++ library/lexer.m 30 May 2007 07:18:47 -0000
@@ -1217,6 +1217,14 @@
EncodingInt = 1;
").
+:- pragma foreign_proc("Erlang",
+ backend_unicode_encoding_int = (EncodingInt::out),
+ [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail,
+ does_not_affect_liveness],
+"
+ EncodingInt = 0
+").
+
:- pred get_hex_escape(char::in, list(char)::in, list(char)::in,
token::out, io::di, io::uo) is det.
Index: library/math.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/math.m,v
retrieving revision 1.57
diff -u -r1.57 math.m
--- library/math.m 15 Jan 2007 02:24:00 -0000 1.57
+++ library/math.m 30 May 2007 07:18:47 -0000
@@ -290,6 +290,14 @@
succeeded = true;
").
+:- pragma foreign_proc("Erlang",
+ math_domain_checks,
+ [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail,
+ does_not_affect_liveness],
+"
+ SUCCESS_INDICATOR = true
+").
+
%
% Mathematical constants from math.m
%
@@ -313,6 +321,12 @@
"
Pi = java.lang.Math.PI;
").
+:- pragma foreign_proc("Erlang",
+ math.pi = (Pi::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Pi = math:pi()
+").
% This version is only used for back-ends for which there is no
% matching foreign_proc version. We define this with sufficient
% digits that if the underlying implementation's
@@ -366,6 +380,18 @@
"
Ceil = java.lang.Math.ceil(Num);
").
+:- pragma foreign_proc("Erlang",
+ math.ceiling(Num::in) = (Ceil::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ T = erlang:trunc(Num),
+ case (Num - T) > 0 of
+ true ->
+ Ceil = float(T + 1);
+ false ->
+ Ceil = float(T)
+ end
+").
:- pragma foreign_proc("C",
math.floor(Num::in) = (Floor::out),
@@ -386,6 +412,18 @@
"
Floor = java.lang.Math.floor(Num);
").
+:- pragma foreign_proc("Erlang",
+ math.floor(Num::in) = (Floor::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ T = erlang:trunc(Num),
+ case (Num - T) < 0 of
+ true ->
+ Floor = float(T - 1);
+ false ->
+ Floor = float(T)
+ end
+").
:- pragma foreign_proc("C",
math.round(Num::in) = (Rounded::out),
@@ -408,6 +446,18 @@
"
Rounded = java.lang.Math.round(Num);
").
+:- pragma foreign_proc("Java",
+ math.round(Num::in) = (Rounded::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Rounded = java.lang.Math.round(Num);
+").
+:- pragma foreign_proc("Erlang",
+ math.round(Num::in) = (Rounded::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Rounded = round(Num)
+").
math.round(Num) = math.floor(Num + 0.5).
math.truncate(X) = (X < 0.0 -> math.ceiling(X) ; math.floor(X)).
@@ -440,6 +490,12 @@
"
SquareRoot = java.lang.Math.sqrt(X);
").
+:- pragma foreign_proc("Erlang",
+ math.sqrt_2(X::in) = (SquareRoot::out),
+ [thread_safe, promise_pure],
+"
+ SquareRoot = math:sqrt(X)
+").
% This version is only used for back-ends for which there is no
% matching foreign_proc version.
math.sqrt_2(X) = math.exp(math.ln(X) / 2.0).
@@ -515,6 +571,13 @@
Res = java.lang.Math.pow(X, Y);
").
+:- pragma foreign_proc("Erlang",
+ math.pow_2(X::in, Y::in) = (Res::out),
+ [thread_safe, promise_pure],
+"
+ Res = math:pow(X, Y)
+").
+
:- pragma foreign_proc("C",
math.exp(X::in) = (Exp::out),
[will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail,
@@ -534,6 +597,12 @@
"
Exp = java.lang.Math.exp(X);
").
+:- pragma foreign_proc("Erlang",
+ math.exp(X::in) = (Exp::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Exp = math:exp(X)
+").
math.ln(X) = Log :-
( math_domain_checks, X =< 0.0 ->
@@ -563,6 +632,12 @@
"
Log = java.lang.Math.log(X);
").
+:- pragma foreign_proc("Erlang",
+ math.ln_2(X::in) = (Log::out),
+ [thread_safe, promise_pure],
+"
+ Log = math:log(X)
+").
math.log10(X) = Log :-
( math_domain_checks, X =< 0.0 ->
@@ -586,6 +661,12 @@
"
Log10 = System.Math.Log10(X);
").
+:- pragma foreign_proc("Erlang",
+ math.log10_2(X::in) = (Log10::out),
+ [thread_safe, promise_pure],
+"
+ Log10 = math:log10(X)
+").
% Java doesn't have a built-in log10, so default to mercury here.
math.log10_2(X) = math.ln_2(X) / math.ln_2(10.0).
@@ -648,6 +729,7 @@
Log = System.Math.Log(X, B);
").
% Java implementation will default to mercury here.
+% Erlang implementation will default to mercury here.
math.log_2(B, X) = math.ln_2(X) / math.ln_2(B).
:- pragma foreign_proc("C",
@@ -669,6 +751,12 @@
"
Sin = java.lang.Math.sin(X);
").
+:- pragma foreign_proc("Erlang",
+ math.sin(X::in) = (Sin::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Sin = math:sin(X)
+").
:- pragma foreign_proc("C",
math.cos(X::in) = (Cos::out),
@@ -689,6 +777,12 @@
"
Cos = java.lang.Math.cos(X);
").
+:- pragma foreign_proc("Erlang",
+ math.cos(X::in) = (Cos::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Cos = math:cos(X)
+").
:- pragma foreign_proc("C",
math.tan(X::in) = (Tan::out),
@@ -709,6 +803,12 @@
"
Tan = java.lang.Math.tan(X);
").
+:- pragma foreign_proc("Erlang",
+ math.tan(X::in) = (Tan::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Tan = math:tan(X)
+").
math.asin(X) = ASin :-
(
@@ -743,6 +843,12 @@
"
ASin = java.lang.Math.asin(X);
").
+:- pragma foreign_proc("Erlang",
+ math.asin_2(X::in) = (ASin::out),
+ [thread_safe, promise_pure],
+"
+ ASin = math:asin(X)
+").
math.acos(X) = ACos :-
(
@@ -777,6 +883,12 @@
"
ACos = java.lang.Math.acos(X);
").
+:- pragma foreign_proc("Erlang",
+ math.acos_2(X::in) = (ACos::out),
+ [thread_safe, promise_pure],
+"
+ ACos = math:acos(X)
+").
:- pragma foreign_proc("C",
@@ -798,6 +910,12 @@
"
ATan = java.lang.Math.atan(X);
").
+:- pragma foreign_proc("Erlang",
+ math.atan(X::in) = (ATan::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ ATan = math:atan(X)
+").
:- pragma foreign_proc("C",
math.atan2(Y::in, X::in) = (ATan2::out),
@@ -818,6 +936,12 @@
"
ATan2 = java.lang.Math.atan2(Y, X);
").
+:- pragma foreign_proc("Erlang",
+ math.atan2(Y::in, X::in) = (ATan2::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ ATan2 = math:atan2(Y, X)
+").
:- pragma foreign_proc("C",
math.sinh(X::in) = (Sinh::out),
@@ -832,6 +956,12 @@
"
Sinh = System.Math.Sinh(X);
").
+:- pragma foreign_proc("Erlang",
+ math.sinh(X::in) = (Sinh::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Sinh = math:sinh(X)
+").
% Java doesn't have any hyperbolic functions built in.
math.sinh(X) = Sinh :-
Sinh = (exp(X)-exp(-X)) / 2.0.
@@ -849,6 +979,12 @@
"
Cosh = System.Math.Cosh(X);
").
+:- pragma foreign_proc("Erlang",
+ math.cosh(X::in) = (Cosh::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Cosh = math:cosh(X)
+").
% Java doesn't have any hyperbolic functions built in.
math.cosh(X) = Cosh :-
Cosh = (exp(X)+exp(-X)) / 2.0.
@@ -865,6 +1001,12 @@
[will_not_call_mercury, promise_pure, thread_safe],
"
Tanh = System.Math.Tanh(X);
+").
+:- pragma foreign_proc("Erlang",
+ math.tanh(X::in) = (Tanh::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Tanh = math:tanh(X)
").
% Java doesn't have any hyperbolic functions built in.
math.tanh(X) = Tanh :-
Index: library/mutvar.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/mutvar.m,v
retrieving revision 1.3
diff -u -r1.3 mutvar.m
--- library/mutvar.m 1 Feb 2007 08:07:59 -0000 1.3
+++ library/mutvar.m 30 May 2007 07:18:47 -0000
@@ -169,5 +169,35 @@
").
%-----------------------------------------------------------------------------%
+%
+% Erlang implementation
+% XXX ets are not garbage collected
+% but shareable between processes
+%
+
+:- pragma foreign_type("Erlang", mutvar(T), "").
+
+:- pragma foreign_proc("Erlang",
+ new_mutvar0(Ref::uo),
+ [will_not_call_mercury, thread_safe],
+"
+ Ref = ets:new(mutvar, [set, public])
+").
+
+:- pragma foreign_proc("Erlang",
+ get_mutvar(Ref::in, X::uo),
+ [will_not_call_mercury, thread_safe],
+"
+ [{value, X}] = ets:lookup(Ref, value)
+").
+
+:- pragma foreign_proc("Erlang",
+ set_mutvar(Ref::in, X::in),
+ [will_not_call_mercury, thread_safe],
+"
+ ets:insert(Ref, {value, X})
+").
+
+%-----------------------------------------------------------------------------%
:- end_module mutvar.
%-----------------------------------------------------------------------------%
Index: library/ops.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/ops.m,v
retrieving revision 1.68
diff -u -r1.68 ops.m
--- library/ops.m 21 Dec 2006 11:11:32 -0000 1.68
+++ library/ops.m 30 May 2007 07:18:47 -0000
@@ -70,7 +70,7 @@
% Check whether a string is the name of an infix operator,
% and if it is, return its precedence and associativity.
%
- pred ops.lookup_infix_op(Table::in, string::in, ops.priority::out,
+ pred lookup_infix_op(Table::in, string::in, ops.priority::out,
ops.assoc::out, ops.assoc::out) is semidet,
% Check whether a string is the name of a prefix operator,
Index: library/par_builtin.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/par_builtin.m,v
retrieving revision 1.10
diff -u -r1.10 par_builtin.m
--- library/par_builtin.m 18 Feb 2007 08:01:56 -0000 1.10
+++ library/par_builtin.m 30 May 2007 07:18:47 -0000
@@ -93,6 +93,8 @@
% Placeholder only.
:- pragma foreign_type(il, future(T), "class [mscorlib]System.Object").
+:- pragma foreign_type("Erlang", future(T), "").
+
:- pragma foreign_proc("C",
new_future(Future::uo),
[will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail],
Index: library/private_builtin.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/private_builtin.m,v
retrieving revision 1.167
diff -u -r1.167 private_builtin.m
--- library/private_builtin.m 4 May 2007 15:06:43 -0000 1.167
+++ library/private_builtin.m 30 May 2007 07:18:47 -0000
@@ -191,6 +191,20 @@
"
Res = S1.compareTo(S2);
").
+:- pragma foreign_proc("Erlang",
+ builtin_strcmp(Res::out, S1::in, S2::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ % XXX is there a more efficient three-way compare?
+ if
+ S1 =:= S2 ->
+ Res = 0;
+ S1 < S2 ->
+ Res = -1;
+ true ->
+ Res = 1
+ end
+").
builtin_unify_float(F, F).
@@ -551,6 +565,33 @@
").
+:- pragma foreign_code("Erlang", "
+
+'__Unify____type_info_0'(X, Y) ->
+ throw(""unify for type_info"").
+
+'__Unify____typeclass_info_0'(X, Y) ->
+ throw(""unify for typeclass_info"").
+
+'__Unify____base_typeclass_info_0'(X, Y) ->
+ throw(""unify for base_typeclass_info"").
+
+'__Unify____type_ctor_info_0'(X, Y) ->
+ throw(""unify for type_ctor_info"").
+
+'__Compare____type_ctor_info_0'(X, Y) ->
+ throw(""compare for type_ctor_info"").
+
+'__Compare____type_info_0'(X, Y) ->
+ throw(""compare for type_info"").
+
+'__Compare____typeclass_info_0'(X, Y) ->
+ throw(""compare for typeclass_info"").
+
+'__Compare____base_typeclass_info_0'(X, Y) ->
+ throw(""compare for base_typeclass_info"").
+").
+
:- pragma foreign_proc("C",
type_info_from_typeclass_info(TypeClassInfo::in, Index::in,
TypeInfo::out),
@@ -658,6 +699,40 @@
(Object[]) TypeClassInfo0, Index);
").
+% XXX untested
+
+:- pragma foreign_proc("Erlang",
+ type_info_from_typeclass_info(TypeClassInfo::in, Index::in,
+ TypeInfo::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ TypeInfo = element(Index, TypeClassInfo)
+").
+
+:- pragma foreign_proc("Erlang",
+ unconstrained_type_info_from_typeclass_info(TypeClassInfo::in,
+ Index::in, TypeInfo::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ TypeInfo = element(Index, TypeClassInfo)
+").
+
+:- pragma foreign_proc("Erlang",
+ superclass_from_typeclass_info(TypeClassInfo0::in, Index::in,
+ TypeClassInfo::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ TypeClassInfo = element(Index, TypeClassInfo0)
+").
+
+:- pragma foreign_proc("Erlang",
+ instance_constraint_from_typeclass_info(TypeClassInfo0::in,
+ Index::in, TypeClassInfo::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ TypeClassInfo = element(Index, TypeClassInfo0)
+").
+
%-----------------------------------------------------------------------------%
% This section of the module contains predicates that are used
@@ -912,6 +987,70 @@
/* XXX No trailing for the Java back-end, so take no action. */
").
+:- pragma foreign_proc("Erlang",
+ store_ticket(Ticket::out),
+ [will_not_call_mercury, thread_safe],
+"
+ % XXX No trailing for the Erlang back-end, so take no action.
+ Ticket = null
+").
+
+:- pragma foreign_proc("Erlang",
+ reset_ticket_undo(_Ticket::in),
+ [will_not_call_mercury, thread_safe],
+"
+ % XXX No trailing for the Erlang back-end, so take no action.
+ void
+").
+
+:- pragma foreign_proc("Erlang",
+ reset_ticket_commit(_Ticket::in),
+ [will_not_call_mercury, thread_safe],
+"
+ % XXX No trailing for the Erlang back-end, so take no action.
+ void
+").
+
+:- pragma foreign_proc("Erlang",
+ reset_ticket_solve(_Ticket::in),
+ [will_not_call_mercury, thread_safe],
+"
+ % XXX No trailing for the Erlang back-end, so take no action.
+ void
+").
+
+:- pragma foreign_proc("Erlang",
+ discard_ticket,
+ [will_not_call_mercury, thread_safe],
+"
+ % XXX No trailing for the Erlang back-end, so take no action.
+ void
+").
+
+:- pragma foreign_proc("Erlang",
+ prune_ticket,
+ [will_not_call_mercury, thread_safe],
+"
+ % XXX No trailing for the Erlang back-end, so take no action.
+ void
+").
+
+:- pragma foreign_proc("Erlang",
+ mark_ticket_stack(TicketCounter::out),
+ [will_not_call_mercury, thread_safe],
+"
+ % XXX No trailing for the Erlang back-end, so take no action.
+ TicketCounter = null
+").
+
+:- pragma foreign_proc("Erlang",
+ prune_tickets_to(_TicketCounter::in),
+ [will_not_call_mercury, thread_safe],
+"
+ % XXX No trailing for the Erlang back-end, so take no action.
+ void
+").
+
trailed_nondet_pragma_foreign_code :-
Msg = string.append_list([
"Sorry, not implemented:\n",
@@ -1089,6 +1228,40 @@
/* We can't do heap reclamation on failure in the Java back-end. */
").
+:- pragma foreign_proc("Erlang",
+ gc_trace(_Pointer::in),
+ [will_not_call_mercury, thread_safe],
+"
+ % For the Erlang back-end, we use the Erlang garbage collector, so we
+ % take no action here.
+ void
+").
+
+:- pragma foreign_proc("Erlang",
+ free_heap(_Val::di),
+ [will_not_call_mercury, thread_safe],
+"
+ % For the Erlang back-end, as for the .NET back-end, we don't define
+ % our own heaps. So take no action here.
+ void
+").
+
+:- pragma foreign_proc("Erlang",
+ mark_hp(SavedHeapPointer::out),
+ [will_not_call_mercury, thread_safe],
+"
+ % We can't do heap reclamation on failure in the Erlang back-end.
+ SavedHeapPointer = null
+").
+
+:- pragma foreign_proc("Erlang",
+ restore_hp(_SavedHeapPointer::in),
+ [will_not_call_mercury, thread_safe],
+"
+ % We can't do heap reclamation on failure in the Erlang back-end.
+ void
+").
+
reclaim_heap_nondet_pragma_foreign_code :-
Msg = string.append_list([
"Sorry, not implemented:\n",
@@ -1332,6 +1505,10 @@
imp,
[will_not_call_mercury, thread_safe],
"").
+:- pragma foreign_proc("Erlang",
+ imp,
+ [will_not_call_mercury, thread_safe],
+"void").
:- pragma foreign_proc("C",
semip,
@@ -1346,6 +1523,10 @@
semip,
[will_not_call_mercury, thread_safe, promise_semipure],
"").
+:- pragma foreign_proc("Erlang",
+ semip,
+ [will_not_call_mercury, thread_safe, promise_semipure],
+"void").
%-----------------------------------------------------------------------------%
@@ -1542,6 +1723,23 @@
").
+:- pragma foreign_code("Erlang", "
+ '__Compare____heap_pointer_0'(_, _) ->
+ throw(""called compare/2 for type `private_builtin.heap_pointer'"").
+
+ '__Unify____heap_pointer_0'(_, _) ->
+ throw(""called unify/2 for type `private_builtin.heap_pointer'"").
+
+ '__Compare____ref_1'(_, _, _) ->
+ throw(""called compare/3 for type `private_builtin.ref'"").
+
+ '__Unify____ref_1'(TypeInfo, X, Y) ->
+ case X =:= Y of
+ true -> {};
+ false -> fail
+ end.
+").
+
%-----------------------------------------------------------------------------%
:- interface.
@@ -1563,6 +1761,16 @@
"
/* All uses of this predicate should override the body. */
MR_fatal_error(""trace_evaluate_runtime_condition called"");
+").
+
+:- pragma foreign_proc("Erlang",
+ trace_evaluate_runtime_condition,
+ [will_not_call_mercury, thread_safe, promise_semipure,
+ does_not_affect_liveness],
+"
+ % All uses of this predicate should override the body.
+ throw(""trace_evaluate_runtime_condition called""),
+ SUCCESS_INDICATOR = false
").
%-----------------------------------------------------------------------------%
Index: library/rtti_implementation.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/rtti_implementation.m,v
retrieving revision 1.75
diff -u -r1.75 rtti_implementation.m
--- library/rtti_implementation.m 6 Mar 2007 05:48:33 -0000 1.75
+++ library/rtti_implementation.m 30 May 2007 07:18:47 -0000
@@ -436,6 +436,13 @@
TypeInfo = TypeInfo_for_T;
").
+:- pragma foreign_proc("Erlang",
+ get_type_info(_T::unused) = (TypeInfo::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ TypeInfo = TypeInfo_for_T
+").
+
get_type_info(_) = _ :-
% This version is only used for back-ends for which there is no
% matching foreign_proc version.
@@ -774,6 +781,100 @@
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
+ % We override the above definitions in the .NET backend.
+
+:- pragma foreign_proc("Erlang",
+ semidet_call_3(Pred::in, X::in, Y::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ SUCCESS_INDICATOR = case Pred(X, Y) of {} -> true; fail -> false end
+").
+:- pragma foreign_proc("Erlang",
+ semidet_call_4(Pred::in, A::in, X::in, Y::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ SUCCESS_INDICATOR = case Pred(A, X, Y) of {} -> true; fail -> false end
+").
+:- pragma foreign_proc("Erlang",
+ semidet_call_5(Pred::in, A::in, B::in, X::in, Y::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ SUCCESS_INDICATOR = case Pred(A, B, X, Y) of {} -> true; fail -> false end
+").
+:- pragma foreign_proc("Erlang",
+ semidet_call_6(Pred::in, A::in, B::in, C::in, X::in, Y::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ SUCCESS_INDICATOR =
+ case Pred(A, B, C, X, Y) of
+ {} -> true;
+ fail -> false
+ end
+").
+:- pragma foreign_proc("Erlang",
+ semidet_call_7(Pred::in, A::in, B::in, C::in, D::in, X::in, Y::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ SUCCESS_INDICATOR =
+ case Pred(A, B, C, D, X, Y) of
+ {} -> true;
+ fail -> false
+ end
+").
+:- pragma foreign_proc("Erlang",
+ semidet_call_8(Pred::in, A::in, B::in, C::in, D::in, E::in,
+ X::in, Y::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ SUCCESS_INDICATOR =
+ case Pred(A, B, C, D, E, X, Y) of
+ {} -> true;
+ fail -> false
+ end
+").
+
+:- pragma foreign_proc("Erlang",
+ result_call_4(Pred::in, Res::out, X::in, Y::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ {Res} = Pred(X, Y)
+").
+
+:- pragma foreign_proc("Erlang",
+ result_call_5(Pred::in, Res::out, A::in, X::in, Y::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ {Res} = Pred(A, X, Y)
+").
+:- pragma foreign_proc("Erlang",
+ result_call_6(Pred::in, Res::out, A::in, B::in, X::in, Y::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ {Res} = Pred(A, B, X, Y)
+").
+:- pragma foreign_proc("Erlang",
+ result_call_7(Pred::in, Res::out, A::in, B::in, C::in, X::in, Y::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ {Res} = Pred(A, B, C, X, Y)
+").
+:- pragma foreign_proc("Erlang",
+ result_call_8(Pred::in, Res::out, A::in, B::in, C::in, D::in, X::in, Y::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ {Res} = Pred(A, B, C, D, X, Y)
+").
+:- pragma foreign_proc("Erlang",
+ result_call_9(Pred::in, Res::out, A::in, B::in, C::in, D::in, E::in,
+ X::in, Y::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ {Res} = Pred(A, B, C, D, E, X, Y)
+").
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
compare_type_infos(Res, TypeInfo1, TypeInfo2) :-
( same_pointer_value(TypeInfo1, TypeInfo2) ->
Res = (=)
@@ -1622,6 +1723,22 @@
:- func get_type_ctor_info(type_info) = type_ctor_info is det.
+:- pragma foreign_code("Erlang", "
+ % field numbers for type_ctor_infos
+ type_ctor_arity() -> 1.
+ type_ctor_version() -> 2.
+ type_ctor_num_ptags() -> 3.
+ type_ctor_rep() -> 4.
+ type_ctor_unify_pred() -> 5.
+ type_ctor_compare_pred() -> 6.
+ type_ctor_module_name() -> 7.
+ type_ctor_name() -> 8.
+ type_functors() -> 9.
+ type_layout() -> 10.
+ type_ctor_num_functors() -> 11.
+ type_ctor_flags() -> 12.
+").
+
:- pragma foreign_code("C#", "
// The field numbers of the contents of type_infos.
@@ -1713,6 +1830,13 @@
(MR_TypeInfo) TypeInfo);
").
+:- pragma foreign_proc("Erlang",
+ get_type_ctor_info(TypeInfo::in) = (TypeCtorInfo::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ TypeCtorInfo = element(1, TypeInfo)
+").
+
get_type_ctor_info(_) = _ :-
% This version is only used for back-ends for which there is no
% matching foreign_proc version.
@@ -2013,6 +2137,13 @@
TypeInfoAtIndex = (object[]) TypeInfo[X];
").
+:- pragma foreign_proc("Erlang",
+ type_info_index(X::in, TypeInfo::in) = (TypeInfoAtIndex::out),
+ [will_not_call_mercury, promise_pure],
+"
+ TypeInfoAtIndex = element(X + 1, TypeInfo)
+").
+
:- pred update_type_info_index(int::in, type_info::in, type_info::di,
type_info::uo) is det.
@@ -2070,6 +2201,12 @@
MR_TypeCtorInfo tci = (MR_TypeCtorInfo) TypeCtorInfo;
Arity = tci->MR_type_ctor_arity;
").
+:- pragma foreign_proc("Erlang",
+ type_ctor_arity(TypeCtorInfo::in) = (Arity::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Arity = element(type_ctor_arity(), TypeCtorInfo)
+").
type_ctor_arity(_) = _ :-
% This version is only used for back-ends for which there is no
% matching foreign_proc version.
@@ -2098,6 +2235,14 @@
tci = (MR_TypeCtorInfo) TypeCtorInfo;
UnifyPred = (MR_Integer) tci->MR_type_ctor_unify_pred;
").
+:- pragma foreign_proc("Erlang",
+ type_ctor_unify_pred(TypeCtorInfo::in) = (UnifyPred::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ % XXX This should be something else.
+ TypeInfo_for_P = 0,
+ UnifyPred = element(type_ctor_unify_pred(), TypeCtorInfo)
+").
type_ctor_unify_pred(_) = "dummy value" :-
% This version is only used for back-ends for which there is no
% matching foreign_proc version.
@@ -2157,6 +2302,61 @@
MR_TypeCtorInfo tci = (MR_TypeCtorInfo) TypeCtorInfo;
TypeCtorRep = MR_type_ctor_rep(tci);
").
+:- pragma foreign_proc("Erlang",
+ type_ctor_rep(TypeCtorInfo::in) = (TypeCtorRep::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ TypeCtorRep =
+ case element(type_ctor_rep(), TypeCtorInfo) of
+ 'MR_TYPECTOR_REP_ENUM' -> {tcr_enum};
+ 'MR_TYPECTOR_REP_ENUM_USEREQ' -> {tcr_enum_usereq};
+ 'MR_TYPECTOR_REP_DU' -> {tcr_du};
+ 'MR_TYPECTOR_REP_DU_USEREQ' -> {tcr_du_usereq};
+ 'MR_TYPECTOR_REP_NOTAG' -> {tcr_notag};
+ 'MR_TYPECTOR_REP_NOTAG_USEREQ' -> {tcr_notag_usereq};
+ 'MR_TYPECTOR_REP_EQUIV' -> {tcr_equiv};
+ 'MR_TYPECTOR_REP_FUNC' -> {tcr_func};
+ 'MR_TYPECTOR_REP_INT' -> {tcr_int};
+ 'MR_TYPECTOR_REP_CHAR' -> {tcr_char};
+ 'MR_TYPECTOR_REP_FLOAT' -> {tcr_float};
+ 'MR_TYPECTOR_REP_STRING' -> {tcr_string};
+ 'MR_TYPECTOR_REP_PRED' -> {tcr_pred};
+ 'MR_TYPECTOR_REP_SUBGOAL' -> {tcr_subgoal};
+ 'MR_TYPECTOR_REP_VOID' -> {tcr_void};
+ 'MR_TYPECTOR_REP_C_POINTER' -> {tcr_c_pointer};
+ 'MR_TYPECTOR_REP_TYPEINFO' -> {tcr_typeinfo};
+ 'MR_TYPECTOR_REP_TYPECLASSINFO' -> {tcr_typeclassinfo};
+ 'MR_TYPECTOR_REP_ARRAY' -> {tcr_array};
+ 'MR_TYPECTOR_REP_SUCCIP' -> {tcr_succip};
+ 'MR_TYPECTOR_REP_HP' -> {tcr_hp};
+ 'MR_TYPECTOR_REP_CURFR' -> {tcr_curfr};
+ 'MR_TYPECTOR_REP_MAXFR' -> {tcr_maxfr};
+ 'MR_TYPECTOR_REP_REDOFR' -> {tcr_redofr};
+ 'MR_TYPECTOR_REP_REDOIP' -> {tcr_redoip};
+ 'MR_TYPECTOR_REP_TRAIL_PTR' -> {tcr_trail_ptr};
+ 'MR_TYPECTOR_REP_TICKET' -> {tcr_ticket};
+ 'MR_TYPECTOR_REP_NOTAG_GROUND' -> {tcr_notag_ground};
+ 'MR_TYPECTOR_REP_NOTAG_GROUND_USEREQ' -> {tcr_notag_ground_usereq};
+ 'MR_TYPECTOR_REP_EQUIV_GROUND' -> {tcr_equiv_ground};
+ 'MR_TYPECTOR_REP_TUPLE' -> {tcr_tuple};
+ 'MR_TYPECTOR_REP_RESERVED_ADDR' -> {tcr_reserved_addr};
+ 'MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ' -> {tcr_reserved_addr_usereq};
+ 'MR_TYPECTOR_REP_TYPECTORINFO' -> {tcr_type_ctor_info};
+ 'MR_TYPECTOR_REP_BASETYPECLASSINFO' -> {tcr_base_typeclass_info};
+ 'MR_TYPECTOR_REP_TYPEDESC' -> {tcr_type_desc};
+ 'MR_TYPECTOR_REP_TYPECTORDESC' -> {tcr_type_ctor_desc};
+ 'MR_TYPECTOR_REP_FOREIGN' -> {tcr_foreign};
+ 'MR_TYPECTOR_REP_REFERENCE' -> {tcr_reference};
+ 'MR_TYPECTOR_REP_STABLE_C_POINTER' -> {tcr_stable_c_pointer};
+ 'MR_TYPECTOR_REP_STABLE_FOREIGN' -> {tcr_stable_foreign};
+ 'MR_TYPECTOR_REP_PSEUDOTYPEDESC' -> {tcr_pseudo_type_desc};
+ 'MR_TYPECTOR_REP_DUMMY' -> {tcr_dummy};
+ 'MR_TYPECTOR_REP_BITMAP' -> {tcr_bitmap};
+ _ -> {tcr_unknown}
+ end
+").
+
+
type_ctor_rep(_) = _ :-
% This version is only used for back-ends for which there is no
% matching foreign_proc version.
@@ -2302,6 +2502,12 @@
[will_not_call_mercury, promise_pure, thread_safe],
"
VarOut = VarIn;
+").
+:- pragma foreign_proc("Erlang",
+ unsafe_cast(VarIn::in) = (VarOut::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ VarOut = VarIn
").
unsafe_cast(_) = _ :-
Index: library/solutions.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/solutions.m,v
retrieving revision 1.6
diff -u -r1.6 solutions.m
--- library/solutions.m 23 Oct 2006 00:33:00 -0000 1.6
+++ library/solutions.m 30 May 2007 07:18:47 -0000
@@ -300,6 +300,10 @@
:- pragma promise_pure(builtin_aggregate/4).
+% XXX this is temporary workaround required to avoid warnings from the
+% Erlang compiler for code that we generate for this module
+:- pragma no_inline(builtin_aggregate/4).
+
builtin_aggregate(GeneratorPred, CollectorPred, Accumulator0, Accumulator) :-
% Save some of the Mercury virtual machine registers
impure get_registers(HeapPtr, SolutionsHeapPtr, TrailPtr),
@@ -491,6 +495,17 @@
TrailPtr = null;
").
+:- pragma foreign_proc("Erlang",
+ get_registers(HeapPtr::out, SolutionsHeapPtr::out, TrailPtr::out),
+ [will_not_call_mercury, thread_safe],
+"
+ % Erlang has a builtin garbage collector,
+ % so we don't have to worry here about heap reclamation on failure.
+ HeapPtr = null,
+ SolutionsHeapPtr = null,
+ TrailPtr = null
+").
+
:- impure pred check_for_floundering(trail_ptr::in) is det.
:- pragma foreign_proc("C",
@@ -519,6 +534,14 @@
/* XXX No trailing for the Java back-end, so take no action. */
").
+:- pragma foreign_proc("Erlang",
+ check_for_floundering(_TrailPtr::in),
+ [will_not_call_mercury, thread_safe],
+"
+ % XXX No trailing for the Erlang back-end, so take no action.
+ void
+").
+
% Discard the topmost trail ticket.
%
:- impure pred discard_trail_ticket is det.
@@ -548,6 +571,14 @@
/* XXX No trailing for the Java back-end, so take no action. */
").
+:- pragma foreign_proc("Erlang",
+ discard_trail_ticket,
+ [will_not_call_mercury, thread_safe],
+"
+ % XXX No trailing for the Erlang back-end, so take no action.
+ void
+").
+
% Swap the heap with the solutions heap
%
:- impure pred swap_heap_and_solutions_heap is det.
@@ -590,6 +621,15 @@
*/
").
+:- pragma foreign_proc("Erlang",
+ swap_heap_and_solutions_heap,
+ [will_not_call_mercury, thread_safe],
+"
+ % For the Erlang back-end, as for the .NET back-end, we don't define
+ % our own heaps. So take no action here.
+ void
+").
+
% partial_deep_copy(SolutionsHeapPtr, OldVal, NewVal):
% Make a copy of all of the parts of OldVar that occur between
% SolutionsHeapPtr and the top of the current solutions heap.
@@ -696,6 +736,29 @@
NewVal = OldVal;
").
+:- pragma foreign_proc("Erlang",
+ partial_deep_copy(_SolutionsHeapPtr::in, OldVal::in, NewVal::out),
+ [will_not_call_mercury, thread_safe],
+"
+ % For the Erlang back-end, as for the .NET implementation,
+ % we don't do heap reclamation on failure,
+ % so we don't need to worry about making deep copies here.
+ % Shallow copies will suffice.
+ NewVal = OldVal
+").
+:- pragma foreign_proc("Erlang",
+ partial_deep_copy(_SolutionsHeapPtr::in, OldVal::mdi, NewVal::muo),
+ [will_not_call_mercury, thread_safe],
+"
+ NewVal = OldVal
+").
+:- pragma foreign_proc("Erlang",
+ partial_deep_copy(_SolutionsHeapPtr::in, OldVal::di, NewVal::uo),
+ [will_not_call_mercury, thread_safe],
+"
+ NewVal = OldVal
+").
+
% reset_solutions_heap(SolutionsHeapPtr):
%
% Reset the solutions heap pointer to the specified value,
@@ -726,6 +789,14 @@
[will_not_call_mercury, thread_safe],
"
/* As above, we take no action. */
+").
+
+:- pragma foreign_proc("Erlang",
+ reset_solutions_heap(_SolutionsHeapPtr::in),
+ [will_not_call_mercury, thread_safe],
+"
+ % As above, we take no action.
+ void
").
:- impure pred start_all_soln_neg_context is det.
Index: library/store.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/store.m,v
retrieving revision 1.61
diff -u -r1.61 store.m
--- library/store.m 23 Oct 2006 00:33:01 -0000 1.61
+++ library/store.m 30 May 2007 07:18:47 -0000
@@ -294,6 +294,12 @@
"
// TypeInfo_for_S
").
+:- pragma foreign_proc("Erlang",
+ store.do_init(_S0::uo),
+ [will_not_call_mercury, promise_pure],
+"
+ TypeInfo_for_S = 'XXX'
+").
% Note -- the syntax for the operations on stores
% might be nicer if we used some new operators, e.g.
@@ -360,6 +366,36 @@
Mutvar.object = Val;
").
+% XXX ets are not garbage collected
+% but shareable between processes
+
+:- pragma foreign_type("Erlang", generic_mutvar(T, S), "").
+
+:- pragma foreign_proc("Erlang",
+ new_mutvar(Val::in, Mutvar::out, S0::di, S::uo),
+ [will_not_call_mercury, promise_pure],
+"
+ Mutvar = ets:new(mutvar, [set, public]),
+ ets:insert(Mutvar, {value, Val}),
+ S = S0
+").
+
+:- pragma foreign_proc("Erlang",
+ get_mutvar(Mutvar::in, Val::out, S0::di, S::uo),
+ [will_not_call_mercury, promise_pure],
+"
+ [{value, Val}] = ets:lookup(Mutvar, value),
+ S = S0
+").
+
+:- pragma foreign_proc("Erlang",
+ set_mutvar(Mutvar::in, Val::in, S0::di, S::uo),
+ [will_not_call_mercury, promise_pure],
+"
+ ets:insert(Mutvar, {value, Val}),
+ S = S0
+").
+
copy_mutvar(Mutvar, Copy, !S) :-
get_mutvar(Mutvar, Value, !S),
new_mutvar(Value, Copy, !S).
@@ -489,6 +525,15 @@
Ref = new mercury.store.Ref(Val);
").
+:- pragma foreign_proc("Erlang",
+ new_ref(Val::di, Ref::out, S0::di, S::uo),
+ [will_not_call_mercury, promise_pure],
+"
+ Ref = ets:new(mutvar, [set, public]),
+ ets:insert(Ref, {value, Val}),
+ S = S0
+").
+
copy_ref_value(Ref, Val) -->
% XXX Need to deep-copy non-atomic types.
unsafe_ref_value(Ref, Val).
@@ -502,7 +547,7 @@
:- pragma foreign_proc("C",
unsafe_ref_value(Ref::in, Val::uo, S0::di, S::uo),
-[will_not_call_mercury, promise_pure, will_not_modify_trail],
+ [will_not_call_mercury, promise_pure, will_not_modify_trail],
"
Val = * (MR_Word *) Ref;
S = S0;
@@ -513,6 +558,14 @@
[will_not_call_mercury, promise_pure],
"
Val = Ref.getValue();
+").
+
+:- pragma foreign_proc("Erlang",
+ unsafe_ref_value(Ref::in, Val::uo, S0::di, S::uo),
+ [will_not_call_mercury, promise_pure],
+"
+ [{value, Val}] = ets:lookup(Ref, value),
+ S = S0
").
ref_functor(Ref, Functor, Arity, !Store) :-
Index: library/string.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/string.m,v
retrieving revision 1.259
diff -u -r1.259 string.m
--- library/string.m 20 Apr 2007 05:18:39 -0000 1.259
+++ library/string.m 30 May 2007 07:18:47 -0000
@@ -1273,6 +1273,14 @@
}
}").
+:- pragma foreign_proc("Erlang",
+ string.to_char_list_2(Str::in, CharList::out),
+ [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail,
+ does_not_affect_liveness],
+"
+ CharList = Str
+").
+
string.to_char_list_2(Str, CharList) :-
string.to_char_list_3(Str, 0, CharList).
@@ -1356,7 +1364,7 @@
Str = ""
;
CharList = [C | Cs],
- \+ char_to_int(C, 0),
+ \+ char.to_int(C, 0),
string.semidet_from_char_list(Cs, Str0),
string.first_char(Str, C, Str0)
).
@@ -1552,6 +1560,14 @@
Str[len] = '\\0';
}").
+:- pragma foreign_proc("Erlang",
+ string.append_list(Strs::in) = (Str::uo),
+ [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail,
+ does_not_affect_liveness],
+"
+ Str = lists:concat(Strs)
+").
+
% We implement string.join_list in C as this minimises the amount of
% garbage created.
:- pragma foreign_proc("C",
@@ -2158,6 +2174,11 @@
"
succeeded = false;
").
+:- pragma foreign_proc("Erlang", using_sprintf,
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ SUCCESS_INDICATOR = false
+").
% Construct a format string suitable to passing to sprintf.
%
@@ -3231,6 +3252,13 @@
FloatString = java.lang.Double.toString(FloatVal);
").
+:- pragma foreign_proc("Erlang",
+ string.lowlevel_float_to_string(FloatVal::in, FloatString::uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ [FloatString] = io_lib:format(""~.12f"", [FloatVal])
+").
+
string.det_to_float(FloatString) =
( string.to_float(FloatString, FloatVal) ->
FloatVal
@@ -3327,6 +3355,23 @@
}
").
+:- pragma foreign_proc("Erlang",
+ string.to_float(FloatString::in, FloatVal::out),
+ [will_not_call_mercury, promise_pure, thread_safe, will_not_modify_trail,
+ does_not_affect_liveness],
+"
+ % string:to_float fails on integers, so tack on a trailing '.0' string.
+ case string:to_float(FloatString ++ "".0"") of
+ {FloatVal, []} ->
+ SUCCESS_INDICATOR = true;
+ {FloatVal, "".0""} ->
+ SUCCESS_INDICATOR = true;
+ _ ->
+ SUCCESS_INDICATOR = false,
+ FloatVal = -1.0
+ end
+").
+
% Trim redundant trailing zeroes from the fractional part of the
% string representation of a float.
%
@@ -3374,6 +3419,12 @@
"
SUCCESS_INDICATOR = (Str.IndexOf(Ch) != -1);
").
+:- pragma foreign_proc("Erlang",
+ string.contains_char(Str::in, Ch::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ SUCCESS_INDICATOR = (string:chr(Str, Ch) =/= 0)
+").
string.contains_char(String, Char) :-
string.contains_char(String, Char, 0, string.length(String)).
@@ -3455,6 +3506,13 @@
"
Ch = Str.charAt(Index);
").
+:- pragma foreign_proc("Erlang",
+ string.unsafe_index(Str::in, Index::in, Ch::uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ % `lists:nth' counts from 1.
+ Ch = lists:nth(Index + 1, Str)
+").
string.unsafe_index(Str, Index, Char) :-
( string.first_char(Str, First, Rest) ->
( Index = 0 ->
@@ -3610,6 +3668,13 @@
"
Str = Str0.substring(0, Index) + Ch + Str0.substring(Index + 1);
").
+:- pragma foreign_proc("Erlang",
+ string.unsafe_set_char_2(Ch::in, Index::in, Str0::in, Str::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ {Left, [_ | Right]} = lists:split(Index, Str0),
+ Str = Left ++ [Ch | Right]
+").
% :- pragma foreign_proc("C",
% string.unsafe_set_char_2(Ch::in, Index::in, Str0::di, Str::uo),
@@ -3656,6 +3721,12 @@
"
Length = Str.length();
").
+:- pragma foreign_proc("Erlang",
+ string.length(Str::in, Length::uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Length = string:len(Str)
+").
:- pragma foreign_proc("C",
string.length(Str::ui, Length::uo),
@@ -3672,9 +3743,16 @@
").
:- pragma foreign_proc("Java",
string.length(Str::ui, Length::uo),
- [will_not_call_mercury, promise_pure, thread_safe], "
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
Length = Str.length();
").
+:- pragma foreign_proc("Erlang",
+ string.length(Str::ui, Length::uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Length = string:len(Str)
+").
string.length(Str0, Len) :-
% XXX This copy is only necessary because of the ui.
@@ -3724,6 +3802,13 @@
SUCCESS_INDICATOR = S3.Equals(System.String.Concat(S1, S2));
}").
+:- pragma foreign_proc("Erlang",
+ string.append_iii(S1::in, S2::in, S3::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ SUCCESS_INDICATOR = string:equal(S1 ++ S2, S3)
+").
+
string.append_iii(X, Y, Z) :-
string.mercury_append(X, Y, Z).
@@ -3788,6 +3873,13 @@
S3 = System.String.Concat(S1, S2);
}").
+:- pragma foreign_proc("Erlang",
+ string.append_iio(S1::in, S2::in, S3::uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ S3 = S1 ++ S2
+").
+
string.append_iio(X, Y, Z) :-
string.mercury_append(X, Y, Z).
@@ -3834,6 +3926,13 @@
S2 = S3.Substring(S1Len);
").
+:- pragma foreign_proc("Erlang",
+ string.append_ooi_3(S1Len::in, _S3Len::in, S1::out, S2::out, S3::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ {S1, S2} = lists:split(S1Len, S3)
+").
+
string.append_ooi_3(S1Len, _S3Len, S1, S2, S3) :-
string.split(S3, S1Len, S1, S2).
@@ -3912,6 +4011,12 @@
"
SubString = Str.substring(Start, Start + Count);
").
+:- pragma foreign_proc("Erlang",
+ string.unsafe_substring(Str::in, Start::in, Count::in, SubString::uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ SubString = string:sub_string(Str, 1 + Start, Start + Count)
+").
:- pragma foreign_proc("C",
string.split(Str::in, Count::in, Left::uo, Right::uo),
@@ -3961,6 +4066,22 @@
}
}").
+:- pragma foreign_proc("Erlang",
+ string.split(Str::in, Count::in, Left::uo, Right::uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ if
+ Count =< 0 ->
+ Left = """",
+ Right = Str;
+ Count > length(Str) ->
+ Left = Str,
+ Right = """";
+ true ->
+ {Left, Right} = lists:split(Count, Str)
+ end
+").
+
string.split(Str, Count, Left, Right) :-
( Count =< 0 ->
Left = "",
@@ -4013,6 +4134,21 @@
Str.charAt(0) == First &&
Str.endsWith(Rest));
").
+:- pragma foreign_proc("Erlang",
+ string.first_char(Str::in, First::in, Rest::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ case Str of
+ [First0 | Rest0] ->
+ SUCCESS_INDICATOR = true,
+ First = First0,
+ Rest = Rest0;
+ _ ->
+ SUCCESS_INDICATOR = false,
+ First = 0,
+ Rest = []
+ end
+").
:- pragma foreign_proc("C",
string.first_char(Str::in, First::uo, Rest::in),
@@ -4047,6 +4183,18 @@
First = (char) 0;
}
").
+:- pragma foreign_proc("Erlang",
+ string.first_char(Str::in, First::uo, Rest::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ case Str of
+ [First | Rest] ->
+ SUCCESS_INDICATOR = true;
+ _ ->
+ SUCCESS_INDICATOR = false,
+ First = 0
+ end
+").
:- pragma foreign_proc("C",
string.first_char(Str::in, First::in, Rest::uo),
@@ -4093,6 +4241,18 @@
Rest = null;
}
}").
+:- pragma foreign_proc("Erlang",
+ string.first_char(Str::in, First::in, Rest::uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ case Str of
+ [First | Rest] ->
+ SUCCESS_INDICATOR = true;
+ _ ->
+ SUCCESS_INDICATOR = false,
+ Rest = []
+ end
+").
:- pragma foreign_proc("C",
string.first_char(Str::in, First::uo, Rest::uo),
@@ -4139,6 +4299,21 @@
succeeded = true;
}
}").
+:- pragma foreign_proc("Erlang",
+ string.first_char(Str::in, First::uo, Rest::uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ case Str of
+ [First0 | Rest0] ->
+ SUCCESS_INDICATOR = true,
+ First = First0,
+ Rest = Rest0;
+ _ ->
+ SUCCESS_INDICATOR = false,
+ First = 0,
+ Rest = []
+ end
+").
:- pragma foreign_proc("C",
string.first_char(Str::uo, First::in, Rest::in),
@@ -4165,6 +4340,12 @@
java.lang.String FirstStr = java.lang.String.valueOf(First);
Str = FirstStr.concat(Rest);
}").
+:- pragma foreign_proc("Erlang",
+ string.first_char(Str::uo, First::in, Rest::in),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Str = [First | Rest]
+").
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
Index: library/table_builtin.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/table_builtin.m,v
retrieving revision 1.58
diff -u -r1.58 table_builtin.m
--- library/table_builtin.m 19 Apr 2007 07:08:17 -0000 1.58
+++ library/table_builtin.m 30 May 2007 07:18:47 -0000
@@ -1508,7 +1508,8 @@
impure private_builtin.imp.
table_mmos_completion(_) :-
- impure private_builtin.imp.
+ impure private_builtin.imp,
+ fail.
% Required only to avoid warnings; never executed.
%
Index: library/thread.semaphore.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/thread.semaphore.m,v
retrieving revision 1.6
diff -u -r1.6 thread.semaphore.m
--- library/thread.semaphore.m 21 Mar 2007 22:30:27 -0000 1.6
+++ library/thread.semaphore.m 30 May 2007 07:18:47 -0000
@@ -89,6 +89,7 @@
:- pragma foreign_type("C", semaphore, "ML_Semaphore *").
:- pragma foreign_type("IL", semaphore,
"class [semaphore__csharp_code]ML_Semaphore").
+:- pragma foreign_type("Erlang", semaphore, "").
:- pragma foreign_decl("C", "
#ifdef MR_CONSERVATIVE_GC
Index: library/time.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/time.m,v
retrieving revision 1.57
diff -u -r1.57 time.m
--- library/time.m 1 May 2007 01:38:24 -0000 1.57
+++ library/time.m 30 May 2007 07:18:47 -0000
@@ -235,6 +235,9 @@
:- pragma foreign_type("Java", time_t_rep, "java.util.Date")
where comparison is compare_time_t_reps.
+:- pragma foreign_type("Erlang", time_t_rep, "")
+ where comparison is compare_time_t_reps.
+
:- pred compare_time_t_reps(comparison_result::uo,
time_t_rep::in, time_t_rep::in) is det.
@@ -451,6 +454,12 @@
"
Ret = new java.util.Date();
").
+:- pragma foreign_proc("Erlang",
+ time.c_time(Ret::out, _IO0::di, _IO::uo),
+ [will_not_call_mercury, promise_pure, tabled_for_io],
+"
+ Ret = time()
+").
:- pred time.time_t_is_invalid(time_t_rep::in) is semidet.
@@ -501,6 +510,12 @@
[will_not_call_mercury, promise_pure, thread_safe],
"
Diff = (double) (T1.getTime() - T0.getTime()) / 1000;
+").
+:- pragma foreign_proc("Erlang",
+ time.c_difftime(T1::in, T0::in, Diff::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Diff = float(calendar:time_to_seconds(T1) - calendar:time_to_seconds(T0))
").
%-----------------------------------------------------------------------------%
Index: library/type_desc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/type_desc.m,v
retrieving revision 1.45
diff -u -r1.45 type_desc.m
--- library/type_desc.m 18 Jan 2007 07:33:04 -0000 1.45
+++ library/type_desc.m 30 May 2007 07:18:47 -0000
@@ -425,6 +425,13 @@
(mercury.runtime.TypeInfo_Struct) TypeInfo_for_T);
").
+:- pragma foreign_proc("Erlang",
+ type_of(_Value::unused) = (TypeInfo::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
+ TypeInfo = TypeInfo_for_T
+").
+
:- pragma foreign_proc("C",
has_type(_Arg::unused, TypeInfo::in),
[will_not_call_mercury, thread_safe, promise_pure],
@@ -446,6 +453,13 @@
TypeInfo_for_T = ((mercury.type_desc.Type_desc_0) TypeInfo).struct;
").
+:- pragma foreign_proc("Erlang",
+ has_type(_Arg::unused, TypeInfo::in),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
+ TypeInfo_for_T = TypeInfo
+").
+
% Export this function in order to use it in runtime/mercury_trace_external.c
:- pragma foreign_export("C", type_name(in) = out, "ML_type_name").
@@ -847,6 +861,47 @@
(""compare/3 for type_ctor_desc type implemented"");
}
+").
+
+:- pragma foreign_code("Erlang", "
+ '__Unify____type_desc_0'(X, Y) ->
+ case X =:= Y of
+ true -> {};
+ false -> fail
+ end.
+
+ '__Unify____type_ctor_desc_0'(X, Y) ->
+ case X =:= Y of
+ true -> {};
+ false -> fail
+ end.
+
+ '__Unify____pseudo_type_desc_0'(X, Y) ->
+ case X =:= Y of
+ true -> {};
+ false -> fail
+ end.
+
+ '__Compare____type_desc_0'(X, Y) ->
+ if
+ X =:= Y -> {{'='}};
+ X < Y -> {{'<'}};
+ true -> {{'>'}}
+ end.
+
+ '__Compare____type_ctor_desc_0'(X, Y) ->
+ if
+ X =:= Y -> {{'='}};
+ X < Y -> {{'<'}};
+ true -> {{'>'}}
+ end.
+
+ '__Compare____pseudo_type_desc_0'(X, Y) ->
+ if
+ X =:= Y -> {{'='}};
+ X < Y -> {{'<'}};
+ true -> {{'>'}}
+ end.
").
%-----------------------------------------------------------------------------%
--------------------------------------------------------------------------
mercury-reviews mailing list
Post messages to: mercury-reviews at csse.unimelb.edu.au
Administrative Queries: owner-mercury-reviews at csse.unimelb.edu.au
Subscriptions: mercury-reviews-request at csse.unimelb.edu.au
--------------------------------------------------------------------------
More information about the reviews
mailing list