mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2025-12-12 04:14:06 +00:00
Code Issues Projects Releases Wiki Activity

User-guided type specialization.

Browse Source 
Estimated hours taken: 60

User-guided type specialization.

compiler/prog_data.m:
compiler/prog_io_pragma.m:
compiler/modules.m:
compiler/module_qual.m:
compiler/mercury_to_mercury.m:
	Handle `:- pragma type_spec'.

compiler/prog_io_pragma.m:
	Factor out some common code to parse predicate names with arguments.

compiler/hlds_module.m:
	Added a field to the module_sub_info to hold information about
	user-requested type specializations, filled in by make_hlds.m
	and not used by anything after higher_order.m.

compiler/make_hlds.m:
	For each `:- pragma type_spec' declaration, introduce a new predicate
	which just calls the predicate to be specialized with the
	specified argument types. This forces higher_order.m to produce
	the specialized versions.

compiler/higher_order.m:
	Process the user-requested type specializations first to ensure
	that they get the correct names.
	Allow partial matches against user-specified versions, e.g.
		map__lookup(map(int, list(int)), int, list(int)) matches
		map__lookup(map(int, V), int, V).
	Perform specialization where a typeclass constraint matches a
	known instance, but the construction of the typeclass_info is
	done in the calling module.
	Give slightly more informative progress messages.

compiler/dead_proc_elim.m:
	Remove specializations for dead procedures.

compiler/prog_io_util.m:
	Change the definition of the `maybe1' and `maybe_functor' types
	to avoid the need for copying to convert between `maybe1'
	and `maybe1(generic)'.
	Changed the interface of `make_pred_name_with_context' to allow
	creation of predicate names for type specializations which describe
	the type substitution.

compiler/make_hlds.m:
compiler/prog_io_pragma.m:
	Make the specification of pragma declarations in error
	messages consistent. (There are probably some more to
	be fixed elsewhere for termination and tabling).

compiler/intermod.m:
	Write type specialization pragmas for predicates declared
	in `.opt' files.

compiler/mercury_to_mercury.m:
	Export `mercury_output_item' for use by intermod.m.

compiler/options.m:
	Add an option `--user-guided-type-specialization' enabled
	with `-O2' or higher.

compiler/handle_options.m:
	`--type-specialization' implies `--user-guided-type-specialization'.

compiler/hlds_goal.m:
	Add predicates to construct constants. These are duplicated
	in several other places, I'll fix that as a separate change.

