KevinMidboe/linguist
1
0
Fork 0
mirror of https://github.com/KevinMidboe/linguist.git synced 2025-10-29 17:50:22 +00:00
Code Issues Packages Projects Releases Wiki Activity

Included store.m in Mercury/samples, now 100% coverage in Mercury library/ and compiler/

Browse Source
This commit is contained in:
Sebastian Godelet
2014-04-06 20:00:21 +02:00
parent 8b39d30a6e
commit fa9660d5a1
2 changed files with 1304 additions and 69 deletions
Download Patch File Download Diff File Expand all files Collapse all files

443
lib/linguist/samples.json
View File

@@ -563,8 +563,8 @@
"zshrc"
]
},
"tokens_total": 481534,
"languages_total": 560,
"tokens_total": 484777,
"languages_total": 561,
"tokens": {
"Groovy": {
"SHEBANG#!groovy": 1,
@@ -36958,66 +36958,66 @@
"time": 1
},
"Mercury": {
"%": 363,
"-": 6240,
"module": 44,
"%": 416,
"-": 6914,
"module": 45,
"rot13_verbose.": 1,
"interface.": 11,
"import_module": 121,
"io.": 7,
"pred": 232,
"interface.": 12,
"import_module": 124,
"io.": 8,
"pred": 253,
"main": 15,
"(": 3101,
"(": 3284,
"io__state": 4,
")": 3099,
".": 544,
")": 3284,
".": 592,
"mode": 6,
"di": 5,
"uo": 5,
"is": 199,
"det.": 180,
"di": 54,
"uo": 58,
"is": 244,
"det.": 182,
"implementation.": 11,
"char": 7,
"int": 113,
"int": 124,
"require.": 5,
"rot13a/2": 1,
"A": 6,
"table": 1,
"to": 4,
"to": 16,
"map": 7,
"the": 4,
"the": 27,
"alphabetic": 2,
"characters": 1,
"their": 1,
"rot13": 11,
"equivalents": 1,
"fails": 1,
"if": 4,
"if": 15,
"input": 1,
"not": 1,
"not": 7,
"rot13a": 55,
"in": 457,
"out": 303,
"in": 506,
"out": 334,
"semidet.": 10,
"rot13/2": 1,
"Applies": 1,
"algorithm": 1,
"a": 1,
"a": 10,
"character.": 1,
"Char": 12,
"RotChar": 8,
"TmpChar": 2,
"then": 3,
"else": 3,
"else": 8,
"io__read_char": 1,
"Res": 8,
"{": 13,
"{": 23,
"ok": 3,
"}": 13,
"}": 24,
"io__write_char": 1,
";": 848,
";": 898,
"eof": 3,
"error": 4,
"error": 6,
"ErrorCode": 4,
"io__error_message": 2,
"ErrorMessage": 4,
@@ -37026,11 +37026,11 @@
"io__write_string": 2,
"io__nl": 1,
"hello.": 1,
"io": 5,
"io": 6,
"IO": 4,
"io.write_string": 1,
"rot13_concise.": 1,
"state": 2,
"state": 3,
"string.": 7,
"alphabet": 3,
"cycle": 4,
@@ -37041,9 +37041,9 @@
"sub_string_search": 1,
"Index": 3,
"NewIndex": 2,
"+": 122,
"+": 125,
"mod": 1,
"*": 1,
"*": 18,
"//": 1,
"index_det": 1,
"read_char": 1,
@@ -37051,18 +37051,353 @@
"error_message": 1,
"stderr_stream": 1,
"nl": 1,
"store.": 1,
"typeclass": 1,
"store": 52,
"T": 52,
"where": 8,
"[": 184,
"]": 184,
"type": 56,
"S": 133,
"instance": 4,
"io.state": 3,
"some": 4,
"store.init": 2,
"generic_mutvar": 15,
"io_mutvar": 1,
"store_mutvar": 1,
"store.new_mutvar": 1,
"det": 21,
"<": 14,
"store.copy_mutvar": 1,
"store.get_mutvar": 1,
"store.set_mutvar": 1,
"<=>": 5,
"new_cyclic_mutvar": 2,
"Func": 4,
"Mutvar": 23,
"Create": 1,
"new": 25,
"mutable": 3,
"variable": 1,
"whose": 2,
"value": 16,
"initialized": 2,
"with": 5,
"returned": 1,
"from": 1,
"specified": 1,
"function": 3,
"The": 2,
"argument": 6,
"passed": 2,
"mutvar": 6,
"itself": 4,
"has": 4,
"yet": 1,
"been": 1,
"this": 4,
"safe": 2,
"because": 1,
"does": 3,
"get": 2,
"so": 3,
"it": 1,
"can": 1,
"t": 5,
"examine": 1,
"uninitialized": 1,
"This": 2,
"predicate": 1,
"useful": 1,
"for": 8,
"creating": 1,
"self": 1,
"referential": 1,
"values": 1,
"such": 2,
"as": 5,
"circular": 1,
"linked": 1,
"lists": 1,
"For": 1,
"example": 1,
"clist": 2,
"node": 1,
"store.new_cyclic_mutvar": 1,
"func": 24,
"generic_ref": 20,
"io_ref": 1,
"store_ref": 1,
"store.new_ref": 1,
"store.ref_functor": 1,
"string": 114,
"store.arg_ref": 1,
"ArgT": 4,
"store.new_arg_ref": 3,
"store.set_ref": 1,
"store.set_ref_value": 1,
"store.copy_ref_value": 1,
"store.extract_ref_value": 1,
"Nasty": 1,
"performance": 2,
"hacks": 1,
"WARNING": 1,
"use": 1,
"of": 10,
"these": 1,
"procedures": 2,
"dangerous": 1,
"Use": 1,
"them": 1,
"only": 4,
"last": 1,
"resort": 1,
"critical": 1,
"and": 6,
"profiling": 5,
"shows": 1,
"that": 2,
"using": 1,
"versions": 1,
"bottleneck": 1,
"These": 1,
"may": 1,
"vanish": 1,
"future": 1,
"version": 3,
"Mercury": 1,
"unsafe_arg_ref": 1,
"same": 2,
"arg_ref": 12,
"unsafe_new_arg_ref": 1,
"new_arg_ref": 1,
"except": 1,
"they": 4,
"doesn": 1,
"check": 1,
"errors": 1,
"don": 3,
"work": 3,
"no_tag": 1,
"types": 3,
"exactly": 2,
"one": 2,
"functor": 2,
"which": 2,
"arguments": 2,
"occupy": 1,
"word": 2,
"other": 1,
"functors.": 1,
"store.unsafe_arg_ref": 1,
"store.unsafe_new_arg_ref": 1,
"implementation": 1,
"deconstruct": 2,
"require": 1,
"just": 1,
"dummy": 2,
"no": 365,
"real": 1,
"representation": 1,
"pragma": 41,
"foreign_type": 10,
"C": 24,
"MR_Word": 24,
"can_pass_as_mercury_type": 5,
"equality": 5,
"store_equal": 7,
"comparison": 5,
"store_compare": 7,
"IL": 2,
"int32": 1,
"Java": 12,
"Erlang": 3,
"semidet": 2,
"_": 149,
"attempt": 2,
"unify": 21,
"two": 2,
"stores": 2,
"comparison_result": 1,
"compare": 1,
"Mutvars": 1,
"references": 1,
"are": 1,
"each": 1,
"represented": 1,
"pointer": 1,
"single": 1,
"on": 1,
"heap": 1,
"private_builtin.ref": 2,
"ref": 2,
"store.do_init": 6,
"foreign_proc": 28,
"_S0": 16,
"will_not_call_mercury": 28,
"promise_pure": 30,
"will_not_modify_trail": 7,
"new_mutvar": 5,
"Val": 45,
"S0": 23,
"get_mutvar": 5,
"set_mutvar": 5,
"_S": 12,
"copy_mutvar": 1,
"Copy": 2,
"Value": 4,
"store.unsafe_new_uninitialized_mutvar": 1,
"unsafe_new_uninitialized_mutvar": 4,
"MR_offset_incr_hp_msg": 5,
"MR_SIZE_SLOT_SIZE": 10,
"1": 5,
"MR_ALLOC_ID": 5,
"2": 2,
"MR_define_size_slot": 5,
"0": 2,
"object": 21,
"MutVar": 4,
"Store": 5,
"apply": 1,
"Ref": 41,
"foreign_code": 2,
"public": 17,
"class": 4,
"Object": 9,
"referenced": 4,
"obj": 7,
"Specific": 2,
"field": 20,
"or": 2,
"null": 8,
"specify": 2,
"XXX": 3,
"GetFields": 2,
"return": 6,
"fields": 3,
"any": 2,
"particular": 2,
"order": 2,
"really": 2,
"usable": 2,
"System": 1,
"Reflection": 1,
"FieldInfo": 1,
"Constructors": 2,
"init": 8,
"num": 8,
"setField": 4,
"Set": 2,
"according": 2,
"given": 2,
"index": 2,
"void": 4,
"GetType": 1,
"Return": 6,
"reference": 4,
"getValue": 4,
"GetValue": 1,
"Update": 2,
"setValue": 2,
"SetValue": 1,
"java": 35,
"static": 1,
"lang": 28,
"getDeclaredFields": 2,
"reflect": 1,
"Field": 5,
"try": 3,
"getClass": 1,
"catch": 11,
"SecurityException": 1,
"se": 1,
"throw": 11,
"RuntimeException": 11,
"Security": 1,
"manager": 1,
"denied": 1,
"access": 3,
"ArrayIndexOutOfBoundsException": 1,
"e": 13,
"No": 1,
"Exception": 3,
"Unable": 3,
"set": 16,
"getMessage": 3,
"IllegalAccessException": 2,
"inaccessible": 2,
"IllegalArgumentException": 2,
"mismatch": 2,
"NullPointerException": 2,
"new_ref": 4,
"ets": 3,
"insert": 1,
"copy_ref_value": 1,
"unsafe_ref_value": 6,
"store.unsafe_ref_value": 1,
"lookup": 1,
"ref_functor": 1,
"Functor": 6,
"Arity": 5,
"canonicalize": 1,
"foreign_decl": 1,
"include": 4,
"mercury_type_info": 1,
"h": 4,
"mercury_heap": 1,
"mercury_misc": 1,
"MR_fatal_error": 5,
"mercury_deconstruct": 1,
"MR_arg": 3,
"ArgNum": 7,
"ArgRef": 22,
"may_not_duplicate": 1,
"MR_TypeInfo": 10,
"type_info": 8,
"arg_type_info": 6,
"exp_arg_type_info": 6,
"const": 10,
"MR_DuArgLocn": 2,
"arg_locn": 9,
"TypeInfo_for_T": 2,
"TypeInfo_for_ArgT": 2,
"MR_save_transient_registers": 2,
"MR_NONCANON_ABORT": 2,
"number": 2,
"range": 2,
"MR_compare_type_info": 2,
"MR_COMPARE_EQUAL": 2,
"wrong": 2,
"MR_restore_transient_registers": 2,
"NULL": 2,
"MR_arg_bits": 2,
"store.ref/2": 3,
"MR_arg_value": 2,
"C#": 6,
"store.Ref": 8,
"Ref.getValue": 6,
"*arg_ref": 1,
"*arg_locn": 1,
"&": 7,
"&&": 1,
"ValRef": 1,
"Ref.setValue": 3,
"ValRef.getValue": 2,
"*Ptr": 2,
"Ptr": 4,
"MR_strip_tag": 2,
"Arg": 6,
"rot13_ralph.": 1,
"io__read_byte": 1,
"Result": 4,
"X": 9,
"io__write_byte": 1,
"ErrNo": 2,
"func": 23,
"int.": 4,
"z": 1,
"Rot13": 2,
"<": 2,
"C": 6,
"rem": 1,
"check_hlds.polymorphism.": 1,
"hlds.": 1,
@@ -37101,7 +37436,6 @@
"polymorphism_make_type_info_vars": 1,
"term.context": 3,
"polymorphism_make_type_info_var": 1,
"type": 41,
"int_or_var": 2,
"iov_int": 1,
"iov_var": 1,
@@ -37134,7 +37468,6 @@
"type_ctor": 1,
"cons_id": 2,
"type_info_kind": 2,
"type_info": 2,
"type_ctor_info.": 1,
"new_type_info_var_raw": 1,
"check_hlds.clause_to_proc.": 1,
@@ -37192,8 +37525,6 @@
"pred_info_orig_arity": 3,
"no_type_info_builtin": 3,
"copy_module_clauses_to_procs": 1,
"[": 163,
"]": 163,
"polymorphism_process_pred_msg": 3,
"PredTable0": 3,
"map.lookup": 2,
@@ -37216,7 +37547,6 @@
"ArgTypes": 6,
"pred_info_set_arg_types": 1,
"PredInfo1": 5,
"_": 144,
"|": 28,
"OldHeadVarTypes": 2,
"type_list_subsumes": 2,
@@ -37234,7 +37564,6 @@
"map.map_values_only": 1,
".ProcInfo": 2,
"ProcInfo": 43,
"det": 3,
"introduce_exists_casts_proc": 1,
"Procs": 4,
"pred_info_set_procedures": 2,
@@ -37243,14 +37572,11 @@
"flag": 4,
"write_pred_progress_message": 1,
"polymorphism_process_pred": 4,
"mutable": 2,
"selected_pred": 1,
"bool": 406,
"no": 364,
"ground": 9,
"untrailed": 2,
"level": 1,
"promise_pure": 2,
"pred_id_to_int": 1,
"impure": 2,
"set_selected_pred": 2,
@@ -37306,8 +37632,6 @@
"ClausesRep": 2,
"map.init": 7,
"TVarNameMap": 2,
"This": 1,
"only": 1,
"used": 2,
"while": 1,
"adding": 1,
@@ -37452,7 +37776,6 @@
"poly_arg_vector_set_exist_type_infos": 1,
"poly_arg_vector_set_univ_typeclass_infos": 1,
"poly_arg_vector_set_exist_typeclass_infos": 1,
"some": 1,
"ToLocn": 4,
"TheVar": 2,
"TheLocn": 2,
@@ -37525,7 +37848,6 @@
"Call": 4,
"call_foreign_proc": 4,
"polymorphism_process_foreign_proc": 3,
"unify": 20,
"XVar": 11,
"Y": 9,
"Mode": 12,
@@ -37688,14 +38010,12 @@
".Unification": 5,
"complicated_unify": 2,
"construct": 1,
"deconstruct": 1,
"assign": 46,
"simple_test": 1,
"X0": 8,
"ConsId0": 5,
"Mode0": 4,
"TypeOfX": 6,
"Arity": 3,
"closure_cons": 1,
"ShroudedPredProcId": 2,
"proc": 2,
@@ -37722,7 +38042,6 @@
"UnifyExpr": 2,
"Unify": 2,
"PredArgTypes": 10,
"Functor": 4,
"create_fresh_vars": 5,
"module_info_pred_proc_info": 4,
"QualifiedPName": 5,
@@ -37852,7 +38171,6 @@
"UnivTypeClassArgInfos": 2,
"TypeClassArgInfos": 2,
"list.filter": 1,
"semidet": 1,
"list.member": 2,
"ExistUnconstrainedVars": 2,
"UnivUnconstrainedVars": 2,
@@ -37869,7 +38187,6 @@
"make_foreign_args": 1,
"tvarset": 3,
"pair": 7,
"string": 113,
"box_policy": 2,
"Constraint": 2,
"MaybeArgName": 7,
@@ -37988,7 +38305,6 @@
"option_table": 5,
"maybe_option_table": 3,
"inconsequential_options": 1,
"set": 13,
"options_help": 1,
"option_table_add_mercury_library_directory": 1,
"option_table.": 2,
@@ -38073,7 +38389,6 @@
"deduction/deforestation": 1,
"debug_il_asm": 3,
"il_asm": 1,
"IL": 1,
"generation": 1,
"via": 1,
"asm": 1,
@@ -38180,7 +38495,6 @@
"il_only": 4,
"compile_to_c": 4,
"c": 1,
"java": 6,
"java_only": 4,
"csharp": 6,
"csharp_only": 4,
@@ -38190,7 +38504,6 @@
"erlang_only": 4,
"exec_trace": 3,
"decl_debug": 3,
"profiling": 4,
"profile_time": 5,
"profile_calls": 6,
"time_profiling": 3,
@@ -38465,7 +38778,6 @@
"common_data": 2,
"common_layout_data": 2,
"Also": 1,
"for": 1,
"MLDS": 2,
"optimizations.": 1,
"optimize_peep": 2,
@@ -38659,7 +38971,6 @@
"typecheck_ambiguity_warn_limit": 2,
"typecheck_ambiguity_error_limit": 2,
"help": 4,
"version": 2,
"fullarch": 2,
"cross_compiling": 2,
"local_module_id": 2,
@@ -38696,7 +39007,6 @@
"OptionsList": 2,
"multi.": 1,
"bool_special": 7,
"XXX": 1,
"should": 1,
"be": 1,
"accumulating": 49,
@@ -38951,9 +39261,6 @@
"init_fail_info": 2,
"will": 1,
"override": 1,
"this": 1,
"dummy": 1,
"value": 1,
"nested": 1,
"conjunction": 1,
"depth": 1,
@@ -39176,7 +39483,6 @@
"internal_layout_info": 6,
"Exec0": 3,
"Resume": 5,
"Return": 4,
"Internal": 8,
"Internals": 6,
"map.det_insert": 3,
@@ -39395,7 +39701,6 @@
"pick_stack_resume_point": 3,
"StackLabel": 9,
"LabelConst": 4,
"const": 8,
"llconst_code_addr": 6,
"ite_region_info": 5,
"ite_info": 3,
@@ -51655,7 +51960,7 @@
"RMarkdown": 19,
"Stylus": 76,
"Bluespec": 1298,
"Mercury": 27385,
"Mercury": 30628,
"Erlang": 2928,
"NSIS": 725,
"Arduino": 20,
@@ -51803,7 +52108,7 @@
"RMarkdown": 1,
"Stylus": 1,
"Bluespec": 2,
"Mercury": 7,
"Mercury": 8,
"Erlang": 5,
"NSIS": 2,
"Arduino": 1,
@@ -51850,5 +52155,5 @@
"Protocol Buffer": 1,
"Scheme": 2
},
"md5": "5277eee29d26cba1c645879dc518c0b9"
"md5": "1c540f92a03ec13cf822b38473b5a4ff"
}

930
samples/Mercury/store.m Normal file
View File

@@ -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);
").