KevinMidboe/linguist
1
0
Fork 0
mirror of https://github.com/KevinMidboe/linguist.git synced 2025-10-29 09:40:21 +00:00
Code Issues Packages Projects Releases Wiki Activity
Files
master
linguist/samples/Mercury/store.m

931 lines
29 KiB
Mathematica
Raw Permalink Blame History

%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et wm=0 tw=0
%-----------------------------------------------------------------------------%
% Copyright (C) 1994-1997, 2000-2008, 2010-2011 The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB in the Mercury distribution.
%-----------------------------------------------------------------------------%
%
% File: store.m.
% Main author: fjh.
% Stability: low.
%
% This file provides facilities for manipulating mutable stores.
% A store can be considered a mapping from abstract keys to their values.
% A store holds a set of nodes, each of which may contain a value of any
% type.
%
% Stores may be used to implement cyclic data structures such as circular
% linked lists, etc.
%
% Stores can have two different sorts of keys:
% mutable variables (mutvars) and references (refs).
% The difference between mutvars and refs is that mutvars can only be updated
% atomically, whereas it is possible to update individual fields of a
% reference one at a time (presuming the reference refers to a structured
% term).
%
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- module store.
:- interface.
:- import_module io.
%-----------------------------------------------------------------------------%
% Stores and keys are indexed by a type S of typeclass store(S) that
% is used to distinguish between different stores. By using an
% existential type declaration for store.new (see below), we use the
% type system to ensure at compile time that you never attempt to use
% a key from one store to access a different store.
%
:- typeclass store(T) where [].
:- type store(S).
:- instance store(io.state).
:- instance store(store(S)).
% Initialize a new store.
%
:- some [S] pred store.init(store(S)::uo) is det.
%-----------------------------------------------------------------------------%
%
% Mutvars
%
% generic_mutvar(T, S):
% A mutable variable holding a value of type T in store S.
%
:- type generic_mutvar(T, S).
:- type io_mutvar(T) == generic_mutvar(T, io.state).
:- type store_mutvar(T, S) == generic_mutvar(T, store(S)).
% Create a new mutable variable, initialized with the specified value.
%
:- pred store.new_mutvar(T::in, generic_mutvar(T, S)::out, S::di, S::uo)
is det <= store(S).
% copy_mutvar(OldMutvar, NewMutvar, S0, S) is equivalent to the sequence
% get_mutvar(OldMutvar, Value, S0, S1),
% new_mutvar(NewMutvar, Value, S1, S )
%
:- pred store.copy_mutvar(generic_mutvar(T, S)::in, generic_mutvar(T, S)::out,
S::di, S::uo) is det <= store(S).
% Lookup the value stored in a given mutable variable.
%
:- pred store.get_mutvar(generic_mutvar(T, S)::in, T::out,
S::di, S::uo) is det <= store(S).
% Replace the value stored in a given mutable variable.
%
:- pred store.set_mutvar(generic_mutvar(T, S)::in, T::in,
S::di, S::uo) is det <= store(S).
% new_cyclic_mutvar(Func, Mutvar):
%
% Create a new mutable variable, whose value is initialized
% with the value returned from the specified function `Func'.
% The argument passed to the function is the mutvar itself,
% whose value has not yet been initialized (this is safe
% because the function does not get passed the store, so
% it can't examine the uninitialized value).
%
% This predicate is useful for creating self-referential values
% such as circular linked lists.
% For example:
%
% :- type clist(T, S) ---> node(T, mutvar(clist(T, S))).
%
% :- pred init_cl(T::in, clist(T, S)::out,
% store(S)::di, store(S)::uo) is det.
%
% init_cl(X, CList, !Store) :-
% store.new_cyclic_mutvar(func(CL) = node(X, CL), CList,
% !Store).
%
:- pred store.new_cyclic_mutvar((func(generic_mutvar(T, S)) = T)::in,
generic_mutvar(T, S)::out, S::di, S::uo) is det <= store(S).
%-----------------------------------------------------------------------------%
%
% References
%
% generic_ref(T, S):
%
% A reference to value of type T in store S.
%
:- type generic_ref(T, S).
:- type io_ref(T, S) == generic_ref(T, io.state).
:- type store_ref(T, S) == generic_ref(T, store(S)).
% new_ref(Val, Ref):
% /* In C: Ref = malloc(...); *Ref = Val; */
%
% Given a value of any type `T', insert a copy of the term
% into the store and return a new reference to that term.
% (This does not actually perform a copy, it just returns a view
% of the representation of that value.
% It does however allocate one cell to hold the reference;
% you can use new_arg_ref to avoid that.)
%
:- pred store.new_ref(T::di, generic_ref(T, S)::out,
S::di, S::uo) is det <= store(S).
% ref_functor(Ref, Functor, Arity):
%
% Given a reference to a term, return the functor and arity
% of that term.
%
:- pred store.ref_functor(generic_ref(T, S)::in, string::out, int::out,
S::di, S::uo) is det <= store(S).
% arg_ref(Ref, ArgNum, ArgRef):
% /* Pseudo-C code: ArgRef = &Ref[ArgNum]; */
%
% Given a reference to a term, return a reference to
% the specified argument (field) of that term
% (argument numbers start from zero).
% It is an error if the argument number is out of range,
% or if the argument reference has the wrong type.
%
:- pred store.arg_ref(generic_ref(T, S)::in, int::in,
generic_ref(ArgT, S)::out, S::di, S::uo) is det <= store(S).
% new_arg_ref(Val, ArgNum, ArgRef):
% /* Pseudo-C code: ArgRef = &Val[ArgNum]; */
%
% Equivalent to `new_ref(Val, Ref), arg_ref(Ref, ArgNum, ArgRef)',
% except that it is more efficient.
% It is an error if the argument number is out of range,
% or if the argument reference has the wrong type.
%
:- pred store.new_arg_ref(T::di, int::in, generic_ref(ArgT, S)::out,
S::di, S::uo) is det <= store(S).
% set_ref(Ref, ValueRef):
% /* Pseudo-C code: *Ref = *ValueRef; */
%
% Given a reference to a term (Ref),
% a reference to another term (ValueRef),
% update the store so that the term referred to by Ref
% is replaced with the term referenced by ValueRef.
%
:- pred store.set_ref(generic_ref(T, S)::in, generic_ref(T, S)::in,
S::di, S::uo) is det <= store(S).
% set_ref_value(Ref, Value):
% /* Pseudo-C code: *Ref = Value; */
%
% Given a reference to a term (Ref), and a value (Value),
% update the store so that the term referred to by Ref
% is replaced with Value.
%
:- pred store.set_ref_value(generic_ref(T, S)::in, T::di,
S::di, S::uo) is det <= store(S).
% Given a reference to a term, return that term.
% Note that this requires making a copy, so this pred may
% be inefficient if used to return large terms; it
% is most efficient with atomic terms.
% XXX current implementation buggy (does shallow copy)
%
:- pred store.copy_ref_value(generic_ref(T, S)::in, T::uo,
S::di, S::uo) is det <= store(S).
% Same as above, but without making a copy. Destroys the store.
%
:- pred store.extract_ref_value(S::di, generic_ref(T, S)::in, T::out)
is det <= store(S).
%-----------------------------------------------------------------------------%
%
% Nasty performance hacks
%
% WARNING: use of these procedures is dangerous!
% Use them only as a last resort, only if performance is critical, and only if
% profiling shows that using the safe versions is a bottleneck.
%
% These procedures may vanish in some future version of Mercury.
% `unsafe_arg_ref' is the same as `arg_ref',
% and `unsafe_new_arg_ref' is the same as `new_arg_ref'
% except that they doesn't check for errors,
% and they don't work for `no_tag' types (types with
% exactly one functor which has exactly one argument),
% and they don't work for arguments which occupy a word with other
% arguments,
% and they don't work for types with >4 functors.
% If the argument number is out of range,
% or if the argument reference has the wrong type,
% or if the argument is a `no_tag' type,
% or if the argument uses a packed representation,
% then the behaviour is undefined, and probably harmful.
:- pred store.unsafe_arg_ref(generic_ref(T, S)::in, int::in,
generic_ref(ArgT, S)::out, S::di, S::uo) is det <= store(S).
:- pred store.unsafe_new_arg_ref(T::di, int::in, generic_ref(ArgT, S)::out,
S::di, S::uo) is det <= store(S).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module deconstruct.
:- import_module require.
:- instance store(store(S)) where [].
:- instance store(io.state) where [].
% The store type itself is just a dummy type,
% with no real representation.
:- type store(S).
:- pragma foreign_type("C", store(S), "MR_Word", [can_pass_as_mercury_type])
where equality is store_equal, comparison is store_compare.
:- pragma foreign_type("IL", store(S), "int32", [can_pass_as_mercury_type])
where equality is store_equal, comparison is store_compare.
:- pragma foreign_type("C#", store(S), "int", [can_pass_as_mercury_type])
where equality is store_equal, comparison is store_compare.
:- pragma foreign_type("Java", store(S), "int", [can_pass_as_mercury_type])
where equality is store_equal, comparison is store_compare.
:- pragma foreign_type("Erlang", store(S), "", [can_pass_as_mercury_type])
where equality is store_equal, comparison is store_compare.
:- pred store_equal(store(S)::in, store(S)::in) is semidet.
store_equal(_, _) :-
error("attempt to unify two stores").
:- pred store_compare(comparison_result::uo, store(S)::in, store(S)::in)
is det.
store_compare(_, _, _) :-
error("attempt to compare two stores").
% Mutvars and references are each represented as a pointer to a single word
% on the heap.
:- type generic_mutvar(T, S) ---> mutvar(private_builtin.ref(T)).
:- type generic_ref(T, S) ---> ref(private_builtin.ref(T)).
store.init(S) :-
store.do_init(S).
:- some [S] pred store.do_init(store(S)::uo) is det.
:- pragma foreign_proc("C",
store.do_init(_S0::uo),
[will_not_call_mercury, promise_pure, will_not_modify_trail],
"
TypeInfo_for_S = 0;
").
:- pragma foreign_proc("C#",
store.do_init(_S0::uo),
[will_not_call_mercury, promise_pure],
"
TypeInfo_for_S = null;
").
:- pragma foreign_proc("Java",
store.do_init(_S0::uo),
[will_not_call_mercury, promise_pure],
"
TypeInfo_for_S = null;
").
:- 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.
%
% :- op(.., xfx, ('<-')).
% :- op(.., fy, ('!')).
% :- op(.., xfx, (':=')).
%
% Then we could do something like this:
%
% Ptr <- new(Val) --> new_mutvar(Val, Ptr).
% Val <- !Ptr --> get_mutvar(Ptr, Val).
% !Ptr := Val --> set_mutvar(Ptr, Val).
%
% I wonder whether it is worth it? Hmm, probably not.
:- pragma foreign_proc("C",
new_mutvar(Val::in, Mutvar::out, S0::di, S::uo),
[will_not_call_mercury, promise_pure, will_not_modify_trail],
"
MR_offset_incr_hp_msg(Mutvar, MR_SIZE_SLOT_SIZE, MR_SIZE_SLOT_SIZE + 1,
MR_ALLOC_ID, ""store.mutvar/2"");
MR_define_size_slot(0, Mutvar, 1);
* (MR_Word *) Mutvar = Val;
S = S0;
").
:- pragma foreign_proc("C",
get_mutvar(Mutvar::in, Val::out, S0::di, S::uo),
[will_not_call_mercury, promise_pure, will_not_modify_trail],
"
Val = * (MR_Word *) Mutvar;
S = S0;
").
:- pragma foreign_proc("C",
set_mutvar(Mutvar::in, Val::in, S0::di, S::uo),
[will_not_call_mercury, promise_pure, will_not_modify_trail],
"
* (MR_Word *) Mutvar = Val;
S = S0;
").
:- pragma foreign_type("C#", generic_mutvar(T, S), "object[]").
:- pragma foreign_proc("C#",
new_mutvar(Val::in, Mutvar::out, _S0::di, _S::uo),
[will_not_call_mercury, promise_pure],
"
Mutvar = new object[] { Val };
").
:- pragma foreign_proc("C#",
get_mutvar(Mutvar::in, Val::out, _S0::di, _S::uo),
[will_not_call_mercury, promise_pure],
"
Val = Mutvar[0];
").
:- pragma foreign_proc("C#",
set_mutvar(Mutvar::in, Val::in, _S0::di, _S::uo),
[will_not_call_mercury, promise_pure],
"
Mutvar[0] = Val;
").
:- pragma foreign_type("Java", generic_mutvar(T, S), "mutvar.Mutvar").
:- pragma foreign_proc("Java",
new_mutvar(Val::in, Mutvar::out, _S0::di, _S::uo),
[will_not_call_mercury, promise_pure],
"
Mutvar = new mutvar.Mutvar(Val);
").
:- pragma foreign_proc("Java",
get_mutvar(Mutvar::in, Val::out, _S0::di, _S::uo),
[will_not_call_mercury, promise_pure],
"
Val = Mutvar.object;
").
:- pragma foreign_proc("Java",
set_mutvar(Mutvar::in, Val::in, _S0::di, _S::uo),
[will_not_call_mercury, promise_pure],
"
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).
:- pred store.unsafe_new_uninitialized_mutvar(generic_mutvar(T, S)::out,
S::di, S::uo) is det <= store(S).
:- pragma foreign_proc("C",
unsafe_new_uninitialized_mutvar(Mutvar::out, S0::di, S::uo),
[will_not_call_mercury, promise_pure, will_not_modify_trail],
"
MR_offset_incr_hp_msg(Mutvar, MR_SIZE_SLOT_SIZE, MR_SIZE_SLOT_SIZE + 1,
MR_ALLOC_ID, ""store.mutvar/2"");
MR_define_size_slot(0, Mutvar, 1);
S = S0;
").
:- pragma foreign_proc("C#",
unsafe_new_uninitialized_mutvar(Mutvar::out, _S0::di, _S::uo),
[will_not_call_mercury, promise_pure],
"
Mutvar = new object[1];
").
:- pragma foreign_proc("Java",
unsafe_new_uninitialized_mutvar(Mutvar::out, _S0::di, _S::uo),
[will_not_call_mercury, promise_pure],
"
Mutvar = new mutvar.Mutvar();
").
store.new_cyclic_mutvar(Func, MutVar, !Store) :-
store.unsafe_new_uninitialized_mutvar(MutVar, !Store),
Value = apply(Func, MutVar),
store.set_mutvar(MutVar, Value, !Store).
%-----------------------------------------------------------------------------%
:- pragma foreign_type("C#", generic_ref(T, S), "store.Ref").
:- pragma foreign_code("C#",
"
public class Ref {
// Object referenced.
public object obj;
// Specific field of object referenced, or null to
// specify the object itself.
// XXX GetFields does not return fields in any particular order so
// this is not really usable.
public System.Reflection.FieldInfo field;
// Constructors
public Ref(object init) {
obj = init;
field = null;
}
public Ref(object init, int num) {
obj = init;
setField(num);
}
// Set the field according to a given index.
public void setField(int num) {
field = obj.GetType().GetFields()[num];
}
// Return the value of the reference.
public object getValue() {
if (field == null) {
return obj;
} else {
return field.GetValue(obj);
}
}
// Update the value of the reference.
public void setValue(object value) {
field.SetValue(obj, value);
}
} // class Ref
").
:- pragma foreign_type(java, generic_ref(T, S), "store.Ref").
:- pragma foreign_code("Java",
"
public static class Ref {
// Object referenced.
public java.lang.Object object;
// Specific field of object referenced, or null to
// specify the object itself.
// XXX getDeclaredFields does not return fields in any particular
// order so this is not really usable.
public java.lang.reflect.Field field;
// Constructors
public Ref(java.lang.Object init) {
object = init;
field = null;
}
public Ref(java.lang.Object init, int num) {
object = init;
setField(num);
}
// Set the field according to a given index.
public void setField(int num) {
try {
field = object.getClass().getDeclaredFields()[num];
} catch (java.lang.SecurityException se) {
throw new java.lang.RuntimeException(
""Security manager denied access to object fields"");
} catch (java.lang.ArrayIndexOutOfBoundsException e) {
throw new java.lang.RuntimeException(
""No such field in object"");
} catch (java.lang.Exception e) {
throw new java.lang.RuntimeException(
""Unable to set field: "" + e.getMessage());
}
}
// Return the value of the reference.
public java.lang.Object getValue() {
if (field == null) {
return object;
} else {
try {
return field.get(object);
} catch (java.lang.IllegalAccessException e) {
throw new java.lang.RuntimeException(
""Field inaccessible"");
} catch (java.lang.IllegalArgumentException e)
{
throw new java.lang.RuntimeException(
""Field-object mismatch"");
} catch (java.lang.NullPointerException e) {
throw new java.lang.RuntimeException(
""Object is null"");
} catch (java.lang.Exception e) {
throw new java.lang.RuntimeException(
""Unable to access field: "" + e.getMessage());
}
}
}
// Update the value of the reference.
public void setValue(java.lang.Object value) {
try {
field.set(object, value);
} catch (java.lang.IllegalAccessException e) {
throw new java.lang.RuntimeException(""Field inaccessible"");
} catch (java.lang.IllegalArgumentException e) {
throw new java.lang.RuntimeException(
""Field-object mismatch"");
} catch (java.lang.NullPointerException e) {
throw new java.lang.RuntimeException(""Object is null"");
} catch (java.lang.Exception e) {
throw new java.lang.RuntimeException(
""Unable to access field: "" + e.getMessage());
}
}
} // class Ref
").
:- pragma foreign_proc("C",
new_ref(Val::di, Ref::out, S0::di, S::uo),
[will_not_call_mercury, promise_pure, will_not_modify_trail],
"
MR_offset_incr_hp_msg(Ref, MR_SIZE_SLOT_SIZE, MR_SIZE_SLOT_SIZE + 1,
MR_ALLOC_ID, ""store.ref/2"");
MR_define_size_slot(0, Ref, 1);
* (MR_Word *) Ref = Val;
S = S0;
").
:- pragma foreign_proc("C#",
new_ref(Val::di, Ref::out, _S0::di, _S::uo),
[will_not_call_mercury, promise_pure],
"
Ref = new store.Ref(Val);
").
:- pragma foreign_proc("Java",
new_ref(Val::di, Ref::out, _S0::di, _S::uo),
[will_not_call_mercury, promise_pure],
"
Ref = new 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).
% Unsafe_ref_value extracts the value that a reference refers to, without
% making a copy; it is unsafe because the store could later be modified,
% changing the returned value.
%
:- pred store.unsafe_ref_value(generic_ref(T, S)::in, T::uo,
S::di, S::uo) is det <= store(S).
:- 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],
"
Val = * (MR_Word *) Ref;
S = S0;
").
:- pragma foreign_proc("C#",
unsafe_ref_value(Ref::in, Val::uo, _S0::di, _S::uo),
[will_not_call_mercury, promise_pure],
"
Val = Ref.getValue();
").
:- pragma foreign_proc("Java",
unsafe_ref_value(Ref::in, Val::uo, _S0::di, _S::uo),
[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) :-
unsafe_ref_value(Ref, Val, !Store),
functor(Val, canonicalize, Functor, Arity).
:- pragma foreign_decl("C",
"
#include ""mercury_type_info.h""
#include ""mercury_heap.h""
#include ""mercury_misc.h"" /* for MR_fatal_error() */
#include ""mercury_deconstruct.h"" /* for MR_arg() */
").
:- pragma foreign_proc("C",
arg_ref(Ref::in, ArgNum::in, ArgRef::out, S0::di, S::uo),
[will_not_call_mercury, promise_pure, may_not_duplicate],
"{
MR_TypeInfo type_info;
MR_TypeInfo arg_type_info;
MR_TypeInfo exp_arg_type_info;
MR_Word *arg_ref;
const MR_DuArgLocn *arg_locn;
type_info = (MR_TypeInfo) TypeInfo_for_T;
exp_arg_type_info = (MR_TypeInfo) TypeInfo_for_ArgT;
MR_save_transient_registers();
if (!MR_arg(type_info, (MR_Word *) Ref, ArgNum, &arg_type_info,
&arg_ref, &arg_locn, MR_NONCANON_ABORT))
{
MR_fatal_error(""store.arg_ref: argument number out of range"");
}
if (MR_compare_type_info(arg_type_info, exp_arg_type_info) !=
MR_COMPARE_EQUAL)
{
MR_fatal_error(""store.arg_ref: argument has wrong type"");
}
MR_restore_transient_registers();
if (arg_locn != NULL && arg_locn->MR_arg_bits != 0) {
MR_offset_incr_hp_msg(ArgRef, MR_SIZE_SLOT_SIZE,
MR_SIZE_SLOT_SIZE + 1, MR_ALLOC_ID, ""store.ref/2"");
MR_define_size_slot(0, ArgRef, 1);
* (MR_Word *) ArgRef = MR_arg_value(arg_ref, arg_locn);
} else {
ArgRef = (MR_Word) arg_ref;
}
S = S0;
}").
:- pragma foreign_proc("C#",
arg_ref(Ref::in, ArgNum::in, ArgRef::out, _S0::di, _S::uo),
[will_not_call_mercury, promise_pure],
"
/*
** XXX Some dynamic type-checking should be done here to check that
** the type of the specified Arg matches the type supplied by the caller.
** This will require RTTI.
*/
ArgRef = new store.Ref(Ref.getValue(), ArgNum);
").
:- pragma foreign_proc("Java",
arg_ref(Ref::in, ArgNum::in, ArgRef::out, _S0::di, _S::uo),
[will_not_call_mercury, promise_pure],
"
/*
** XXX Some dynamic type-checking should be done here to check that
** the type of the specified Arg matches the type supplied by the caller.
** This will require RTTI.
*/
ArgRef = new store.Ref(Ref.getValue(), ArgNum);
").
:- pragma foreign_proc("C",
new_arg_ref(Val::di, ArgNum::in, ArgRef::out, S0::di, S::uo),
[will_not_call_mercury, promise_pure, may_not_duplicate],
"{
MR_TypeInfo type_info;
MR_TypeInfo arg_type_info;
MR_TypeInfo exp_arg_type_info;
MR_Word *arg_ref;
const MR_DuArgLocn *arg_locn;
type_info = (MR_TypeInfo) TypeInfo_for_T;
exp_arg_type_info = (MR_TypeInfo) TypeInfo_for_ArgT;
MR_save_transient_registers();
if (!MR_arg(type_info, (MR_Word *) &Val, ArgNum, &arg_type_info,
&arg_ref, &arg_locn, MR_NONCANON_ABORT))
{
MR_fatal_error(""store.new_arg_ref: argument number out of range"");
}
if (MR_compare_type_info(arg_type_info, exp_arg_type_info) !=
MR_COMPARE_EQUAL)
{
MR_fatal_error(""store.new_arg_ref: argument has wrong type"");
}
MR_restore_transient_registers();
if (arg_locn != NULL && arg_locn->MR_arg_bits != 0) {
MR_offset_incr_hp_msg(ArgRef, MR_SIZE_SLOT_SIZE,
MR_SIZE_SLOT_SIZE + 1, MR_ALLOC_ID, ""store.ref/2"");
MR_define_size_slot(0, ArgRef, 1);
* (MR_Word *) ArgRef = MR_arg_value(arg_ref, arg_locn);
} else if (arg_ref == &Val) {
/*
** For no_tag types, the argument may have the same address as the
** term. Since the term (Val) is currently on the C stack, we can't
** return a pointer to it; so if that is the case, then we need
** to copy it to the heap before returning.
*/
MR_offset_incr_hp_msg(ArgRef, MR_SIZE_SLOT_SIZE,
MR_SIZE_SLOT_SIZE + 1, MR_ALLOC_ID, ""store.ref/2"");
MR_define_size_slot(0, ArgRef, 1);
* (MR_Word *) ArgRef = Val;
} else {
ArgRef = (MR_Word) arg_ref;
}
S = S0;
}").
:- pragma foreign_proc("C#",
new_arg_ref(Val::di, ArgNum::in, ArgRef::out, _S0::di, _S::uo),
[will_not_call_mercury, promise_pure],
"
/*
** XXX Some dynamic type-checking should be done here to check that
** the type of the specified Arg matches the type supplied by the caller.
** This will require RTTI.
*/
ArgRef = new store.Ref(Val, ArgNum);
").
:- pragma foreign_proc("Java",
new_arg_ref(Val::di, ArgNum::in, ArgRef::out, _S0::di, _S::uo),
[will_not_call_mercury, promise_pure],
"
/*
** XXX Some dynamic type-checking should be done here to check that
** the type of the specified Arg matches the type supplied by the caller.
** This will require RTTI.
*/
ArgRef = new store.Ref(Val, ArgNum);
").
:- pragma foreign_proc("C",
set_ref(Ref::in, ValRef::in, S0::di, S::uo),
[will_not_call_mercury, promise_pure],
"
* (MR_Word *) Ref = * (MR_Word *) ValRef;
S = S0;
").
:- pragma foreign_proc("C#",
set_ref(Ref::in, ValRef::in, _S0::di, _S::uo),
[will_not_call_mercury, promise_pure],
"
Ref.setValue(ValRef.getValue());
").
:- pragma foreign_proc("Java",
set_ref(Ref::in, ValRef::in, _S0::di, _S::uo),
[will_not_call_mercury, promise_pure],
"
Ref.setValue(ValRef.getValue());
").
:- pragma foreign_proc("C",
set_ref_value(Ref::in, Val::di, S0::di, S::uo),
[will_not_call_mercury, promise_pure],
"
* (MR_Word *) Ref = Val;
S = S0;
").
:- pragma foreign_proc("Java",
set_ref_value(Ref::in, Val::di, _S0::di, _S::uo),
[will_not_call_mercury, promise_pure],
"
Ref.setValue(Val);
").
:- pragma foreign_proc("C",
extract_ref_value(_S::di, Ref::in, Val::out),
[will_not_call_mercury, promise_pure],
"
Val = * (MR_Word *) Ref;
").
:- pragma foreign_proc("C#",
extract_ref_value(_S::di, Ref::in, Val::out),
[will_not_call_mercury, promise_pure],
"
Val = Ref.getValue();
").
:- pragma foreign_proc("Java",
extract_ref_value(_S::di, Ref::in, Val::out),
[will_not_call_mercury, promise_pure],
"
Val = Ref.getValue();
").
%-----------------------------------------------------------------------------%
:- pragma foreign_proc("C",
unsafe_arg_ref(Ref::in, Arg::in, ArgRef::out, S0::di, S::uo),
[will_not_call_mercury, promise_pure],
"{
/* unsafe - does not check type & arity, won't handle no_tag types */
MR_Word *Ptr;
Ptr = (MR_Word *) MR_strip_tag((MR_Word) Ref);
ArgRef = (MR_Word) &Ptr[Arg];
S = S0;
}").
:- pragma foreign_proc("C#",
unsafe_arg_ref(Ref::in, Arg::in, ArgRef::out, _S0::di, _S::uo),
[will_not_call_mercury, promise_pure],
"
ArgRef = new store.Ref(Ref.getValue(), Arg);
").
:- pragma foreign_proc("Java",
unsafe_arg_ref(Ref::in, Arg::in, ArgRef::out, _S0::di, _S::uo),
[will_not_call_mercury, promise_pure],
"
ArgRef = new store.Ref(Ref.getValue(), Arg);
").
:- pragma foreign_proc("C",
unsafe_new_arg_ref(Val::di, Arg::in, ArgRef::out, S0::di, S::uo),
[will_not_call_mercury, promise_pure],
"{
/* unsafe - does not check type & arity, won't handle no_tag types */
MR_Word *Ptr;
Ptr = (MR_Word *) MR_strip_tag((MR_Word) Val);
ArgRef = (MR_Word) &Ptr[Arg];
S = S0;
}").
:- pragma foreign_proc("C#",
unsafe_new_arg_ref(Val::di, Arg::in, ArgRef::out, _S0::di, _S::uo),
[will_not_call_mercury, promise_pure],
"
ArgRef = new store.Ref(Val, Arg);
").
:- pragma foreign_proc("Java",
unsafe_new_arg_ref(Val::di, Arg::in, ArgRef::out, _S0::di, _S::uo),
[will_not_call_mercury, promise_pure],
"
ArgRef = new store.Ref(Val, Arg);
").
Reference in New Issue View Git Blame Copy Permalink