compiler/type_util.m:
	Added functions `int_type/0', `string_type/0', `float_type/0'
	and `char_type/0' which return the builtin types.
	These are duplicated in several other places,
	I'll fix that as a separate change.

library/private_builtin.m:
	Added `instance_constraint_from_typeclass_info/3' to extract
	the typeclass_infos for a constraint on an instance declaration.
	This is useful for specializing class method calls.
	Added `thread_safe' to various `:- pragma c_code's.
	Added `:- pragma inline' declarations for `builtin_compare_*', which
	are important for user-guided type specialization. (`builtin_unify_*'
	are simple enough to go in the `.opt' files automatically).

compiler/polymorphism.m:
	`instance_constraint_from_typeclass_info/3' does not need type_infos.
	Add `instance_constraint_from_typeclass_info/3' to the
	list of `typeclass_info_manipulator's which higher_order.m
	can interpret.

NEWS:
doc/reference_manual.texi:
doc/user_guide.texi
	Document the new pragma and option.

tests/invalid/Mmakefile:
tests/invalid/type_spec.m:
tests/invalid/type_spec.err_exp:
	Test error reporting for invalid type specializations.

tests/hard_coded/Mmakefile:
tests/invalid/type_spec.m:
tests/invalid/type_spec.exp:
	Test type specialization.
This commit is contained in:
Simon Taylor
1999-04-23 01:03:51 +00:00
parent 425b5e5022
commit 79dcbbef15
32 changed files with 2448 additions and 805 deletions
Download Patch File Download Diff File Expand all files Collapse all files

671
compiler/prog_io_pragma.m
View File

@@ -1,5 +1,5 @@
%-----------------------------------------------------------------------------%
% Copyright (C) 1996-1998 The University of Melbourne.
% Copyright (C) 1996-1999 The University of Melbourne.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
@@ -22,7 +22,8 @@
:- implementation.
:- import_module prog_io, prog_io_goal, hlds_pred, term_util, term_errors, rl.
:- import_module prog_io, prog_io_goal, prog_util, hlds_pred.
:- import_module term_util, term_errors, rl.
:- import_module int, map, string, std_util, bool, require.
parse_pragma(ModuleName, VarSet, PragmaTerms, Result) :-
@@ -60,12 +61,12 @@ parse_pragma_type(_, "source_file", PragmaTerms, ErrorTerm, _VarSet, Result) :-
Result = ok(pragma(source_file(SourceFile)))
;
Result = error(
"string expected in `pragma source_file' declaration",
"string expected in `:- pragma source_file' declaration",
SourceFileTerm)
)
;
Result = error(
"wrong number of arguments in `pragma source_file' declaration",
"wrong number of arguments in `:- pragma source_file' declaration",
ErrorTerm)
).
@@ -83,7 +84,7 @@ parse_pragma_type(_, "c_header_code", PragmaTerms,
)
;
Result = error(
"wrong number of arguments in `pragma c_header_code(...) declaration",
"wrong number of arguments in `:- pragma c_header_code' declaration",
ErrorTerm)
).
@@ -210,136 +211,44 @@ parse_pragma_type(ModuleName, "c_code", PragmaTerms,
ErrorTerm)
).
parse_pragma_type(ModuleName, "import", PragmaTerms, ErrorTerm,
_VarSet, Result) :-
(
PragmaTerms = [PredAndModesTerm, FlagsTerm,
C_FunctionTerm]
->
parse_pragma_type(ModuleName, "import", PragmaTerms,
ErrorTerm, _VarSet, Result) :-
(
(
PredAndModesTerm = term__functor(_, _, _),
C_FunctionTerm = term__functor(term__string(C_Function), [], _)
->
(
PredAndModesTerm = term__functor(term__atom("="),
[FuncAndArgModesTerm, RetModeTerm], _)
->
parse_implicitly_qualified_term(ModuleName,
FuncAndArgModesTerm, PredAndModesTerm,
"pragma import declaration", FuncAndArgModesResult),
(
FuncAndArgModesResult = ok(FuncName, ArgModeTerms),
(
convert_mode_list(ArgModeTerms, ArgModes),
convert_mode(RetModeTerm, RetMode)
->
list__append(ArgModes, [RetMode], Modes),
(
parse_pragma_c_code_attributes_term(FlagsTerm,
Flags)
->
Result = ok(pragma(import(FuncName, function,
Modes, Flags, C_Function)))
;
Result = error("invalid second argument in `:- pragma import/3' declaration -- expecting C code attribute or list of attributes'",
FlagsTerm)
)
;
Result = error(
"expected pragma import(FuncName(ModeList) = Mode, Attributes, C_Function)",
PredAndModesTerm)
)
;
FuncAndArgModesResult = error(Msg, Term),
Result = error(Msg, Term)
)
PragmaTerms = [PredAndModesTerm, FlagsTerm, C_FunctionTerm],
( parse_pragma_c_code_attributes_term(FlagsTerm, Flags) ->
FlagsResult = ok(Flags)
;
parse_implicitly_qualified_term(ModuleName,
PredAndModesTerm, ErrorTerm,
"pragma import declaration", PredAndModesResult),
(
PredAndModesResult = ok(PredName, ModeTerms),
(
convert_mode_list(ModeTerms, Modes)
->
(
parse_pragma_c_code_attributes_term(FlagsTerm,
Flags)
->
Result = ok(pragma(import(PredName, predicate,
Modes, Flags, C_Function)))
;
Result = error("invalid second argument in `:- pragma import/3' declaration -- expecting C code attribute or list of attributes'",
FlagsResult = error("invalid second argument in `:- pragma import/3' declaration -- expecting C code attribute or list of attributes'",
FlagsTerm)
)
;
Result = error(
"expected pragma import(PredName(ModeList), Attributes, C_Function)",
PredAndModesTerm)
)
;
PredAndModesResult = error(Msg, Term),
Result = error(Msg, Term)
)
)
)
;
Result = error(
"expected pragma import(PredName(ModeList), Attributes, C_Function)",
PredAndModesTerm)
)
;
PragmaTerms = [PredAndModesTerm, C_FunctionTerm]
->
default_attributes(Attributes),
PragmaTerms = [PredAndModesTerm, C_FunctionTerm],
default_attributes(Flags),
FlagsResult = ok(Flags)
)
->
(
PredAndModesTerm = term__functor(_, _, _),
C_FunctionTerm = term__functor(term__string(C_Function), [], _)
->
parse_pred_or_func_and_arg_modes(yes(ModuleName),
PredAndModesTerm, ErrorTerm,
"`:- pragma import' declaration",
PredAndArgModesResult),
(
PredAndModesTerm = term__functor(term__atom("="),
[FuncAndArgModesTerm, RetModeTerm], _)
->
parse_implicitly_qualified_term(ModuleName,
FuncAndArgModesTerm, PredAndModesTerm,
"pragma import declaration", FuncAndArgModesResult),
PredAndArgModesResult = ok(PredName - PredOrFunc,
ArgModes),
(
FuncAndArgModesResult = ok(FuncName, ArgModeTerms),
(
convert_mode_list(ArgModeTerms, ArgModes),
convert_mode(RetModeTerm, RetMode)
->
list__append(ArgModes, [RetMode], Modes),
Result = ok(pragma(import(FuncName, function,
Modes, Attributes, C_Function)))
;
Result = error(
"expected pragma import(FuncName(ModeList) = Mode, C_Function)",
PredAndModesTerm)
)
FlagsResult = ok(Attributes),
Result = ok(pragma(import(PredName, PredOrFunc,
ArgModes, Attributes, C_Function)))
;
FuncAndArgModesResult = error(Msg, Term),
FlagsResult = error(Msg, Term),
Result = error(Msg, Term)
)
;
parse_implicitly_qualified_term(ModuleName,
PredAndModesTerm, ErrorTerm,
"pragma import declaration", PredAndModesResult),
(
PredAndModesResult = ok(PredName, ModeTerms),
(
convert_mode_list(ModeTerms, Modes)
->
Result = ok(pragma(import(PredName, predicate,
Modes, Attributes, C_Function)))
;
Result = error(
"expected pragma import(PredName(ModeList), C_Function)",
PredAndModesTerm)
)
;
PredAndModesResult = error(Msg, Term),
PredAndArgModesResult = error(Msg, Term),
Result = error(Msg, Term)
)
)
;
Result = error(
@@ -349,65 +258,28 @@ parse_pragma_type(ModuleName, "import", PragmaTerms, ErrorTerm,
;
Result =
error(
"wrong number of arguments in `pragma import(...)' declaration",
"wrong number of arguments in `:- pragma import' declaration",
ErrorTerm)
).
).
parse_pragma_type(_ModuleName, "export", PragmaTerms, ErrorTerm,
_VarSet, Result) :-
parse_pragma_type(_ModuleName, "export", PragmaTerms,
ErrorTerm, _VarSet, Result) :-
(
PragmaTerms = [PredAndModesTerm, C_FunctionTerm]
->
(
PredAndModesTerm = term__functor(_, _, _),
C_FunctionTerm = term__functor(term__string(C_Function), [], _)
->
parse_pred_or_func_and_arg_modes(no, PredAndModesTerm,
ErrorTerm, "`:- pragma export' declaration",
PredAndModesResult),
(
PredAndModesTerm = term__functor(term__atom("="),
[FuncAndArgModesTerm, RetModeTerm], _)
->
parse_qualified_term(FuncAndArgModesTerm,
PredAndModesTerm, "pragma export declaration",
FuncAndArgModesResult),
(
FuncAndArgModesResult = ok(FuncName, ArgModeTerms),
(
convert_mode_list(ArgModeTerms, ArgModes),
convert_mode(RetModeTerm, RetMode)
->
list__append(ArgModes, [RetMode], Modes),
Result =
ok(pragma(export(FuncName, function,
Modes, C_Function)))
;
Result = error(
"expected pragma export(FuncName(ModeList) = Mode, C_Function)",
PredAndModesTerm)
)
;
FuncAndArgModesResult = error(Msg, Term),
Result = error(Msg, Term)
)
;
parse_qualified_term(PredAndModesTerm, ErrorTerm,
"pragma export declaration", PredAndModesResult),
(
PredAndModesResult = ok(PredName, ModeTerms),
(
convert_mode_list(ModeTerms, Modes)
->
Result =
ok(pragma(export(PredName, predicate, Modes,
C_Function)))
;
Result = error(
"expected pragma export(PredName(ModeList), C_Function)",
PredAndModesTerm)
)
;
PredAndModesResult = error(Msg, Term),
Result = error(Msg, Term)
)
PredAndModesResult = ok(PredName - PredOrFunc, Modes),
Result = ok(pragma(export(PredName, PredOrFunc,
Modes, C_Function)))
;
PredAndModesResult = error(Msg, Term),
Result = error(Msg, Term)
)
;
Result = error(
@@ -417,7 +289,7 @@ parse_pragma_type(_ModuleName, "export", PragmaTerms, ErrorTerm,
;
Result =
error(
"wrong number of arguments in `pragma export(...)' declaration",
"wrong number of arguments in `:- pragma export' declaration",
ErrorTerm)
).
@@ -457,8 +329,8 @@ parse_pragma_type(ModuleName, "obsolete", PragmaTerms, ErrorTerm,
% pragma unused_args should never appear in user programs,
% only in .opt files.
parse_pragma_type(_ModuleName, "unused_args", PragmaTerms, ErrorTerm,
_VarSet, Result) :-
parse_pragma_type(ModuleName, "unused_args", PragmaTerms,
ErrorTerm, _VarSet, Result) :-
(
PragmaTerms = [
PredOrFuncTerm,
@@ -477,8 +349,9 @@ parse_pragma_type(_ModuleName, "unused_args", PragmaTerms, ErrorTerm,
term__atom("function"), [], _),
PredOrFunc = function
),
parse_qualified_term(PredNameTerm, ErrorTerm,
"predicate name", PredNameResult),
parse_implicitly_qualified_term(ModuleName, PredNameTerm,
ErrorTerm, "`:- pragma unused_args' declaration",
PredNameResult),
PredNameResult = ok(PredName, []),
convert_int_list(UnusedArgsTerm, UnusedArgsResult),
UnusedArgsResult = ok(UnusedArgs)
@@ -486,7 +359,65 @@ parse_pragma_type(_ModuleName, "unused_args", PragmaTerms, ErrorTerm,
Result = ok(pragma(unused_args(PredOrFunc, PredName,
Arity, ProcId, UnusedArgs)))
;
Result = error("error in pragma unused_args", ErrorTerm)
Result = error("error in `:- pragma unused_args'", ErrorTerm)
).
parse_pragma_type(ModuleName, "type_spec", PragmaTerms, ErrorTerm,
VarSet0, Result) :-
(
(
PragmaTerms = [PredAndModesTerm, TypeSubnTerm],
MaybeName = no
;
PragmaTerms = [PredAndModesTerm, TypeSubnTerm, SpecNameTerm],
SpecNameTerm = term__functor(_, _, SpecContext),
% This form of the pragma should not appear in source files.
term__context_file(SpecContext, FileName),
\+ string__remove_suffix(FileName, ".m", _),
parse_implicitly_qualified_term(ModuleName,
SpecNameTerm, ErrorTerm, "", NameResult),
NameResult = ok(SpecName, []),
MaybeName = yes(SpecName)
)
->
parse_arity_or_modes(ModuleName, PredAndModesTerm, ErrorTerm,
"`:- pragma type_spec' declaration",
ArityOrModesResult),
(
ArityOrModesResult = ok(arity_or_modes(PredName,
Arity, MaybePredOrFunc, MaybeModes)),
conjunction_to_list(TypeSubnTerm, TypeSubnList),
% The varset is actually a tvarset.
varset__coerce(VarSet0, TVarSet),
( list__map(convert_type_spec_pair, TypeSubnList, TypeSubn) ->
( MaybeName = yes(SpecializedName0) ->
SpecializedName = SpecializedName0
;
unqualify_name(PredName, UnqualName),
make_pred_name(ModuleName, "TypeSpecOf",
MaybePredOrFunc, UnqualName,
type_subst(TVarSet, TypeSubn),
SpecializedName)
),
Result = ok(pragma(type_spec(PredName,
SpecializedName, Arity, MaybePredOrFunc,
MaybeModes, TypeSubn, TVarSet)))
;
Result = error(
"expected type substitution in `:- pragma type_spec' declaration",
TypeSubnTerm)
)
;
ArityOrModesResult = error(Msg, Term),
Result = error(Msg, Term)
)
;
Result = error(
"wrong number of arguments in `:- pragma type_spec' declaration",
ErrorTerm)
).
parse_pragma_type(ModuleName, "fact_table", PragmaTerms, ErrorTerm,
@@ -513,7 +444,7 @@ parse_pragma_type(ModuleName, "fact_table", PragmaTerms, ErrorTerm,
;
Result =
error(
"wrong number of arguments in pragma fact_table(..., ...) declaration",
"wrong number of arguments in `:- pragma fact_table' declaration",
ErrorTerm)
).
@@ -556,12 +487,12 @@ parse_pragma_type(ModuleName, "aditi_index", PragmaTerms,
;
AttributeResult = error(_, AttrErrorTerm),
Result = error(
"expected attribute list for `:- pragma aditi_index(...)' declaration",
"expected attribute list for `:- pragma aditi_index' declaration",
AttrErrorTerm)
)
;
Result = error(
"expected index type for `:- pragma aditi_index(...)' declaration",
"expected index type for `:- pragma aditi_index' declaration",
IndexTypeTerm)
)
;
@@ -570,7 +501,7 @@ parse_pragma_type(ModuleName, "aditi_index", PragmaTerms,
)
;
Result = error(
"wrong number of arguments in pragma aditi_index(..., ..., ...) declaration",
"wrong number of arguments in `:- pragma aditi_index' declaration",
ErrorTerm)
).
@@ -607,7 +538,7 @@ parse_pragma_type(ModuleName, "supp_magic",
Pragma = supp_magic(Name, Arity)),
PragmaTerms, ErrorTerm, Result).
parse_pragma_type(ModuleName, "context",
parse_pragma_type(ModuleName, "context",
PragmaTerms, ErrorTerm, _, Result) :-
parse_simple_pragma(ModuleName, "context",
lambda([Name::in, Arity::in, Pragma::out] is det,
@@ -623,13 +554,11 @@ parse_pragma_type(ModuleName, "owner",
Pragma = owner(Name, Arity, Owner)),
[SymNameAndArityTerm], ErrorTerm, Result)
;
string__append_list(["expected owner name for
`pragma owner(...)' declaration"], ErrorMsg),
ErrorMsg = "expected owner name for `:- pragma owner' declaration",
Result = error(ErrorMsg, OwnerTerm)
)
;
string__append_list(["wrong number of arguments in
`pragma owner(...)' declaration"], ErrorMsg),
ErrorMsg = "wrong number of arguments in `:- pragma owner' declaration",
Result = error(ErrorMsg, ErrorTerm)
).
@@ -648,73 +577,46 @@ parse_pragma_type(ModuleName, "termination_info", PragmaTerms, ErrorTerm,
ArgSizeTerm,
TerminationTerm
],
(
PredAndModesTerm0 = term__functor(Const, Terms0, _)
->
(
Const = term__atom("="),
Terms0 = [FuncAndModesTerm, FuncResultTerm0]
->
% function
PredOrFunc = function,
PredAndModesTerm = FuncAndModesTerm,
FuncResultTerm = [FuncResultTerm0]
;
% predicate
PredOrFunc = predicate,
PredAndModesTerm = PredAndModesTerm0,
FuncResultTerm = []
),
parse_implicitly_qualified_term(ModuleName,
PredAndModesTerm, ErrorTerm,
"`pragma termination_info' declaration", PredNameResult),
PredNameResult = ok(PredName, ModeListTerm0),
(
PredOrFunc = predicate,
ModeListTerm = ModeListTerm0
;
PredOrFunc = function,
list__append(ModeListTerm0, FuncResultTerm, ModeListTerm)
),
convert_mode_list(ModeListTerm, ModeList),
(
parse_pred_or_func_and_arg_modes(yes(ModuleName), PredAndModesTerm0,
ErrorTerm, "`:- pragma termination_info' declaration",
NameAndModesResult),
NameAndModesResult = ok(PredName - PredOrFunc, ModeList),
(
ArgSizeTerm = term__functor(term__atom("not_set"), [], _),
MaybeArgSizeInfo = no
;
;
ArgSizeTerm = term__functor(term__atom("infinite"), [],
ArgSizeContext),
MaybeArgSizeInfo = yes(infinite(
[ArgSizeContext - imported_pred]))
;
;
ArgSizeTerm = term__functor(term__atom("finite"),
[IntTerm, UsedArgsTerm], _),
IntTerm = term__functor(term__integer(Int), [], _),
convert_bool_list(UsedArgsTerm, UsedArgs),
MaybeArgSizeInfo = yes(finite(Int, UsedArgs))
),
(
),
(
TerminationTerm = term__functor(term__atom("not_set"), [], _),
MaybeTerminationInfo = no
;
;
TerminationTerm = term__functor(term__atom("can_loop"),
[], TermContext),
MaybeTerminationInfo = yes(can_loop(
[TermContext - imported_pred]))
;
;
TerminationTerm = term__functor(term__atom("cannot_loop"),
[], _),
MaybeTerminationInfo = yes(cannot_loop)
),
Result0 = ok(pragma(termination_info(PredOrFunc, PredName,
ModeList, MaybeArgSizeInfo, MaybeTerminationInfo)))
;
Result0 = error("unexpected variable in pragma termination_info",
ErrorTerm)
)
),
Result0 = ok(pragma(termination_info(PredOrFunc, PredName,
ModeList, MaybeArgSizeInfo, MaybeTerminationInfo)))
->
Result = Result0
;
Result = error("syntax error in `pragma termination_info'", ErrorTerm)
Result = error(
"syntax error in `:- pragma termination_info' declaration",
ErrorTerm)
).
parse_pragma_type(ModuleName, "terminates", PragmaTerms,
@@ -758,8 +660,8 @@ parse_simple_pragma(ModuleName, PragmaType, MakePragma,
Result = error(ErrorMsg, PredAndArityTerm)
)
;
string__append_list(["wrong number of arguments in `pragma ",
PragmaType, "(...)' declaration"], ErrorMsg),
string__append_list(["wrong number of arguments in `:- pragma ",
PragmaType, "' declaration"], ErrorMsg),
Result = error(ErrorMsg, ErrorTerm)
).
@@ -781,13 +683,13 @@ parse_pred_name_and_arity(ModuleName, PragmaType, PredAndArityTerm,
Result = ok(PredName, Arity)
;
string__append_list(
["expected predname/arity for `pragma ",
PragmaType, "(...)' declaration"], ErrorMsg),
["expected predname/arity for `:- pragma ",
PragmaType, "' declaration"], ErrorMsg),
Result = error(ErrorMsg, PredAndArityTerm)
)
;
string__append_list(["expected predname/arity for `pragma ",
PragmaType, "(...)' declaration"], ErrorMsg),
string__append_list(["expected predname/arity for `:- pragma ",
PragmaType, "' declaration"], ErrorMsg),
Result = error(ErrorMsg, PredAndArityTerm)
).
@@ -896,55 +798,37 @@ parse_threadsafe(term__functor(term__atom("not_thread_safe"), [], _),
:- mode parse_pragma_c_code(in, in, in, in, in, out) is det.
parse_pragma_c_code(ModuleName, Flags, PredAndVarsTerm0, PragmaImpl,
VarSet, Result) :-
VarSet0, Result) :-
parse_pred_or_func_and_args(yes(ModuleName), PredAndVarsTerm0,
PredAndVarsTerm0, "`:- pragma c_code' declaration", PredAndArgsResult),
(
PredAndVarsTerm0 = term__functor(Const, Terms0, _)
->
PredAndArgsResult = ok(PredName, VarList0 - MaybeRetTerm),
(
% is this a function or a predicate?
Const = term__atom("="),
Terms0 = [FuncAndVarsTerm, FuncResultTerm0]
MaybeRetTerm = yes(FuncResultTerm0)
->
% function
PredOrFunc = function,
PredAndVarsTerm = FuncAndVarsTerm,
FuncResultTerms = [FuncResultTerm0]
list__append(VarList0, [FuncResultTerm0], VarList)
;
% predicate
PredOrFunc = predicate,
PredAndVarsTerm = PredAndVarsTerm0,
FuncResultTerms = []
VarList = VarList0
),
parse_implicitly_qualified_term(ModuleName,
PredAndVarsTerm, PredAndVarsTerm0,
"pragma c_code declaration", PredNameResult),
parse_pragma_c_code_varlist(VarSet0, VarList, PragmaVars, Error),
(
PredNameResult = ok(PredName, VarList0),
(
PredOrFunc = predicate,
VarList = VarList0
;
PredOrFunc = function,
list__append(VarList0, FuncResultTerms, VarList)
),
varset__coerce(VarSet, ProgVarSet),
parse_pragma_c_code_varlist(VarSet, VarList, PragmaVars,
Error),
(
Error = no,
Result = ok(pragma(c_code(Flags, PredName,
PredOrFunc, PragmaVars, ProgVarSet, PragmaImpl)))
;
Error = yes(ErrorMessage),
Result = error(ErrorMessage, PredAndVarsTerm)
)
;
PredNameResult = error(Msg, Term),
Result = error(Msg, Term)
Error = no,
varset__coerce(VarSet0, VarSet),
Result = ok(pragma(c_code(Flags, PredName,
PredOrFunc, PragmaVars, VarSet, PragmaImpl)))
;
Error = yes(ErrorMessage),
Result = error(ErrorMessage, PredAndVarsTerm0)
)
;
Result = error("unexpected variable in `pragma c_code' declaration",
PredAndVarsTerm0)
PredAndArgsResult = error(Msg, Term),
Result = error(Msg, Term)
).
% parse the variable list in the pragma c code declaration.
@@ -996,7 +880,36 @@ parse_tabling_pragma(ModuleName, PragmaName, TablingType, PragmaTerms,
(
PragmaTerms = [PredAndModesTerm0]
->
string__append_list(["`:- pragma ", PragmaName, "' declaration"],
ParseMsg),
parse_arity_or_modes(ModuleName, PredAndModesTerm0,
ErrorTerm, ParseMsg, ArityModesResult),
(
ArityModesResult = ok(arity_or_modes(PredName,
Arity, MaybePredOrFunc, MaybeModes)),
Result = ok(pragma(tabled(TablingType, PredName, Arity,
MaybePredOrFunc, MaybeModes)))
;
ArityModesResult = error(Msg, Term),
Result = error(Msg, Term)
)
;
string__append_list(["wrong number of arguments in `:- pragma ",
PragmaName, "' declaration"], ErrorMessage),
Result = error(ErrorMessage, ErrorTerm)
).
:- type arity_or_modes
---> arity_or_modes(sym_name, arity,
maybe(pred_or_func), maybe(list(mode))).
:- pred parse_arity_or_modes(module_name, term, term,
string, maybe1(arity_or_modes)).
:- mode parse_arity_or_modes(in, in, in, in, out) is det.
parse_arity_or_modes(ModuleName, PredAndModesTerm0,
ErrorTerm, ErrorMsg, Result) :-
(
% Is this a simple pred/arity pragma
PredAndModesTerm0 = term__functor(term__atom("/"),
[PredNameTerm, ArityTerm], _)
@@ -1006,104 +919,101 @@ parse_tabling_pragma(ModuleName, PragmaName, TablingType, PragmaTerms,
PredNameTerm, PredAndModesTerm0, "", ok(PredName, [])),
ArityTerm = term__functor(term__integer(Arity), [], _)
->
Result = ok(pragma(tabled(TablingType, PredName, Arity,
no, no)))
Result = ok(arity_or_modes(PredName, Arity, no, no))
;
string__append_list(
["expected predname/arity for `pragma ",
PragmaName, "(...)' declaration"], ErrorMsg),
Result = error(ErrorMsg, PredAndModesTerm0)
string__append("expected predname/arity for", ErrorMsg, Msg),
Result = error(Msg, ErrorTerm)
)
;
% Is this a specific mode pragma
PredAndModesTerm0 = term__functor(Const, Terms0, _)
->
(
% is this a function or a predicate?
Const = term__atom("="),
Terms0 = [FuncAndModesTerm, FuncResultTerm0]
->
% function
PredOrFunc = function,
PredAndModesTerm = FuncAndModesTerm,
FuncResultTerms = [ FuncResultTerm0 ]
;
% predicate
PredOrFunc = predicate,
PredAndModesTerm = PredAndModesTerm0,
FuncResultTerms = []
),
string__append_list(["`pragma ", PragmaName, "(...)' declaration"],
ParseMsg),
parse_qualified_term(PredAndModesTerm, PredAndModesTerm0,
ParseMsg, PredNameResult),
(
PredNameResult = ok(PredName, ModeList0),
(
PredOrFunc = predicate,
ModeList = ModeList0
parse_pred_or_func_and_arg_modes(yes(ModuleName),
PredAndModesTerm0, PredAndModesTerm0, ErrorMsg,
PredAndModesResult),
(
PredAndModesResult = ok(PredName - PredOrFunc, Modes),
list__length(Modes, Arity0),
( PredOrFunc = function ->
Arity is Arity0 - 1
;
PredOrFunc = function,
list__append(ModeList0, FuncResultTerms, ModeList)
Arity = Arity0
),
(
convert_mode_list(ModeList, Modes)
->
list__length(Modes, Arity0),
(
PredOrFunc = function
->
Arity is Arity0 - 1
;
Arity = Arity0
),
Result = ok(pragma(tabled(TablingType, PredName, Arity,
yes(PredOrFunc), yes(Modes))))
;
string__append_list(["syntax error in pragma '",
PragmaName, "(...)' declaration"],ErrorMessage),
Result = error(ErrorMessage, PredAndModesTerm)
)
Result = ok(arity_or_modes(PredName, Arity,
yes(PredOrFunc), yes(Modes)))
;
PredNameResult = error(Msg, Term),
PredAndModesResult = error(Msg, Term),
Result = error(Msg, Term)
)
;
string__append_list(["unexpected variable in `pragma ", PragmaName,
"'"], ErrorMessage),
Result = error(ErrorMessage, PredAndModesTerm0)
)
;
string__append_list(["wrong number of arguments in `pragma ",
PragmaName, "(...)' declaration"], ErrorMessage),
Result = error(ErrorMessage, ErrorTerm)
).
).
:- pred convert_int_list(term::in, maybe1(list(int))::out) is det.
:- type maybe_pred_or_func_modes ==
maybe2(pair(sym_name, pred_or_func), list(mode)).
:- type maybe_pred_or_func(T) == maybe2(sym_name, pair(list(T), maybe(T))).
convert_int_list(term__variable(V),
error("variable in int list", term__variable(V))).
convert_int_list(term__functor(Functor, Args, Context), Result) :-
(
Functor = term__atom("."),
Args = [term__functor(term__integer(Int), [], _), RestTerm]
->
convert_int_list(RestTerm, RestResult),
:- pred parse_pred_or_func_and_arg_modes(maybe(module_name), term, term,
string, maybe_pred_or_func_modes).
:- mode parse_pred_or_func_and_arg_modes(in, in, in, in, out) is det.
parse_pred_or_func_and_arg_modes(MaybeModuleName, PredAndModesTerm,
ErrorTerm, Msg, Result) :-
parse_pred_or_func_and_args(MaybeModuleName, PredAndModesTerm,
ErrorTerm, Msg, PredAndArgsResult),
(
PredAndArgsResult =
ok(PredName, ArgModeTerms - MaybeRetModeTerm),
( convert_mode_list(ArgModeTerms, ArgModes0) ->
(
RestResult = ok(List0),
Result = ok([Int | List0])
MaybeRetModeTerm = yes(RetModeTerm),
( convert_mode(RetModeTerm, RetMode) ->
list__append(ArgModes0, [RetMode], ArgModes),
Result = ok(PredName - function, ArgModes)
;
string__append("error in return mode in ",
Msg, ErrorMsg),
Result = error(ErrorMsg, ErrorTerm)
)
;
RestResult = error(_, _),
Result = RestResult
MaybeRetModeTerm = no,
Result = ok(PredName - predicate, ArgModes0)
)
;
string__append("error in argument modes in ", Msg,
ErrorMsg),
Result = error(ErrorMsg, ErrorTerm)
)
;
Functor = term__atom("[]"),
Args = []
PredAndArgsResult = error(ErrorMsg, Term),
Result = error(ErrorMsg, Term)
).
:- pred parse_pred_or_func_and_args(maybe(sym_name), term, term, string,
maybe_pred_or_func(term)).
:- mode parse_pred_or_func_and_args(in, in, in, in, out) is det.
parse_pred_or_func_and_args(MaybeModuleName, PredAndArgsTerm, ErrorTerm,
Msg, PredAndArgsResult) :-
(
PredAndArgsTerm = term__functor(term__atom("="),
[FuncAndArgsTerm, FuncResultTerm], _)
->
Result = ok([])
FunctorTerm = FuncAndArgsTerm,
MaybeFuncResult = yes(FuncResultTerm)
;
Result = error("error in int list",
term__functor(Functor, Args, Context))
FunctorTerm = PredAndArgsTerm,
MaybeFuncResult = no
),
(
MaybeModuleName = yes(ModuleName),
parse_implicitly_qualified_term(ModuleName, FunctorTerm,
ErrorTerm, Msg, Result)
;
MaybeModuleName = no,
parse_qualified_term(FunctorTerm, ErrorTerm, Msg, Result)
),
(
Result = ok(SymName, Args),
PredAndArgsResult = ok(SymName, Args - MaybeFuncResult)
;
Result = error(ErrorMsg, Term),
PredAndArgsResult = error(ErrorMsg, Term)
).
:- pred convert_bool_list(term::in, list(bool)::out) is semidet.
@@ -1126,3 +1036,56 @@ convert_bool_list(term__functor(Functor, Args, _), Bools) :-
Args = [],
Bools = []
).
:- pred convert_int_list(term::in, maybe1(list(int))::out) is det.
convert_int_list(ListTerm, Result) :-
convert_list(ListTerm,
lambda([Term::in, Int::out] is semidet, (
Term = term__functor(term__integer(Int), [], _)
)), Result).
%
% convert_list(T, P, M) will convert a term T into a list of
% type X where P is a predicate that converts each element of
% the list into the correct type. M will hold the list if the
% conversion succeded for each element of M, otherwise it will
% hold the error.
%
:- pred convert_list(term, pred(term, T), maybe1(list(T))).
:- mode convert_list(in, pred(in, out) is semidet, out) is det.
convert_list(term__variable(V),_, error("variable in list", term__variable(V))).
convert_list(term__functor(Functor, Args, Context), Pred, Result) :-
(
Functor = term__atom("."),
Args = [Term, RestTerm],
call(Pred, Term, Element)
->
convert_list(RestTerm, Pred, RestResult),
(
RestResult = ok(List0),
Result = ok([Element | List0])
;
RestResult = error(_, _),
Result = RestResult
)
;
Functor = term__atom("[]"),
Args = []
->
Result = ok([])
;
Result = error("error in list",
term__functor(Functor, Args, Context))
).
:- pred convert_type_spec_pair(term::in, pair(tvar, type)::out) is semidet.
convert_type_spec_pair(Term, TypeSpec) :-
Term = term__functor(term__atom("="), [TypeVarTerm, SpecTypeTerm0], _),
TypeVarTerm = term__variable(TypeVar0),
term__coerce_var(TypeVar0, TypeVar),
term__coerce(SpecTypeTerm0, SpecType),
TypeSpec = TypeVar - SpecType.