mirror of
https://github.com/Mercury-Language/mercury.git
synced 2025-12-12 04:14:06 +00:00
c192d50143
Estimated hours taken: 15 Add preliminary support for a new pragma: :- pragma foreign_code(LanguageString, .... <same args as c_code>). This is intended to be the eventual replacement of pragma c_code. Presently the only valid language is "C". The existing pragma c_code is simply turned into pragma foreign_code. pragma foreign_code is not a supported pragma at the moment. There are several other changes that are intended (for example, foreign_code will be impure by default). This change also changes the HLDS goal pragma_c_code/7 to pragma_foreign_code/8 where the extra argument is the foreign language. Any code currently generating output for pragma C code simply checks that the foreign language is set to "c". Since this is the only alternative of the type foreign_language, it will always succeed. However when new alternatives are added it should be fairly easy to find where the changes need to be made. Some type names and predicate names have also been updated, however there are many more that haven't yet been touched. compiler/prog_io_pragma.m: Accept the new syntax. Turn the old syntax into the new item. compiler/hlds_goal.m: Change pragma_c_code/7 to pragma_foreign_code/8. Define the foreign_language type. compiler/llds.m: Change user_c_code/2 to user_foreign_code/3. compiler/*.m: Update the rest of the compiler to handle these types. Make a few small changes to update variable names, predicate names and type names.
1171 lines
37 KiB
Mathematica
1171 lines
37 KiB
Mathematica
%-----------------------------------------------------------------------------%
|
|
% Copyright (C) 1996-2000 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.
|
|
%-----------------------------------------------------------------------------%
|
|
%
|
|
% File: prog_io_pragma.m.
|
|
% Main authors: fjh, dgj.
|
|
%
|
|
% This module handles the parsing of pragma directives.
|
|
|
|
:- module prog_io_pragma.
|
|
|
|
:- interface.
|
|
|
|
:- import_module prog_data, prog_io_util.
|
|
:- import_module list, varset, term.
|
|
|
|
% parse the pragma declaration.
|
|
:- pred parse_pragma(module_name, varset, list(term), maybe1(item)).
|
|
:- mode parse_pragma(in, in, in, out) is semidet.
|
|
|
|
:- implementation.
|
|
|
|
:- import_module prog_io, prog_io_goal, prog_util.
|
|
:- import_module term_util, term_errors.
|
|
:- import_module int, map, string, std_util, bool, require.
|
|
|
|
parse_pragma(ModuleName, VarSet, PragmaTerms, Result) :-
|
|
(
|
|
% new syntax: `:- pragma foo(...).'
|
|
PragmaTerms = [SinglePragmaTerm],
|
|
SinglePragmaTerm = term__functor(term__atom(PragmaType),
|
|
PragmaArgs, _),
|
|
parse_pragma_type(ModuleName, PragmaType, PragmaArgs,
|
|
SinglePragmaTerm, VarSet, Result0)
|
|
->
|
|
Result = Result0
|
|
;
|
|
% old syntax: `:- pragma(foo, ...).'
|
|
% XXX we should issue a warning; this syntax is deprecated.
|
|
PragmaTerms = [PragmaTypeTerm | PragmaArgs2],
|
|
PragmaTypeTerm = term__functor(term__atom(PragmaType), [], _),
|
|
parse_pragma_type(ModuleName, PragmaType, PragmaArgs2,
|
|
PragmaTypeTerm, VarSet, Result1)
|
|
->
|
|
Result = Result1
|
|
;
|
|
fail
|
|
).
|
|
|
|
:- pred parse_pragma_type(module_name, string, list(term), term,
|
|
varset, maybe1(item)).
|
|
:- mode parse_pragma_type(in, in, in, in, in, out) is semidet.
|
|
|
|
parse_pragma_type(_, "source_file", PragmaTerms, ErrorTerm, _VarSet, Result) :-
|
|
( PragmaTerms = [SourceFileTerm] ->
|
|
(
|
|
SourceFileTerm = term__functor(term__string(SourceFile), [], _)
|
|
->
|
|
Result = ok(pragma(source_file(SourceFile)))
|
|
;
|
|
Result = error(
|
|
"string expected in `:- pragma source_file' declaration",
|
|
SourceFileTerm)
|
|
)
|
|
;
|
|
Result = error(
|
|
"wrong number of arguments in `:- pragma source_file' declaration",
|
|
ErrorTerm)
|
|
).
|
|
|
|
parse_pragma_type(_, "c_header_code", PragmaTerms,
|
|
ErrorTerm, _VarSet, Result) :-
|
|
(
|
|
PragmaTerms = [HeaderTerm]
|
|
->
|
|
(
|
|
HeaderTerm = term__functor(term__string(HeaderCode), [], _)
|
|
->
|
|
Result = ok(pragma(c_header_code(HeaderCode)))
|
|
;
|
|
Result = error("expected string for C header code", HeaderTerm)
|
|
)
|
|
;
|
|
Result = error(
|
|
"wrong number of arguments in `:- pragma c_header_code' declaration",
|
|
ErrorTerm)
|
|
).
|
|
|
|
parse_pragma_type(ModuleName, "foreign_code", PragmaTerms,
|
|
ErrorTerm, VarSet, Result) :-
|
|
parse_pragma_foreign_code_pragma(ModuleName, "foreign_code",
|
|
PragmaTerms, ErrorTerm, VarSet, Result).
|
|
|
|
% pragma c_code is almost as if we have written foreign_code
|
|
% with the language set to "C".
|
|
% There are a few differences (error messages, some deprecated
|
|
% syntax is still supported for c_code) so we pass the original
|
|
% pragma name to parse_pragma_foreign_code_pragma.
|
|
parse_pragma_type(ModuleName, "c_code", PragmaTerms,
|
|
ErrorTerm, VarSet, Result) :-
|
|
(
|
|
PragmaTerms = [term__functor(_, _, Context) | _]
|
|
->
|
|
LangC = term__functor(term__string("C"), [], Context),
|
|
parse_pragma_foreign_code_pragma(ModuleName, "c_code",
|
|
[LangC | PragmaTerms], ErrorTerm, VarSet, Result)
|
|
;
|
|
Result = error("wrong number of arguments or unexpected variable in `:- pragma c_code' declaration",
|
|
ErrorTerm)
|
|
).
|
|
|
|
:- pred parse_foreign_language(term, foreign_language).
|
|
:- mode parse_foreign_language(in, out) is semidet.
|
|
|
|
parse_foreign_language(term__functor(term__string("C"), _, _), c).
|
|
parse_foreign_language(term__functor(term__string("c"), _, _), c).
|
|
%parse_foreign_language(term__functor(term__string("C++"), _, _), cplusplus).
|
|
%parse_foreign_language(term__functor(term__string("c++"), _, _), cplusplus).
|
|
|
|
|
|
% This predicate parses both c_code and foreign_code pragmas.
|
|
:- pred parse_pragma_foreign_code_pragma(module_name, string,
|
|
list(term), term, varset, maybe1(item)).
|
|
:- mode parse_pragma_foreign_code_pragma(in, in, in, in, in, out) is det.
|
|
|
|
parse_pragma_foreign_code_pragma(ModuleName, Pragma, PragmaTerms,
|
|
ErrorTerm, VarSet, Result) :-
|
|
string__format("invalid `:- pragma %s' declaration ", [s(Pragma)],
|
|
InvalidDeclStr),
|
|
|
|
Check6 = (func(PTerms6, ForeignLanguage) = Res is semidet :-
|
|
PTerms6 = [PredAndVarsTerm, FlagsTerm,
|
|
FieldsTerm, FirstTerm, LaterTerm, SharedTerm],
|
|
( parse_pragma_c_code_attributes_term(FlagsTerm, Flags) ->
|
|
( parse_pragma_keyword("local_vars", FieldsTerm, Fields,
|
|
FieldsContext) ->
|
|
( parse_pragma_keyword("first_code", FirstTerm, First,
|
|
FirstContext) ->
|
|
( parse_pragma_keyword("retry_code", LaterTerm, Later,
|
|
LaterContext) ->
|
|
( parse_pragma_keyword("shared_code", SharedTerm,
|
|
Shared, SharedContext) ->
|
|
parse_pragma_foreign_code(ModuleName,
|
|
ForeignLanguage, Flags, PredAndVarsTerm,
|
|
nondet(Fields, yes(FieldsContext),
|
|
First, yes(FirstContext),
|
|
Later, yes(LaterContext),
|
|
share, Shared, yes(SharedContext)),
|
|
VarSet, Res)
|
|
; parse_pragma_keyword("duplicated_code",
|
|
SharedTerm, Shared, SharedContext) ->
|
|
parse_pragma_foreign_code(ModuleName,
|
|
ForeignLanguage, Flags, PredAndVarsTerm,
|
|
nondet(Fields, yes(FieldsContext),
|
|
First, yes(FirstContext),
|
|
Later, yes(LaterContext),
|
|
duplicate, Shared, yes(SharedContext)),
|
|
VarSet, Res)
|
|
; parse_pragma_keyword("common_code", SharedTerm,
|
|
Shared, SharedContext) ->
|
|
parse_pragma_foreign_code(ModuleName,
|
|
ForeignLanguage, Flags, PredAndVarsTerm,
|
|
nondet(Fields, yes(FieldsContext),
|
|
First, yes(FirstContext),
|
|
Later, yes(LaterContext),
|
|
automatic, Shared, yes(SharedContext)),
|
|
VarSet, Res)
|
|
;
|
|
ErrMsg = "-- invalid seventh argument, expecting `common_code(<code>)'",
|
|
Res = error(string__append(InvalidDeclStr,
|
|
ErrMsg), SharedTerm)
|
|
)
|
|
;
|
|
ErrMsg = "-- invalid sixth argument, expecting `retry_code(<code>)'",
|
|
Res = error(string__append(InvalidDeclStr, ErrMsg),
|
|
LaterTerm)
|
|
)
|
|
;
|
|
ErrMsg = "-- invalid fifth argument, expecting `first_code(<code>)'",
|
|
Res = error(string__append(InvalidDeclStr, ErrMsg),
|
|
FirstTerm)
|
|
)
|
|
;
|
|
ErrMsg = "-- invalid fourth argument, expecting `local_vars(<fields>)'",
|
|
Res = error(string__append(InvalidDeclStr, ErrMsg),
|
|
FieldsTerm)
|
|
)
|
|
;
|
|
ErrMsg = "-- invalid third argument, expecting foreign code attribute or list of attributes",
|
|
Res = error(string__append(InvalidDeclStr, ErrMsg), FlagsTerm)
|
|
)
|
|
),
|
|
|
|
Check5 = (func(PTerms5, ForeignLanguage) = Res is semidet :-
|
|
PTerms5 = [PredAndVarsTerm, FlagsTerm,
|
|
FieldsTerm, FirstTerm, LaterTerm],
|
|
term__context_init(DummyContext),
|
|
SharedTerm = term__functor(term__atom("common_code"),
|
|
[term__functor(term__string(""), [], DummyContext)],
|
|
DummyContext),
|
|
Res = Check6([PredAndVarsTerm, FlagsTerm, FieldsTerm, FirstTerm,
|
|
LaterTerm, SharedTerm], ForeignLanguage)
|
|
),
|
|
|
|
Check3 = (func(PTerms3, ForeignLanguage) = Res is semidet :-
|
|
PTerms3 = [PredAndVarsTerm, FlagsTerm, CodeTerm],
|
|
(
|
|
CodeTerm = term__functor(term__string(Code), [], Context)
|
|
->
|
|
( parse_pragma_c_code_attributes_term(FlagsTerm, Flags) ->
|
|
parse_pragma_foreign_code(ModuleName, ForeignLanguage,
|
|
Flags, PredAndVarsTerm,
|
|
ordinary(Code, yes(Context)), VarSet, Res)
|
|
; parse_pragma_c_code_attributes_term(PredAndVarsTerm, Flags) ->
|
|
% XXX we should issue a warning; this syntax is deprecated
|
|
% We will continue to accept this if c_code is used, but
|
|
% not with foreign_code
|
|
( Pragma = "c_code" ->
|
|
parse_pragma_foreign_code(ModuleName, ForeignLanguage,
|
|
Flags, FlagsTerm, ordinary(Code, yes(Context)),
|
|
VarSet, Res)
|
|
;
|
|
ErrMsg = "-- invalid second argument, expecting predicate or function mode",
|
|
Res = error(string__append(InvalidDeclStr, ErrMsg),
|
|
PredAndVarsTerm)
|
|
)
|
|
;
|
|
ErrMsg = "-- invalid third argument, expecting a foreign code attribute or list of attributes",
|
|
Res = error(string__append(InvalidDeclStr, ErrMsg),
|
|
FlagsTerm)
|
|
)
|
|
;
|
|
ErrMsg = "-- invalid fourth argument, expecting string containing foreign code",
|
|
Res = error(string__append(InvalidDeclStr, ErrMsg),
|
|
CodeTerm)
|
|
)
|
|
),
|
|
|
|
|
|
Check2 = (func(PTerms2, ForeignLanguage) = Res is semidet :-
|
|
PTerms2 = [PredAndVarsTerm, CodeTerm],
|
|
% XXX we should issue a warning; this syntax is deprecated.
|
|
% We will continue to accept this if c_code is used, but
|
|
% not with foreign_code
|
|
(
|
|
Pragma = "c_code"
|
|
->
|
|
% may_call_mercury is a conservative default.
|
|
default_attributes(Attributes),
|
|
(
|
|
CodeTerm = term__functor(term__string(Code), [],
|
|
Context)
|
|
->
|
|
parse_pragma_foreign_code(ModuleName,
|
|
ForeignLanguage, Attributes,
|
|
PredAndVarsTerm, ordinary(Code,
|
|
yes(Context)), VarSet, Res)
|
|
;
|
|
ErrMsg = "-- expecting either `may_call_mercury' or `will_not_call_mercury', and a string for C code",
|
|
Res = error(string__append(InvalidDeclStr, ErrMsg),
|
|
CodeTerm)
|
|
)
|
|
;
|
|
ErrMsg = "-- doesn't say whether it can call mercury",
|
|
Res = error(string__append(InvalidDeclStr, ErrMsg),
|
|
ErrorTerm)
|
|
)
|
|
),
|
|
|
|
Check1 = (func(PTerms1, ForeignLanguage) = Res is semidet :-
|
|
PTerms1 = [Just_Code_Term],
|
|
(
|
|
Just_Code_Term = term__functor(term__string(
|
|
Just_Code), [], _)
|
|
->
|
|
Res = ok(pragma(foreign(ForeignLanguage,
|
|
Just_Code)))
|
|
;
|
|
ErrMsg = "-- expected string for foreign code",
|
|
Res = error(string__append(InvalidDeclStr, ErrMsg),
|
|
ErrorTerm)
|
|
)
|
|
),
|
|
|
|
CheckLength = (func(PTermsLen, ForeignLanguage) = Res :-
|
|
(
|
|
Res0 = Check1(PTermsLen, ForeignLanguage)
|
|
->
|
|
Res = Res0
|
|
;
|
|
Res0 = Check2(PTermsLen, ForeignLanguage)
|
|
->
|
|
Res = Res0
|
|
;
|
|
Res0 = Check3(PTermsLen, ForeignLanguage)
|
|
->
|
|
Res = Res0
|
|
;
|
|
Res0 = Check5(PTermsLen, ForeignLanguage)
|
|
->
|
|
Res = Res0
|
|
;
|
|
Res0 = Check6(PTermsLen, ForeignLanguage)
|
|
->
|
|
Res = Res0
|
|
;
|
|
ErrMsg = "-- wrong number of arguments",
|
|
Res = error(string__append(InvalidDeclStr, ErrMsg),
|
|
ErrorTerm)
|
|
)
|
|
),
|
|
|
|
|
|
CheckLanguage = (func(PTermsLang) = Res is semidet :-
|
|
PTermsLang = [Lang | Rest],
|
|
(
|
|
parse_foreign_language(Lang, ForeignLanguage)
|
|
->
|
|
Res = CheckLength(Rest, ForeignLanguage)
|
|
;
|
|
ErrMsg = "-- invalid language parameter",
|
|
Res = error(string__append(InvalidDeclStr, ErrMsg),
|
|
Lang)
|
|
)
|
|
),
|
|
|
|
(
|
|
Result0 = CheckLanguage(PragmaTerms)
|
|
->
|
|
Result = Result0
|
|
;
|
|
ErrMsg0 = "-- wrong number of arguments",
|
|
Result = error(string__append(InvalidDeclStr, ErrMsg0),
|
|
ErrorTerm)
|
|
).
|
|
|
|
|
|
parse_pragma_type(ModuleName, "import", PragmaTerms,
|
|
ErrorTerm, _VarSet, Result) :-
|
|
(
|
|
(
|
|
PragmaTerms = [PredAndModesTerm, FlagsTerm, C_FunctionTerm],
|
|
( parse_pragma_c_code_attributes_term(FlagsTerm, Flags) ->
|
|
FlagsResult = ok(Flags)
|
|
;
|
|
FlagsResult = error("invalid second argument in `:- pragma import/3' declaration -- expecting C code attribute or list of attributes'",
|
|
FlagsTerm)
|
|
)
|
|
;
|
|
PragmaTerms = [PredAndModesTerm, C_FunctionTerm],
|
|
default_attributes(Flags),
|
|
FlagsResult = ok(Flags)
|
|
)
|
|
->
|
|
(
|
|
C_FunctionTerm = term__functor(term__string(C_Function), [], _)
|
|
->
|
|
parse_pred_or_func_and_arg_modes(yes(ModuleName),
|
|
PredAndModesTerm, ErrorTerm,
|
|
"`:- pragma import' declaration",
|
|
PredAndArgModesResult),
|
|
(
|
|
PredAndArgModesResult = ok(PredName - PredOrFunc,
|
|
ArgModes),
|
|
(
|
|
FlagsResult = ok(Attributes),
|
|
Result = ok(pragma(import(PredName, PredOrFunc,
|
|
ArgModes, Attributes, C_Function)))
|
|
;
|
|
FlagsResult = error(Msg, Term),
|
|
Result = error(Msg, Term)
|
|
)
|
|
;
|
|
PredAndArgModesResult = error(Msg, Term),
|
|
Result = error(Msg, Term)
|
|
)
|
|
;
|
|
Result = error(
|
|
"expected pragma import(PredName(ModeList), C_Function)",
|
|
PredAndModesTerm)
|
|
)
|
|
;
|
|
Result =
|
|
error(
|
|
"wrong number of arguments in `:- pragma import' declaration",
|
|
ErrorTerm)
|
|
).
|
|
|
|
parse_pragma_type(_ModuleName, "export", PragmaTerms,
|
|
ErrorTerm, _VarSet, Result) :-
|
|
(
|
|
PragmaTerms = [PredAndModesTerm, C_FunctionTerm]
|
|
->
|
|
(
|
|
C_FunctionTerm = term__functor(term__string(C_Function), [], _)
|
|
->
|
|
parse_pred_or_func_and_arg_modes(no, PredAndModesTerm,
|
|
ErrorTerm, "`:- pragma export' declaration",
|
|
PredAndModesResult),
|
|
(
|
|
PredAndModesResult = ok(PredName - PredOrFunc, Modes),
|
|
Result = ok(pragma(export(PredName, PredOrFunc,
|
|
Modes, C_Function)))
|
|
;
|
|
PredAndModesResult = error(Msg, Term),
|
|
Result = error(Msg, Term)
|
|
)
|
|
;
|
|
Result = error(
|
|
"expected pragma export(PredName(ModeList), C_Function)",
|
|
PredAndModesTerm)
|
|
)
|
|
;
|
|
Result =
|
|
error(
|
|
"wrong number of arguments in `:- pragma export' declaration",
|
|
ErrorTerm)
|
|
).
|
|
|
|
parse_pragma_type(ModuleName, "inline", PragmaTerms, ErrorTerm,
|
|
_VarSet, Result) :-
|
|
parse_simple_pragma(ModuleName, "inline",
|
|
lambda([Name::in, Arity::in, Pragma::out] is det,
|
|
Pragma = inline(Name, Arity)),
|
|
PragmaTerms, ErrorTerm, Result).
|
|
|
|
parse_pragma_type(ModuleName, "no_inline", PragmaTerms, ErrorTerm,
|
|
_VarSet, Result) :-
|
|
parse_simple_pragma(ModuleName, "no_inline",
|
|
lambda([Name::in, Arity::in, Pragma::out] is det,
|
|
Pragma = no_inline(Name, Arity)),
|
|
PragmaTerms, ErrorTerm, Result).
|
|
|
|
parse_pragma_type(ModuleName, "memo", PragmaTerms, ErrorTerm,
|
|
_VarSet, Result) :-
|
|
parse_tabling_pragma(ModuleName, "memo", eval_memo,
|
|
PragmaTerms, ErrorTerm, Result).
|
|
parse_pragma_type(ModuleName, "loop_check", PragmaTerms,
|
|
ErrorTerm, _VarSet, Result) :-
|
|
parse_tabling_pragma(ModuleName, "loop_check", eval_loop_check,
|
|
PragmaTerms, ErrorTerm, Result).
|
|
parse_pragma_type(ModuleName, "minimal_model", PragmaTerms, ErrorTerm,
|
|
_VarSet, Result) :-
|
|
parse_tabling_pragma(ModuleName, "minimal_model", eval_minimal,
|
|
PragmaTerms, ErrorTerm, Result).
|
|
|
|
parse_pragma_type(ModuleName, "obsolete", PragmaTerms, ErrorTerm,
|
|
_VarSet, Result) :-
|
|
parse_simple_pragma(ModuleName, "obsolete",
|
|
lambda([Name::in, Arity::in, Pragma::out] is det,
|
|
Pragma = obsolete(Name, Arity)),
|
|
PragmaTerms, ErrorTerm, Result).
|
|
|
|
% pragma unused_args should never appear in user programs,
|
|
% only in .opt files.
|
|
parse_pragma_type(ModuleName, "unused_args", PragmaTerms,
|
|
ErrorTerm, _VarSet, Result) :-
|
|
(
|
|
PragmaTerms = [
|
|
PredOrFuncTerm,
|
|
PredNameTerm,
|
|
term__functor(term__integer(Arity), [], _),
|
|
term__functor(term__integer(ModeNum), [], _),
|
|
UnusedArgsTerm
|
|
],
|
|
(
|
|
PredOrFuncTerm = term__functor(
|
|
term__atom("predicate"), [], _),
|
|
PredOrFunc = predicate
|
|
;
|
|
PredOrFuncTerm = term__functor(
|
|
term__atom("function"), [], _),
|
|
PredOrFunc = function
|
|
),
|
|
parse_implicitly_qualified_term(ModuleName, PredNameTerm,
|
|
ErrorTerm, "`:- pragma unused_args' declaration",
|
|
PredNameResult),
|
|
PredNameResult = ok(PredName, []),
|
|
convert_int_list(UnusedArgsTerm, UnusedArgsResult),
|
|
UnusedArgsResult = ok(UnusedArgs)
|
|
->
|
|
Result = ok(pragma(unused_args(PredOrFunc, PredName,
|
|
Arity, ModeNum, UnusedArgs)))
|
|
;
|
|
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,
|
|
_VarSet, Result) :-
|
|
(
|
|
PragmaTerms = [PredAndArityTerm, FileNameTerm]
|
|
->
|
|
parse_pred_name_and_arity(ModuleName, "fact_table",
|
|
PredAndArityTerm, ErrorTerm, NameArityResult),
|
|
(
|
|
NameArityResult = ok(PredName, Arity),
|
|
(
|
|
FileNameTerm = term__functor(term__string(FileName), [], _)
|
|
->
|
|
Result = ok(pragma(fact_table(PredName, Arity, FileName)))
|
|
;
|
|
Result = error("expected string for fact table filename",
|
|
FileNameTerm)
|
|
)
|
|
;
|
|
NameArityResult = error(ErrorMsg, _),
|
|
Result = error(ErrorMsg, PredAndArityTerm)
|
|
)
|
|
;
|
|
Result =
|
|
error(
|
|
"wrong number of arguments in `:- pragma fact_table' declaration",
|
|
ErrorTerm)
|
|
).
|
|
|
|
parse_pragma_type(ModuleName, "aditi", PragmaTerms, ErrorTerm, _, Result) :-
|
|
parse_simple_pragma(ModuleName, "aditi",
|
|
lambda([Name::in, Arity::in, Pragma::out] is det,
|
|
Pragma = aditi(Name, Arity)),
|
|
PragmaTerms, ErrorTerm, Result).
|
|
|
|
parse_pragma_type(ModuleName, "base_relation", PragmaTerms,
|
|
ErrorTerm, _, Result) :-
|
|
parse_simple_pragma(ModuleName, "base_relation",
|
|
lambda([Name::in, Arity::in, Pragma::out] is det,
|
|
Pragma = base_relation(Name, Arity)),
|
|
PragmaTerms, ErrorTerm, Result).
|
|
|
|
parse_pragma_type(ModuleName, "aditi_index", PragmaTerms,
|
|
ErrorTerm, _, Result) :-
|
|
( PragmaTerms = [PredNameArityTerm, IndexTypeTerm, AttributesTerm] ->
|
|
parse_pred_name_and_arity(ModuleName, "aditi_index",
|
|
PredNameArityTerm, ErrorTerm, NameArityResult),
|
|
(
|
|
NameArityResult = ok(PredName, PredArity),
|
|
(
|
|
IndexTypeTerm = term__functor(term__atom(IndexTypeStr),
|
|
[], _),
|
|
(
|
|
IndexTypeStr = "unique_B_tree",
|
|
IndexType = unique_B_tree
|
|
;
|
|
IndexTypeStr = "non_unique_B_tree",
|
|
IndexType = non_unique_B_tree
|
|
)
|
|
->
|
|
convert_int_list(AttributesTerm, AttributeResult),
|
|
(
|
|
AttributeResult = ok(Attributes),
|
|
Result = ok(pragma(aditi_index(PredName, PredArity,
|
|
index_spec(IndexType, Attributes))))
|
|
;
|
|
AttributeResult = error(_, AttrErrorTerm),
|
|
Result = error(
|
|
"expected attribute list for `:- pragma aditi_index' declaration",
|
|
AttrErrorTerm)
|
|
)
|
|
;
|
|
Result = error(
|
|
"expected index type for `:- pragma aditi_index' declaration",
|
|
IndexTypeTerm)
|
|
)
|
|
;
|
|
NameArityResult = error(NameErrorMsg, NameErrorTerm),
|
|
Result = error(NameErrorMsg, NameErrorTerm)
|
|
)
|
|
;
|
|
Result = error(
|
|
"wrong number of arguments in `:- pragma aditi_index' declaration",
|
|
ErrorTerm)
|
|
).
|
|
|
|
parse_pragma_type(ModuleName, "naive", PragmaTerms, ErrorTerm, _, Result) :-
|
|
parse_simple_pragma(ModuleName, "naive",
|
|
lambda([Name::in, Arity::in, Pragma::out] is det,
|
|
Pragma = naive(Name, Arity)),
|
|
PragmaTerms, ErrorTerm, Result).
|
|
|
|
parse_pragma_type(ModuleName, "psn", PragmaTerms, ErrorTerm, _, Result) :-
|
|
parse_simple_pragma(ModuleName, "psn",
|
|
lambda([Name::in, Arity::in, Pragma::out] is det,
|
|
Pragma = psn(Name, Arity)),
|
|
PragmaTerms, ErrorTerm, Result).
|
|
|
|
parse_pragma_type(ModuleName, "aditi_memo",
|
|
PragmaTerms, ErrorTerm, _, Result) :-
|
|
parse_simple_pragma(ModuleName, "aditi_memo",
|
|
lambda([Name::in, Arity::in, Pragma::out] is det,
|
|
Pragma = aditi_memo(Name, Arity)),
|
|
PragmaTerms, ErrorTerm, Result).
|
|
|
|
parse_pragma_type(ModuleName, "aditi_no_memo",
|
|
PragmaTerms, ErrorTerm, _, Result) :-
|
|
parse_simple_pragma(ModuleName, "aditi_no_memo",
|
|
lambda([Name::in, Arity::in, Pragma::out] is det,
|
|
Pragma = aditi_no_memo(Name, Arity)),
|
|
PragmaTerms, ErrorTerm, Result).
|
|
|
|
parse_pragma_type(ModuleName, "supp_magic",
|
|
PragmaTerms, ErrorTerm, _, Result) :-
|
|
parse_simple_pragma(ModuleName, "supp_magic",
|
|
lambda([Name::in, Arity::in, Pragma::out] is det,
|
|
Pragma = supp_magic(Name, Arity)),
|
|
PragmaTerms, ErrorTerm, Result).
|
|
|
|
parse_pragma_type(ModuleName, "context",
|
|
PragmaTerms, ErrorTerm, _, Result) :-
|
|
parse_simple_pragma(ModuleName, "context",
|
|
lambda([Name::in, Arity::in, Pragma::out] is det,
|
|
Pragma = context(Name, Arity)),
|
|
PragmaTerms, ErrorTerm, Result).
|
|
|
|
parse_pragma_type(ModuleName, "owner",
|
|
PragmaTerms, ErrorTerm, _, Result) :-
|
|
( PragmaTerms = [SymNameAndArityTerm, OwnerTerm] ->
|
|
( OwnerTerm = term__functor(term__atom(Owner), [], _) ->
|
|
parse_simple_pragma(ModuleName, "owner",
|
|
lambda([Name::in, Arity::in, Pragma::out] is det,
|
|
Pragma = owner(Name, Arity, Owner)),
|
|
[SymNameAndArityTerm], ErrorTerm, Result)
|
|
;
|
|
ErrorMsg = "expected owner name for `:- pragma owner' declaration",
|
|
Result = error(ErrorMsg, OwnerTerm)
|
|
)
|
|
;
|
|
ErrorMsg = "wrong number of arguments in `:- pragma owner' declaration",
|
|
Result = error(ErrorMsg, ErrorTerm)
|
|
).
|
|
|
|
parse_pragma_type(ModuleName, "promise_pure", PragmaTerms, ErrorTerm,
|
|
_VarSet, Result) :-
|
|
parse_simple_pragma(ModuleName, "promise_pure",
|
|
lambda([Name::in, Arity::in, Pragma::out] is det,
|
|
Pragma = promise_pure(Name, Arity)),
|
|
PragmaTerms, ErrorTerm, Result).
|
|
|
|
parse_pragma_type(ModuleName, "termination_info", PragmaTerms, ErrorTerm,
|
|
_VarSet, Result) :-
|
|
(
|
|
PragmaTerms = [
|
|
PredAndModesTerm0,
|
|
ArgSizeTerm,
|
|
TerminationTerm
|
|
],
|
|
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"), [], _),
|
|
MaybeArgSizeInfo = yes(infinite)
|
|
;
|
|
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"), [], _),
|
|
MaybeTerminationInfo = yes(can_loop)
|
|
;
|
|
TerminationTerm = term__functor(term__atom("cannot_loop"),
|
|
[], _),
|
|
MaybeTerminationInfo = yes(cannot_loop)
|
|
),
|
|
Result0 = ok(pragma(termination_info(PredOrFunc, PredName,
|
|
ModeList, MaybeArgSizeInfo, MaybeTerminationInfo)))
|
|
->
|
|
Result = Result0
|
|
;
|
|
Result = error(
|
|
"syntax error in `:- pragma termination_info' declaration",
|
|
ErrorTerm)
|
|
).
|
|
|
|
parse_pragma_type(ModuleName, "terminates", PragmaTerms,
|
|
ErrorTerm, _VarSet, Result) :-
|
|
parse_simple_pragma(ModuleName, "terminates",
|
|
lambda([Name::in, Arity::in, Pragma::out] is det,
|
|
Pragma = terminates(Name, Arity)),
|
|
PragmaTerms, ErrorTerm, Result).
|
|
|
|
parse_pragma_type(ModuleName, "does_not_terminate", PragmaTerms,
|
|
ErrorTerm, _VarSet, Result) :-
|
|
parse_simple_pragma(ModuleName, "does_not_terminate",
|
|
lambda([Name::in, Arity::in, Pragma::out] is det,
|
|
Pragma = does_not_terminate(Name, Arity)),
|
|
PragmaTerms, ErrorTerm, Result).
|
|
|
|
parse_pragma_type(ModuleName, "check_termination", PragmaTerms,
|
|
ErrorTerm, _VarSet, Result) :-
|
|
parse_simple_pragma(ModuleName, "check_termination",
|
|
lambda([Name::in, Arity::in, Pragma::out] is det,
|
|
Pragma = check_termination(Name, Arity)),
|
|
PragmaTerms, ErrorTerm, Result).
|
|
|
|
:- pred parse_simple_pragma(module_name, string,
|
|
pred(sym_name, int, pragma_type),
|
|
list(term), term, maybe1(item)).
|
|
:- mode parse_simple_pragma(in, in, pred(in, in, out) is det,
|
|
in, in, out) is det.
|
|
|
|
parse_simple_pragma(ModuleName, PragmaType, MakePragma,
|
|
PragmaTerms, ErrorTerm, Result) :-
|
|
( PragmaTerms = [PredAndArityTerm] ->
|
|
parse_pred_name_and_arity(ModuleName, PragmaType,
|
|
PredAndArityTerm, ErrorTerm, NameArityResult),
|
|
(
|
|
NameArityResult = ok(PredName, Arity),
|
|
call(MakePragma, PredName, Arity, Pragma),
|
|
Result = ok(pragma(Pragma))
|
|
;
|
|
NameArityResult = error(ErrorMsg, _),
|
|
Result = error(ErrorMsg, PredAndArityTerm)
|
|
)
|
|
;
|
|
string__append_list(["wrong number of arguments in `:- pragma ",
|
|
PragmaType, "' declaration"], ErrorMsg),
|
|
Result = error(ErrorMsg, ErrorTerm)
|
|
).
|
|
|
|
:- pred parse_pred_name_and_arity(module_name, string, term, term,
|
|
maybe2(sym_name, arity)).
|
|
:- mode parse_pred_name_and_arity(in, in, in, in, out) is det.
|
|
|
|
parse_pred_name_and_arity(ModuleName, PragmaType, PredAndArityTerm,
|
|
ErrorTerm, Result) :-
|
|
(
|
|
parse_name_and_arity(ModuleName, PredAndArityTerm,
|
|
PredName, Arity)
|
|
->
|
|
Result = ok(PredName, Arity)
|
|
;
|
|
string__append_list(["expected predname/arity for `pragma ",
|
|
PragmaType, "' declaration"], ErrorMsg),
|
|
Result = error(ErrorMsg, ErrorTerm)
|
|
).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- pred parse_pragma_keyword(string, term, string, term__context).
|
|
:- mode parse_pragma_keyword(in, in, out, out) is semidet.
|
|
|
|
parse_pragma_keyword(ExpectedKeyword, Term, StringArg, StartContext) :-
|
|
Term = term__functor(term__atom(ExpectedKeyword), [Arg], _),
|
|
Arg = term__functor(term__string(StringArg), [], StartContext).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- type collected_pragma_c_code_attribute
|
|
---> may_call_mercury(may_call_mercury)
|
|
; thread_safe(thread_safe)
|
|
.
|
|
|
|
:- pred parse_pragma_c_code_attributes_term(term,
|
|
pragma_foreign_code_attributes).
|
|
:- mode parse_pragma_c_code_attributes_term(in, out) is semidet.
|
|
|
|
parse_pragma_c_code_attributes_term(Term, Attributes) :-
|
|
default_attributes(Attributes0),
|
|
parse_pragma_c_code_attributes_term0(Term, AttrList),
|
|
( list__member(may_call_mercury(will_not_call_mercury), AttrList) ->
|
|
( list__member(may_call_mercury(may_call_mercury), AttrList) ->
|
|
% XXX an error message would be nice
|
|
fail
|
|
;
|
|
set_may_call_mercury(Attributes0,
|
|
will_not_call_mercury, Attributes1)
|
|
)
|
|
;
|
|
Attributes1 = Attributes0
|
|
),
|
|
( list__member(thread_safe(thread_safe), AttrList) ->
|
|
( list__member(thread_safe(not_thread_safe), AttrList) ->
|
|
% XXX an error message would be nice
|
|
fail
|
|
;
|
|
set_thread_safe(Attributes1, thread_safe, Attributes)
|
|
)
|
|
;
|
|
Attributes = Attributes1
|
|
).
|
|
|
|
:- pred parse_pragma_c_code_attributes_term0(term,
|
|
list(collected_pragma_c_code_attribute)).
|
|
:- mode parse_pragma_c_code_attributes_term0(in, out) is semidet.
|
|
|
|
parse_pragma_c_code_attributes_term0(Term, Flags) :-
|
|
(
|
|
parse_single_pragma_c_code_attribute(Term, Flag)
|
|
->
|
|
Flags = [Flag]
|
|
;
|
|
(
|
|
Term = term__functor(term__atom("[]"), [], _),
|
|
Flags = []
|
|
;
|
|
Term = term__functor(term__atom("."), [Hd, Tl], _),
|
|
Flags = [Flag|Flags0],
|
|
parse_single_pragma_c_code_attribute(Hd, Flag),
|
|
parse_pragma_c_code_attributes_term0(Tl, Flags0)
|
|
)
|
|
).
|
|
|
|
:- pred parse_single_pragma_c_code_attribute(term,
|
|
collected_pragma_c_code_attribute).
|
|
:- mode parse_single_pragma_c_code_attribute(in, out) is semidet.
|
|
|
|
parse_single_pragma_c_code_attribute(Term, Flag) :-
|
|
( parse_may_call_mercury(Term, MayCallMercury) ->
|
|
Flag = may_call_mercury(MayCallMercury)
|
|
; parse_threadsafe(Term, ThreadSafe) ->
|
|
Flag = thread_safe(ThreadSafe)
|
|
;
|
|
fail
|
|
).
|
|
|
|
:- pred parse_may_call_mercury(term, may_call_mercury).
|
|
:- mode parse_may_call_mercury(in, out) is semidet.
|
|
|
|
parse_may_call_mercury(term__functor(term__atom("recursive"), [], _),
|
|
may_call_mercury).
|
|
parse_may_call_mercury(term__functor(term__atom("non_recursive"), [], _),
|
|
will_not_call_mercury).
|
|
parse_may_call_mercury(term__functor(term__atom("may_call_mercury"), [], _),
|
|
may_call_mercury).
|
|
parse_may_call_mercury(term__functor(term__atom("will_not_call_mercury"), [],
|
|
_), will_not_call_mercury).
|
|
|
|
:- pred parse_threadsafe(term, thread_safe).
|
|
:- mode parse_threadsafe(in, out) is semidet.
|
|
|
|
parse_threadsafe(term__functor(term__atom("thread_safe"), [], _),
|
|
thread_safe).
|
|
parse_threadsafe(term__functor(term__atom("not_thread_safe"), [], _),
|
|
not_thread_safe).
|
|
|
|
% parse a pragma c_code declaration
|
|
|
|
:- pred parse_pragma_foreign_code(module_name, foreign_language,
|
|
pragma_foreign_code_attributes, term, pragma_foreign_code_impl,
|
|
varset, maybe1(item)).
|
|
:- mode parse_pragma_foreign_code(in, in, in, in, in, in, out) is det.
|
|
|
|
parse_pragma_foreign_code(ModuleName, ForeignLanguage, Flags, PredAndVarsTerm0,
|
|
PragmaImpl, VarSet0, Result) :-
|
|
parse_pred_or_func_and_args(yes(ModuleName), PredAndVarsTerm0,
|
|
PredAndVarsTerm0, "`:- pragma c_code' declaration", PredAndArgsResult),
|
|
(
|
|
PredAndArgsResult = ok(PredName, VarList0 - MaybeRetTerm),
|
|
(
|
|
% is this a function or a predicate?
|
|
MaybeRetTerm = yes(FuncResultTerm0)
|
|
->
|
|
% function
|
|
PredOrFunc = function,
|
|
list__append(VarList0, [FuncResultTerm0], VarList)
|
|
;
|
|
% predicate
|
|
PredOrFunc = predicate,
|
|
VarList = VarList0
|
|
),
|
|
parse_pragma_c_code_varlist(VarSet0, VarList, PragmaVars, Error),
|
|
(
|
|
Error = no,
|
|
varset__coerce(VarSet0, VarSet),
|
|
Result = ok(pragma(foreign(ForeignLanguage, Flags, PredName,
|
|
PredOrFunc, PragmaVars, VarSet, PragmaImpl)))
|
|
;
|
|
Error = yes(ErrorMessage),
|
|
Result = error(ErrorMessage, PredAndVarsTerm0)
|
|
|
|
)
|
|
;
|
|
PredAndArgsResult = error(Msg, Term),
|
|
Result = error(Msg, Term)
|
|
).
|
|
|
|
% parse the variable list in the pragma c code declaration.
|
|
% The final argument is 'no' for no error, or 'yes(ErrorMessage)'.
|
|
:- pred parse_pragma_c_code_varlist(varset, list(term),
|
|
list(pragma_var), maybe(string)).
|
|
:- mode parse_pragma_c_code_varlist(in, in, out, out) is det.
|
|
|
|
parse_pragma_c_code_varlist(_, [], [], no).
|
|
parse_pragma_c_code_varlist(VarSet, [V|Vars], PragmaVars, Error):-
|
|
(
|
|
V = term__functor(term__atom("::"), [VarTerm, ModeTerm], _),
|
|
VarTerm = term__variable(Var)
|
|
->
|
|
(
|
|
varset__search_name(VarSet, Var, VarName)
|
|
->
|
|
(
|
|
convert_mode(ModeTerm, Mode)
|
|
->
|
|
term__coerce_var(Var, ProgVar),
|
|
P = (pragma_var(ProgVar, VarName, Mode)),
|
|
parse_pragma_c_code_varlist(VarSet,
|
|
Vars, PragmaVars0, Error),
|
|
PragmaVars = [P|PragmaVars0]
|
|
;
|
|
PragmaVars = [],
|
|
Error = yes("unknown mode in pragma c_code")
|
|
)
|
|
;
|
|
% if the variable wasn't in the varset it must be an
|
|
% underscore variable.
|
|
PragmaVars = [], % return any old junk for that.
|
|
Error = yes(
|
|
"sorry, not implemented: anonymous `_' variable in pragma c_code")
|
|
)
|
|
;
|
|
PragmaVars = [], % return any old junk in PragmaVars
|
|
Error = yes("arguments not in form 'Var :: mode'")
|
|
).
|
|
|
|
|
|
:- pred parse_tabling_pragma(module_name, string, eval_method, list(term),
|
|
term, maybe1(item)).
|
|
:- mode parse_tabling_pragma(in, in, in, in, in, out) is det.
|
|
|
|
parse_tabling_pragma(ModuleName, PragmaName, TablingType, PragmaTerms,
|
|
ErrorTerm, Result) :-
|
|
(
|
|
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], _)
|
|
->
|
|
(
|
|
parse_implicitly_qualified_term(ModuleName,
|
|
PredNameTerm, PredAndModesTerm0, "", ok(PredName, [])),
|
|
ArityTerm = term__functor(term__integer(Arity), [], _)
|
|
->
|
|
Result = ok(arity_or_modes(PredName, Arity, no, no))
|
|
;
|
|
string__append("expected predname/arity for", ErrorMsg, Msg),
|
|
Result = error(Msg, ErrorTerm)
|
|
)
|
|
;
|
|
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
|
|
;
|
|
Arity = Arity0
|
|
),
|
|
Result = ok(arity_or_modes(PredName, Arity,
|
|
yes(PredOrFunc), yes(Modes)))
|
|
;
|
|
PredAndModesResult = error(Msg, Term),
|
|
Result = error(Msg, Term)
|
|
)
|
|
).
|
|
|
|
:- type maybe_pred_or_func_modes ==
|
|
maybe2(pair(sym_name, pred_or_func), list(mode)).
|
|
|
|
:- 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) ->
|
|
(
|
|
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)
|
|
)
|
|
;
|
|
MaybeRetModeTerm = no,
|
|
Result = ok(PredName - predicate, ArgModes0)
|
|
)
|
|
;
|
|
string__append("error in argument modes in ", Msg,
|
|
ErrorMsg),
|
|
Result = error(ErrorMsg, ErrorTerm)
|
|
)
|
|
;
|
|
PredAndArgsResult = error(ErrorMsg, Term),
|
|
Result = error(ErrorMsg, Term)
|
|
).
|
|
|
|
:- pred convert_bool_list(term::in, list(bool)::out) is semidet.
|
|
|
|
convert_bool_list(term__functor(Functor, Args, _), Bools) :-
|
|
(
|
|
Functor = term__atom("."),
|
|
Args = [term__functor(AtomTerm, [], _), RestTerm],
|
|
(
|
|
AtomTerm = term__atom("yes"),
|
|
Bool = yes
|
|
;
|
|
AtomTerm = term__atom("no"),
|
|
Bool = no
|
|
),
|
|
convert_bool_list(RestTerm, RestList),
|
|
Bools = [ Bool | RestList ]
|
|
;
|
|
Functor = term__atom("[]"),
|
|
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.
|
|
|