%-----------------------------------------------------------------------------% % vim: ft=mercury ts=4 sw=4 expandtab %-----------------------------------------------------------------------------% % Copyright (C) 1996-2007 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, zs. % % This module handles the parsing of pragma directives. % %-----------------------------------------------------------------------------% :- module parse_tree.prog_io_pragma. :- interface. :- import_module libs.globals. :- import_module mdbcomp.prim_data. :- import_module parse_tree.prog_item. :- import_module parse_tree.prog_io_util. :- import_module list. :- import_module term. :- import_module varset. %-----------------------------------------------------------------------------% % Parse the pragma declaration. % :- pred parse_pragma(module_name::in, varset::in, list(term)::in, maybe1(item)::out) is semidet. % Parse a term that represents a foreign language. % :- pred parse_foreign_language(term::in, foreign_language::out) is semidet. %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- implementation. :- import_module libs.compiler_util. :- import_module libs.rat. :- import_module parse_tree.prog_ctgc. :- import_module parse_tree.prog_data. :- import_module parse_tree.prog_io. :- import_module parse_tree.prog_out. :- import_module parse_tree.prog_util. :- import_module assoc_list. :- import_module bool. :- import_module int. :- import_module maybe. :- import_module pair. :- import_module set. :- import_module string. :- import_module unit. %-----------------------------------------------------------------------------% parse_pragma(ModuleName, VarSet, PragmaTerms, Result) :- ( PragmaTerms = [SinglePragmaTerm0], parse_type_decl_where_part_if_present(non_solver_type, ModuleName, SinglePragmaTerm0, SinglePragmaTerm, WherePartResult), SinglePragmaTerm = term.functor(term.atom(PragmaType), PragmaArgs, _), parse_pragma_type(ModuleName, PragmaType, PragmaArgs, SinglePragmaTerm, VarSet, Result0) -> ( % The code to process `where' attributes will return an error % result if solver attributes are given for a non-solver type. % Because this is a non-solver type, if the unification with % WhereResult succeeds then _NoSolverTypeDetails is guaranteed to % be `no'. WherePartResult = ok2(_NoSolverTypeDetails, MaybeUserEqComp), ( MaybeUserEqComp = yes(_), Result0 = ok1(Item0) -> ( Item0 = item_type_defn(_, _, _, _, _), Item0 ^ td_ctor_defn = parse_tree_foreign_type(Type, _, Assertions) -> Result = ok1(Item0 ^ td_ctor_defn := parse_tree_foreign_type(Type, MaybeUserEqComp, Assertions)) ; Msg = "unexpected `where equality/comparison is'", Result = error1([Msg - SinglePragmaTerm0]) ) ; Result = Result0 ) ; WherePartResult = error2(Errors), Result = error1(Errors) ) ; fail ). :- pred parse_pragma_type(module_name::in, string::in, list(term)::in, term::in, varset::in, maybe1(item)::out) is semidet. parse_pragma_type(_, "source_file", PragmaTerms, ErrorTerm, _VarSet, Result) :- ( PragmaTerms = [SourceFileTerm] -> ( SourceFileTerm = term.functor(term.string(SourceFile), [], _) -> Result = ok1(item_pragma(user, pragma_source_file(SourceFile))) ; Msg = "string expected in `:- pragma source_file' declaration", Result = error1([Msg - SourceFileTerm]) ) ; Msg = "wrong number of arguments in " ++ "`:- pragma source_file' declaration", Result = error1([Msg - ErrorTerm]) ). parse_pragma_type(ModuleName, "foreign_type", PragmaTerms, ErrorTerm, VarSet, Result) :- ( ( PragmaTerms = [LangTerm, MercuryTypeTerm, ForeignTypeTerm], MaybeAssertionTerm = no ; PragmaTerms = [LangTerm, MercuryTypeTerm, ForeignTypeTerm, AssertionTerm], MaybeAssertionTerm = yes(AssertionTerm) ) -> ( parse_foreign_language(LangTerm, Language) -> parse_foreign_language_type(ForeignTypeTerm, Language, MaybeForeignType), ( MaybeForeignType = ok1(ForeignType), parse_type_defn_head(ModuleName, MercuryTypeTerm, ErrorTerm, MaybeTypeDefnHead), ( MaybeTypeDefnHead = ok2(MercuryTypeSymName, MercuryParams), varset.coerce(VarSet, TVarSet), ( parse_maybe_foreign_type_assertions(MaybeAssertionTerm, Assertions) -> % rafe: XXX I'm not sure that `no' here is right % - we might need some more parsing... Result = ok1(item_type_defn(TVarSet, MercuryTypeSymName, MercuryParams, parse_tree_foreign_type(ForeignType, no, Assertions), cond_true)) ; MaybeAssertionTerm = yes(ErrorAssertionTerm) -> Msg = "invalid assertion in " ++ "`:- pragma foreign_type' declaration", Result = error1([Msg - ErrorAssertionTerm]) ; unexpected(this_file, "parse_pragma_type: unexpected failure of " ++ "parse_maybe_foreign_type_assertion") ) ; MaybeTypeDefnHead = error2(Errors), Result = error1(Errors) ) ; MaybeForeignType = error1(Errors), Result = error1(Errors) ) ; Msg = "invalid foreign language in " ++ "`:- pragma foreign_type' declaration", Result = error1([Msg - LangTerm]) ) ; Msg = "wrong number of arguments in " ++ "`:- pragma foreign_type' declaration", Result = error1([Msg - ErrorTerm]) ). parse_pragma_type(ModuleName, "foreign_decl", PragmaTerms, ErrorTerm, VarSet, Result) :- parse_pragma_foreign_decl_pragma(ModuleName, "foreign_decl", PragmaTerms, ErrorTerm, VarSet, Result). parse_pragma_type(ModuleName, "c_header_code", PragmaTerms, ErrorTerm, VarSet, Result) :- ( PragmaTerms = [term.functor(_, _, Context) | _] -> LangC = term.functor(term.string("C"), [], Context), parse_pragma_foreign_decl_pragma(ModuleName, "c_header_code", [LangC | PragmaTerms], ErrorTerm, VarSet, Result) ; Msg = "wrong number of arguments or unexpected variable " ++ "in `:- pragma c_header_code' declaration", Result = error1([Msg - ErrorTerm]) ). parse_pragma_type(ModuleName, "foreign_code", PragmaTerms, ErrorTerm, VarSet, Result) :- parse_pragma_foreign_code_pragma(ModuleName, "foreign_code", PragmaTerms, ErrorTerm, VarSet, Result). parse_pragma_type(ModuleName, "foreign_proc", PragmaTerms, ErrorTerm, VarSet, Result) :- parse_pragma_foreign_proc_pragma(ModuleName, "foreign_proc", PragmaTerms, ErrorTerm, VarSet, Result). parse_pragma_type(_ModuleName, "foreign_export", PragmaTerms, ErrorTerm, _VarSet, Result) :- ( PragmaTerms = [LangTerm, PredAndModesTerm, FunctionTerm] -> ( FunctionTerm = term.functor(term.string(Function), [], _) -> parse_pred_or_func_and_arg_modes(no, PredAndModesTerm, ErrorTerm, "`:- pragma foreign_export' declaration", PredAndModesResult), ( PredAndModesResult = ok2(PredName - PredOrFunc, Modes), ( parse_foreign_language(LangTerm, ForeignLanguage) -> Result = ok1(item_pragma(user, pragma_foreign_export(ForeignLanguage, PredName, PredOrFunc, Modes, Function))) ; Msg = "invalid foreign language in " ++ "`:- pragma foreign_export declaration", Result = error1([Msg - LangTerm]) ) ; PredAndModesResult = error2(Errors), Result = error1(Errors) ) ; Msg = "expected pragma " ++ "foreign_export(Lang, PredName(ModeList), Function)", Result = error1([Msg - PredAndModesTerm]) ) ; Msg = "wrong number of arguments in " ++ "`:- pragma foreign_export' declaration", Result = error1([Msg - ErrorTerm]) ). % pragma c_code is almost as if we have written foreign_code % or foreign_proc 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) :- ( % arity = 1 (same as foreign_code) PragmaTerms = [term.functor(_, _, Context)] -> LangC = term.functor(term.string("C"), [], Context), parse_pragma_foreign_code_pragma(ModuleName, "c_code", [LangC | PragmaTerms], ErrorTerm, VarSet, Result) ; % arity > 1 (same as foreign_proc) PragmaTerms = [term.functor(_, _, Context) | _] -> LangC = term.functor(term.string("C"), [], Context), parse_pragma_foreign_proc_pragma(ModuleName, "c_code", [LangC | PragmaTerms], ErrorTerm, VarSet, Result) ; Msg = "wrong number of arguments or unexpected variable" ++ "in `:- pragma c_code' declaration", Result = error1([Msg - ErrorTerm]) ). parse_pragma_type(_ModuleName, "c_import_module", PragmaTerms, ErrorTerm, _VarSet, Result) :- ( PragmaTerms = [ImportTerm], sym_name_and_args(ImportTerm, Import, []) -> Result = ok1(item_pragma(user, pragma_foreign_import_module(lang_c, Import))) ; Msg = "wrong number of arguments or invalid module name " ++ "in `:- pragma c_import_module' declaration", Result = error1([Msg - ErrorTerm]) ). parse_pragma_type(_ModuleName, "foreign_import_module", PragmaTerms, ErrorTerm, _VarSet, Result) :- ( PragmaTerms = [LangTerm, ImportTerm], sym_name_and_args(ImportTerm, Import, []) -> ( parse_foreign_language(LangTerm, Language) -> Result = ok1(item_pragma(user, pragma_foreign_import_module(Language, Import))) ; Msg = "invalid foreign language in " ++ "`:- pragma foreign_import_module' declaration", Result = error1([Msg - LangTerm]) ) ; Msg = "wrong number of arguments or invalid module name " ++ "in `:- pragma foreign_import_module' declaration", Result = error1([Msg - ErrorTerm]) ). parse_pragma_type(ModuleName, "import", PragmaTerms, ErrorTerm, VarSet, Result) :- % XXX We assume all imports are C. ForeignLanguage = lang_c, ( ( PragmaTerms = [PredAndModesTerm, FlagsTerm, FunctionTerm], parse_pragma_foreign_proc_attributes_term(ForeignLanguage, "import", VarSet, FlagsTerm, MaybeFlags), ( MaybeFlags = error1(FlagsErrors0), FlagsErrors = assoc_list.map_keys_only( string.append("invalid second argument in " ++ "`:- pragma import/3' declaration : "), FlagsErrors0), FlagsResult = error1(FlagsErrors) ; MaybeFlags = ok1(Flags), FlagsResult = ok1(Flags) ) ; PragmaTerms = [PredAndModesTerm, FunctionTerm], Flags0 = default_attributes(ForeignLanguage), % Pragma import uses legacy purity behaviour. set_legacy_purity_behaviour(yes, Flags0, Flags), FlagsResult = ok1(Flags) ) -> ( FunctionTerm = term.functor(term.string(Function), [], _) -> parse_pred_or_func_and_arg_modes(yes(ModuleName), PredAndModesTerm, ErrorTerm, "`:- pragma import' declaration", PredAndArgModesResult), ( PredAndArgModesResult = ok2(PredName - PredOrFunc, ArgModes), ( FlagsResult = ok1(Attributes), Result = ok1(item_pragma(user, pragma_import(PredName, PredOrFunc, ArgModes, Attributes, Function))) ; FlagsResult = error1(FlagsErrors2), Result = error1(FlagsErrors2) ) ; PredAndArgModesResult = error2(PredAndArgModesErrors), Result = error1(PredAndArgModesErrors) ) ; Msg = "expected pragma import(PredName(ModeList), Function)", Result = error1([Msg - PredAndModesTerm]) ) ; Msg = "wrong number of arguments in `:- pragma import' declaration", Result = error1([Msg - ErrorTerm]) ). parse_pragma_type(_ModuleName, "export", PragmaTerms, ErrorTerm, _VarSet, Result) :- ( PragmaTerms = [PredAndModesTerm, FunctionTerm] -> ( FunctionTerm = term.functor(term.string(Function), [], _) -> parse_pred_or_func_and_arg_modes(no, PredAndModesTerm, ErrorTerm, "`:- pragma export' declaration", PredAndModesResult), ( PredAndModesResult = ok2(PredName - PredOrFunc, Modes), Result = ok1(item_pragma(user, pragma_foreign_export(lang_c, PredName, PredOrFunc, Modes, Function))) ; PredAndModesResult = error2(PredAndModesErrors), Result = error1(PredAndModesErrors) ) ; Result = error1( ["expected pragma export(PredName(ModeList), Function)" - PredAndModesTerm]) ) ; Msg = "wrong number of arguments in `:- pragma export' declaration", Result = error1([Msg - ErrorTerm]) ). parse_pragma_type(ModuleName, "inline", PragmaTerms, ErrorTerm, _VarSet, Result) :- MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :- Pragma = pragma_inline(Name, Arity)), parse_simple_pragma(ModuleName, "inline", MakePragma, PragmaTerms, ErrorTerm, Result). parse_pragma_type(ModuleName, "no_inline", PragmaTerms, ErrorTerm, _VarSet, Result) :- MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :- Pragma = pragma_no_inline(Name, Arity)), parse_simple_pragma(ModuleName, "no_inline", MakePragma, 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) :- % We don't yet know whether we will use the stack_copy or the own_stacks % technique for computing minimal models. The decision depends on the % grade, and is made in make_hlds.m; the stack_copy here is just a % placeholder. parse_tabling_pragma(ModuleName, "minimal_model", eval_minimal(stack_copy), PragmaTerms, ErrorTerm, Result). parse_pragma_type(ModuleName, "obsolete", PragmaTerms, ErrorTerm, _VarSet, Result) :- MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :- Pragma = pragma_obsolete(Name, Arity)), parse_simple_pragma(ModuleName, "obsolete", MakePragma, 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 = pf_predicate ; PredOrFuncTerm = term.functor(term.atom("function"), [], _), PredOrFunc = pf_function ), parse_implicitly_qualified_term(ModuleName, PredNameTerm, ErrorTerm, "`:- pragma unused_args' declaration", PredNameResult), PredNameResult = ok2(PredName, []), convert_int_list(UnusedArgsTerm, UnusedArgsResult), UnusedArgsResult = ok1(UnusedArgs) -> Result = ok1(item_pragma(user, pragma_unused_args(PredOrFunc, PredName, Arity, ModeNum, UnusedArgs))) ; Result = error1(["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 = ok2(SpecName, []), MaybeName = yes(SpecName) ) -> parse_arity_or_modes(ModuleName, PredAndModesTerm, ErrorTerm, "`:- pragma type_spec' declaration", ArityOrModesResult), ( ArityOrModesResult = ok1(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 ; MaybeName = no, UnqualName = unqualify_name(PredName), make_pred_name(ModuleName, "TypeSpecOf", MaybePredOrFunc, UnqualName, newpred_type_subst(TVarSet, TypeSubn), SpecializedName) ), TypeSpecPragma = pragma_type_spec(PredName, SpecializedName, Arity, MaybePredOrFunc, MaybeModes, TypeSubn, TVarSet, set.init), Result = ok1(item_pragma(user, TypeSpecPragma)) ; Msg = "expected type substitution in " ++ "`:- pragma type_spec' declaration", Result = error1([Msg - TypeSubnTerm]) ) ; ArityOrModesResult = error1(Errors), Result = error1(Errors) ) ; Msg = "wrong number of arguments in `:- pragma type_spec' declaration", Result = error1([Msg - ErrorTerm]) ). parse_pragma_type(ModuleName, "reserve_tag", PragmaTerms, ErrorTerm, _VarSet, Result) :- MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :- Pragma = pragma_reserve_tag(Name, Arity)), parse_simple_type_pragma(ModuleName, "reserve_tag", MakePragma, PragmaTerms, ErrorTerm, Result). 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 = ok2(PredName, Arity), ( FileNameTerm = term.functor(term.string(FileName), [], _) -> Result = ok1(item_pragma(user, pragma_fact_table(PredName, Arity, FileName))) ; Result = error1(["expected string for fact table filename" - FileNameTerm]) ) ; NameArityResult = error2(Errors), Result = error1(Errors) ) ; Msg = "wrong number of arguments " ++ "in `:- pragma fact_table' declaration", Result = error1([Msg - ErrorTerm]) ). parse_pragma_type(ModuleName, "promise_equivalent_clauses", PragmaTerms, ErrorTerm, _VarSet, Result) :- MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :- Pragma = pragma_promise_equivalent_clauses(Name, Arity)), parse_simple_pragma(ModuleName, "promise_equivalent_clauses", MakePragma, PragmaTerms, ErrorTerm, Result). parse_pragma_type(ModuleName, "promise_pure", PragmaTerms, ErrorTerm, _VarSet, Result) :- MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :- Pragma = pragma_promise_pure(Name, Arity)), parse_simple_pragma(ModuleName, "promise_pure", MakePragma, PragmaTerms, ErrorTerm, Result). parse_pragma_type(ModuleName, "promise_semipure", PragmaTerms, ErrorTerm, _VarSet, Result) :- MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :- Pragma = pragma_promise_semipure(Name, Arity)), parse_simple_pragma(ModuleName, "promise_semipure", MakePragma, 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 = ok2(PredName - PredOrFunc, ModeList), ( ArgSizeTerm = term.functor(term.atom("not_set"), [], _), MaybeArgSizeInfo = no ; ArgSizeTerm = term.functor(term.atom("infinite"), [], _), MaybeArgSizeInfo = yes(infinite(unit)) ; 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(unit)) ; TerminationTerm = term.functor(term.atom("cannot_loop"), [], _), MaybeTerminationInfo = yes(cannot_loop(unit)) ), Result0 = ok1(item_pragma(user, pragma_termination_info(PredOrFunc, PredName, ModeList, MaybeArgSizeInfo, MaybeTerminationInfo))) -> Result = Result0 ; Msg = "syntax error in `:- pragma termination_info' declaration", Result = error1([Msg - ErrorTerm]) ). parse_pragma_type(ModuleName, "termination2_info", PragmaTerms, ErrorTerm, _VarSet, Result) :- ( PragmaTerms = [ PredAndModesTerm0, SuccessArgSizeTerm, FailureArgSizeTerm, TerminationTerm ], parse_pred_or_func_and_arg_modes(yes(ModuleName), PredAndModesTerm0, ErrorTerm, "`:- pragma termination2_info' declaration", NameAndModesResult), NameAndModesResult = ok2(PredName - PredOrFunc, ModeList), parse_arg_size_constraints(SuccessArgSizeTerm, SuccessArgSizeResult), SuccessArgSizeResult = ok1(SuccessArgSizeInfo), parse_arg_size_constraints(FailureArgSizeTerm, FailureArgSizeResult), FailureArgSizeResult = ok1(FailureArgSizeInfo), ( TerminationTerm = term.functor(term.atom("not_set"), [], _), MaybeTerminationInfo = no ; TerminationTerm = term.functor(term.atom("can_loop"), [], _), MaybeTerminationInfo = yes(can_loop(unit)) ; TerminationTerm = term.functor(term.atom("cannot_loop"), [], _), MaybeTerminationInfo = yes(cannot_loop(unit)) ), Result0 = ok1(item_pragma(user, pragma_termination2_info(PredOrFunc, PredName, ModeList, SuccessArgSizeInfo, FailureArgSizeInfo, MaybeTerminationInfo))) -> Result = Result0 ; Msg = "syntax error in `:- pragma termination2_info' declaration", Result = error1([Msg - ErrorTerm]) ). parse_pragma_type(ModuleName, "terminates", PragmaTerms, ErrorTerm, _VarSet, Result) :- MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :- Pragma = pragma_terminates(Name, Arity)), parse_simple_pragma(ModuleName, "terminates", MakePragma, PragmaTerms, ErrorTerm, Result). parse_pragma_type(ModuleName, "does_not_terminate", PragmaTerms, ErrorTerm, _VarSet, Result) :- MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :- Pragma = pragma_does_not_terminate(Name, Arity)), parse_simple_pragma(ModuleName, "does_not_terminate", MakePragma, PragmaTerms, ErrorTerm, Result). parse_pragma_type(ModuleName, "check_termination", PragmaTerms, ErrorTerm, _VarSet, Result) :- MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :- Pragma = pragma_check_termination(Name, Arity)), parse_simple_pragma(ModuleName, "check_termination", MakePragma, PragmaTerms, ErrorTerm, Result). parse_pragma_type(ModuleName, "structure_sharing", PragmaTerms, ErrorTerm, _VarSet, Result) :- ( PragmaTerms = [ PredAndModesTerm0, HeadVarsTerm, HeadVarTypesTerm, SharingInformationTerm ], parse_pred_or_func_and_arg_modes(yes(ModuleName), PredAndModesTerm0, ErrorTerm, "`:- pragma structure_sharing' declaration", NameAndModesResult), NameAndModesResult = ok2(PredName - PredOrFunc, ModeList), % Parse the head variables: HeadVarsTerm = term.functor(term.atom("vars"), ListHVTerm, _), term.vars_list(ListHVTerm, HeadVarsGeneric), list.map(term.coerce_var, HeadVarsGeneric, HeadVars), % Parse the types: HeadVarTypesTerm = term.functor(term.atom("types"), ListTypeTerms, _), parse_types(ListTypeTerms, ok1(Types)), % Parse the actual structure sharing information. ( SharingInformationTerm = term.functor(term.atom("not_available"), _, _), MaybeSharingAs = no ; SharingInformationTerm = term.functor(term.atom("yes"), SharingTerm, _), SharingTerm = [SharingAsTerm], MaybeSharingAs = yes(parse_structure_sharing_domain(SharingAsTerm)) ), Result0 = ok1(item_pragma(user, pragma_structure_sharing(PredOrFunc, PredName, ModeList, HeadVars, Types, MaybeSharingAs))) -> Result = Result0 ; Msg = "syntax error in `:- pragma structure_sharing' declaration", Result = error1([Msg - ErrorTerm]) ). parse_pragma_type(ModuleName, "structure_reuse", PragmaTerms, ErrorTerm, _VarSet, Result) :- ( PragmaTerms = [ PredAndModesTerm0, HeadVarsTerm, HeadVarTypesTerm, MaybeStructureReuseTerm ], parse_pred_or_func_and_arg_modes(yes(ModuleName), PredAndModesTerm0, ErrorTerm, "`:- pragma structure_reuse' declaration", NameAndModesResult), NameAndModesResult = ok2(PredName - PredOrFunc, ModeList), % Parse the headvariables: HeadVarsTerm = term.functor(term.atom("vars"), ListHVTerm, _), term.vars_list(ListHVTerm, HeadVarsGeneric), list.map(term.coerce_var, HeadVarsGeneric, HeadVars), % Parse the types: HeadVarTypesTerm = term.functor(term.atom("types"), ListTypeTerms, _), parse_types(ListTypeTerms, ok1(Types)), % Parse the actual structure reuse information. ( MaybeStructureReuseTerm = term.functor(term.atom("not_available"), _, _), MaybeStructureReuse = no ; MaybeStructureReuseTerm = term.functor(term.atom("yes"), MaybeStructureReuseTermArgs, _), MaybeStructureReuseTermArgs = [ StructureReuseTerm ], StructureReuse = parse_structure_reuse_domain(StructureReuseTerm), MaybeStructureReuse = yes(StructureReuse) ), Result0 = ok1(item_pragma(user, pragma_structure_reuse(PredOrFunc, PredName, ModeList, HeadVars, Types, MaybeStructureReuse))) -> Result = Result0 ; Msg = "syntax error in `:- pragma structure_reuse' declaration", Result = error1([Msg - ErrorTerm]) ). parse_pragma_type(ModuleName, "exceptions", PragmaTerms, ErrorTerm, _VarSet, Result) :- ( PragmaTerms = [ PredOrFuncTerm, PredNameTerm, term.functor(term.integer(Arity), [], _), term.functor(term.integer(ModeNum), [], _), ThrowStatusTerm ], ( PredOrFuncTerm = term.functor(term.atom("predicate"), [], _), PredOrFunc = pf_predicate ; PredOrFuncTerm = term.functor(term.atom("function"), [], _), PredOrFunc = pf_function ), parse_implicitly_qualified_term(ModuleName, PredNameTerm, ErrorTerm, "`:- pragma exceptions' declaration", PredNameResult), PredNameResult = ok2(PredName, []), ( ThrowStatusTerm = term.functor(term.atom("will_not_throw"), [], _), ThrowStatus = will_not_throw ; ThrowStatusTerm = term.functor(term.atom("may_throw"), [ExceptionTypeTerm], _), ( ExceptionTypeTerm = term.functor( term.atom("user_exception"), [], _), ExceptionType = user_exception ; ExceptionTypeTerm = term.functor( term.atom("type_exception"), [], _), ExceptionType = type_exception ), ThrowStatus = may_throw(ExceptionType) ; ThrowStatusTerm = term.functor( term.atom("conditional"), [], _), ThrowStatus = throw_conditional ) -> Result = ok1(item_pragma(user, pragma_exceptions(PredOrFunc, PredName, Arity, ModeNum, ThrowStatus))) ; Result = error1(["error in `:- pragma exceptions'" - ErrorTerm]) ). parse_pragma_type(ModuleName, "trailing_info", PragmaTerms, ErrorTerm, _VarSet, Result) :- ( PragmaTerms = [ PredOrFuncTerm, PredNameTerm, term.functor(term.integer(Arity), [], _), term.functor(term.integer(ModeNum), [], _), TrailingStatusTerm ], ( PredOrFuncTerm = term.functor(term.atom("predicate"), [], _), PredOrFunc = pf_predicate ; PredOrFuncTerm = term.functor(term.atom("function"), [], _), PredOrFunc = pf_function ), parse_implicitly_qualified_term(ModuleName, PredNameTerm, ErrorTerm, "`:- pragma trailing_info' declaration", PredNameResult), PredNameResult = ok2(PredName, []), ( TrailingStatusTerm = term.functor( term.atom("will_not_modify_trail"), [], _), TrailingStatus = trail_will_not_modify ; TrailingStatusTerm = term.functor( term.atom("may_modify_trail"), [], _), TrailingStatus = trail_may_modify ; TrailingStatusTerm = term.functor( term.atom("conditional"), [], _), TrailingStatus = trail_conditional ) -> Result = ok1(item_pragma(user, pragma_trailing_info(PredOrFunc, PredName, Arity, ModeNum, TrailingStatus))) ; Result = error1(["error in `:- pragma trailing_info'" - ErrorTerm]) ). parse_pragma_type(ModuleName, "mm_tabling_info", PragmaTerms, ErrorTerm, _VarSet, Result) :- ( PragmaTerms = [ PredOrFuncTerm, PredNameTerm, term.functor(term.integer(Arity), [], _), term.functor(term.integer(ModeNum), [], _), MM_TablingStatusTerm ], ( PredOrFuncTerm = term.functor(term.atom("predicate"), [], _), PredOrFunc = pf_predicate ; PredOrFuncTerm = term.functor(term.atom("function"), [], _), PredOrFunc = pf_function ), parse_implicitly_qualified_term(ModuleName, PredNameTerm, ErrorTerm, "`:- pragma mm_tabling_info' declaration", PredNameResult), PredNameResult = ok2(PredName, []), ( MM_TablingStatusTerm = term.functor( term.atom("mm_tabled_will_not_call"), [], _), MM_TablingStatus = mm_tabled_will_not_call ; MM_TablingStatusTerm = term.functor( term.atom("mm_tabled_may_call"), [], _), MM_TablingStatus = mm_tabled_may_call ; MM_TablingStatusTerm = term.functor( term.atom("mm_tabled_conditional"), [], _), MM_TablingStatus = mm_tabled_conditional ) -> Result = ok1(item_pragma(user, pragma_mm_tabling_info(PredOrFunc, PredName, Arity, ModeNum, MM_TablingStatus))) ; Result = error1(["error in `:- pragma mm_tabling_info'" - ErrorTerm]) ). parse_pragma_type(ModuleName, "mode_check_clauses", PragmaTerms, ErrorTerm, _VarSet, Result) :- MakePragma = (pred(Name::in, Arity::in, Pragma::out) is det :- Pragma = pragma_mode_check_clauses(Name, Arity)), parse_simple_pragma(ModuleName, "mode_check_clauses", MakePragma, PragmaTerms, ErrorTerm, Result). :- pred parse_foreign_decl_is_local(term::in, foreign_decl_is_local::out) is semidet. parse_foreign_decl_is_local(term.functor(Functor, [], _), IsLocal) :- ( Functor = term.string(String) ; Functor = term.atom(String) ), ( String = "local", IsLocal = foreign_decl_is_local ; String = "exported", IsLocal = foreign_decl_is_exported ). parse_foreign_language(term.functor(term.string(String), _, _), Lang) :- globals.convert_foreign_language(String, Lang). parse_foreign_language(term.functor(term.atom(String), _, _), Lang) :- globals.convert_foreign_language(String, Lang). :- pred parse_foreign_language_type(term::in, foreign_language::in, maybe1(foreign_language_type)::out) is det. parse_foreign_language_type(InputTerm, Language, Result) :- ( Language = lang_il, ( InputTerm = term.functor(term.string(ILTypeName), [], _) -> parse_il_type_name(ILTypeName, InputTerm, Result) ; Result = error1(["invalid backend specification term" - InputTerm]) ) ; Language = lang_c, ( InputTerm = term.functor(term.string(CTypeName), [], _) -> Result = ok1(c(c_type(CTypeName))) ; Result = error1(["invalid backend specification term" - InputTerm]) ) ; Language = lang_java, ( InputTerm = term.functor(term.string(JavaTypeName), [], _) -> Result = ok1(java(java_type(JavaTypeName))) ; Result = error1(["invalid backend specification term" - InputTerm]) ) ; Language = lang_erlang, ( InputTerm = term.functor(term.string(_ErlangTypeName), [], _) -> % XXX should we check if the type is blank? Result = ok1(erlang(erlang_type)) ; Result = error1(["invalid backend specification term" - InputTerm]) ) ; ( Language = lang_managed_cplusplus ; Language = lang_csharp ), Msg = "unsupported language specified, unable to parse backend type", Result = error1([Msg - InputTerm]) ). :- pred parse_il_type_name(string::in, term::in, maybe1(foreign_language_type)::out) is det. parse_il_type_name(String0, ErrorTerm, ForeignType) :- ( parse_special_il_type_name(String0, ForeignTypeResult) -> ForeignType = ok1(il(ForeignTypeResult)) ; string.append("class [", String1, String0), string.sub_string_search(String1, "]", Index) -> string.left(String1, Index, AssemblyName), string.split(String1, Index + 1, _, TypeNameStr), TypeSymName = string_to_sym_name(TypeNameStr), ForeignType = ok1(il(il_type(reference, AssemblyName, TypeSymName))) ; string.append("valuetype [", String1, String0), string.sub_string_search(String1, "]", Index) -> string.left(String1, Index, AssemblyName), string.split(String1, Index + 1, _, TypeNameStr), TypeSymName = string_to_sym_name(TypeNameStr), ForeignType = ok1(il(il_type(value, AssemblyName, TypeSymName))) ; ForeignType = error1(["invalid foreign language type description" - ErrorTerm]) ). % Parse all the special assembler names for all the builtin types. % See Partition I 'Built-In Types' (Section 8.2.2) for the list % of all builtin types. % :- pred parse_special_il_type_name(string::in, il_foreign_type::out) is semidet. parse_special_il_type_name("bool", il_type(value, "mscorlib", qualified(unqualified("System"), "Boolean"))). parse_special_il_type_name("char", il_type(value, "mscorlib", qualified(unqualified("System"), "Char"))). parse_special_il_type_name("object", il_type(reference, "mscorlib", qualified(unqualified("System"), "Object"))). parse_special_il_type_name("string", il_type(reference, "mscorlib", qualified(unqualified("System"), "String"))). parse_special_il_type_name("float32", il_type(value, "mscorlib", qualified(unqualified("System"), "Single"))). parse_special_il_type_name("float64", il_type(value, "mscorlib", qualified(unqualified("System"), "Double"))). parse_special_il_type_name("int8", il_type(value, "mscorlib", qualified(unqualified("System"), "SByte"))). parse_special_il_type_name("int16", il_type(value, "mscorlib", qualified(unqualified("System"), "Int16"))). parse_special_il_type_name("int32", il_type(value, "mscorlib", qualified(unqualified("System"), "Int32"))). parse_special_il_type_name("int64", il_type(value, "mscorlib", qualified(unqualified("System"), "Int64"))). parse_special_il_type_name("natural int", il_type(value, "mscorlib", qualified(unqualified("System"), "IntPtr"))). parse_special_il_type_name("native int", il_type(value, "mscorlib", qualified(unqualified("System"), "IntPtr"))). parse_special_il_type_name("natural unsigned int", il_type(value, "mscorlib", qualified(unqualified("System"), "UIntPtr"))). parse_special_il_type_name("native unsigned int", il_type(value, "mscorlib", qualified(unqualified("System"), "UIntPtr"))). parse_special_il_type_name("refany", il_type(value, "mscorlib", qualified(unqualified("System"), "TypedReference"))). parse_special_il_type_name("typedref", il_type(value, "mscorlib", qualified(unqualified("System"), "TypedReference"))). parse_special_il_type_name("unsigned int8", il_type(value, "mscorlib", qualified(unqualified("System"), "Byte"))). parse_special_il_type_name("unsigned int16", il_type(value, "mscorlib", qualified(unqualified("System"), "UInt16"))). parse_special_il_type_name("unsigned int32", il_type(value, "mscorlib", qualified(unqualified("System"), "UInt32"))). parse_special_il_type_name("unsigned int64", il_type(value, "mscorlib", qualified(unqualified("System"), "UInt64"))). :- pred parse_maybe_foreign_type_assertions(maybe(term)::in, list(foreign_type_assertion)::out) is semidet. parse_maybe_foreign_type_assertions(no, []). parse_maybe_foreign_type_assertions(yes(Term), Assertions) :- parse_foreign_type_assertions(Term, Assertions). :- pred parse_foreign_type_assertions(term::in, list(foreign_type_assertion)::out) is semidet. parse_foreign_type_assertions(Term, Assertions) :- ( Term = term.functor(term.atom("[]"), [], _) -> Assertions = [] ; Term = term.functor(term.atom("[|]"), [Head, Tail], _), parse_foreign_type_assertion(Head, HeadAssertion), parse_foreign_type_assertions(Tail, TailAssertions), Assertions = [HeadAssertion | TailAssertions] ). :- pred parse_foreign_type_assertion(term::in, foreign_type_assertion::out) is semidet. parse_foreign_type_assertion(Term, Assertion) :- Term = term.functor(term.atom(Constant), [], _), Constant = "can_pass_as_mercury_type", Assertion = foreign_type_can_pass_as_mercury_type. parse_foreign_type_assertion(Term, Assertion) :- Term = term.functor(term.atom(Constant), [], _), Constant = "stable", Assertion = foreign_type_stable. % This predicate parses both c_header_code and foreign_decl pragmas. % :- pred parse_pragma_foreign_decl_pragma(module_name::in, string::in, list(term)::in, term::in, varset::in, maybe1(item)::out) is det. parse_pragma_foreign_decl_pragma(_ModuleName, Pragma, PragmaTerms, ErrorTerm, _VarSet, Result) :- string.format("invalid `:- pragma %s' declaration ", [s(Pragma)], InvalidDeclStr), ( ( PragmaTerms = [LangTerm, HeaderTerm], IsLocal = foreign_decl_is_exported ; PragmaTerms = [LangTerm, IsLocalTerm, HeaderTerm], parse_foreign_decl_is_local(IsLocalTerm, IsLocal) ) -> ( parse_foreign_language(LangTerm, ForeignLanguage) -> ( HeaderTerm = term.functor(term.string( HeaderCode), [], _) -> DeclCode = pragma_foreign_decl(ForeignLanguage, IsLocal, HeaderCode), Result = ok1(item_pragma(user, DeclCode)) ; ErrMsg = "-- expected string for foreign declaration code", Result = error1([string.append(InvalidDeclStr, ErrMsg) - HeaderTerm]) ) ; ErrMsg = "-- invalid language parameter", Result = error1([(InvalidDeclStr ++ ErrMsg) - LangTerm]) ) ; string.format("invalid `:- pragma %s' declaration ", [s(Pragma)], ErrorStr), Result = error1([ErrorStr - ErrorTerm]) ). % This predicate parses both c_code and foreign_code pragmas. % Processing of foreign_proc (or c_code that defines a procedure) % is handled in parse_pragma_foreign_proc_pragma below. % :- pred parse_pragma_foreign_code_pragma(module_name::in, string::in, list(term)::in, term::in, varset::in, maybe1(item)::out) is det. parse_pragma_foreign_code_pragma(_ModuleName, Pragma, PragmaTerms, ErrorTerm, _VarSet, Result) :- string.format("invalid `:- pragma %s' declaration ", [s(Pragma)], InvalidDeclStr), ( PragmaTerms = [LangTerm, CodeTerm] -> ( parse_foreign_language(LangTerm, ForeignLanguagePrime) -> ForeignLanguage = ForeignLanguagePrime, LangErrs = [] ; LangMsg = InvalidDeclStr ++ "-- invalid language parameter", LangErrs = [LangMsg - LangTerm], ForeignLanguage = lang_c % Dummy, ignored when LangErrs \= [] ), ( CodeTerm = term.functor(term.string(CodePrime), [], _) -> Code = CodePrime, CodeErrs = [] ; Code = "", % Dummy, ignored when CodeErrs \= [] CodeMsg = InvalidDeclStr ++ "-- expected string for foreign code", CodeErrs = [CodeMsg - CodeTerm] ), Errs = LangErrs ++ CodeErrs, ( Errs = [], Result = ok1(item_pragma(user, pragma_foreign_code(ForeignLanguage, Code))) ; Errs = [_ | _], Result = error1(Errs) ) ; Msg = InvalidDeclStr ++ "-- wrong number of arguments", Result = error1([Msg - ErrorTerm]) ). % This predicate parses both c_code and foreign_proc pragmas. % :- pred parse_pragma_foreign_proc_pragma(module_name::in, string::in, list(term)::in, term::in, varset::in, maybe1(item)::out) is det. parse_pragma_foreign_proc_pragma(ModuleName, Pragma, PragmaTerms, ErrorTerm, VarSet, Result) :- string.format("invalid `:- pragma %s' declaration ", [s(Pragma)], InvalidDeclStr), ( PragmaTerms = [LangTerm | RestTerms], ( parse_foreign_language(LangTerm, ForeignLanguagePrime) -> ForeignLanguage = ForeignLanguagePrime, LangErrs = [] ; ForeignLanguage = lang_c, % Dummy, ignored when LangErrs \= [] LangMsg = "-- invalid language parameter", LangErrs = [(InvalidDeclStr ++ LangMsg) - LangTerm] ), ( ( RestTerms = [PredAndVarsTerm, CodeTerm], parse_pragma_ordinary_foreign_proc_pragma_old(ModuleName, Pragma, VarSet, PredAndVarsTerm, CodeTerm, ErrorTerm, ForeignLanguage, InvalidDeclStr, RestResult) ; RestTerms = [PredAndVarsTerm, FlagsTerm, CodeTerm], parse_pragma_ordinary_foreign_proc_pragma(ModuleName, Pragma, VarSet, PredAndVarsTerm, FlagsTerm, CodeTerm, ForeignLanguage, InvalidDeclStr, RestResult) ; RestTerms = [PredAndVarsTerm, FlagsTerm, FieldsTerm, FirstTerm, LaterTerm], term.context_init(DummyContext), SharedTerm = term.functor(term.atom("common_code"), [term.functor(term.string(""), [], DummyContext)], DummyContext), parse_pragma_model_non_foreign_proc_pragma(ModuleName, Pragma, VarSet, PredAndVarsTerm, FlagsTerm, FieldsTerm, FirstTerm, LaterTerm, SharedTerm, ForeignLanguage, InvalidDeclStr, RestResult) ; RestTerms = [PredAndVarsTerm, FlagsTerm, FieldsTerm, FirstTerm, LaterTerm, SharedTerm], parse_pragma_model_non_foreign_proc_pragma(ModuleName, Pragma, VarSet, PredAndVarsTerm, FlagsTerm, FieldsTerm, FirstTerm, LaterTerm, SharedTerm, ForeignLanguage, InvalidDeclStr, RestResult) ) -> ( RestResult = ok1(Item), ( LangErrs = [], Result = ok1(Item) ; LangErrs = [_ | _], Result = error1(LangErrs) ) ; RestResult = error1(RestErrs), Result = error1(LangErrs ++ RestErrs) ) ; ErrMsg = "-- wrong number of arguments", Result = error1([(InvalidDeclStr ++ ErrMsg) - ErrorTerm]) ) ; PragmaTerms = [], ErrMsg = "-- wrong number of arguments", Result = error1([(InvalidDeclStr ++ ErrMsg) - ErrorTerm]) ). :- pred parse_pragma_ordinary_foreign_proc_pragma_old(module_name::in, string::in, varset::in, term::in, term::in, term::in, foreign_language::in, string::in, maybe1(item)::out) is det. parse_pragma_ordinary_foreign_proc_pragma_old(ModuleName, Pragma, VarSet, PredAndVarsTerm, CodeTerm, ErrorTerm, ForeignLanguage, InvalidDeclStr, Result) :- % 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" -> Attributes0 = default_attributes(ForeignLanguage), set_legacy_purity_behaviour(yes, Attributes0, Attributes), ( CodeTerm = term.functor(term.string(Code), [], CodeContext) -> Impl = fc_impl_ordinary(Code, yes(CodeContext)), parse_pragma_foreign_code(ModuleName, Attributes, PredAndVarsTerm, Impl, VarSet, Result) ; ErrMsg = "-- expecting either `may_call_mercury' or " ++ "`will_not_call_mercury', and a string for foreign code", Result = error1([(InvalidDeclStr ++ ErrMsg) - CodeTerm]) ) ; ErrMsg = "-- doesn't say whether it can call mercury", Result = error1([(InvalidDeclStr ++ ErrMsg) - ErrorTerm]) ). :- pred parse_pragma_ordinary_foreign_proc_pragma(module_name::in, string::in, varset::in, term::in, term::in, term::in, foreign_language::in, string::in, maybe1(item)::out) is det. parse_pragma_ordinary_foreign_proc_pragma(ModuleName, Pragma, VarSet, SecondTerm, ThirdTerm, CodeTerm, ForeignLanguage, InvalidDeclStr, Result) :- ( CodeTerm = term.functor(term.string(CodePrime), [], CodeContextPrime) -> Code = CodePrime, CodeContext = CodeContextPrime, CodeErrs = [] ; Code = "", % Dummy CodeContext = term.context_init, % Dummy CodeMsg = "-- invalid fourth argument, " ++ "expecting string containing foreign code", CodeErrs = [(InvalidDeclStr ++ CodeMsg) - CodeTerm] ), parse_pragma_foreign_proc_attributes_term(ForeignLanguage, Pragma, VarSet, ThirdTerm, MaybeFlagsThird), ( MaybeFlagsThird = ok1(Flags), FlagsErrs = [], PredAndVarsTerm = SecondTerm ; MaybeFlagsThird = error1(FlagsThirdErrors), parse_pragma_foreign_proc_attributes_term(ForeignLanguage, Pragma, VarSet, SecondTerm, MaybeFlagsSecond), ( MaybeFlagsSecond = ok1(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" -> PredAndVarsTerm = ThirdTerm, FlagsErrs = [] ; PredAndVarsTerm = ThirdTerm, % Dummy FlagsMsg = "-- invalid second argument, " ++ "expecting predicate or function mode", FlagsErrs = [(InvalidDeclStr ++ FlagsMsg) - SecondTerm] ) ; MaybeFlagsSecond = error1(_), Flags = default_attributes(ForeignLanguage), % Dummy PredAndVarsTerm = SecondTerm, % Dummy % We report the error appropriate to the preferred syntax. FlagsErrs = assoc_list.map_keys_only(string.append( InvalidDeclStr ++ "-- invalid third argument: "), FlagsThirdErrors) ) ), Errs = CodeErrs ++ FlagsErrs, ( Errs = [], Impl = fc_impl_ordinary(Code, yes(CodeContext)), parse_pragma_foreign_code(ModuleName, Flags, PredAndVarsTerm, Impl, VarSet, Result) ; Errs = [_ | _], Result = error1(Errs) ). :- pred parse_pragma_model_non_foreign_proc_pragma(module_name::in, string::in, varset::in, term::in, term::in, term::in, term::in, term::in, term::in, foreign_language::in, string::in, maybe1(item)::out) is det. parse_pragma_model_non_foreign_proc_pragma(ModuleName, Pragma, VarSet, PredAndVarsTerm, FlagsTerm, FieldsTerm, FirstTerm, LaterTerm, SharedTerm, ForeignLanguage, InvalidDeclStr, Result) :- parse_pragma_foreign_proc_attributes_term(ForeignLanguage, Pragma, VarSet, FlagsTerm, MaybeFlags), ( MaybeFlags = ok1(Flags), FlagsErrs = [] ; MaybeFlags = error1(FlagErrs0), Flags = default_attributes(ForeignLanguage), % Dummy FlagsErrs = assoc_list.map_keys_only(string.append( InvalidDeclStr ++ "-- invalid third argument: "), FlagErrs0) ), ( parse_pragma_keyword("local_vars", FieldsTerm, FieldsPrime, FieldsContextPrime) -> Fields = FieldsPrime, FieldsContext = FieldsContextPrime, LocalErrs = [] ; Fields = "", % Dummy FieldsContext = term.context_init, % Dummy LocalMsg = "-- invalid fourth argument, " ++ "expecting `local_vars()'", LocalErrs = [(InvalidDeclStr ++ LocalMsg) - FieldsTerm] ), ( parse_pragma_keyword("first_code", FirstTerm, FirstPrime, FirstContextPrime) -> First = FirstPrime, FirstContext = FirstContextPrime, FirstErrs = [] ; First = "", % Dummy FirstContext = term.context_init, % Dummy FirstMsg = "-- invalid fifth argument, expecting `first_code()'", FirstErrs = [(InvalidDeclStr ++ FirstMsg) - FirstTerm] ), ( parse_pragma_keyword("retry_code", LaterTerm, LaterPrime, LaterContextPrime) -> Later = LaterPrime, LaterContext = LaterContextPrime, LaterErrs = [] ; Later = "", % Dummy LaterContext = term.context_init, % Dummy LaterMsg = "-- invalid sixth argument, expecting `retry_code()'", LaterErrs = [(InvalidDeclStr ++ LaterMsg) - LaterTerm] ), ( parse_pragma_keyword("shared_code", SharedTerm, SharedPrime, SharedContextPrime) -> Shared = SharedPrime, SharedContext = SharedContextPrime, Treatment = shared_code_share, SharedErrs = [] ; parse_pragma_keyword("duplicated_code", SharedTerm, SharedPrime, SharedContextPrime) -> Shared = SharedPrime, SharedContext = SharedContextPrime, Treatment = shared_code_duplicate, SharedErrs = [] ; parse_pragma_keyword("common_code", SharedTerm, SharedPrime, SharedContextPrime) -> Shared = SharedPrime, SharedContext = SharedContextPrime, Treatment = shared_code_automatic, SharedErrs = [] ; Shared = "", % Dummy SharedContext = term.context_init, % Dummy Treatment = shared_code_automatic, % Dummy SharedMsg = "-- invalid seventh argument, " ++ "expecting `common_code()'", SharedErrs = [(InvalidDeclStr ++ SharedMsg) - SharedTerm] ), Errs = FlagsErrs ++ LocalErrs ++ FirstErrs ++ LaterErrs ++ SharedErrs, ( Errs = [], Impl = fc_impl_model_non(Fields, yes(FieldsContext), First, yes(FirstContext), Later, yes(LaterContext), Treatment, Shared, yes(SharedContext)), parse_pragma_foreign_code(ModuleName, Flags, PredAndVarsTerm, Impl, VarSet, Result) ; Errs = [_ | _], Result = error1(Errs) ). % This parses a pragma that refers to a predicate or function. % :- pred parse_simple_pragma(module_name::in, string::in, pred(sym_name, int, pragma_type)::(pred(in, in, out) is det), list(term)::in, term::in, maybe1(item)::out) is det. parse_simple_pragma(ModuleName, PragmaType, MakePragma, PragmaTerms, ErrorTerm, Result) :- parse_simple_pragma_base(ModuleName, PragmaType, "predicate or function", MakePragma, PragmaTerms, ErrorTerm, Result). % This parses a pragma that refers to type. % :- pred parse_simple_type_pragma(module_name::in, string::in, pred(sym_name, int, pragma_type)::(pred(in, in, out) is det), list(term)::in, term::in, maybe1(item)::out) is det. parse_simple_type_pragma(ModuleName, PragmaType, MakePragma, PragmaTerms, ErrorTerm, Result) :- parse_simple_pragma_base(ModuleName, PragmaType, "type", MakePragma, PragmaTerms, ErrorTerm, Result). % This parses a pragma that refers to symbol name / arity. % :- pred parse_simple_pragma_base(module_name::in, string::in, string::in, pred(sym_name, int, pragma_type)::(pred(in, in, out) is det), list(term)::in, term::in, maybe1(item)::out) is det. parse_simple_pragma_base(ModuleName, PragmaType, NameKind, MakePragma, PragmaTerms, ErrorTerm, Result) :- ( PragmaTerms = [PredAndArityTerm] -> parse_simple_name_and_arity(ModuleName, PragmaType, NameKind, PredAndArityTerm, PredAndArityTerm, NameArityResult), ( NameArityResult = ok2(PredName, Arity), call(MakePragma, PredName, Arity, Pragma), Result = ok1(item_pragma(user, Pragma)) ; NameArityResult = error2(Errors), Result = error1(Errors) ) ; ErrorMsg = "wrong number of arguments in `:- pragma " ++ PragmaType ++ "' declaration", Result = error1([ErrorMsg - ErrorTerm]) ). :- pred parse_pred_name_and_arity(module_name::in, string::in, term::in, term::in, maybe2(sym_name, arity)::out) is det. parse_pred_name_and_arity(ModuleName, PragmaType, NameAndArityTerm, ErrorTerm, Result) :- parse_simple_name_and_arity(ModuleName, PragmaType, "predicate or function", NameAndArityTerm, ErrorTerm, Result). :- pred parse_simple_name_and_arity(module_name::in, string::in, string::in, term::in, term::in, maybe2(sym_name, arity)::out) is det. parse_simple_name_and_arity(ModuleName, PragmaType, NameKind, NameAndArityTerm, ErrorTerm, Result) :- ( parse_name_and_arity(ModuleName, NameAndArityTerm, Name, Arity) -> Result = ok2(Name, Arity) ; ErrorMsg = "expected " ++ NameKind ++ " name/arity for `pragma " ++ PragmaType ++ "' declaration", Result = error2([ErrorMsg - ErrorTerm]) ). %-----------------------------------------------------------------------------% :- pred parse_pragma_keyword(string::in, term::in, string::out, term.context::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_foreign_proc_attribute ---> coll_may_call_mercury(proc_may_call_mercury) ; coll_thread_safe(proc_thread_safe) ; coll_tabled_for_io(proc_tabled_for_io) ; coll_purity(purity) ; coll_user_annotated_sharing(user_annotated_sharing) ; coll_max_stack_size(int) ; coll_backend(backend) ; coll_terminates(proc_terminates) ; coll_will_not_throw_exception ; coll_ordinary_despite_detism ; coll_may_modify_trail(proc_may_modify_trail) ; coll_may_call_mm_tabled(may_call_mm_tabled) ; coll_box_policy(box_policy) ; coll_affects_liveness(proc_affects_liveness) ; coll_allocates_memory(proc_allocates_memory) ; coll_registers_roots(proc_registers_roots) ; coll_may_duplicate(proc_may_duplicate). :- pred parse_pragma_foreign_proc_attributes_term(foreign_language::in, string::in, varset::in, term::in, maybe1(pragma_foreign_proc_attributes)::out) is det. parse_pragma_foreign_proc_attributes_term(ForeignLanguage, Pragma, Varset, Term, MaybeAttributes) :- Attributes0 = default_attributes(ForeignLanguage), ( ( Pragma = "c_code" ; Pragma = "import" ) -> set_legacy_purity_behaviour(yes, Attributes0, Attributes1), set_purity(purity_pure, Attributes1, Attributes2) ; Attributes2 = Attributes0 ), ConflictingAttributes = [ coll_may_call_mercury(proc_will_not_call_mercury) - coll_may_call_mercury(proc_may_call_mercury), coll_thread_safe(proc_thread_safe) - coll_thread_safe(proc_not_thread_safe), coll_tabled_for_io(proc_tabled_for_io) - coll_tabled_for_io(proc_tabled_for_io_unitize), coll_tabled_for_io(proc_tabled_for_io) - coll_tabled_for_io(proc_tabled_for_descendant_io), coll_tabled_for_io(proc_tabled_for_io) - coll_tabled_for_io(proc_not_tabled_for_io), coll_tabled_for_io(proc_tabled_for_io_unitize) - coll_tabled_for_io(proc_tabled_for_descendant_io), coll_tabled_for_io(proc_tabled_for_io_unitize) - coll_tabled_for_io(proc_not_tabled_for_io), coll_tabled_for_io(proc_tabled_for_descendant_io) - coll_tabled_for_io(proc_not_tabled_for_io), coll_purity(purity_pure) - coll_purity(purity_impure), coll_purity(purity_pure) - coll_purity(purity_semipure), coll_purity(purity_semipure) - coll_purity(purity_impure), coll_terminates(proc_terminates) - coll_terminates(proc_does_not_terminate), coll_terminates(depends_on_mercury_calls) - coll_terminates(proc_terminates), coll_terminates(depends_on_mercury_calls) - coll_terminates(proc_does_not_terminate), coll_may_modify_trail(proc_may_modify_trail) - coll_may_modify_trail(proc_will_not_modify_trail), coll_may_call_mercury(proc_will_not_call_mercury) - coll_may_call_mm_tabled(may_call_mm_tabled), coll_box_policy(native_if_possible) - coll_box_policy(always_boxed), coll_affects_liveness(proc_affects_liveness) - coll_affects_liveness(proc_does_not_affect_liveness), coll_allocates_memory(proc_does_not_allocate_memory) - coll_allocates_memory(proc_allocates_bounded_memory), coll_allocates_memory(proc_does_not_allocate_memory) - coll_allocates_memory(proc_allocates_unbounded_memory), coll_allocates_memory(proc_allocates_bounded_memory) - coll_allocates_memory(proc_allocates_unbounded_memory), coll_registers_roots(proc_does_not_register_roots) - coll_registers_roots(proc_registers_roots), coll_registers_roots(proc_does_not_register_roots) - coll_registers_roots(proc_does_not_have_roots), coll_registers_roots(proc_registers_roots) - coll_registers_roots(proc_does_not_have_roots), coll_may_duplicate(proc_may_duplicate) - coll_may_duplicate(proc_may_not_duplicate) ], ( parse_pragma_foreign_proc_attributes_term0(Varset, Term, AttrList) -> ( some [Conflict1, Conflict2] ( list.member(Conflict1 - Conflict2, ConflictingAttributes), list.member(Conflict1, AttrList), list.member(Conflict2, AttrList) ) -> % We could include Conflict1 and Conflict2 in the message, % but the conflict is usually very obvious even without this. Msg = "conflicting attributes in attribute list", MaybeAttributes = error1([Msg - Term]) ; list.foldl(process_attribute, AttrList, Attributes2, Attributes), MaybeAttributes = check_required_attributes(ForeignLanguage, Attributes, Term) ) ; ErrMsg = "expecting a foreign proc attribute or list of attributes", MaybeAttributes = error1([ErrMsg - Term]) ). % Update the pragma_foreign_proc_attributes according to the given % collected_pragma_foreign_proc_attribute. % :- pred process_attribute(collected_pragma_foreign_proc_attribute::in, pragma_foreign_proc_attributes::in, pragma_foreign_proc_attributes::out) is det. process_attribute(coll_may_call_mercury(MayCallMercury), !Attrs) :- set_may_call_mercury(MayCallMercury, !Attrs). process_attribute(coll_thread_safe(ThreadSafe), !Attrs) :- set_thread_safe(ThreadSafe, !Attrs). process_attribute(coll_tabled_for_io(TabledForIO), !Attrs) :- set_tabled_for_io(TabledForIO, !Attrs). process_attribute(coll_purity(Pure), !Attrs) :- set_purity(Pure, !Attrs). process_attribute(coll_terminates(Terminates), !Attrs) :- set_terminates(Terminates, !Attrs). process_attribute(coll_user_annotated_sharing(UserSharing), !Attrs) :- set_user_annotated_sharing(UserSharing, !Attrs). process_attribute(coll_will_not_throw_exception, !Attrs) :- set_may_throw_exception(proc_will_not_throw_exception, !Attrs). process_attribute(coll_max_stack_size(Size), !Attrs) :- add_extra_attribute(max_stack_size(Size), !Attrs). process_attribute(coll_backend(Backend), !Attrs) :- add_extra_attribute(backend(Backend), !Attrs). process_attribute(coll_ordinary_despite_detism, !Attrs) :- set_ordinary_despite_detism(yes, !Attrs). process_attribute(coll_may_modify_trail(TrailMod), !Attrs) :- set_may_modify_trail(TrailMod, !Attrs). process_attribute(coll_may_call_mm_tabled(MayCallTabled), !Attrs) :- set_may_call_mm_tabled(MayCallTabled, !Attrs). process_attribute(coll_box_policy(BoxPolicy), !Attrs) :- set_box_policy(BoxPolicy, !Attrs). process_attribute(coll_affects_liveness(AffectsLiveness), !Attrs) :- set_affects_liveness(AffectsLiveness, !Attrs). process_attribute(coll_allocates_memory(AllocatesMemory), !Attrs) :- set_allocates_memory(AllocatesMemory, !Attrs). process_attribute(coll_registers_roots(RegistersRoots), !Attrs) :- set_registers_roots(RegistersRoots, !Attrs). process_attribute(coll_may_duplicate(MayDuplicate), !Attrs) :- set_may_duplicate(yes(MayDuplicate), !Attrs). % Check whether all the required attributes have been set for % a particular language % :- func check_required_attributes(foreign_language, pragma_foreign_proc_attributes, term) = maybe1(pragma_foreign_proc_attributes). check_required_attributes(lang_c, Attrs, _Term) = ok1(Attrs). check_required_attributes(lang_managed_cplusplus, Attrs, _Term) = ok1(Attrs). check_required_attributes(lang_csharp, Attrs, _Term) = ok1(Attrs). check_required_attributes(lang_il, Attrs, Term) = Res :- MaxStackAttrs = list.filter_map( (func(X) = X is semidet :- X = max_stack_size(_)), get_extra_attributes(Attrs)), ( MaxStackAttrs = [], Res = error1(["expecting max_stack_size attribute for IL code" - Term]) ; MaxStackAttrs = [_ | _], Res = ok1(Attrs) ). check_required_attributes(lang_java, Attrs, _Term) = ok1(Attrs). check_required_attributes(lang_erlang, Attrs, _Term) = ok1(Attrs). :- pred parse_pragma_foreign_proc_attributes_term0(varset::in, term::in, list(collected_pragma_foreign_proc_attribute)::out) is semidet. parse_pragma_foreign_proc_attributes_term0(Varset, Term, Flags) :- ( parse_single_pragma_foreign_proc_attribute(Varset, Term, Flag) -> Flags = [Flag] ; ( Term = term.functor(term.atom("[]"), [], _), Flags = [] ; Term = term.functor(term.atom("[|]"), [Head, Tail], _), parse_single_pragma_foreign_proc_attribute(Varset, Head, HeadFlag), parse_pragma_foreign_proc_attributes_term0(Varset, Tail, TailFlags), Flags = [HeadFlag | TailFlags] ) ). :- pred parse_single_pragma_foreign_proc_attribute(varset::in, term::in, collected_pragma_foreign_proc_attribute::out) is semidet. parse_single_pragma_foreign_proc_attribute(Varset, Term, Flag) :- ( parse_may_call_mercury(Term, MayCallMercury) -> Flag = coll_may_call_mercury(MayCallMercury) ; parse_threadsafe(Term, ThreadSafe) -> Flag = coll_thread_safe(ThreadSafe) ; parse_tabled_for_io(Term, TabledForIo) -> Flag = coll_tabled_for_io(TabledForIo) ; parse_user_annotated_sharing(Varset, Term, UserSharing) -> Flag = coll_user_annotated_sharing(UserSharing) ; parse_max_stack_size(Term, Size) -> Flag = coll_max_stack_size(Size) ; parse_backend(Term, Backend) -> Flag = coll_backend(Backend) ; parse_purity_promise(Term, Purity) -> Flag = coll_purity(Purity) ; parse_terminates(Term, Terminates) -> Flag = coll_terminates(Terminates) ; parse_no_exception_promise(Term) -> Flag = coll_will_not_throw_exception ; parse_ordinary_despite_detism(Term) -> Flag = coll_ordinary_despite_detism ; parse_may_modify_trail(Term, TrailMod) -> Flag = coll_may_modify_trail(TrailMod) ; parse_may_call_mm_tabled(Term, CallsTabled) -> Flag = coll_may_call_mm_tabled(CallsTabled) ; parse_box_policy(Term, BoxPolicy) -> Flag = coll_box_policy(BoxPolicy) ; parse_affects_liveness(Term, AffectsLiveness) -> Flag = coll_affects_liveness(AffectsLiveness) ; parse_allocates_memory(Term, AllocatesMemory) -> Flag = coll_allocates_memory(AllocatesMemory) ; parse_registers_roots(Term, RegistersRoots) -> Flag = coll_registers_roots(RegistersRoots) ; parse_may_duplicate(Term, MayDuplicate) -> Flag = coll_may_duplicate(MayDuplicate) ; fail ). :- pred parse_may_call_mercury(term::in, proc_may_call_mercury::out) is semidet. parse_may_call_mercury(term.functor(term.atom("recursive"), [], _), proc_may_call_mercury). parse_may_call_mercury(term.functor(term.atom("non_recursive"), [], _), proc_will_not_call_mercury). parse_may_call_mercury(term.functor(term.atom("may_call_mercury"), [], _), proc_may_call_mercury). parse_may_call_mercury(term.functor(term.atom("will_not_call_mercury"), [], _), proc_will_not_call_mercury). :- pred parse_threadsafe(term::in, proc_thread_safe::out) is semidet. parse_threadsafe(term.functor(term.atom("thread_safe"), [], _), proc_thread_safe). parse_threadsafe(term.functor(term.atom("not_thread_safe"), [], _), proc_not_thread_safe). parse_threadsafe(term.functor(term.atom("maybe_thread_safe"), [], _), proc_maybe_thread_safe). :- pred parse_may_modify_trail(term::in, proc_may_modify_trail::out) is semidet. parse_may_modify_trail(term.functor(term.atom("may_modify_trail"), [], _), proc_may_modify_trail). parse_may_modify_trail(term.functor(term.atom("will_not_modify_trail"), [], _), proc_will_not_modify_trail). :- pred parse_may_call_mm_tabled(term::in, may_call_mm_tabled::out) is semidet. parse_may_call_mm_tabled(Term, may_call_mm_tabled) :- Term = term.functor(term.atom("may_call_mm_tabled"), [], _). parse_may_call_mm_tabled(Term, will_not_call_mm_tabled) :- Term = term.functor(term.atom("will_not_call_mm_tabled"), [], _). :- pred parse_box_policy(term::in, box_policy::out) is semidet. parse_box_policy(term.functor(term.atom("native_if_possible"), [], _), native_if_possible). parse_box_policy(term.functor(term.atom("always_boxed"), [], _), always_boxed). :- pred parse_affects_liveness(term::in, proc_affects_liveness::out) is semidet. parse_affects_liveness(Term, AffectsLiveness) :- Term = term.functor(term.atom(Functor), [], _), ( Functor = "affects_liveness", AffectsLiveness = proc_affects_liveness ; ( Functor = "doesnt_affect_liveness" ; Functor = "does_not_affect_liveness" ), AffectsLiveness = proc_does_not_affect_liveness ). :- pred parse_allocates_memory(term::in, proc_allocates_memory::out) is semidet. parse_allocates_memory(Term, AllocatesMemory) :- Term = term.functor(term.atom(Functor), [], _), ( ( Functor = "doesnt_allocate_memory" ; Functor = "does_not_allocate_memory" ), AllocatesMemory = proc_does_not_allocate_memory ; Functor = "allocates_bounded_memory", AllocatesMemory = proc_allocates_bounded_memory ; Functor = "allocates_unbounded_memory", AllocatesMemory = proc_allocates_unbounded_memory ). :- pred parse_registers_roots(term::in, proc_registers_roots::out) is semidet. parse_registers_roots(Term, RegistersRoots) :- Term = term.functor(term.atom(Functor), [], _), ( Functor = "registers_roots", RegistersRoots = proc_registers_roots ; ( Functor = "doesnt_register_roots" ; Functor = "does_not_register_roots" ), RegistersRoots = proc_does_not_register_roots ; ( Functor = "doesnt_have_roots" ; Functor = "does_not_have_roots" ), RegistersRoots = proc_does_not_have_roots ). :- pred parse_may_duplicate(term::in, proc_may_duplicate::out) is semidet. parse_may_duplicate(Term, RegistersRoots) :- Term = term.functor(term.atom(Functor), [], _), ( Functor = "may_duplicate", RegistersRoots = proc_may_duplicate ; Functor = "may_not_duplicate", RegistersRoots = proc_may_not_duplicate ). :- pred parse_tabled_for_io(term::in, proc_tabled_for_io::out) is semidet. parse_tabled_for_io(term.functor(term.atom(Str), [], _), TabledForIo) :- ( Str = "tabled_for_io", TabledForIo = proc_tabled_for_io ; Str = "tabled_for_io_unitize", TabledForIo = proc_tabled_for_io_unitize ; Str = "tabled_for_descendant_io", TabledForIo = proc_tabled_for_descendant_io ; Str = "not_tabled_for_io", TabledForIo = proc_not_tabled_for_io ). :- pred parse_max_stack_size(term::in, int::out) is semidet. parse_max_stack_size(term.functor( term.atom("max_stack_size"), [SizeTerm], _), Size) :- SizeTerm = term.functor(term.integer(Size), [], _). :- pred parse_backend(term::in, backend::out) is semidet. parse_backend(term.functor(term.atom(Functor), [], _), Backend) :- ( Functor = "high_level_backend", Backend = high_level_backend ; Functor = "low_level_backend", Backend = low_level_backend ). :- pred parse_purity_promise(term::in, purity::out) is semidet. parse_purity_promise(term.functor(term.atom("promise_pure"), [], _), purity_pure). parse_purity_promise(term.functor(term.atom("promise_semipure"), [], _), purity_semipure). :- pred parse_terminates(term::in, proc_terminates::out) is semidet. parse_terminates(term.functor(term.atom("terminates"), [], _), proc_terminates). parse_terminates(term.functor(term.atom("does_not_terminate"), [], _), proc_does_not_terminate). :- pred parse_no_exception_promise(term::in) is semidet. parse_no_exception_promise(term.functor( term.atom("will_not_throw_exception"), [], _)). :- pred parse_ordinary_despite_detism(term::in) is semidet. parse_ordinary_despite_detism( term.functor(term.atom("ordinary_despite_detism"), [], _)). % Parse a pragma foreign_code declaration. % :- pred parse_pragma_foreign_code(module_name::in, pragma_foreign_proc_attributes::in, term::in, pragma_foreign_code_impl::in, varset::in, maybe1(item)::out) is det. parse_pragma_foreign_code(ModuleName, Flags, PredAndVarsTerm0, PragmaImpl, VarSet0, Result) :- parse_pred_or_func_and_args(yes(ModuleName), PredAndVarsTerm0, PredAndVarsTerm0, "`:- pragma c_code' declaration", PredAndArgsResult), ( PredAndArgsResult = ok2(PredName, VarList0 - MaybeRetTerm), ( % Is this a function or a predicate? MaybeRetTerm = yes(FuncResultTerm0) -> PredOrFunc = pf_function, list.append(VarList0, [FuncResultTerm0], VarList) ; PredOrFunc = pf_predicate, VarList = VarList0 ), parse_pragma_c_code_varlist(VarSet0, VarList, PragmaVars, Error), ( Error = no, varset.coerce(VarSet0, ProgVarSet), varset.coerce(VarSet0, InstVarSet), Result = ok1(item_pragma(user, pragma_foreign_proc(Flags, PredName, PredOrFunc, PragmaVars, ProgVarSet, InstVarSet, PragmaImpl))) ; Error = yes(ErrorMessage), Result = error1([ErrorMessage - PredAndVarsTerm0]) ) ; PredAndArgsResult = error2(Errors), Result = error1(Errors) ). % 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::in, list(term)::in, list(pragma_var)::out, maybe(string)::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(allow_constrained_inst_var, ModeTerm, Mode0) -> constrain_inst_vars_in_mode(Mode0, Mode), term.coerce_var(Var, ProgVar), PragmaVar = pragma_var(ProgVar, VarName, Mode, native_if_possible), parse_pragma_c_code_varlist(VarSet, Vars, PragmaVars0, Error), PragmaVars = [PragmaVar | 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::in, string::in, eval_method::in, list(term)::in, term::in, maybe1(item)::out) is det. parse_tabling_pragma(ModuleName, PragmaName, TablingType, PragmaTerms, ErrorTerm, Result) :- ( ( PragmaTerms = [PredAndModesTerm0], MaybeAttrs = no ; PragmaTerms = [PredAndModesTerm0, AttrListTerm0], MaybeAttrs = yes(AttrListTerm0) ) -> ParseMsg = "`:- pragma " ++ PragmaName ++ "' declaration", parse_arity_or_modes(ModuleName, PredAndModesTerm0, ErrorTerm, ParseMsg, ArityModesResult), ( ArityModesResult = ok1(arity_or_modes(PredName, Arity, MaybePredOrFunc, MaybeModes)), ( MaybeAttrs = no, PragmaType = pragma_tabled(TablingType, PredName, Arity, MaybePredOrFunc, MaybeModes, no), Result = ok1(item_pragma(user, PragmaType)) ; MaybeAttrs = yes(AttrsListTerm), convert_maybe_list(AttrsListTerm, parse_tabling_attribute(TablingType), "expected tabling attribute", MaybeAttributeList), ( MaybeAttributeList = ok1(AttributeList), update_tabling_attributes(AttributeList, default_memo_table_attributes, MaybeAttributes), ( MaybeAttributes = ok1(Attributes), PragmaType = pragma_tabled(TablingType, PredName, Arity, MaybePredOrFunc, MaybeModes, yes(Attributes)), Result = ok1(item_pragma(user, PragmaType)) ; MaybeAttributes = error1(Errors), Result = error1(Errors) ) ; MaybeAttributeList = error1(Errors), Result = error1(Errors) ) ) ; ArityModesResult = error1(Errors), Result = error1(Errors) ) ; ErrorMsg = "wrong number of arguments in `:- pragma " ++ PragmaName ++ "' declaration", Result = error1([ErrorMsg - ErrorTerm]) ). :- type single_tabling_attribute ---> attr_strictness(call_table_strictness) ; attr_size_limit(int) ; attr_statistics ; attr_allow_reset. :- pred update_tabling_attributes( assoc_list(term, single_tabling_attribute)::in, table_attributes::in, maybe1(table_attributes)::out) is det. update_tabling_attributes([], Attributes, ok1(Attributes)). update_tabling_attributes([Term - SingleAttr | TermSingleAttrs], !.Attributes, MaybeAttributes) :- ( SingleAttr = attr_strictness(Strictness), ( !.Attributes ^ table_attr_strictness = all_strict -> !:Attributes = !.Attributes ^ table_attr_strictness := Strictness, update_tabling_attributes(TermSingleAttrs, !.Attributes, MaybeAttributes) ; Msg = "duplicate argument tabling methods attribute" ++ "in `:- pragma memo' declaration", MaybeAttributes = error1([Msg - Term]) ) ; SingleAttr = attr_size_limit(Limit), ( !.Attributes ^ table_attr_size_limit = no -> !:Attributes = !.Attributes ^ table_attr_size_limit := yes(Limit), update_tabling_attributes(TermSingleAttrs, !.Attributes, MaybeAttributes) ; Msg = "duplicate size limits attribute" ++ "in `:- pragma memo' declaration", MaybeAttributes = error1([Msg - Term]) ) ; SingleAttr = attr_statistics, ( !.Attributes ^ table_attr_statistics = table_dont_gather_statistics -> !:Attributes = !.Attributes ^ table_attr_statistics := table_gather_statistics, update_tabling_attributes(TermSingleAttrs, !.Attributes, MaybeAttributes) ; Msg = "duplicate statistics attribute" ++ "in `:- pragma memo' declaration", MaybeAttributes = error1([Msg - Term]) ) ; SingleAttr = attr_allow_reset, ( !.Attributes ^ table_attr_allow_reset = table_dont_allow_reset -> !:Attributes = !.Attributes ^ table_attr_allow_reset := table_allow_reset, update_tabling_attributes(TermSingleAttrs, !.Attributes, MaybeAttributes) ; Msg = "duplicate allow_reset attribute" ++ "in `:- pragma memo' declaration", MaybeAttributes = error1([Msg - Term]) ) ). :- pred parse_tabling_attribute(eval_method::in, term::in, maybe1(pair(term, single_tabling_attribute))::out) is semidet. parse_tabling_attribute(EvalMethod, Term, MaybeTermAttribute) :- Term = term.functor(term.atom(Functor), Args, _), ( Functor = "fast_loose", Args = [], ( eval_method_allows_fast_loose(EvalMethod) = yes -> Attribute = attr_strictness(all_fast_loose), MaybeTermAttribute = ok1(Term - Attribute) ; Msg = "evaluation method " ++ eval_method_to_string(EvalMethod) ++ " doesn't allow fast_loose tabling", MaybeTermAttribute = error1([Msg - Term]) ) ; Functor = "specified", Args = [Arg], convert_list(Arg, parse_arg_tabling_method, "expected argument tabling method", MaybeMaybeArgMethods), ( MaybeMaybeArgMethods = ok1(MaybeArgMethods), ( eval_method_allows_fast_loose(EvalMethod) = yes -> Attribute = attr_strictness(specified(MaybeArgMethods)), MaybeTermAttribute = ok1(Term - Attribute) ; Msg = "evaluation method " ++ eval_method_to_string(EvalMethod) ++ " doesn't allow specified tabling methods", MaybeTermAttribute = error1([Msg - Term]) ) ; MaybeMaybeArgMethods = error1(Errors), MaybeTermAttribute = error1(Errors) ) ; Functor = "size_limit", Args = [Arg], Arg = term.functor(term.integer(Limit), [], _), ( eval_method_allows_size_limit(EvalMethod) = yes -> Attribute = attr_size_limit(Limit), MaybeTermAttribute = ok1(Term - Attribute) ; Msg = "evaluation method " ++ eval_method_to_string(EvalMethod) ++ " doesn't allow size limits", MaybeTermAttribute = error1([Msg - Term]) ) ; Functor = "statistics", Args = [], Attribute = attr_statistics, MaybeTermAttribute = ok1(Term - Attribute) ; Functor = "allow_reset", Args = [], Attribute = attr_allow_reset, MaybeTermAttribute = ok1(Term - Attribute) ). :- func eval_method_allows_fast_loose(eval_method) = bool. eval_method_allows_fast_loose(eval_normal) = no. eval_method_allows_fast_loose(eval_loop_check) = yes. eval_method_allows_fast_loose(eval_memo) = yes. eval_method_allows_fast_loose(eval_table_io(_, _)) = no. eval_method_allows_fast_loose(eval_minimal(_)) = no. :- func eval_method_allows_size_limit(eval_method) = bool. eval_method_allows_size_limit(eval_normal) = no. eval_method_allows_size_limit(eval_loop_check) = yes. eval_method_allows_size_limit(eval_memo) = yes. eval_method_allows_size_limit(eval_table_io(_, _)) = no. eval_method_allows_size_limit(eval_minimal(_)) = no. :- pred parse_arg_tabling_method(term::in, maybe(arg_tabling_method)::out) is semidet. parse_arg_tabling_method(term.functor(term.atom("value"), [], _), yes(arg_value)). parse_arg_tabling_method(term.functor(term.atom("addr"), [], _), yes(arg_addr)). parse_arg_tabling_method(term.functor(term.atom("promise_implied"), [], _), yes(arg_promise_implied)). parse_arg_tabling_method(term.functor(term.atom("output"), [], _), no). :- type arity_or_modes ---> arity_or_modes( sym_name, arity, maybe(pred_or_func), maybe(list(mer_mode)) ). :- pred parse_arity_or_modes(module_name::in, term::in, term::in, string::in, maybe1(arity_or_modes)::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, "", ok2(PredName, [])), ArityTerm = term.functor(term.integer(Arity), [], _) -> Result = ok1(arity_or_modes(PredName, Arity, no, no)) ; Msg = "expected predname/arity for" ++ ErrorMsg, Result = error1([Msg - ErrorTerm]) ) ; parse_pred_or_func_and_arg_modes(yes(ModuleName), PredAndModesTerm0, PredAndModesTerm0, ErrorMsg, PredAndModesResult), ( PredAndModesResult = ok2(PredName - PredOrFunc, Modes), list.length(Modes, Arity0), ( PredOrFunc = pf_function -> Arity = Arity0 - 1 ; Arity = Arity0 ), Result = ok1(arity_or_modes(PredName, Arity, yes(PredOrFunc), yes(Modes))) ; PredAndModesResult = error2(Errors), Result = error1(Errors) ) ). :- type maybe_pred_or_func_modes == maybe2(pair(sym_name, pred_or_func), list(mer_mode)). :- pred parse_pred_or_func_and_arg_modes(maybe(module_name)::in, term::in, term::in, string::in, maybe_pred_or_func_modes::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 = ok2(PredName, ArgModeTerms - MaybeRetModeTerm), ( convert_mode_list(allow_constrained_inst_var, ArgModeTerms, ArgModes0) -> ( MaybeRetModeTerm = yes(RetModeTerm), ( convert_mode(allow_constrained_inst_var, RetModeTerm, RetMode) -> list.append(ArgModes0, [RetMode], ArgModes1), list.map(constrain_inst_vars_in_mode, ArgModes1, ArgModes), Result = ok2(PredName - pf_function, ArgModes) ; ErrorMsg = "error in return mode in " ++ Msg, Result = error2([ErrorMsg - ErrorTerm]) ) ; MaybeRetModeTerm = no, Result = ok2(PredName - pf_predicate, ArgModes0) ) ; ErrorMsg = "error in argument modes in " ++ Msg, Result = error2([ErrorMsg - ErrorTerm]) ) ; PredAndArgsResult = error2(Errors), Result = error2(Errors) ). :- pred convert_bool(term::in, bool::out) is semidet. convert_bool(Term, Bool) :- Term = term.functor(term.atom(Name), [], _), ( Name = "yes", Bool = yes ; Name = "no", Bool = no ). :- pred convert_bool_list(term::in, list(bool)::out) is semidet. convert_bool_list(ListTerm, Bools) :- convert_list(ListTerm, convert_bool, "expected boolean", ok1(Bools)). :- pred convert_int(term::in, int::out) is semidet. convert_int(Term, Int) :- Term = term.functor(term.integer(Int), [], _). :- pred convert_int_list(term::in, maybe1(list(int))::out) is det. convert_int_list(ListTerm, Result) :- convert_list(ListTerm, convert_int, "expected integer", 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::in, pred(term, T)::(pred(in, out) is semidet), string::in, maybe1(list(T))::out) is det. convert_list(term.variable(V, C), _, UnrecognizedMsg, error1([UnrecognizedMsg - term.variable(V, C)])). convert_list(term.functor(Functor, Args, Context), Pred, UnrecognizedMsg, Result) :- ( Functor = term.atom("[|]"), Args = [Term, RestTerm] -> ( call(Pred, Term, Element) -> convert_list(RestTerm, Pred, UnrecognizedMsg, RestResult), ( RestResult = ok1(List0), Result = ok1([Element | List0]) ; RestResult = error1(_), Result = RestResult ) ; Result = error1([UnrecognizedMsg - Term]) ) ; Functor = term.atom("[]"), Args = [] -> Result = ok1([]) ; Result = error1(["error in list" - term.functor(Functor, Args, Context)]) ). % 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_maybe_list(term::in, pred(term, maybe1(T))::(pred(in, out) is semidet), string::in, maybe1(list(T))::out) is det. convert_maybe_list(term.variable(V, C), _, UnrecognizedMsg, error1([UnrecognizedMsg - term.variable(V, C)])). convert_maybe_list(term.functor(Functor, Args, Context), Pred, UnrecognizedMsg, Result) :- ( Functor = term.atom("[|]"), Args = [Term, RestTerm] -> ( call(Pred, Term, ElementResult) -> ( ElementResult = ok1(Element), convert_maybe_list(RestTerm, Pred, UnrecognizedMsg, RestResult), ( RestResult = ok1(List0), Result = ok1([Element | List0]) ; RestResult = error1(_), Result = RestResult ) ; ElementResult = error1(Errors), Result = error1(Errors) ) ; Result = error1([UnrecognizedMsg - Term]) ) ; Functor = term.atom("[]"), Args = [] -> Result = ok1([]) ; Result = error1(["error in list" - term.functor(Functor, Args, Context)]) ). :- pred convert_type_spec_pair(term::in, pair(tvar, mer_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), parse_type(SpecTypeTerm0, ok1(SpecType)), TypeSpec = TypeVar - SpecType. %-----------------------------------------------------------------------------% % % Parsing termination2_info pragmas. % :- pred parse_arg_size_constraints(term::in, maybe1(maybe(list(arg_size_constr)))::out) is semidet. parse_arg_size_constraints(ArgSizeTerm, Result) :- ( ArgSizeTerm = term.functor(term.atom("not_set"), [], _), Result = ok1(no) ; ArgSizeTerm = term.functor(term.atom("constraints"), [Constraints0], _), convert_list(Constraints0, parse_arg_size_constraint, "expected constraint", ConstraintsResult), ConstraintsResult = ok1(Constraints), Result = ok1(yes(Constraints)) ). :- pred parse_arg_size_constraint(term::in, arg_size_constr::out) is semidet. parse_arg_size_constraint(Term, Constr) :- ( Term = term.functor(term.atom("le"), [Terms, ConstantTerm], _), convert_list(Terms, parse_lp_term, "expected linear term", TermsResult), TermsResult = ok1(LPTerms), parse_rational(ConstantTerm, Constant), Constr = le(LPTerms, Constant) ; Term = term.functor(term.atom("eq"), [Terms, ConstantTerm], _), convert_list(Terms, parse_lp_term, "expected linear term", TermsResult), TermsResult = ok1(LPTerms), parse_rational(ConstantTerm, Constant), Constr = eq(LPTerms, Constant) ). :- pred parse_lp_term(term::in, pair(int, rat)::out) is semidet. parse_lp_term(Term, LpTerm) :- Term = term.functor(term.atom("term"), [VarIdTerm, CoeffTerm], _), VarIdTerm = term.functor(term.integer(VarId), [], _), parse_rational(CoeffTerm, Coeff), LpTerm = VarId - Coeff. :- pred parse_rational(term::in, rat::out) is semidet. parse_rational(Term, Rational) :- Term = term.functor(term.atom("r"), [NumerTerm, DenomTerm], _), NumerTerm = term.functor(term.integer(Numer), [], _), DenomTerm = term.functor(term.integer(Denom), [], _), Rational = rat.rat(Numer, Denom). %-----------------------------------------------------------------------------% :- func this_file = string. this_file = "prog_io_pragma.m". %-----------------------------------------------------------------------------% :- end_module prog_io_pragma. %-----------------------------------------------------------------------------%