Merge pull request #1098 from github/1049-update

1049 update

lib/linguist/languages.yml

@@ -872,6 +872,9 @@ INI:
   - .properties
   primary_extension: .ini
   
+Inno Setup:
+  primary_extension: .iss
+
 Idris:
   type: programming
   lexer: Text only
@@ -1173,6 +1176,18 @@ MediaWiki:
   wrap: true
   primary_extension: .mediawiki
 
+Mercury:
+  type: programming
+  # This is the background colour on the web page.
+  color: "#abcdef"
+  # The primary extension is .m, but lingist won't accept duplicates
+  primary_extension: .mercury
+  # Mercury's syntax is not prolog syntax, but they do share the lexer
+  lexer: Prolog
+  extensions:
+  - .m
+  - .moo
+
 MiniD: # Legacy
   searchable: false
   primary_extension: .minid # Dummy extension

lib/linguist/vendor.yml

@@ -186,3 +186,6 @@
 
 # .DS_Store's
 - .[Dd][Ss]_[Ss]tore$
+
+# Mercury --use-subdirs
+- Mercury/

samples/Mercury/expr.moo

@@ -0,0 +1,72 @@
+:- module expr.
+
+:- interface.
+
+:- import_module char, int, list.
+
+:- type token
+	--->	('+')
+	;	('-')
+	;	('*')
+	;	('/')
+	;	num(int)
+	;	('(')
+	;	(')')
+	;	eof
+	.
+
+:- parse(exprn/1, token, eof, xx, in, out).
+
+:- pred scan(list(char), list(token)).
+:- mode scan(in, out) is det.
+
+:- implementation.
+
+:- import_module string, require.
+
+:- rule exprn(int).
+exprn(Num)	--->	exprn(A), [+], term(B), { Num = A + B }.
+exprn(Num)	--->	exprn(A), [-], term(B), { Num = A - B }.
+exprn(Num)	--->	term(Num).
+
+:- rule term(int).
+term(Num)	--->	term(A), [*], factor(B), { Num = A * B }.
+term(Num)	--->	term(A), [/], factor(B), { Num = A // B }.
+term(Num)	--->	factor(Num).
+
+:- rule factor(int).
+factor(Num)	--->	['('], exprn(Num), [')'].
+factor(Num)	--->	[num(Num)].
+
+scan(Chars, Toks) :-
+	scan(Chars, [], Toks0),
+	list__reverse(Toks0, Toks).
+
+:- pred scan(list(char), list(token), list(token)).
+:- mode scan(in, in, out) is det.
+
+scan([], Toks, [eof|Toks]).
+scan([C|Cs], Toks0, Toks) :-
+	( char__is_whitespace(C) ->
+		scan(Cs, Toks0, Toks)
+	; char__is_digit(C) ->
+		takewhile(char__is_digit, [C|Cs], Digits, Rest),
+		string__from_char_list(Digits, NumStr),
+		Num = string__det_to_int(NumStr),
+		scan(Rest, [num(Num)|Toks0], Toks)
+	; C = ('+') ->
+		scan(Cs, ['+'|Toks0], Toks)
+	; C = ('-') ->
+		scan(Cs, ['-'|Toks0], Toks)
+	; C = ('*') ->
+		scan(Cs, ['*'|Toks0], Toks)
+	; C = ('/') ->
+		scan(Cs, ['/'|Toks0], Toks)
+	; C = ('(') ->
+		scan(Cs, ['('|Toks0], Toks)
+	; C = (')') ->
+		scan(Cs, [')'|Toks0], Toks)
+	;
+		error("expr: syntax error in input")
+	).
+

samples/Mercury/hello.m

@@ -0,0 +1,14 @@
+% "Hello World" in Mercury.
+
+% This source file is hereby placed in the public domain.  -fjh (the author).
+
+:- module hello.
+:- interface.
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+:- implementation.
+
+main(!IO) :-
+	io.write_string("Hello, world\n", !IO).

samples/Mercury/rot13_concise.m

@@ -0,0 +1,58 @@
+% File: rot13_concise.m
+% Main authors: Warwick Harvey <wharvey@cs.monash.edu.au>
+%               Fergus Henderson <fjh@cs.mu.oz.au>
+%
+% rot13_concise:
+%
+% Program to read its input, apply the rot13 algorithm, and write it out
+% again.
+%
+% This version is more concise (but less efficient) than its companion,
+% rot13_verbose.
+%
+% Key features:
+% - is independent of character set (e.g. ASCII, EBCDIC)
+% - has proper error handling
+%
+
+:- module rot13_concise.
+
+:- interface.
+:- import_module io.
+
+:- pred main(state, state).
+:- mode main(di, uo) is det.
+
+:- implementation.
+:- import_module char, int, string.
+
+% The length of `alphabet' should be a multiple of `cycle'.
+alphabet = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ".
+cycle = 26.
+
+rot_n(N, Char) = RotChar :-
+	char_to_string(Char, CharString),
+	( if sub_string_search(alphabet, CharString, Index) then
+		NewIndex = (Index + N) mod cycle + cycle * (Index // cycle),
+		index_det(alphabet, NewIndex, RotChar)
+	else
+		RotChar = Char
+	).
+
+rot13(Char) = rot_n(13, Char).
+
+main -->
+	read_char(Res),
+	( { Res = ok(Char) },
+		print(rot13(Char)),
+		main
+	; { Res = eof }
+	; { Res = error(ErrorCode) },
+		{ error_message(ErrorCode, ErrorMessage) },
+		stderr_stream(StdErr),
+		print(StdErr, "rot13: error reading input: "),
+		print(StdErr, ErrorMessage),
+		nl(StdErr)
+	).
+
+

samples/Mercury/rot13_ralph.m

@@ -0,0 +1,50 @@
+% ---------------------------------------------------------------------------- %
+% rot13_ralph.m
+% Copyright (C) 2001 Ralph Becket <rbeck@microsoft.com>
+% Tue Jan  9 18:10:44 GMT 2001
+% vim: ts=4 sw=4 et tw=0 wm=0 ff=unix ft=mercury
+%
+% Short and sweet.
+%
+% ---------------------------------------------------------------------------- %
+
+:- module rot13_ralph.
+
+:- interface.
+
+:- import_module io.
+
+
+
+:- pred main(io__state::di, io__state::uo) is det.
+
+% ---------------------------------------------------------------------------- %
+% ---------------------------------------------------------------------------- %
+
+:- implementation.
+
+:- import_module int, require.
+
+% ---------------------------------------------------------------------------- %
+
+main -->
+    io__read_byte(Result),
+    (   { Result = ok(X) },         io__write_byte(rot13(X)), main
+    ;   { Result = eof }
+    ;   { Result = error(ErrNo)},   { error(io__error_message(ErrNo)) }
+    ).
+
+% ---------------------------------------------------------------------------- %
+
+:- func rot13(int) = int.
+
+rot13(X) =
+    (      if 0'a =< X, X =< 0'z then Rot13(X, 0'a)
+      else if 0'A =< X, X =< 0'Z then Rot13(X, 0'A)
+      else X
+    )
+ :-
+    Rot13 = ( func(C, A) = ((13 + C - A) `rem` 26) + A ).
+
+% ---------------------------------------------------------------------------- %
+% ---------------------------------------------------------------------------- %

samples/Mercury/rot13_verbose.m

@@ -0,0 +1,116 @@
+% File: rot13_verbose.m
+% Main author: Warwick Harvey <wharvey@cs.monash.edu.au>
+% Additional input: Fergus Henderson <fjh@cs.mu.oz.au>
+
+%
+% rot13_verbose:
+%
+% Program to read its input, apply the rot13 algorithm, and write it out
+% again.
+%
+% This version is more verbose (and more efficient) than its companion,
+% rot13_concise.
+%
+% Key features:
+% - is independent of character set (e.g. ASCII, EBCDIC)
+% - has proper error handling
+% - reasonably efficient (uses a table to do the rotation)
+%
+
+:- module rot13_verbose.
+
+:- interface.
+:- import_module io.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+:- implementation.
+:- import_module char, int, require.
+
+	% rot13a/2
+	% A table to map the alphabetic characters to their rot13 equivalents
+	% (fails if the input is not alphabetic).
+:- pred rot13a(char, char).
+:- mode rot13a(in, out) is semidet.
+
+rot13a('a', 'n').
+rot13a('b', 'o').
+rot13a('c', 'p').
+rot13a('d', 'q').
+rot13a('e', 'r').
+rot13a('f', 's').
+rot13a('g', 't').
+rot13a('h', 'u').
+rot13a('i', 'v').
+rot13a('j', 'w').
+rot13a('k', 'x').
+rot13a('l', 'y').
+rot13a('m', 'z').
+rot13a('n', 'a').
+rot13a('o', 'b').
+rot13a('p', 'c').
+rot13a('q', 'd').
+rot13a('r', 'e').
+rot13a('s', 'f').
+rot13a('t', 'g').
+rot13a('u', 'h').
+rot13a('v', 'i').
+rot13a('w', 'j').
+rot13a('x', 'k').
+rot13a('y', 'l').
+rot13a('z', 'm').
+rot13a('A', 'N').
+rot13a('B', 'O').
+rot13a('C', 'P').
+rot13a('D', 'Q').
+rot13a('E', 'R').
+rot13a('F', 'S').
+rot13a('G', 'T').
+rot13a('H', 'U').
+rot13a('I', 'V').
+rot13a('J', 'W').
+rot13a('K', 'X').
+rot13a('L', 'Y').
+rot13a('M', 'Z').
+rot13a('N', 'A').
+rot13a('O', 'B').
+rot13a('P', 'C').
+rot13a('Q', 'D').
+rot13a('R', 'E').
+rot13a('S', 'F').
+rot13a('T', 'G').
+rot13a('U', 'H').
+rot13a('V', 'I').
+rot13a('W', 'J').
+rot13a('X', 'K').
+rot13a('Y', 'L').
+rot13a('Z', 'M').
+
+	% rot13/2
+	% Applies the rot13 algorithm to a character.
+:- pred rot13(char, char).
+:- mode rot13(in, out) is det.
+
+rot13(Char, RotChar) :-
+	( if rot13a(Char, TmpChar) then
+		RotChar = TmpChar
+	else
+		RotChar = Char
+	).
+
+main -->
+	io__read_char(Res),
+	( { Res = ok(Char) },
+		{ rot13(Char, RotChar) },
+		io__write_char(RotChar),
+		main
+	; { Res = eof }
+	; { Res = error(ErrorCode) },
+		{ io__error_message(ErrorCode, ErrorMessage) },
+		io__stderr_stream(StdErr),
+		io__write_string(StdErr, "rot13: error reading input: "),
+		io__write_string(StdErr, ErrorMessage),
+		io__nl(StdErr)
+	).
+

samples/Mercury/store.m

@@ -0,0 +1,930 @@
+%-----------------------------------------------------------------------------%
+% 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);
+").

samples/Moocode/hello.moo

@@ -0,0 +1,5 @@
+@program toy:wind
+this.wound = this.wound + 2;
+player:tell("You wind up the ", this.name,".");
+player.location:announce(player.name, " winds up the ", this.name,".");
+.

samples/Moocode/toy.moo

@@ -0,0 +1,19 @@
+@verb toy:do_the_work this none this
+@program toy:do_the_work
+if (this.wound)
+  if ($object_utils:isa(this.location,$room))
+    this.location:announce_all(this.name," ", this:continue_msg());
+    this.wound = this.wound - 1;
+    if (this.wound)
+      fork (15)
+        this:do_the_work();
+      endfork
+    else
+      this.location:announce_all(this.name, " ", this:wind_down_msg());
+    endif
+  endif
+  if (this.wound < 0)
+    this.wound = 0;
+  endif
+endif
+.