mirror of
https://github.com/Mercury-Language/mercury.git
synced 2025-12-14 05:12:33 +00:00
702b512aaf
Estimated hours taken: 1 compiler/prog_data.m: Add a new type of annotation on procedures defined by pragma foreign code. For now the annotation is ignored. When I/O tabling is implemented (soon), this annotation will ask for the procedure to be considered an I/O predicate and tabled accordingly. compiler/prog_io_pragma.m: Parse the new annotation. tests/valid/tabled_for_io.m: Test case to check that the compiler accepts the new annotation. tests/valid/Mmakefile: Enable the test case.
1195 lines
37 KiB
Mathematica
1195 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)
|
|
).
|
|
|
|
|
|
% XXX this should use the same language specification
|
|
% strings as globals__convert_target.
|
|
:- 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)
|
|
; tabled_for_io(tabled_for_io).
|
|
|
|
:- 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, Attributes2)
|
|
)
|
|
;
|
|
Attributes2 = Attributes1
|
|
),
|
|
( list__member(tabled_for_io(tabled_for_io), AttrList) ->
|
|
( list__member(tabled_for_io(not_tabled_for_io), AttrList) ->
|
|
% XXX an error message would be nice
|
|
fail
|
|
;
|
|
set_tabled_for_io(Attributes2, tabled_for_io,
|
|
Attributes)
|
|
)
|
|
;
|
|
Attributes = Attributes2
|
|
).
|
|
|
|
:- 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)
|
|
; parse_tabled_for_io(Term, TabledForIo) ->
|
|
Flag = tabled_for_io(TabledForIo)
|
|
;
|
|
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).
|
|
|
|
:- pred parse_tabled_for_io(term, tabled_for_io).
|
|
:- mode parse_tabled_for_io(in, out) is semidet.
|
|
|
|
parse_tabled_for_io(term__functor(term__atom("tabled_for_io"), [], _),
|
|
tabled_for_io).
|
|
parse_tabled_for_io(term__functor(term__atom("not_tabled_for_io"), [], _),
|
|
not_tabled_for_io).
|
|
|
|
% 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.
|
|
|