mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2025-12-13 21:04:00 +00:00
Code Issues Projects Releases Wiki Activity
Files
9dd11b2fc6c9dfd337c0040f0e635ab1c752c209
mercury/compiler/prog_io_pragma.m
Simon Taylor 9dd11b2fc6 Smart recompilation. Record version numbers for each item 
Estimated hours taken: 400

Smart recompilation. Record version numbers for each item
in interface files. Record which items are used in each compilation.
Only recompile a module if the output file does not exist or
nothing has changed.

There is still some work to do on this:
- it doesn't work with inter-module optimization.
- it doesn't work when the module name doesn't match the file name.
  (this problem will go away when mmake functionality is moved into
  the compiler.

I'll hold off documenting this change in the NEWS file and
on the web page for a month or so, until I've had a bit more
experience using it.

compiler/options.m:
compiler/handle_options.m:
doc/user_guide.texi:
	Add an option `--smart-recompilation', currently off by default.

	Add an internal option `--generate-version-numbers' to control
	whether version numbers are written to the interface files. If
	`--smart-recompilation' is disabled because the module
	is being compiled with `--intermodule-optimization' (e.g. in the
	standard library), we still want to write the version numbers
	to the interface files.

	Add an option `--verbose-recompilation' (default off)
	to write messages describing why recompilation is needed.

	Add an option `--warn-smart-recompilation' (default on)
	to control warnings relating to the smart recompilation
	system. Warn if smart recompilation will not work with
	the output and inter-module optimization options given.

compiler/recompilation.m:
	Type declarations for smart recompilation.
	Predicates to record program items used by compilation.

compiler/recompilation_version.m:
	Compute version numbers for program items in interface files.

compiler/recompilation_usage.m:
	Find all items used by a compilation.

compiler/recompilation_check.m:
	Check whether recompilation is necessary.

compiler/timestamp.m:
	Timestamp ADT for smart recompilation.

compiler/mercury_compile.m:
	Invoke the smart recompilation passes.

compiler/modules.m:
compiler/prog_io.m:
	Return timestamps for modules read.

	When reading a module make sure the current input stream
	is reset to its old value, not stdin.

	Handle version number items in interface files.

compiler/module_qual.m:
compiler/unify_proc.m:
compiler/make_hlds.m:
	Record all items used by local items.

compiler/make_hlds.m:
	Process `:- pragma type_spec' declarations in
	add_item_list_clauses. The qual_info is needed
	when processing `:- pragma type_spec' declarations
	so that any equivalence types used by the declaration
	can be recorded as used by the predicate or function to
	which the `:- pragma type_spec' applies.

compiler/equiv_type.m:
	For each imported item, record which equivalence types
	are used by that item.

compiler/hlds_module.m:
	Add a field to the module_info to store information about
	items used during compilation of a module.

compiler/check_typeclass.m:
	Make sure any items used in clauses for typeclass method
	implementations are recorded in the `.used' file.

compiler/prog_data.m:
compiler/*.m:
	Factor out some duplicated code by combining the
	pred and func, and pred_mode and func_mode items.

	Make it easier to extract the name of a type, inst or mode
	from its declaration.

	Add an item type to hold the version numbers for an interface file.

	Allow warnings to be reported for `nothing' items (used for
	reporting when version numbers are written using an
	obsolete format).

compiler/prog_io.m:
compiler/prog_io_util.m:
compiler/typecheck.m:
compiler/type_util.m:
compiler/*.m:
	Strip contexts from all types, not just those in class constraints.
	This makes it possible to use ordinary unification to check
	whether items have changed (with the exception of clauses).

	Remove code to create types with contexts in typechecking.

	Remove code scattered through the compiler to remove contexts
	from types in class constraints.

compiler/hlds_pred.m:
compiler/prog_util.m:
	Move hlds_pred__adjust_func_arity to prog_util, so that it
	can be used by the pre-hlds passes.

compiler/typecheck.m:
compiler/hlds_module.m:
	Move typecheck__visible_modules to hlds_module.m, so it can
	be used by recompilation_usage.m.

compiler/typecheck.m:
	Add a comment telling where updates may be required if the
	code to typecheck a var-functor unification changes.

compiler/error_util.m:
	Allow writing messages without contexts (used for the verbose
	recompilation messages).

	Add functions to format sym_name and sym_name_and_arity,
	and to add punctuation to the end of an error message
	without unwanted line breaks before the punctuation.

scripts/Mmake.rules:
compiler/modules.m:
	Don't remove the output file before running the compiler. We need
	to leave the old output file intact if smart recompilation detects
	that recompilation is not needed.

compiler/notes/compiler_design.html:
	Document the new modules.

library/io.m:
NEWS:
	Add predicates to find the modification time of files
	and input_streams.

library/set.m:
NEWS:
	Add a predicate version of set__fold

	Don't sort the output of set__filter, it's already sorted.

library/std_util.m:
NEWS:
	Add a predicate `std_util__map_maybe/3' and a function
  	`std_util__map_maybe/2' to apply a predicate or a function to
    	a value stored in a term of type `std_util__maybe'.

configure.in:
runtime/mercury_conf.h.in:
runtime/RESERVED_MACRO_NAMES:
	When checking whether the compiler is recent enough, check for
	the --warn-smart-recompilation option.

	Check for stat().

library/Mmakefile:
	Disable warnings about smart recompilation not working with
	`--intermodule-optimization'.

browser/Mmakefile:
	Disable warnings about smart recompilation not working when
	the module name doesn't match the file name.

runtime/mercury_string.h:
	Add a macro MR_make_string_const() which automates computation
	of the length of string argument to MR_string_const().

tests/recompilation/Mmakefile:
tests/recompilation/runtests:
tests/recompilation/test_functions:
tests/recompilation/TESTS:
tests/recompilation/README:
	A framework for testing smart recompilation.
	The option currently only works for the recompilation directory.

tests/recompilation/TEST.m.{1,2}:
tests/recompilation/TEST_2.m.{1,2}:
tests/recompilation/TEST.exp.{1,2}:
tests/recompilation/TEST.err_exp.2:
	Test cases, where TEST is one of add_constructor_r, add_instance_r,
	add_instance_2_r, add_type_nr, change_class_r, change_instance_r,
	change_mode_r, field_r, func_overloading_nr, func_overloading_r,
	lambda_mode_r, nested_module_r, no_version_numbers_r,
	pragma_type_spec_r, pred_ctor_ambiguity_r, pred_overloading_r,
	add_type_re, remove_type_re, type_qual_re.

tests/handle_options:
	Add an option `-e' to generate any missing expected output files.
2001-06-27 05:05:21 +00:00

1483 lines
47 KiB
Mathematica
Raw Blame History

%-----------------------------------------------------------------------------%
% Copyright (C) 1996-2001 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 globals, prog_io, prog_io_goal, prog_util.
:- import_module term_util, term_errors.
:- import_module int, map, string, std_util, bool, require, set.
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(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)
;
Result = error("wrong number of arguments or unexpected variable 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).
parse_pragma_type(ModuleName, "foreign_proc", PragmaTerms,
ErrorTerm, VarSet, Result) :-
parse_pragma_foreign_proc_pragma(ModuleName, "foreign_proc",
PragmaTerms, ErrorTerm, VarSet, Result).
% 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)
;
Result = error("wrong number of arguments or unexpected variable in `:- pragma c_code' declaration",
ErrorTerm)
).
:- pred parse_foreign_language(term, foreign_language).
:- mode parse_foreign_language(in, out) is semidet.
parse_foreign_language(term__functor(term__string(String), _, _), Lang) :-
globals__convert_foreign_language(String, Lang).
% This predicate parses both c_header_code and foreign_decl pragmas.
:- pred parse_pragma_foreign_decl_pragma(module_name, string,
list(term), term, varset, maybe1(item)).
:- mode parse_pragma_foreign_decl_pragma(in, in, in, in, in, out) is det.
parse_pragma_foreign_decl_pragma(_ModuleName, Pragma, PragmaTerms,
ErrorTerm, _VarSet, Result) :-
string__format("invalid `:- pragma %s' declaration ", [s(Pragma)],
InvalidDeclStr),
(
PragmaTerms = [Lang, HeaderTerm]
->
(
parse_foreign_language(Lang, ForeignLanguage)
->
(
HeaderTerm = term__functor(term__string(
HeaderCode), [], _)
->
Result = ok(pragma(foreign_decl(
ForeignLanguage, HeaderCode)))
;
ErrMsg = "-- expected string for foreign declaration code",
Result = error(string__append(InvalidDeclStr,
ErrMsg), HeaderTerm)
)
;
ErrMsg = "-- invalid language parameter",
Result = error(string__append(InvalidDeclStr, ErrMsg),
Lang)
)
;
string__format("invalid `:- pragma %s' declaration ", [s(Pragma)],
ErrorStr),
Result = error(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, 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),
Check1 = (func(PTerms1, ForeignLanguage) = Res is semidet :-
PTerms1 = [Just_Code_Term],
(
Just_Code_Term = term__functor(term__string(
Just_Code), [], _)
->
Res = ok(pragma(foreign_code(ForeignLanguage,
Just_Code)))
;
ErrMsg = "-- expected string for foreign code",
Res = error(string__append(InvalidDeclStr, ErrMsg),
ErrorTerm)
)
),
% After foreign_proc has bootstrapped and the library has
% been updated to use foreign_proc where appropriate, we
% should uncomment this code and remove Check2, Check3,
% Check5, Check6 and the other definition of CheckLength.
/*
CheckLength = (func(PTermsLen, ForeignLanguage) = Res :-
(
Res0 = Check1(PTermsLen, ForeignLanguage)
->
Res = Res0
;
ErrMsg = "-- wrong number of arguments",
Res = error(string__append(InvalidDeclStr, ErrMsg),
ErrorTerm)
)
),
*/
Check6 = (func(PTerms6, ForeignLanguage) = Res is semidet :-
PTerms6 = [PredAndVarsTerm, FlagsTerm,
FieldsTerm, FirstTerm, LaterTerm, SharedTerm],
( parse_pragma_foreign_proc_attributes_term(
ForeignLanguage, 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,
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,
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,
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 proc 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_foreign_proc_attributes_term(ForeignLanguage,
FlagsTerm, Flags) ->
parse_pragma_foreign_code(ModuleName, Flags,
PredAndVarsTerm, ordinary(Code, yes(Context)),
VarSet, Res)
; parse_pragma_foreign_proc_attributes_term(ForeignLanguage,
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,
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 proc 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(ForeignLanguage, Attributes),
(
CodeTerm = term__functor(term__string(Code), [],
Context)
->
parse_pragma_foreign_code(ModuleName,
Attributes, PredAndVarsTerm, ordinary(Code,
yes(Context)), VarSet, Res)
;
ErrMsg = "-- expecting either `may_call_mercury' or `will_not_call_mercury', and a string for foreign code",
Res = error(string__append(InvalidDeclStr, ErrMsg),
CodeTerm)
)
;
ErrMsg = "-- doesn't say whether it can call mercury",
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)
).
% This predicate parses both c_code and foreign_proc pragmas.
:- pred parse_pragma_foreign_proc_pragma(module_name, string,
list(term), term, varset, maybe1(item)).
:- mode parse_pragma_foreign_proc_pragma(in, in, in, in, in, out) is det.
parse_pragma_foreign_proc_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_foreign_proc_attributes_term(
ForeignLanguage, 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,
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,
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,
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 proc 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_foreign_proc_attributes_term(ForeignLanguage,
FlagsTerm, Flags) ->
parse_pragma_foreign_code(ModuleName, Flags,
PredAndVarsTerm, ordinary(Code, yes(Context)),
VarSet, Res)
; parse_pragma_foreign_proc_attributes_term(ForeignLanguage,
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,
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 proc 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(ForeignLanguage, Attributes),
(
CodeTerm = term__functor(term__string(Code), [],
Context)
->
parse_pragma_foreign_code(ModuleName,
Attributes, PredAndVarsTerm, ordinary(Code,
yes(Context)), VarSet, Res)
;
ErrMsg = "-- expecting either `may_call_mercury' or `will_not_call_mercury', and a string for foreign code",
Res = error(string__append(InvalidDeclStr, ErrMsg),
CodeTerm)
)
;
ErrMsg = "-- doesn't say whether it can call mercury",
Res = error(string__append(InvalidDeclStr, ErrMsg),
ErrorTerm)
)
),
CheckLength = (func(PTermsLen, ForeignLanguage) = Res :-
(
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) :-
% XXX we assume all imports are C
ForeignLanguage = c,
(
(
PragmaTerms = [PredAndModesTerm, FlagsTerm, FunctionTerm],
( parse_pragma_foreign_proc_attributes_term(ForeignLanguage,
FlagsTerm, Flags) ->
FlagsResult = ok(Flags)
;
FlagsResult = error("invalid second argument in `:- pragma import/3' declaration -- expecting a foreign proc attribute or list of attributes'",
FlagsTerm)
)
;
PragmaTerms = [PredAndModesTerm, FunctionTerm],
default_attributes(ForeignLanguage, Flags),
FlagsResult = ok(Flags)
)
->
(
FunctionTerm = term__functor(term__string(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, Function)))
;
FlagsResult = error(Msg, Term),
Result = error(Msg, Term)
)
;
PredAndArgModesResult = error(Msg, Term),
Result = error(Msg, Term)
)
;
Result = error(
"expected pragma import(PredName(ModeList), Function)",
PredAndModesTerm)
)
;
Result =
error(
"wrong number of arguments in `:- pragma import' declaration",
ErrorTerm)
).
parse_pragma_type(_ModuleName, "export", PragmaTerms,
ErrorTerm, _VarSet, Result) :-
% XXX we implicitly assume exports are only for C
(
PragmaTerms = [PredAndModesTerm, FunctionTerm]
->
(
FunctionTerm = term__functor(term__string(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, Function)))
;
PredAndModesResult = error(Msg, Term),
Result = error(Msg, Term)
)
;
Result = error(
"expected pragma export(PredName(ModeList), 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, set__init)))
;
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, "promise_semipure", PragmaTerms, ErrorTerm,
_VarSet, Result) :-
parse_simple_pragma(ModuleName, "promise_semipure",
lambda([Name::in, Arity::in, Pragma::out] is det,
Pragma = promise_semipure(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_foreign_proc_attribute
---> may_call_mercury(may_call_mercury)
; thread_safe(thread_safe)
; tabled_for_io(tabled_for_io)
; aliasing.
:- pred parse_pragma_foreign_proc_attributes_term(foreign_language, term,
pragma_foreign_proc_attributes).
:- mode parse_pragma_foreign_proc_attributes_term(in, in, out) is semidet.
parse_pragma_foreign_proc_attributes_term(ForeignLanguage, Term, Attributes) :-
default_attributes(ForeignLanguage, Attributes0),
parse_pragma_foreign_proc_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_foreign_proc_attributes_term0(term,
list(collected_pragma_foreign_proc_attribute)).
:- mode parse_pragma_foreign_proc_attributes_term0(in, out) is semidet.
parse_pragma_foreign_proc_attributes_term0(Term, Flags) :-
(
parse_single_pragma_foreign_proc_attribute(Term, Flag)
->
Flags = [Flag]
;
(
Term = term__functor(term__atom("[]"), [], _),
Flags = []
;
Term = term__functor(term__atom("."), [Hd, Tl], _),
Flags = [Flag|Flags0],
parse_single_pragma_foreign_proc_attribute(Hd, Flag),
parse_pragma_foreign_proc_attributes_term0(Tl, Flags0)
)
).
:- pred parse_single_pragma_foreign_proc_attribute(term,
collected_pragma_foreign_proc_attribute).
:- mode parse_single_pragma_foreign_proc_attribute(in, out) is semidet.
parse_single_pragma_foreign_proc_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)
; parse_aliasing(Term) ->
Flag = aliasing
;
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).
% XXX For the moment we just ignore the following attributes.
% These attributes are used for aliasing on the reuse branch,
% and ignoring them allows the main branch compiler to compile
% the reuse branch.
:- pred parse_aliasing(term).
:- mode parse_aliasing(in) is semidet.
parse_aliasing(term__functor(term__atom("no_aliasing"), [], _)).
parse_aliasing(term__functor(term__atom("unknown_aliasing"), [], _)).
parse_aliasing(term__functor(term__atom("alias"), [_Types, _Alias], _)).
% parse a pragma foreign_code declaration
:- pred parse_pragma_foreign_code(module_name, pragma_foreign_proc_attributes,
term, pragma_foreign_code_impl, varset, maybe1(item)).
:- mode parse_pragma_foreign_code(in, in, in, in, in, 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 = 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_proc(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),
convert_type(SpecTypeTerm0, SpecType),
TypeSpec = TypeVar - SpecType.
Reference in New Issue View Git Blame Copy Permalink