%-----------------------------------------------------------------------------e % vim: ft=mercury ts=4 sw=4 et %-----------------------------------------------------------------------------e % Copyright (C) 1993-2005 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.m. % Main author: fjh. % % This module defines predicates for parsing Mercury programs. % % In some ways the representation of programs here is considerably % more complex than is necessary for the compiler. % The basic reason for this is that it was designed to preserve % as much information about the source code as possible, so that % this representation could also be used for other tools such % as pretty-printers. % Currently the only information that is lost is that comments and % whitespace are stripped, any redundant parenthesization % are lost, distinctions between different spellings of the same % operator (eg "\+" vs "not") are lost, and DCG clauses get expanded. % It would be a good idea to preserve all those too (well, maybe not % the redundant parentheses), but right now it's not worth the effort. % % So that means that this phase of compilation is purely parsing. % No simplifications are done (other than DCG expansion). % The results of this phase specify % basically the same information as is contained in the source code, % but in a parse tree rather than a flat file. % Simplifications are done only by make_hlds.m, which transforms % the parse tree which we built here into the HLDS. % % Some of this code is a rather bad example of cut-and-paste style reuse. % It should be cleaned up to eliminate most of the duplication. % But that task really needs to wait until we implement higher-order % predicates. For the moment, just be careful that any changes % you make are reflected correctly in all similar parts of this % file. % % Implication and equivalence implemented by squirrel, who would also % like to get her hands on this file and give it a good clean up and % put it into good clean "mercury" style! % % Wishlist: % % 1. implement importing/exporting operators with a particular fixity % eg. :- import_op prefix(+). % only prefix +, not infix % (not important, but should be there for reasons of symmetry.) % 2. improve the handling of type and inst parameters % 3. improve the error reporting (most of the semidet preds should % be det and should return a meaningful indication of where an % error occured). :- module parse_tree__prog_io. :- interface. :- import_module libs.timestamp. :- import_module mdbcomp.prim_data. :- import_module parse_tree.prog_data. :- import_module parse_tree.prog_item. :- import_module parse_tree.prog_io_util. :- import_module bool. :- import_module io. :- import_module list. :- import_module std_util. :- import_module term. :- import_module varset. %-----------------------------------------------------------------------------% % This module (prog_io) exports the following predicates: :- type file_name == string. :- type dir_name == string. % Open a source or interface file, returning `ok(FileInfo)' on success % (where FileInfo is information about the file such as the file name % or the directory in which it was found), or `error(Message)' on failure. :- type open_file(FileInfo) == pred(maybe_error(FileInfo), io, io). :- inst open_file == (pred(out, di, uo) is det). :- type module_error ---> no_module_errors % no errors ; some_module_errors % some syntax errors ; fatal_module_errors. % couldn't open the file % read_module(OpenFile, FileName, DefaultModuleName, % ReturnTimestamp, Error, MaybeFileInfo, ActualModuleName, Messages, % Program, MaybeModuleTimestamp): % % Reads and parses the file opened by OpenFile using the default module % name DefaultModuleName. If ReturnTimestamp is `yes', attempt to return % the modification timestamp in MaybeModuleTimestamp. Error is % `fatal_module_errors' if the file coudn't be opened, `some_module_errors' % if a syntax error was detected, and `no_module_errors' otherwise. % MaybeFileInfo is the information about the file (usually the file or % directory name) returned by OpenFile. ActualModuleName is the module name % specified in the `:- module' declaration, if any, or the % DefaultModuleName if there is no `:- module' declaration. % Messages is a list of warning/error messages. Program is the parse tree. % :- pred read_module(open_file(FileInfo)::in(open_file), module_name::in, bool::in, module_error::out, maybe(FileInfo)::out, module_name::out, message_list::out, item_list::out, maybe(io__res(timestamp))::out, io::di, io::uo) is det. :- pred read_module_if_changed(open_file(FileInfo)::in(open_file), module_name::in, timestamp::in, module_error::out, maybe(FileInfo)::out, module_name::out, message_list::out, item_list::out, maybe(io__res(timestamp))::out, io::di, io::uo) is det. % Same as read_module, but use intermod_directories instead of % search_directories when searching for the file. % Also report an error if the actual module name doesn't match % the expected module name. % :- pred read_opt_file(file_name::in, module_name::in, module_error::out, message_list::out, item_list::out, io::di, io::uo) is det. % check_module_has_expected_name(FileName, ExpectedName, ActualName): % % Check that two module names are equal, and report an error if they % aren't. % :- pred check_module_has_expected_name(file_name::in, module_name::in, module_name::in, io::di, io::uo) is det. % search_for_file(Dirs, FileName, FoundFileName, !IO): % % Search Dirs for FileName, opening the file if it is found, % and returning the path name of the file that was found. % :- pred search_for_file(list(dir_name)::in, file_name::in, maybe_error(file_name)::out, io::di, io::uo) is det. % search_for_file_returning_dir(Dirs, FileName, FoundDirName, !IO): % % Search Dirs for FileName, opening the file if it is found, and returning % the name of the directory in which the file was found. % :- pred search_for_file_returning_dir(list(dir_name)::in, file_name::in, maybe_error(dir_name)::out, io::di, io::uo) is det. % search_for_module_source(Dirs, ModuleName, FoundSourceFileName, !IO): % % Look for the source for ModuleName in Dirs. This will also search for % files matching partially qualified versions of ModuleName. For example, % module foo.bar.baz can be found in foo.bar.m, bar.baz.m or bar.m. % :- pred search_for_module_source(list(dir_name)::in, module_name::in, maybe_error(file_name)::out, io::di, io::uo) is det. % Read the first item from the given file to find the module name. % :- pred find_module_name(file_name::in, maybe(module_name)::out, io::di, io::uo) is det. % parse_item(ModuleName, VarSet, Term, MaybeItem): % % Parse Term. If successful, MaybeItem is bound to the parsed item, % otherwise it is bound to an appropriate error message. Qualify % appropriate parts of the item, with ModuleName as the module name. % :- pred parse_item(module_name::in, varset::in, term::in, maybe_item_and_context::out) is det. % parse_decl(ModuleName, VarSet, Term, Result): % % Parse Term as a declaration. If successful, Result is bound to the % parsed item, otherwise it is bound to an appropriate error message. % Qualify appropriate parts of the item, with ModuleName as the module % name. % :- pred parse_decl(module_name::in, varset::in, term::in, maybe_item_and_context::out) is det. % parse_type_defn_head(ModuleName, Head, Body, HeadResult): % % Check the head of a type definition for errors. % :- pred parse_type_defn_head(module_name::in, term::in, term::in, maybe2(sym_name, list(type_param))::out) is det. % parse_type_decl_where_part_if_present(TypeSymName, Arity, % IsSolverType, Inst, ModuleName, Term0, Term, Result): % % Checks if Term0 is a term of the form ` where '. % If so, returns the `' in Term and the parsed `' % in Result. If not, returns Term = Term0 and Result = no. % :- pred parse_type_decl_where_part_if_present(is_solver_type::in, module_name::in, term::in, term::out, maybe2(maybe(solver_type_details), maybe(unify_compare))::out) is det. %-----------------------------------------------------------------------------% % A QualifiedTerm is one of % Name(Args) % Module.Name(Args) % (or if Args is empty, one of % Name % Module.Name) % where Module is a SymName. For backwards compatibility, we allow `__' % as an alternative to `.'. % Sym_name_and_args takes a term and returns a sym_name and a list of % argument terms. It fails if the input is not valid syntax for a % QualifiedTerm. % :- pred sym_name_and_args(term(T)::in, sym_name::out, list(term(T))::out) is semidet. % parse_qualified_term/4 takes a term (and also the containing term, % and a string describing the context from which it was called % [e.g. "clause head"]) and returns a sym_name and a list of argument % terms. Returns an error on ill-formed input. See also % parse_implicitly_qualified_term/5 (below). % :- pred parse_qualified_term(term(T)::in, term(T)::in, string::in, maybe_functor(T)::out) is det. % parse_implicitly_qualified_term(DefaultModName, Term, % ContainingTerm, Msg, Result): % % parse_implicitly_qualified_term/5 takes a default module name and a term, % (and also the containing term, and a string describing the context from % which it was called (e.g. "clause head"), and returns a sym_name and % a list of argument terms. Returns an error on ill-formed input or % a module qualifier that doesn't match the DefaultModName. % % Note: parse_qualified_term/4 is used for places where a symbol is _used_, % in which case no default module name exists, whereas % parse_implicitly_qualified_term/5 is used for places where a symbol % is _defined_; in that case, there is a default module name (the name % of the current module) -- specifying a module qualifier explicitly % is redundant, but it is allowed, so long as the module qualifier % specified matches the default. % :- pred parse_implicitly_qualified_term(module_name::in, term(T)::in, term(T)::in, string::in, maybe_functor(T)::out) is det. %-----------------------------------------------------------------------------% % Replace all occurrences of inst_var(I) with % constrained_inst_var(I, ground(shared, none)). % :- pred constrain_inst_vars_in_mode(mer_mode::in, mer_mode::out) is det. % Replace all occurrences of inst_var(I) with % constrained_inst_var(I, Inst) where I -> Inst is in the inst_var_sub. % If I is not in the inst_var_sub, default to ground(shared, none). % :- pred constrain_inst_vars_in_mode(inst_var_sub::in, mer_mode::in, mer_mode::out) is det. %-----------------------------------------------------------------------------% % Check that for each constrained_inst_var all occurrences have the % same constraint. % :- pred inst_var_constraints_are_consistent_in_modes(list(mer_mode)::in) is semidet. %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- implementation. :- import_module libs.globals. :- import_module libs.options. :- import_module parse_tree.modules. :- import_module parse_tree.modules. :- import_module parse_tree.prog_io_dcg. :- import_module parse_tree.prog_io_goal. :- import_module parse_tree.prog_io_pragma. :- import_module parse_tree.prog_io_typeclass. :- import_module parse_tree.prog_io_util. :- import_module parse_tree.prog_mode. :- import_module parse_tree.prog_out. :- import_module parse_tree.prog_type. :- import_module parse_tree.prog_util. :- import_module recompilation. :- import_module recompilation.version. :- import_module assoc_list. :- import_module dir. :- import_module int. :- import_module map. :- import_module parser. :- import_module require. :- import_module set. :- import_module std_util. :- import_module string. :- import_module term_io. :- import_module time. %-----------------------------------------------------------------------------% read_module(OpenFile, DefaultModuleName, ReturnTimestamp, Error, FileData, ModuleName, Messages, Items, MaybeModuleTimestamp, !IO) :- read_module_2(OpenFile, DefaultModuleName, no, ReturnTimestamp, Error, FileData, ModuleName, Messages, Items, MaybeModuleTimestamp, !IO). read_module_if_changed(OpenFile, DefaultModuleName, OldTimestamp, Error, FileData, ModuleName, Messages, Items, MaybeModuleTimestamp, !IO) :- read_module_2(OpenFile, DefaultModuleName, yes(OldTimestamp), yes, Error, FileData, ModuleName, Messages, Items, MaybeModuleTimestamp, !IO). read_opt_file(FileName, DefaultModuleName, Error, Messages, Items, !IO) :- globals__io_lookup_accumulating_option(intermod_directories, Dirs, !IO), read_module_2(search_for_file(Dirs, FileName), DefaultModuleName, no, no, Error, _, ModuleName, Messages, Items, _, !IO), check_module_has_expected_name(FileName, DefaultModuleName, ModuleName, !IO). check_module_has_expected_name(FileName, ExpectedName, ActualName, !IO) :- ( ActualName \= ExpectedName -> sym_name_to_string(ActualName, ActualString), sym_name_to_string(ExpectedName, ExpectedString), io__write_strings([ "Error: file `", FileName, "' contains the wrong module.\n", "Expected module `", ExpectedString, "', found module `", ActualString, "'.\n" ], !IO), io__set_exit_status(1, !IO) ; true ). % This implementation uses io__read_term to read in the program one term % at a time, and then converts those terms into clauses and declarations, % checking for errors as it goes. Note that rather than using difference % lists, we just build up the lists of items and messages in reverse order % and then reverse them afterwards. (Using difference lists would require % late-input modes.) % :- pred read_module_2(open_file(T)::in(open_file), module_name::in, maybe(timestamp)::in, bool::in, module_error::out, maybe(T)::out, module_name::out, message_list::out, item_list::out, maybe(io__res(timestamp))::out, io::di, io::uo) is det. read_module_2(OpenFile, DefaultModuleName, MaybeOldTimestamp, ReturnTimestamp, Error, MaybeFileData, ModuleName, Messages, Items, MaybeModuleTimestamp, !IO) :- io__input_stream(OldInputStream, !IO), OpenFile(OpenResult, !IO), ( OpenResult = ok(FileData), MaybeFileData = yes(FileData), ( ReturnTimestamp = yes -> io__input_stream_name(InputStreamName, !IO), io__file_modification_time(InputStreamName, TimestampResult, !IO), ( TimestampResult = ok(Timestamp), MaybeModuleTimestamp = yes(ok(time_t_to_timestamp(Timestamp))) ; TimestampResult = error(IOError), MaybeModuleTimestamp = yes(error(IOError)) ) ; MaybeModuleTimestamp = no ), ( MaybeOldTimestamp = yes(OldTimestamp), MaybeModuleTimestamp = yes(ok(OldTimestamp)) -> % XXX Currently smart recompilation won't work % if ModuleName \= DefaultModuleName. % In that case, smart recompilation will be disabled % and read_module should never be passed an old timestamp. ModuleName = DefaultModuleName, Items = [], Error = no_module_errors, Messages = [] ; read_all_items(DefaultModuleName, ModuleName, Messages, Items, Error, !IO) ), io__set_input_stream(OldInputStream, ModuleInputStream, !IO), io__close_input(ModuleInputStream, !IO) ; OpenResult = error(Message0), io__progname_base("mercury_compile", Progname, !IO), Message = Progname ++ ": " ++ Message0, dummy_term(Term), Messages = [Message - Term], Error = fatal_module_errors, Items = [], ModuleName = DefaultModuleName, MaybeFileData = no, MaybeModuleTimestamp = no ). search_for_file(Dirs, FileName, Result, !IO) :- search_for_file_returning_dir(Dirs, FileName, Result0, !IO), ( Result0 = ok(Dir), ( dir__this_directory(Dir) -> PathName = FileName ; PathName = dir__make_path_name(Dir, FileName) ), Result = ok(PathName) ; Result0 = error(Message), Result = error(Message) ). search_for_file_returning_dir(Dirs, FileName, R, !IO) :- search_for_file_returning_dir(Dirs, Dirs, FileName, R, !IO). :- pred search_for_file_returning_dir(list(dir_name)::in, list(dir_name)::in, file_name::in, maybe_error(dir_name)::out, io::di, io::uo) is det. search_for_file_returning_dir([], AllDirs, FileName, error(Msg), !IO) :- Msg = append_list(["cannot find `", FileName, "' in directories ", string__join_list(", ", AllDirs)]). search_for_file_returning_dir([Dir | Dirs], AllDirs, FileName, R, !IO) :- ( dir__this_directory(Dir) -> ThisFileName = FileName ; ThisFileName = dir__make_path_name(Dir, FileName) ), io__see(ThisFileName, R0, !IO), ( R0 = ok -> R = ok(Dir) ; search_for_file_returning_dir(Dirs, AllDirs, FileName, R, !IO) ). search_for_module_source(Dirs, ModuleName, MaybeFileName, !IO) :- search_for_module_source(Dirs, ModuleName, ModuleName, MaybeFileName, !IO). :- pred search_for_module_source(list(dir_name)::in, module_name::in, module_name::in, maybe_error(file_name)::out, io::di, io::uo) is det. search_for_module_source(Dirs, ModuleName, PartialModuleName, Result, !IO) :- module_name_to_file_name(PartialModuleName, ".m", no, FileName, !IO), search_for_file(Dirs, FileName, Result0, !IO), ( Result0 = ok(_), Result = Result0 ; Result0 = error(_), ( PartialModuleName1 = drop_one_qualifier(PartialModuleName) -> search_for_module_source(Dirs, ModuleName, PartialModuleName1, Result, !IO) ; sym_name_to_string(ModuleName, ModuleNameStr), Result = error("can't find source for module `" ++ ModuleNameStr ++ "'") ) ). :- func drop_one_qualifier(module_name) = module_name is semidet. drop_one_qualifier(qualified(ParentQual, ChildName)) = drop_one_qualifier_2(ParentQual, ChildName). :- func drop_one_qualifier_2(module_name, string) = module_name. drop_one_qualifier_2(ParentQual, ChildName) = PartialQual :- ( ParentQual = unqualified(_ParentName), PartialQual = unqualified(ChildName) ; ParentQual = qualified(GrandParentQual, ParentName), PartialGrandParentQual = drop_one_qualifier_2(GrandParentQual, ParentName), PartialQual = qualified(PartialGrandParentQual, ChildName) ). %-----------------------------------------------------------------------------% :- type module_end ---> no ; yes(module_name, prog_context). % Extract the final `:- end_module' declaration if any. % :- pred get_end_module(module_name::in, item_list::in, item_list::out, module_end::out) is det. get_end_module(ModuleName, RevItems0, RevItems, EndModule) :- ( % Note: if the module name in the end_module declaration does not match % what we expect, given the source file name, then we assume that it is % for a nested module, and so we leave it alone. If it is not for a % nested module, the error will be caught by make_hlds. RevItems0 = [module_defn(_VarSet, end_module(ModuleName)) - Context | RevItemsPrime] -> RevItems = RevItemsPrime, EndModule = yes(ModuleName, Context) ; RevItems = RevItems0, EndModule = no ). %-----------------------------------------------------------------------------% % Check that the module starts with a :- module declaration, % and that the end_module declaration (if any) is correct, % and construct the final parsing result. % :- pred check_end_module(module_end::in, message_list::in, message_list::out, item_list::in, item_list::out, module_error::in, module_error::out) is det. check_end_module(EndModule, !Messages, !Items, !Error) :- % Double-check that the first item is a `:- module ModuleName' declaration, % and remove it from the front of the item list. ( !.Items = [Item | !:Items], Item = module_defn(_VarSet, module(ModuleName1)) - _Context1 -> % Check that the end module declaration (if any) matches % the begin module declaration. ( EndModule = yes(ModuleName2, Context2), ModuleName1 \= ModuleName2 -> dummy_term_with_context(Context2, Term), add_error("`:- end_module' declaration doesn't " ++ "match `:- module' declaration", Term, !Messages), !:Error = some_module_errors ; true ) ; % If there's no `:- module' declaration at this point, it is % an internal error -- read_first_item should have inserted one. error("check_end_module: no `:- module' declaration") ). %-----------------------------------------------------------------------------% % Create a dummy term. Used for error messages that are not associated % with any particular term or context. % :- pred dummy_term(term::out) is det. dummy_term(Term) :- term__context_init(Context), dummy_term_with_context(Context, Term). % Create a dummy term with the specified context. % Used for error messages that are associated with some specific % context, but for which we don't want to print out the term % (or for which the term isn't available to be printed out). % :- pred dummy_term_with_context(term__context::in, term::out) is det. dummy_term_with_context(Context, Term) :- Term = term__functor(term__atom(""), [], Context). %-----------------------------------------------------------------------------% find_module_name(FileName, MaybeModuleName, !IO) :- io__open_input(FileName, OpenRes, !IO), ( OpenRes = ok(InputStream), io__set_input_stream(InputStream, OldInputStream, !IO), ( string__remove_suffix(FileName, ".m", PartialFileName0) -> PartialFileName = PartialFileName0 ; PartialFileName = FileName ), ( dir__basename(PartialFileName, BaseName0) -> BaseName = BaseName0 ; BaseName = "" ), file_name_to_module_name(BaseName, DefaultModuleName), read_first_item(DefaultModuleName, FileName, ModuleName, RevMessages, _, _, _, !IO), MaybeModuleName = yes(ModuleName), prog_out__write_messages(list__reverse(RevMessages), !IO), io__set_input_stream(OldInputStream, _, !IO), io__close_input(InputStream, !IO) ; OpenRes = error(Error), io__progname_base("mercury_compile", Progname, !IO), io__write_string(Progname, !IO), io__write_string(": error opening `", !IO), io__write_string(FileName, !IO), io__write_string("': ", !IO), io__write_string(io__error_message(Error), !IO), io__write_string(".\n", !IO), MaybeModuleName = no ). % Read a source file from standard in, first reading in % the input term by term and then parsing those terms and producing % a high-level representation. % Parsing is actually a 3-stage process instead of the % normal two-stage process: % lexical analysis (chars -> tokens), % parsing stage 1 (tokens -> terms), % parsing stage 2 (terms -> items). % The final stage produces a list of program items, each of which % may be a declaration or a clause. % % We use a continuation-passing style here. % :- pred read_all_items(module_name::in, module_name::out, message_list::out, item_list::out, module_error::out, io__state::di, io__state::uo) is det. read_all_items(DefaultModuleName, ModuleName, Messages, Items, Error, !IO) :- % Read all the items (the first one is handled specially). io__input_stream(Stream, !IO), io__input_stream_name(Stream, SourceFileName, !IO), read_first_item(DefaultModuleName, SourceFileName, ModuleName, RevMessages0, RevItems0, MaybeSecondTerm, Error0, !IO), ( MaybeSecondTerm = yes(SecondTerm), process_read_term(ModuleName, SecondTerm, MaybeSecondItem), read_items_loop_2(MaybeSecondItem, ModuleName, SourceFileName, RevMessages0, RevMessages1, RevItems0, RevItems1, Error0, Error1, !IO) ; MaybeSecondTerm = no, read_items_loop(ModuleName, SourceFileName, RevMessages0, RevMessages1, RevItems0, RevItems1, Error0, Error1, !IO) ), % Get the end_module declaration (if any), check that it matches % the initial module declaration (if any), and remove both of them % from the final item list. get_end_module(ModuleName, RevItems1, RevItems, EndModule), check_end_module(EndModule, RevMessages1, RevMessages, Items0, Items, Error1, Error), list__reverse(RevMessages, Messages), list__reverse(RevItems, Items0). % We need to jump through a few hoops when reading the first item, % to allow the initial `:- module' declaration to be optional. % The reason is that in order to parse an item, we need to know % which module it is defined in (because we do some module % qualification and checking of module qualifiers at parse time), % but the initial `:- module' declaration and the declaration % that follows it occur in different scopes, so we need to know % what it is that we're parsing before we can parse it! % We solve this dilemma by first parsing it in the root scope, % and then if it turns out to not be a `:- module' declaration % we reparse it in the default module scope. Blecchh. % :- pred read_first_item(module_name::in, file_name::in, module_name::out, message_list::out, item_list::out, maybe(read_term)::out, module_error::out, io__state::di, io__state::uo) is det. read_first_item(DefaultModuleName, SourceFileName, ModuleName, Messages, Items, MaybeSecondTerm, Error, !IO) :- globals__io_lookup_bool_option(warn_missing_module_name, WarnMissing, !IO), globals__io_lookup_bool_option(warn_wrong_module_name, WarnWrong, !IO), % Parse the first term, treating it as occurring within the scope % of the special "root" module (so that any `:- module' declaration % is taken to be a non-nested module unless explicitly qualified). parser__read_term(SourceFileName, MaybeFirstTerm, !IO), root_module_name(RootModuleName), process_read_term(RootModuleName, MaybeFirstTerm, MaybeFirstItem), ( % Apply and then skip `pragma source_file' decls, by calling ourselves % recursively with the new source file name. MaybeFirstItem = ok(FirstItem, _), FirstItem = pragma(_, source_file(NewSourceFileName)) -> read_first_item(DefaultModuleName, NewSourceFileName, ModuleName, Messages, Items, MaybeSecondTerm, Error, !IO) ; % Check if the first term was a `:- module' decl. MaybeFirstItem = ok(FirstItem, FirstContext), FirstItem = module_defn(_VarSet, ModuleDefn), ModuleDefn = module(StartModuleName) -> % If so, then check that it matches the expected module name, % and if not, report a warning. ( match_sym_name(StartModuleName, DefaultModuleName) -> ModuleName = DefaultModuleName, Messages = [] ; match_sym_name(DefaultModuleName, StartModuleName) -> ModuleName = StartModuleName, Messages = [] ; sym_name_to_string(StartModuleName, StartModuleNameString), string__append_list(["source file `", SourceFileName, "' contains module named `", StartModuleNameString, "'"], WrongModuleWarning), maybe_add_warning(WarnWrong, MaybeFirstTerm, FirstContext, WrongModuleWarning, [], Messages), % Which one should we use here? We used to use the default module % name (computed from the filename) but now we use the declared % one. ModuleName = StartModuleName ), make_module_decl(ModuleName, FirstContext, FixedFirstItem), Items = [FixedFirstItem], Error = no_module_errors, MaybeSecondTerm = no ; % If the first term was not a `:- module' decl, then issue a warning % (if warning enabled), and insert an implicit `:- module ModuleName' % decl. ( MaybeFirstItem = ok(_FirstItem, FirstContext0) -> FirstContext = FirstContext0 ; term__context_init(SourceFileName, 1, FirstContext) ), ( WarnMissing = yes, dummy_term_with_context(FirstContext, FirstTerm), add_warning("module should start with a " ++ "`:- module' declaration", FirstTerm, [], Messages) ; WarnMissing = no, Messages = [] ), ModuleName = DefaultModuleName, make_module_decl(ModuleName, FirstContext, FixedFirstItem), % Reparse the first term, this time treating it as occuring within % the scope of the implicit `:- module' decl rather than in the % root module. MaybeSecondTerm = yes(MaybeFirstTerm), Items = [FixedFirstItem], Error = no_module_errors ). :- pred make_module_decl(module_name::in, term__context::in, item_and_context::out) is det. make_module_decl(ModuleName, Context, Item - Context) :- varset__init(EmptyVarSet), ModuleDefn = module(ModuleName), Item = module_defn(EmptyVarSet, ModuleDefn). :- pred maybe_add_warning(bool::in, read_term::in, term__context::in, string::in, message_list::in, message_list::out) is det. maybe_add_warning(DoWarn, MaybeTerm, Context, Warning, !Messages) :- ( DoWarn = yes, ( MaybeTerm = term(_VarSet, Term) -> WarningTerm = Term ; dummy_term_with_context(Context, WarningTerm) ), add_warning(Warning, WarningTerm, !Messages) ; DoWarn = no ). %-----------------------------------------------------------------------------% % The code below was carefully optimized to run efficiently in NU-Prolog. % We used to call read_item(MaybeItem) - which does all the work for % a single item - via io__gc_call/1, which called the goal with % garbage collection. But optimizing for NU-Prolog is no longer a concern. :- pred read_items_loop(module_name::in, file_name::in, message_list::in, message_list::out, item_list::in, item_list::out, module_error::in,module_error::out, io__state::di, io__state::uo) is det. read_items_loop(ModuleName, SourceFileName, !Msgs, !Items, !Error, !IO) :- read_item(ModuleName, SourceFileName, MaybeItem, !IO), read_items_loop_2(MaybeItem, ModuleName, SourceFileName, !Msgs, !Items, !Error, !IO). %-----------------------------------------------------------------------------% :- pred read_items_loop_2(maybe_item_or_eof::in, module_name::in, file_name::in, message_list::in, message_list::out, item_list::in, item_list::out, module_error::in, module_error::out, io__state::di, io__state::uo) is det. read_items_loop_2(eof, _ModuleName, _SourceFile, !Msgs, !Items, !Error, !IO). % If the next item was end-of-file, then we're done. read_items_loop_2(syntax_error(ErrorMsg, LineNumber), ModuleName, SourceFileName, !Msgs, !Items, _Error0, Error, !IO) :- % If the next item was a syntax error, then insert it in the list % of messages and continue looping. term__context_init(SourceFileName, LineNumber, Context), dummy_term_with_context(Context, Term), ThisError = ErrorMsg - Term, !:Msgs = [ThisError | !.Msgs], Error1 = some_module_errors, read_items_loop(ModuleName, SourceFileName, !Msgs, !Items, Error1, Error, !IO). read_items_loop_2(error(M, T), ModuleName, SourceFileName, !Msgs, !Items, _Error0, Error, !IO) :- % If the next item was a semantic error, then insert it in the list % of messages and continue looping. add_error(M, T, !Msgs), Error1 = some_module_errors, read_items_loop(ModuleName, SourceFileName, !Msgs, !Items, Error1, Error, !IO). read_items_loop_2(ok(Item0, Context), ModuleName0, SourceFileName0, !Msgs, !Items, !Error, !IO) :- ( Item0 = nothing(yes(Warning)) -> Warning = item_warning(MaybeOption, Msg, Term), ( MaybeOption = yes(Option), globals__io_lookup_bool_option(Option, Warn, !IO) ; MaybeOption = no, Warn = yes ), ( Warn = yes, add_warning(Msg, Term, !Msgs), globals__io_lookup_bool_option(halt_at_warn, Halt, !IO), ( Halt = yes, !:Error = some_module_errors ; Halt = no ) ; Warn = no ), Item = nothing(no) ; Item = Item0 ), % If the next item was a valid item, check whether it was % a declaration that affects the current parsing context -- % i.e. either a `module'/`end_module' declaration or a % `pragma source_file' declaration. If so, set the new % parsing context according. Next, unless the item is a % `pragma source_file' declaration, insert it into the item list. % Then continue looping. ( Item = pragma(_, source_file(NewSourceFileName)) -> SourceFileName = NewSourceFileName, ModuleName = ModuleName0 ; Item = module_defn(_VarSet, module(NestedModuleName)) -> ModuleName = NestedModuleName, SourceFileName = SourceFileName0, !:Items = [Item - Context | !.Items] ; Item = module_defn(_VarSet, end_module(NestedModuleName)) -> root_module_name(RootModuleName), sym_name_get_module_name(NestedModuleName, RootModuleName, ParentModuleName), ModuleName = ParentModuleName, SourceFileName = SourceFileName0, !:Items = [Item - Context | !.Items] ; Item = module_defn(VarSet, import(module(Modules))) -> ImportItems = list.map(make_pseudo_import_module_decl(VarSet, Context), Modules), SourceFileName = SourceFileName0, ModuleName = ModuleName0, list.append(ImportItems, !Items) ; Item = module_defn(VarSet, use(module(Modules))) -> UseItems = list.map(make_pseudo_use_module_decl(VarSet, Context), Modules), SourceFileName = SourceFileName0, ModuleName = ModuleName0, list.append(UseItems, !Items) ; Item = module_defn(VarSet, include_module(Modules)) -> IncludeItems = list.map( make_pseudo_include_module_decl(VarSet, Context), Modules), SourceFileName = SourceFileName0, ModuleName = ModuleName0, list.append(IncludeItems, !Items) ; SourceFileName = SourceFileName0, ModuleName = ModuleName0, !:Items = [Item - Context | !.Items] ), read_items_loop(ModuleName, SourceFileName, !Msgs, !Items, !Error, !IO). :- func make_pseudo_import_module_decl(prog_varset, prog_context, module_specifier) = item_and_context. make_pseudo_import_module_decl(Varset, Context, ModuleSpecifier) = module_defn(Varset, import(module([ModuleSpecifier]))) - Context. :- func make_pseudo_use_module_decl(prog_varset, prog_context, module_specifier) = item_and_context. make_pseudo_use_module_decl(Varset, Context, ModuleSpecifier) = module_defn(Varset, use(module([ModuleSpecifier]))) - Context. :- func make_pseudo_include_module_decl(prog_varset, prog_context, module_name) = item_and_context. make_pseudo_include_module_decl(Varset, Context, ModuleSpecifier) = module_defn(Varset, include_module([ModuleSpecifier])) - Context. %-----------------------------------------------------------------------------% :- type maybe_item_or_eof ---> eof ; syntax_error(file_name, int) ; error(string, term) ; ok(item, term__context). % Read_item/1 reads a single item, and if it is a valid term parses it. % :- pred read_item(module_name::in, file_name::in, maybe_item_or_eof::out, io::di, io::uo) is det. read_item(ModuleName, SourceFileName, MaybeItem, !IO) :- parser__read_term(SourceFileName, MaybeTerm, !IO), process_read_term(ModuleName, MaybeTerm, MaybeItem). :- pred process_read_term(module_name::in, read_term::in, maybe_item_or_eof::out) is det. process_read_term(_ModuleName, eof, eof). process_read_term(_ModuleName, error(ErrorMsg, LineNumber), syntax_error(ErrorMsg, LineNumber)). process_read_term(ModuleName, term(VarSet, Term), MaybeItemOrEof) :- parse_item(ModuleName, VarSet, Term, MaybeItem), convert_item(MaybeItem, MaybeItemOrEof). :- pred convert_item(maybe_item_and_context::in, maybe_item_or_eof::out) is det. convert_item(ok(Item, Context), ok(Item, Context)). convert_item(error(M, T), error(M, T)). parse_item(ModuleName, VarSet, Term, Result) :- ( Term = term__functor(term__atom(":-"), [Decl], _DeclContext) -> % It's a declaration. parse_decl(ModuleName, VarSet, Decl, Result) ; Term = term__functor(term__atom("-->"), [DCG_H, DCG_B], DCG_Context) -> % It's a DCG clause. parse_dcg_clause(ModuleName, VarSet, DCG_H, DCG_B, DCG_Context, Result) ; % It's either a fact or a rule ( Term = term__functor(term__atom(":-"), [H, B], TermContext) -> % It's a rule. Head = H, Body = B, TheContext = TermContext ; % It's a fact. Head = Term, ( Head = term__functor(_Functor, _Args, HeadContext) -> TheContext = HeadContext ; % Term consists of just a single variable - the context % has been lost. term__context_init(TheContext) ), Body = term__functor(term__atom("true"), [], TheContext) ), varset__coerce(VarSet, ProgVarSet), parse_goal(Body, Body2, ProgVarSet, ProgVarSet2), ( Head = term__functor(term__atom("="), [FuncHead0, FuncResult], _), FuncHead = desugar_field_access(FuncHead0) -> parse_implicitly_qualified_term(ModuleName, FuncHead, Head, "equation head", R2), process_func_clause(R2, FuncResult, ProgVarSet2, Body2, R3) ; parse_implicitly_qualified_term(ModuleName, Head, Term, "clause head", R2), process_pred_clause(R2, ProgVarSet2, Body2, R3) ), add_context(R3, TheContext, Result) ). :- pred process_pred_clause(maybe_functor::in, prog_varset::in, goal::in, maybe1(item)::out) is det. process_pred_clause(ok(Name, Args0), VarSet, Body, ok(clause(user, VarSet, predicate, Name, Args, Body))) :- list__map(term__coerce, Args0, Args). process_pred_clause(error(ErrMessage, Term0), _, _, error(ErrMessage, Term)) :- term__coerce(Term0, Term). :- pred process_func_clause(maybe_functor::in, term::in, prog_varset::in, goal::in, maybe1(item)::out) is det. process_func_clause(ok(Name, Args0), Result0, VarSet, Body, ok(clause(user, VarSet, function, Name, Args, Body))) :- list__append(Args0, [Result0], Args1), list__map(term__coerce, Args1, Args). process_func_clause(error(ErrMessage, Term0), _, _, _, error(ErrMessage, Term)) :- term__coerce(Term0, Term). %-----------------------------------------------------------------------------% :- type decl_attribute ---> purity(purity) ; quantifier(quantifier_type, list(var)) ; constraints(quantifier_type, term) % the term here is the (not yet parsed) list of constraints ; solver_type. :- type quantifier_type ---> exist ; univ. % The term associated with each decl_attribute is the term containing % both the attribute and the declaration that that attribute modifies; % this term is used when printing out error messages for cases when % attributes are used on declarations where they are not allowed. :- type decl_attrs == list(pair(decl_attribute, term)). parse_decl(ModuleName, VarSet, F, Result) :- parse_decl_2(ModuleName, VarSet, F, [], Result). % parse_decl_2(ModuleName, VarSet, Term, Attributes, Result): % % Succeeds if Term is a declaration and binds Result to a representation % of that declaration. Attributes is a list of enclosing declaration % attributes, in the order innermost to outermost. % :- pred parse_decl_2(module_name::in, varset::in, term::in, decl_attrs::in, maybe_item_and_context::out) is det. parse_decl_2(ModuleName, VarSet, F, Attributes, Result) :- ( F = term__functor(term__atom(Atom), Args, Context) -> ( parse_decl_attribute(Atom, Args, Attribute, SubTerm) -> NewAttributes = [Attribute - F | Attributes], parse_decl_2(ModuleName, VarSet, SubTerm, NewAttributes, Result) ; process_decl(ModuleName, VarSet, Atom, Args, Attributes, R) -> add_context(R, Context, Result) ; Result = error("unrecognized declaration", F) ) ; Result = error("atom expected after `:-'", F) ). % process_decl(ModuleName, VarSet, Attributes, Atom, Args, Result): % % Succeeds if Atom(Args) is a declaration and binds Result to a % representation of that declaration. Attributes is a list of % enclosing declaration attributes, in the order outermost to innermost. % :- pred process_decl(module_name::in, varset::in, string::in, list(term)::in, decl_attrs::in, maybe1(item)::out) is semidet. process_decl(ModuleName, VarSet, "type", [TypeDecl], Attributes, Result) :- parse_type_decl(ModuleName, VarSet, TypeDecl, Attributes, Result). process_decl(ModuleName, VarSet, "pred", [PredDecl], Attributes, Result) :- parse_type_decl_pred(ModuleName, VarSet, PredDecl, Attributes, Result). process_decl(ModuleName, VarSet, "func", [FuncDecl], Attributes, Result) :- parse_type_decl_func(ModuleName, VarSet, FuncDecl, Attributes, Result). process_decl(ModuleName, VarSet, "mode", [ModeDecl], Attributes, Result) :- parse_mode_decl(ModuleName, VarSet, ModeDecl, Attributes, Result). process_decl(ModuleName, VarSet, "inst", [InstDecl], Attributes, Result) :- parse_inst_decl(ModuleName, VarSet, InstDecl, Result0), check_no_attributes(Result0, Attributes, Result). process_decl(_ModuleName, VarSet, "import_module", [ModuleSpec], Attributes, Result) :- parse_symlist_decl(parse_module_specifier, make_module, make_import, ModuleSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "use_module", [ModuleSpec], Attributes, Result) :- parse_symlist_decl(parse_module_specifier, make_module, make_use, ModuleSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "export_module", [ModuleSpec], Attributes, Result) :- parse_symlist_decl(parse_module_specifier, make_module, make_export, ModuleSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "import_sym", [SymSpec], Attributes, Result) :- parse_symlist_decl(parse_symbol_specifier, make_sym, make_import, SymSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "use_sym", [SymSpec], Attributes, Result) :- parse_symlist_decl(parse_symbol_specifier, make_sym, make_use, SymSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "export_sym", [SymSpec], Attributes, Result) :- parse_symlist_decl(parse_symbol_specifier, make_sym, make_export, SymSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "import_pred", [PredSpec], Attributes, Result) :- parse_symlist_decl(parse_predicate_specifier, make_pred, make_import, PredSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "use_pred", [PredSpec], Attributes, Result) :- parse_symlist_decl(parse_predicate_specifier, make_pred, make_use, PredSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "export_pred", [PredSpec], Attributes, Result) :- parse_symlist_decl(parse_predicate_specifier, make_pred, make_export, PredSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "import_func", [FuncSpec], Attributes, Result) :- parse_symlist_decl(parse_function_specifier, make_func, make_import, FuncSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "use_func", [FuncSpec], Attributes, Result) :- parse_symlist_decl(parse_function_specifier, make_func, make_use, FuncSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "export_func", [FuncSpec], Attributes, Result) :- parse_symlist_decl(parse_function_specifier, make_func, make_export, FuncSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "import_cons", [ConsSpec], Attributes, Result) :- parse_symlist_decl(parse_constructor_specifier, make_cons, make_import, ConsSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "use_cons", [ConsSpec], Attributes, Result) :- parse_symlist_decl(parse_constructor_specifier, make_cons, make_use, ConsSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "export_cons", [ConsSpec], Attributes, Result) :- parse_symlist_decl(parse_constructor_specifier, make_cons, make_export, ConsSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "import_type", [TypeSpec], Attributes, Result) :- parse_symlist_decl(parse_type_specifier, make_type, make_import, TypeSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "use_type", [TypeSpec], Attributes, Result) :- parse_symlist_decl(parse_type_specifier, make_type, make_use, TypeSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "export_type", [TypeSpec], Attributes, Result) :- parse_symlist_decl(parse_type_specifier, make_type, make_export, TypeSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "import_adt", [ADT_Spec], Attributes, Result) :- parse_symlist_decl(parse_adt_specifier, make_adt, make_import, ADT_Spec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "use_adt", [ADT_Spec], Attributes, Result) :- parse_symlist_decl(parse_adt_specifier, make_adt, make_use, ADT_Spec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "export_adt", [ADT_Spec], Attributes, Result) :- parse_symlist_decl(parse_adt_specifier, make_adt, make_export, ADT_Spec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "import_op", [OpSpec], Attributes, Result) :- parse_symlist_decl(parse_op_specifier, make_op, make_import, OpSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "use_op", [OpSpec], Attributes, Result) :- parse_symlist_decl(parse_op_specifier, make_op, make_use, OpSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet, "export_op", [OpSpec], Attributes, Result) :- parse_symlist_decl(parse_op_specifier, make_op, make_export, OpSpec, Attributes, VarSet, Result). process_decl(_ModuleName, VarSet0, "interface", [], Attributes, Result) :- varset__coerce(VarSet0, VarSet), Result0 = ok(module_defn(VarSet, interface)), check_no_attributes(Result0, Attributes, Result). process_decl(_ModuleName, VarSet0, "implementation", [], Attributes, Result) :- varset__coerce(VarSet0, VarSet), Result0 = ok(module_defn(VarSet, implementation)), check_no_attributes(Result0, Attributes, Result). process_decl(ModuleName, VarSet, "external", Args, Attributes, Result) :- ( Args = [PredSpec], MaybeBackend = no ; Args = [BackendArg, PredSpec], BackendArg = term__functor(term__atom(Functor), [], _), ( Functor = "high_level_backend", Backend = high_level_backend ; Functor = "low_level_backend", Backend = low_level_backend ), MaybeBackend = yes(Backend) ), parse_implicitly_qualified_symbol_name_specifier(ModuleName, PredSpec, Result0), process_maybe1(make_external(VarSet, MaybeBackend), Result0, Result1), check_no_attributes(Result1, Attributes, Result). process_decl(DefaultModuleName, VarSet0, "module", [ModuleName], Attributes, Result) :- parse_module_name(DefaultModuleName, ModuleName, Result0), ( Result0 = ok(ModuleNameSym), varset__coerce(VarSet0, VarSet), Result1 = ok(module_defn(VarSet, module(ModuleNameSym))) ; Result0 = error(A, B), Result1 = error(A, B) ), check_no_attributes(Result1, Attributes, Result). process_decl(DefaultModuleName, VarSet0, "include_module", [ModuleNames], Attributes, Result) :- parse_list(parse_module_name(DefaultModuleName), ModuleNames, Result0), ( Result0 = ok(ModuleNameSyms), varset__coerce(VarSet0, VarSet), Result1 = ok(module_defn(VarSet, include_module(ModuleNameSyms))) ; Result0 = error(A, B), Result1 = error(A, B) ), check_no_attributes(Result1, Attributes, Result). process_decl(DefaultModuleName, VarSet0, "end_module", [ModuleName], Attributes, Result) :- % The name in an `end_module' declaration not inside the scope of the % module being ended, so the default module name here is the parent % of the previous default module name. root_module_name(RootModuleName), sym_name_get_module_name(DefaultModuleName, RootModuleName, ParentOfDefaultModuleName), parse_module_name(ParentOfDefaultModuleName, ModuleName, Result0), ( Result0 = ok(ModuleNameSym), varset__coerce(VarSet0, VarSet), Result1 = ok(module_defn(VarSet, end_module(ModuleNameSym))) ; Result0 = error(A, B), Result1 = error(A, B) ), check_no_attributes(Result1, Attributes, Result). process_decl(ModuleName, VarSet, "pragma", Pragma, Attributes, Result):- parse_pragma(ModuleName, VarSet, Pragma, Result0), check_no_attributes(Result0, Attributes, Result). process_decl(ModuleName, VarSet, "promise", Assertion, Attributes, Result):- parse_promise(ModuleName, true, VarSet, Assertion, Attributes, Result0), check_no_attributes(Result0, Attributes, Result). process_decl(ModuleName, VarSet, "promise_exclusive", PromiseGoal, Attributes, Result):- parse_promise(ModuleName, exclusive, VarSet, PromiseGoal, Attributes, Result). process_decl(ModuleName, VarSet, "promise_exhaustive", PromiseGoal, Attributes, Result):- parse_promise(ModuleName, exhaustive, VarSet, PromiseGoal, Attributes, Result). process_decl(ModuleName, VarSet, "promise_exclusive_exhaustive", PromiseGoal, Attributes, Result):- parse_promise(ModuleName, exclusive_exhaustive, VarSet, PromiseGoal, Attributes, Result). process_decl(ModuleName, VarSet, "typeclass", Args, Attributes, Result):- parse_typeclass(ModuleName, VarSet, Args, Result0), check_no_attributes(Result0, Attributes, Result). process_decl(ModuleName, VarSet, "instance", Args, Attributes, Result):- parse_instance(ModuleName, VarSet, Args, Result0), check_no_attributes(Result0, Attributes, Result). process_decl(ModuleName, VarSet0, "version_numbers", [VersionNumberTerm, ModuleNameTerm, VersionNumbersTerm], Attributes, Result) :- parse_module_specifier(ModuleNameTerm, ModuleNameResult), ( VersionNumberTerm = term__functor(term__integer(VersionNumber), [], _), VersionNumber = version_numbers_version_number -> ( ModuleNameResult = ok(ModuleName) -> recompilation__version__parse_version_numbers(VersionNumbersTerm, Result0), ( Result0 = ok(VersionNumbers), varset__coerce(VarSet0, VarSet), Result1 = module_defn(VarSet, version_numbers(ModuleName, VersionNumbers)), check_no_attributes(ok(Result1), Attributes, Result) ; Result0 = error(A, B), Result = error(A, B) ) ; Result = error("invalid module name in `:- version_numbers'", ModuleNameTerm) ) ; ( VersionNumberTerm = term__functor(_, _, Context) -> Msg = "interface file needs to be recreated, " ++ "the version numbers are out of date", dummy_term_with_context(Context, DummyTerm), Warning = item_warning(yes(warn_smart_recompilation), Msg, DummyTerm), Result = ok(nothing(yes(Warning))) ; Result = error("invalid version number in `:- version_numbers'", VersionNumberTerm) ) ). process_decl(ModuleName, VarSet, InitDecl, Args, Attributes, Result) :- ( InitDecl = "initialise" ; InitDecl = "initialize" ), parse_initialise_decl(ModuleName, VarSet, Args, Result0), check_no_attributes(Result0, Attributes, Result). process_decl(ModuleName, VarSet, FinalDecl, Args, Attributes, Result) :- ( FinalDecl = "finalise" ; FinalDecl = "finalize" ), parse_finalise_decl(ModuleName, VarSet, Args, Result0), check_no_attributes(Result0, Attributes, Result). process_decl(ModuleName, VarSet, "mutable", Args, Attributes, Result) :- parse_mutable_decl(ModuleName, VarSet, Args, Result0), check_no_attributes(Result0, Attributes, Result). :- pred parse_decl_attribute(string::in, list(term)::in, decl_attribute::out, term::out) is semidet. parse_decl_attribute("impure", [Decl], purity(purity_impure), Decl). parse_decl_attribute("semipure", [Decl], purity(purity_semipure), Decl). parse_decl_attribute("<=", [Decl, Constraints], constraints(univ, Constraints), Decl). parse_decl_attribute("=>", [Decl, Constraints], constraints(exist, Constraints), Decl). parse_decl_attribute("some", [TVars, Decl], quantifier(exist, TVarsList), Decl) :- parse_list_of_vars(TVars, TVarsList). parse_decl_attribute("all", [TVars, Decl], quantifier(univ, TVarsList), Decl) :- parse_list_of_vars(TVars, TVarsList). parse_decl_attribute("solver", [Decl], solver_type, Decl). :- pred check_no_attributes(maybe1(T)::in, decl_attrs::in, maybe1(T)::out) is det. check_no_attributes(Result0, Attributes, Result) :- ( Result0 = ok(_), Attributes = [Attr - Term | _] -> attribute_description(Attr, AttrDescr), string__append(AttrDescr, " not allowed here", Message), Result = error(Message, Term) ; Result = Result0 ). :- pred attribute_description(decl_attribute::in, string::out) is det. attribute_description(purity(_), "purity specifier"). attribute_description(quantifier(univ, _), "universal quantifier (`all')"). attribute_description(quantifier(exist, _), "existential quantifier (`some')"). attribute_description(constraints(univ, _), "type class constraint (`<=')"). attribute_description(constraints(exist, _), "existentially quantified type class constraint (`=>')"). attribute_description(solver_type, "solver type specifier"). %-----------------------------------------------------------------------------% :- pred parse_promise(module_name::in, promise_type::in, varset::in, list(term)::in, decl_attrs::in, maybe1(item)::out) is semidet. parse_promise(ModuleName, PromiseType, VarSet, [Term], Attributes, Result) :- varset__coerce(VarSet, ProgVarSet0), parse_goal(Term, Goal0, ProgVarSet0, ProgVarSet), % Get universally quantified variables. ( PromiseType = true -> ( Goal0 = all(UnivVars0, AllGoal) - _Context -> UnivVars0 = UnivVars, Goal = AllGoal ; UnivVars = [], Goal = Goal0 ) ; get_quant_vars(univ, ModuleName, Attributes, _, [], UnivVars0), list__map(term__coerce_var, UnivVars0, UnivVars), Goal0 = Goal ), Result = ok(promise(PromiseType, Goal, ProgVarSet, UnivVars)). %-----------------------------------------------------------------------------% :- pred parse_type_decl(module_name::in, varset::in, term::in, decl_attrs::in, maybe1(item)::out) is det. parse_type_decl(ModuleName, VarSet, TypeDecl, Attributes, Result) :- ( TypeDecl = term__functor(term__atom(Name), Args, _), parse_type_decl_type(ModuleName, Name, Args, Attributes, Cond, R) -> R1 = R, Cond1 = Cond ; process_abstract_type(ModuleName, TypeDecl, Attributes, R1), Cond1 = true ), % We should check the condition for errors (don't bother at the moment, % since we ignore conditions anyhow :-). process_maybe1(make_type_defn(VarSet, Cond1), R1, Result). :- pred make_type_defn(varset::in, condition::in, processed_type_body::in, item::out) is det. make_type_defn(VarSet0, Cond, processed_type_body(Name, Args, TypeDefn), type_defn(VarSet, Name, Args, TypeDefn, Cond)) :- varset__coerce(VarSet0, VarSet). :- pred make_external(varset::in, maybe(backend)::in, sym_name_specifier::in, item::out) is det. make_external(VarSet0, MaybeBackend, SymSpec, module_defn(VarSet, external(MaybeBackend, SymSpec))) :- varset__coerce(VarSet0, VarSet). :- pred get_is_solver_type(is_solver_type::out, decl_attrs::in, decl_attrs::out) is det. get_is_solver_type(IsSolverType, !Attributes) :- ( !.Attributes = [solver_type - _ | !:Attributes] -> IsSolverType = solver_type ; IsSolverType = non_solver_type ). %-----------------------------------------------------------------------------% % Add a warning message to the list of messages. % :- pred add_warning(string::in, term::in, message_list::in, message_list::out) is det. add_warning(Warning, Term, Msgs, [Msg - Term | Msgs]) :- string__append("Warning: ", Warning, Msg). % Add an error message to the list of messages. % :- pred add_error(string::in, term::in, message_list::in, message_list::out) is det. add_error(Error, Term, Msgs, [Msg - Term | Msgs]) :- string__append("Error: ", Error, Msg). %-----------------------------------------------------------------------------% % parse_type_decl_type(Term, Condition, Result) succeeds if Term is % a "type" type declaration, and binds Condition to the condition for % that declaration (if any), and Result to a representation of the % declaration. % :- pred parse_type_decl_type(module_name::in, string::in, list(term)::in, decl_attrs::in, condition::out, maybe1(processed_type_body)::out) is semidet. parse_type_decl_type(ModuleName, "--->", [H, B], Attributes0, Condition, Result) :- get_condition(B, Body, Condition), get_is_solver_type(IsSolverType, Attributes0, Attributes), ( IsSolverType = solver_type, Result = error("a solver type cannot have data constructors", H) ; IsSolverType = non_solver_type, du_type_rhs_ctors_and_where_terms(Body, CtorsTerm, MaybeWhereTerm), CtorsResult = convert_constructors(ModuleName, CtorsTerm), ( CtorsResult = error(String, Term), Result = error(String, Term) ; CtorsResult = ok(Ctors), WhereResult = parse_type_decl_where_term(non_solver_type, ModuleName, MaybeWhereTerm), ( WhereResult = error(String, Term), Result = error(String, Term) ; % 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 du type, if the unification with % WhereResult succeeds then _NoSolverTypeDetails is % guaranteed to be `no'. WhereResult = ok(_NoSolverTypeDetails, MaybeUserEqComp), process_du_type(ModuleName, H, Body, Ctors, MaybeUserEqComp, Result0), check_no_attributes(Result0, Attributes, Result) ) ) ). parse_type_decl_type(ModuleName, "==", [H, B], Attributes, Condition, R) :- get_condition(B, Body, Condition), process_eqv_type(ModuleName, H, Body, R0), check_no_attributes(R0, Attributes, R). parse_type_decl_type(ModuleName, "where", [H, B], Attributes0, Condition, R) :- get_condition(B, Body, Condition), get_is_solver_type(IsSolverType, Attributes0, Attributes), ( IsSolverType = non_solver_type, R = error("only solver types can be defined " ++ "by a `where' block alone", H) ; IsSolverType = solver_type, R0 = parse_type_decl_where_term(solver_type, ModuleName, yes(Body)), ( R0 = error(String, Term), R = error(String, Term) ; R0 = ok(MaybeSolverTypeDetails, MaybeUserEqComp), process_solver_type(ModuleName, H, MaybeSolverTypeDetails, MaybeUserEqComp, R1), check_no_attributes(R1, Attributes, R) ) ). :- pred du_type_rhs_ctors_and_where_terms(term::in, term::out, maybe(term)::out) is det. du_type_rhs_ctors_and_where_terms(Term, CtorsTerm, MaybeWhereTerm) :- ( Term = term__functor(term__atom("where"), [CtorsTerm0, WhereTerm], _Context) -> CtorsTerm = CtorsTerm0, MaybeWhereTerm = yes(WhereTerm) ; CtorsTerm = Term, MaybeWhereTerm = no ). %-----------------------------------------------------------------------------% % parse_type_decl_pred(ModuleName, VarSet, Pred, Attributes, Result) % succeeds if Pred is a predicate type declaration, and binds Result % to a representation of the declaration. % :- pred parse_type_decl_pred(module_name::in, varset::in, term::in, decl_attrs::in, maybe1(item)::out) is det. parse_type_decl_pred(ModuleName, VarSet, Pred, Attributes, R) :- get_condition(Pred, Body, Condition), get_determinism(Body, Body2, MaybeDeterminism), get_with_inst(Body2, Body3, WithInst), get_with_type(Body3, Body4, WithTypeResult), ( WithTypeResult = ok(WithType), process_type_decl_pred_or_func(predicate, ModuleName, WithType, WithInst, MaybeDeterminism, VarSet, Body4, Condition, Attributes, R) ; WithTypeResult = error(Msg, ErrorTerm), R = error(Msg, ErrorTerm) ). :- pred process_type_decl_pred_or_func(pred_or_func::in, module_name::in, maybe(mer_type)::in, maybe1(maybe(mer_inst))::in, maybe1(maybe(determinism))::in, varset::in, term::in, condition::in, decl_attrs::in, maybe1(item)::out) is det. process_type_decl_pred_or_func(PredOrFunc, ModuleName, WithType, WithInst0, MaybeDeterminism0, VarSet, Body, Condition, Attributes, R) :- ( MaybeDeterminism0 = ok(MaybeDeterminism), ( WithInst0 = ok(WithInst), ( MaybeDeterminism = yes(_), WithInst = yes(_) -> R = error("`with_inst` and determinism " ++ "both specified", Body) ; WithInst = yes(_), WithType = no -> R = error("`with_inst` specified without " ++ "`with_type`", Body) ; ( % Function declarations with `with_type` annotations % have the same form as predicate declarations. PredOrFunc = function, WithType = no -> process_func(ModuleName, VarSet, Body, Condition, MaybeDeterminism, Attributes, R) ; process_pred_or_func(PredOrFunc, ModuleName, VarSet, Body, Condition, WithType, WithInst, MaybeDeterminism, Attributes, R) ) ) ; WithInst0 = error(E, T), R = error(E, T) ) ; MaybeDeterminism0 = error(E, T), R = error(E, T) ). %-----------------------------------------------------------------------------% % parse_type_decl_func(ModuleName, Varset, Func, Attributes, Result) % succeeds if Func is a function type declaration, and binds Result to % a representation of the declaration. % :- pred parse_type_decl_func(module_name::in, varset::in, term::in, decl_attrs::in, maybe1(item)::out) is det. parse_type_decl_func(ModuleName, VarSet, Func, Attributes, R) :- get_condition(Func, Body, Condition), get_determinism(Body, Body2, MaybeDeterminism), get_with_inst(Body2, Body3, WithInst), get_with_type(Body3, Body4, WithTypeResult), ( WithTypeResult = ok(WithType), process_type_decl_pred_or_func(function, ModuleName, WithType, WithInst, MaybeDeterminism, VarSet, Body4, Condition, Attributes, R) ; WithTypeResult = error(Msg, ErrorTerm), R = error(Msg, ErrorTerm) ). %-----------------------------------------------------------------------------% % parse_mode_decl_pred(ModuleName, Pred, Condition, Result) succeeds % if Pred is a predicate mode declaration, and binds Condition to the % condition for that declaration (if any), and Result to a % representation of the declaration. % :- pred parse_mode_decl_pred(module_name::in, varset::in, term::in, decl_attrs::in, maybe1(item)::out) is det. parse_mode_decl_pred(ModuleName, VarSet, Pred, Attributes, Result) :- get_condition(Pred, Body, Condition), get_determinism(Body, Body2, MaybeDeterminism0), get_with_inst(Body2, Body3, WithInst0), ( MaybeDeterminism0 = ok(MaybeDeterminism), ( WithInst0 = ok(WithInst), ( MaybeDeterminism = yes(_), WithInst = yes(_) -> Result = error("`with_inst` and " ++ "determinism both specified", Body) ; process_mode(ModuleName, VarSet, Body3, Condition, Attributes, WithInst, MaybeDeterminism, Result) ) ; WithInst0 = error(E, T), Result = error(E, T) ) ; MaybeDeterminism0 = error(E, T), Result = error(E, T) ). %-----------------------------------------------------------------------------% :- pred parse_initialise_decl(module_name::in, varset::in, list(term)::in, maybe1(item)::out) is semidet. parse_initialise_decl(_ModuleName, _VarSet, [Term], Result) :- parse_symbol_name_specifier(Term, MaybeSymNameSpecifier), ( MaybeSymNameSpecifier = error(ErrMsg, Trm), Result = error(ErrMsg, Trm) ; MaybeSymNameSpecifier = ok(SymNameSpecifier), ( SymNameSpecifier = name(_), Result = error("`initialise' declaration requires arity", Term) ; SymNameSpecifier = name_arity(SymName, Arity), ( ( Arity = 2 ; Arity = 0 ) -> Result = ok(initialise(user, SymName, Arity)) ; Result = error("`initialise' " ++ "declaration specifies a predicate " ++ "whose arity is not zero or two", Term) ) ) ). %-----------------------------------------------------------------------------% :- pred parse_finalise_decl(module_name::in, varset::in, list(term)::in, maybe1(item)::out) is semidet. parse_finalise_decl(_ModuleName, _VarSet, [Term], Result) :- parse_symbol_name_specifier(Term, MaybeSymNameSpecifier), ( MaybeSymNameSpecifier = error(ErrMsg, Trm), Result = error(ErrMsg, Trm) ; MaybeSymNameSpecifier = ok(SymNameSpecifier), ( SymNameSpecifier = name(_), Result = error("`finalise' declaration requires arity", Term) ; SymNameSpecifier = name_arity(SymName, Arity), ( ( Arity = 2 ; Arity = 0) -> Result = ok(finalise(user, SymName, Arity)) ; Result = error("`finalise' " ++ "declaration specifies a predicate " ++ "whose arity is not zero or two", Term) ) ) ). %-----------------------------------------------------------------------------% % Mutable declaration syntax: % % :- mutable(name, type, value, inst, ). % (The list of attributes at the end is optional.) % % e.g.: % % :- mutable(counter, int, 0, ground, [thread_safe]). % % This is converted into the following: % % :- semipure pred get_counter(int::out(ground)) is det. % :- pragma foreign_proc("C", % get_counter(X::out(ground)), % [promise_semipure, will_not_call_mercury, thread_safe], % "X = mutable_counter;"). % % :- impure pred set_counter(int::in(ground)) is det. % :- pragma foreign_proc("C", % set_counter(X::in(ground)), % [will_not_call_mercury, thread_safe], % "MR_trail_current_value(&mutable_counter); % mutable_counter = X;"). % % :- pragma foreign_decl("C", "extern MR_Word mutable_counter;"). % :- pragma foreign_code("C", "MR_Word mutable_counter;"); % % :- import_module io. % :- initialise initialise_counter. % :- impure pred initialise_mutable_counter(io::di, io::uo) is det. % % initialise_mutable_counter(!IO) :- % impure set_counter(0). % % If the `thread_safe' attribute is specified in % then foreign_procs are created that have the thread_safe attribute % set. If the `untrailed' attribute is specified in % then the code for trailing the mutable variable in the set predicate % is omitted. :- pred parse_mutable_decl(module_name::in, varset::in, list(term)::in, maybe1(item)::out) is semidet. parse_mutable_decl(_ModuleName, _VarSet, Terms, Result) :- Terms = [NameTerm, TypeTerm, ValueTerm, InstTerm | OptMutAttrsTerm], parse_mutable_name(NameTerm, NameResult), parse_mutable_type(TypeTerm, TypeResult), term__coerce(ValueTerm, Value), parse_mutable_inst(InstTerm, InstResult), ( OptMutAttrsTerm = [], MutAttrsResult = ok(default_mutable_attributes) ; OptMutAttrsTerm = [MutAttrsTerm], parse_mutable_attrs(MutAttrsTerm, MutAttrsResult) ), ( NameResult = ok(Name), TypeResult = ok(Type), InstResult = ok(Inst), MutAttrsResult = ok(MutAttrs) -> Result = ok(mutable(Name, Type, Value, Inst, MutAttrs)) ; NameResult = error(Msg, Term) -> Result = error(Msg, Term) ; TypeResult = error(Msg, Term) -> Result = error(Msg, Term) ; InstResult = error(Msg, Term) -> Result = error(Msg, Term) ; MutAttrsResult = error(Msg, Term) -> Result = error(Msg, Term) ; error("prog_io.parse_mutable_decl: shouldn't be here!") ). :- pred parse_mutable_name(term::in, maybe1(string)::out) is det. parse_mutable_name(NameTerm, NameResult) :- ( NameTerm = term__functor(atom(Name), [], _) -> NameResult = ok(Name) ; NameResult = error("invalid mutable name", NameTerm) ). :- pred parse_mutable_type(term::in, maybe1(mer_type)::out) is det. parse_mutable_type(TypeTerm, TypeResult) :- ( term__contains_var(TypeTerm, _) -> TypeResult = error("the type in a mutable declaration " ++ "cannot contain variables", TypeTerm) ; parse_type(TypeTerm, TypeResult) ). :- pred parse_mutable_inst(term::in, maybe1(mer_inst)::out) is det. parse_mutable_inst(InstTerm, InstResult) :- ( term__contains_var(InstTerm, _) -> InstResult = error("the inst in a mutable declaration " ++ "cannot contain variables", InstTerm) ; convert_inst(no_allow_constrained_inst_var, InstTerm, Inst) -> InstResult = ok(Inst) ; InstResult = error("invalid inst in mutable declaration", InstTerm) ). :- type collected_mutable_attribute ---> trailed(trailed) ; thread_safe(thread_safe) ; foreign_name(foreign_name) ; attach_to_io_state(bool). :- pred parse_mutable_attrs(term::in, maybe1(mutable_var_attributes)::out) is det. parse_mutable_attrs(MutAttrsTerm, MutAttrsResult) :- Attributes0 = default_mutable_attributes, ConflictingAttributes = [ thread_safe(thread_safe) - thread_safe(not_thread_safe), trailed(trailed) - trailed(untrailed) ], ( list_term_to_term_list(MutAttrsTerm, MutAttrTerms), map_parser(parse_mutable_attr, MutAttrTerms, MaybeAttrList), MaybeAttrList = ok(CollectedMutAttrs) -> % We check for trailed/untrailed and thread_safe/not_thread_safe % conflicts here and deal with conflicting foreign_name attributes in % make_hlds_passes.m. % ( list.member(Conflict1 - Conflict2, ConflictingAttributes), list.member(Conflict1, CollectedMutAttrs), list.member(Conflict2, CollectedMutAttrs) -> MutAttrsResult = error("conflicting attributes " ++ "in attribute list", MutAttrsTerm) ; list.foldl(process_mutable_attribute, CollectedMutAttrs, Attributes0, Attributes), MutAttrsResult = ok(Attributes) ) ; MutAttrsResult = error("malformed attribute list in " ++ "mutable declaration", MutAttrsTerm) ). :- pred process_mutable_attribute(collected_mutable_attribute::in, mutable_var_attributes::in, mutable_var_attributes::out) is det. process_mutable_attribute(thread_safe(ThreadSafe), !Attributes) :- set_mutable_var_thread_safe(ThreadSafe, !Attributes). process_mutable_attribute(trailed(Trailed), !Attributes) :- set_mutable_var_trailed(Trailed, !Attributes). process_mutable_attribute(foreign_name(ForeignName), !Attributes) :- set_mutable_add_foreign_name(ForeignName, !Attributes). process_mutable_attribute(attach_to_io_state(AttachToIOState), !Attributes) :- set_mutable_var_attach_to_io_state(AttachToIOState, !Attributes). :- pred parse_mutable_attr(term::in, maybe1(collected_mutable_attribute)::out) is det. parse_mutable_attr(MutAttrTerm, MutAttrResult) :- ( MutAttrTerm = term__functor(term__atom(String), [], _), ( String = "untrailed", MutAttr = trailed(untrailed) ; String = "trailed", MutAttr = trailed(trailed) ; String = "attach_to_io_state", MutAttr = attach_to_io_state(yes) ; String = "thread_safe", MutAttr = thread_safe(thread_safe) ; String = "not_thread_safe", MutAttr = thread_safe(not_thread_safe) ) -> MutAttrResult = ok(MutAttr) ; MutAttrTerm = term.functor(term.atom("foreign_name"), Args, _), Args = [LangTerm, ForeignNameTerm], parse_foreign_language(LangTerm, Lang), ForeignNameTerm = term.functor(term.string(ForeignName), [], _) -> MutAttr = foreign_name(foreign_name(Lang, ForeignName)), MutAttrResult = ok(MutAttr) ; MutAttrResult = error("unrecognised attribute in mutable " ++ "declaration", MutAttrTerm) ). %-----------------------------------------------------------------------------% % The optional `where ...' part of the type definition syntax % is a comma separated list of special type `attributes'. % % The possible attributes (in this order) are either % - `type_is_abstract_noncanonical' on its own appears only in .int2 % files and indicates that the type has user-defined equality and/or % comparison, but that what these predicates are is not known at % this point % or % - `representation is <>' (required for solver types) % - `initialisation is <>' (required for solver types) % - `ground is <>' (required for solver types) % - `any is <>' (required for solver types) % - `equality is <>' (optional) % - `comparison is <>' (optional). % parse_type_decl_where_part_if_present(IsSolverType, ModuleName, Term0, Term, Result) :- ( Term0 = term__functor(term__atom("where"), [Term1, WhereTerm], _Context) -> Term = Term1, Result = parse_type_decl_where_term(IsSolverType, ModuleName, yes(WhereTerm)) ; Term = Term0, Result = ok(no, no) ). % The maybe2 wrapper allows us to return an error code or a pair % of results. Either result half may be empty, hence the maybe % wrapper around each of those. % :- func parse_type_decl_where_term(is_solver_type, module_name, maybe(term)) = maybe2(maybe(solver_type_details), maybe(unify_compare)). parse_type_decl_where_term(_IsSolverType, _ModuleName, no) = ok(no, no). parse_type_decl_where_term(IsSolverType, ModuleName, MaybeTerm0 @ yes(Term)) = MaybeWhereDetails :- some [!MaybeTerm] ( !:MaybeTerm = MaybeTerm0, parse_where_attribute(parse_where_type_is_abstract_noncanonical, TypeIsAbstractNoncanonicalResult, !MaybeTerm), parse_where_attribute(parse_where_is("representation", parse_where_type_is(ModuleName)), RepresentationIsResult, !MaybeTerm), parse_where_attribute(parse_where_initialisation_is(ModuleName), InitialisationIsResult, !MaybeTerm), parse_where_attribute(parse_where_is("ground", parse_where_inst_is(ModuleName)), GroundIsResult, !MaybeTerm), parse_where_attribute(parse_where_is("any", parse_where_inst_is(ModuleName)), AnyIsResult, !MaybeTerm), parse_where_attribute(parse_where_is("equality", parse_where_pred_is(ModuleName)), EqualityIsResult, !MaybeTerm), parse_where_attribute(parse_where_is("comparison", parse_where_pred_is(ModuleName)), ComparisonIsResult, !MaybeTerm), parse_where_end(!.MaybeTerm, WhereEndResult) ), MaybeWhereDetails = make_maybe_where_details( IsSolverType, TypeIsAbstractNoncanonicalResult, RepresentationIsResult, InitialisationIsResult, GroundIsResult, AnyIsResult, EqualityIsResult, ComparisonIsResult, WhereEndResult, Term ). % parse_where_attribute(Parser, Result, MaybeTerm0, MaybeTerm) % handles % - where MaybeTerm0 may contain nothing % - where MaybeTerm0 may be a comma-separated pair % - applies Parser to the appropriate (sub)term to obtain Result % - sets MaybeTerm depending upon whether the Result is an error % or not and whether there is more to parse because MaybeTerm0 % was a comma-separated pair. % :- pred parse_where_attribute((func(term) = maybe1(maybe(T)))::in, maybe1(maybe(T))::out, maybe(term)::in, maybe(term)::out) is det. parse_where_attribute(_Parser, ok(no), no, no ). parse_where_attribute( Parser, Result, yes(Term0), MaybeRest) :- ( Term0 = term__functor(term__atom(","), [Term1, Term], _Context) -> Result = Parser(Term1), MaybeRestIfYes = yes(Term) ; Result = Parser(Term0), MaybeRestIfYes = no ), ( Result = error(_, _), MaybeRest = no ; Result = ok(no), MaybeRest = yes(Term0) ; Result = ok(yes(_)), MaybeRest = MaybeRestIfYes ). % Parser for `where ...' attributes of the form % `attributename is attributevalue'. % :- func parse_where_is(string, func(term) = maybe1(T), term) = maybe1(maybe(T)). parse_where_is(Name, Parser, Term) = Result :- ( Term = term__functor(term__atom("is"), [LHS, RHS], _Context1) -> ( LHS = term__functor(term__atom(Name), [], _Context2) -> RHSResult = Parser(RHS), ( RHSResult = ok(ParsedRHS), Result = ok(yes(ParsedRHS)) ; RHSResult = error(Msg, ProblemTerm), Result = error(Msg, ProblemTerm) ) ; Result = ok(no) ) ; Result = error("expected is/2", Term) ). :- func parse_where_type_is_abstract_noncanonical(term) = maybe1(maybe(unit)). parse_where_type_is_abstract_noncanonical(Term) = ( Term = term__functor(term__atom("type_is_abstract_noncanonical"), [], _Context) -> ok(yes(unit)) ; ok(no) ). :- func parse_where_initialisation_is(module_name, term) = maybe1(maybe(sym_name)). parse_where_initialisation_is(ModuleName, Term) = Result :- Result0 = parse_where_is("initialisation", parse_where_pred_is(ModuleName), Term), ( Result0 = ok(no) -> Result = parse_where_is("initialization", parse_where_pred_is(ModuleName), Term) ; Result = Result0 ). :- func parse_where_pred_is(module_name, term) = maybe1(sym_name). parse_where_pred_is(ModuleName, Term) = Result :- parse_implicitly_qualified_symbol_name(ModuleName, Term, Result). :- func parse_where_inst_is(module_name, term) = maybe1(mer_inst). parse_where_inst_is(_ModuleName, Term) = ( prog_io_util__convert_inst(no_allow_constrained_inst_var, Term, Inst), not prog_mode__inst_contains_unconstrained_var(Inst) -> ok(Inst) ; error("expected a ground, unconstrained inst", Term) ). :- func parse_where_type_is(module_name, term) = maybe1(mer_type). parse_where_type_is(_ModuleName, Term) = Result :- prog_io_util__parse_type(Term, Result). :- pred parse_where_end(maybe(term)::in, maybe1(maybe(unit))::out) is det. parse_where_end(no, ok(yes(unit))). parse_where_end(yes(Term), error("attributes are either badly ordered or " ++ "contain an unrecognised attribute", Term)). :- func make_maybe_where_details( is_solver_type, maybe1(maybe(unit)), maybe1(maybe(mer_type)), maybe1(maybe(init_pred)), maybe1(maybe(mer_inst)), maybe1(maybe(mer_inst)), maybe1(maybe(equality_pred)), maybe1(maybe(comparison_pred)), maybe1(maybe(unit)), term ) = maybe2(maybe(solver_type_details), maybe(unify_compare)). make_maybe_where_details( IsSolverType, TypeIsAbstractNoncanonicalResult, RepresentationIsResult, InitialisationIsResult, GroundIsResult, AnyIsResult, EqualityIsResult, ComparisonIsResult, WhereEndResult, WhereTerm) = Result :- ( TypeIsAbstractNoncanonicalResult = error(String, Term) -> Result = error(String, Term) ; RepresentationIsResult = error(String, Term) -> Result = error(String, Term) ; InitialisationIsResult = error(String, Term) -> Result = error(String, Term) ; GroundIsResult = error(String, Term) -> Result = error(String, Term) ; AnyIsResult = error(String, Term) -> Result = error(String, Term) ; EqualityIsResult = error(String, Term) -> Result = error(String, Term) ; ComparisonIsResult = error(String, Term) -> Result = error(String, Term) ; WhereEndResult = error(String, Term) -> Result = error(String, Term) ; TypeIsAbstractNoncanonicalResult = ok(yes(_)) -> % rafe: XXX I think this is wrong. There isn't a problem with having % the solver_type_details and type_is_abstract_noncanonical. ( RepresentationIsResult = ok(no), InitialisationIsResult = ok(no), GroundIsResult = ok(no), AnyIsResult = ok(no), EqualityIsResult = ok(no), ComparisonIsResult = ok(no) -> Result = ok(no, yes(abstract_noncanonical_type(IsSolverType))) ; Result = error("`where type_is_abstract_noncanonical' " ++ " excludes other `where ...' attributes", WhereTerm) ) ; IsSolverType = solver_type -> ( RepresentationIsResult = ok(yes(RepnType)), InitialisationIsResult = ok(yes(InitPred)), GroundIsResult = ok(MaybeGroundInst), AnyIsResult = ok(MaybeAnyInst), EqualityIsResult = ok(MaybeEqPred), ComparisonIsResult = ok(MaybeCmpPred) -> ( MaybeGroundInst = yes(GroundInst) ; MaybeGroundInst = no, GroundInst = ground_inst ), ( MaybeAnyInst = yes(AnyInst) ; MaybeAnyInst = no, AnyInst = ground_inst ), MaybeSolverTypeDetails = yes(solver_type_details( RepnType, InitPred, GroundInst, AnyInst)), ( MaybeEqPred = no, MaybeCmpPred = no -> MaybeUnifyCompare = no ; MaybeUnifyCompare = yes(unify_compare( MaybeEqPred, MaybeCmpPred)) ), Result = ok(MaybeSolverTypeDetails, MaybeUnifyCompare) ; RepresentationIsResult = ok(no) -> Result = error("solver type definitions must have a" ++ "`representation' attribute", WhereTerm) ; InitialisationIsResult = ok(no) -> Result = error("solver type definitions must have an" ++ "`initialisation' attribute", WhereTerm) ; error("make_maybe_where_details: " ++ "shouldn't have reached this point! (1)") ) ; % Here we know IsSolverType = non_solver_type, so... ( RepresentationIsResult = ok(yes(_)) ; InitialisationIsResult = ok(yes(_)) ; GroundIsResult = ok(yes(_)) ; AnyIsResult = ok(yes(_)) ) -> Result = error("solver type attribute given for " ++ "non-solver type", WhereTerm) ; EqualityIsResult = ok(MaybeEqPred), ComparisonIsResult = ok(MaybeCmpPred) -> Result = ok(no, yes(unify_compare(MaybeEqPred, MaybeCmpPred))) ; error("make_maybe_where_details: " ++ "shouldn't have reached this point! (2)") ). % get_determinism(Term0, Term, Determinism) binds Determinism % to a representation of the determinism condition of Term0, if any, % and binds Term to the other part of Term0. If Term0 does not % contain a determinism, then Determinism is bound to `unspecified'. % :- pred get_determinism(term::in, term::out, maybe1(maybe(determinism))::out) is det. get_determinism(B, Body, Determinism) :- ( B = term__functor(term__atom("is"), Args, _Context1), Args = [Body1, Determinism1] -> Body = Body1, ( Determinism1 = term__functor(term__atom(Determinism2), [], _Context2), standard_det(Determinism2, Determinism3) -> Determinism = ok(yes(Determinism3)) ; Determinism = error("invalid category", Determinism1) ) ; Body = B, Determinism = ok(no) ). % Process the `with_inst` part of a declaration of the form: % :- mode p(int) `with_inst` (pred(in, out) is det). % :- pred get_with_inst(term::in, term::out, maybe1(maybe(mer_inst))::out) is det. get_with_inst(Body0, Body, WithInst) :- ( Body0 = term__functor(term__atom("with_inst"), [Body1, Inst1], _) -> ( convert_inst(allow_constrained_inst_var, Inst1, Inst) -> WithInst = ok(yes(Inst)) ; WithInst = error("invalid inst in `with_inst`", Body0) ), Body = Body1 ; Body = Body0, WithInst = ok(no) ). :- pred get_with_type(term::in, term::out, maybe1(maybe(mer_type))::out) is det. get_with_type(Body0, Body, Result) :- ( Body0 = term__functor(TypeQualifier, [Body1, Type1], _), ( TypeQualifier = term.atom("with_type") ; TypeQualifier = term.atom(":") ) -> Body = Body1, parse_type(Type1, Result0), ( Result0 = ok(Type), Result = ok(yes(Type)) ; Result0 = error(Msg, ErrorTerm), Result = error(Msg, ErrorTerm) ) ; Body = Body0, Result = ok(no) ). %-----------------------------------------------------------------------------% % get_condition(Term0, Term, Condition) binds Condition % to a representation of the 'where' condition of Term0, if any, % and binds Term to the other part of Term0. If Term0 does not % contain a condition, then Condition is bound to true. % :- pred get_condition(term::in, term::out, condition::out) is det. get_condition(Body, Body, true). % % NU-Prolog supported type declarations of the form % % :- pred p(T) where p(X) : sorted(X). % % or % % :- type sorted_list(T) = list(T) where X : sorted(X). % % :- pred p(sorted_list(T). % % There is some code here to support that sort of thing, but % % probably we would now need to use a different syntax, since % % Mercury now uses `where' for different purposes (e.g. specifying % % user-defined equality predicates, and also for type classes ...) % % get_condition(B, Body, Condition) :- % ( % B = term__functor(term__atom("where"), [Body1, Condition1], % _Context) % -> % Body = Body1, % Condition = where(Condition1) % ; % Body = B, % Condition = true % ). %-----------------------------------------------------------------------------% :- type processed_type_body ---> processed_type_body( sym_name, list(type_param), type_defn ). %-----------------------------------------------------------------------------% :- pred process_solver_type(module_name::in, term::in, maybe(solver_type_details)::in, maybe(unify_compare)::in, maybe1(processed_type_body)::out) is det. process_solver_type(ModuleName, Head, MaybeSolverTypeDetails, MaybeUserEqComp, Result) :- ( MaybeSolverTypeDetails = yes(SolverTypeDetails), dummy_term(Body), parse_type_defn_head(ModuleName, Head, Body, Result0), ( Result0 = error(String, Term), Result = error(String, Term) ; Result0 = ok(Name, Params), ( RepnType = SolverTypeDetails ^ representation_type, type_contains_var(RepnType, Var), not list__member(Var, Params) -> Result = error("free type variable in " ++ "representation type", Head) ; Result = ok(processed_type_body(Name, Params, solver_type(SolverTypeDetails, MaybeUserEqComp))) ) ) ; MaybeSolverTypeDetails = no, Result = error("solver type with no solver_type_details", Head) ). %-----------------------------------------------------------------------------% % This is for "Head == Body" (equivalence) definitions. % :- pred process_eqv_type(module_name::in, term::in, term::in, maybe1(processed_type_body)::out) is det. process_eqv_type(ModuleName, Head, Body, Result) :- parse_type_defn_head(ModuleName, Head, Body, Result0), process_eqv_type_2(Result0, Body, Result). :- pred process_eqv_type_2(maybe2(sym_name, list(type_param))::in, term::in, maybe1(processed_type_body)::out) is det. process_eqv_type_2(error(Error, Term), _, error(Error, Term)). process_eqv_type_2(ok(Name, Params), Body0, Result) :- % Check that all the variables in the body occur in the head. ( term__contains_var(Body0, Var), term__coerce_var(Var, TVar), \+ list__member(TVar, Params) -> Result = error("free type parameter in RHS of type definition", Body0) ; parse_type(Body0, BodyResult), ( BodyResult = ok(Body), Result = ok(processed_type_body(Name, Params, eqv_type(Body))) ; BodyResult = error(Msg, ErrorTerm), Result = error(Msg, ErrorTerm) ) ). %-----------------------------------------------------------------------------% % process_du_type(ModuleName, TypeHead, TypeBody, % MaybeUserEqComp, Result): % % Checks that its arguments are well formed, and if they are, % binds Result to a representation of the type information about the % TypeHead. % This is for "Head ---> Body [where ...]" (constructor) definitions. % :- pred process_du_type(module_name::in, term::in, term::in, list(constructor)::in, maybe(unify_compare)::in, maybe1(processed_type_body)::out) is det. process_du_type(ModuleName, Head, Body, Ctors, MaybeUserEqComp, Result) :- parse_type_defn_head(ModuleName, Head, Body, Result0), ( Result0 = error(String, Term), Result = error(String, Term) ; Result0 = ok(Functor, Params), process_du_type_2(Functor, Params, Body, Ctors, MaybeUserEqComp, Result) ). :- pred process_du_type_2(sym_name::in, list(type_param)::in, term::in, list(constructor)::in, maybe(unify_compare)::in, maybe1(processed_type_body)::out) is det. process_du_type_2(Functor, Params, Body, Ctors, MaybeUserEqComp, Result) :- ( % Check that all type variables in the body are either explicitly % existentially quantified or occur in the head. list__member(Ctor, Ctors), Ctor = ctor(ExistQVars, _Constraints, _CtorName, CtorArgs), assoc_list__values(CtorArgs, CtorArgTypes), type_list_contains_var(CtorArgTypes, Var), \+ list__member(Var, ExistQVars), \+ list__member(Var, Params) -> Result = error("free type parameter in RHS of type definition", Body) ; % Check that all type variables in existential quantifiers do not % occur in the head (maybe this should just be a warning, not an error? % If we were to allow it, we would need to rename them apart.) list__member(Ctor, Ctors), Ctor = ctor(ExistQVars, _Constraints, _CtorName, _CtorArgs), list__member(Var, ExistQVars), list__member(Var, Params) -> Result = error("type variable has overlapping scopes " ++ "(explicit type quantifier shadows argument type)", Body) ; % Check that all type variables in existential quantifiers occur % somewhere in the constructor argument types or constraints. list__member(Ctor, Ctors), Ctor = ctor(ExistQVars, Constraints, _CtorName, CtorArgs), list__member(Var, ExistQVars), assoc_list__values(CtorArgs, CtorArgTypes), \+ type_list_contains_var(CtorArgTypes, Var), constraint_list_get_tvars(Constraints, ConstraintTVars), \+ list__member(Var, ConstraintTVars) -> Result = error("type variable in existential quantifier " ++ "does not occur in arguments or constraints of constructor", Body) ; % Check that all type variables in existential constraints occur in % the existential quantifiers. list__member(Ctor, Ctors), Ctor = ctor(ExistQVars, Constraints, _CtorName, _CtorArgs), list__member(Constraint, Constraints), Constraint = constraint(_Name, ConstraintArgs), type_list_contains_var(ConstraintArgs, Var), \+ list__member(Var, ExistQVars) -> Result = error("type variables in class constraints introduced " ++ "with `=>' must be explicitly existentially quantified " ++ "using `some'", Body) ; Result = ok(processed_type_body(Functor, Params, du_type(Ctors, MaybeUserEqComp))) ). %-----------------------------------------------------------------------------% % process_abstract_type(ModuleName, TypeHead, Result): % % Checks that its argument is well formed, and if it is, binds Result % to a representation of the type information about the TypeHead. % :- pred process_abstract_type(module_name::in, term::in, decl_attrs::in, maybe1(processed_type_body)::out) is det. process_abstract_type(ModuleName, Head, Attributes0, Result) :- dummy_term(Body), parse_type_defn_head(ModuleName, Head, Body, Result0), get_is_solver_type(IsSolverType, Attributes0, Attributes), process_abstract_type_2(Result0, IsSolverType, Result1), check_no_attributes(Result1, Attributes, Result). :- pred process_abstract_type_2(maybe2(sym_name, list(type_param))::in, is_solver_type::in, maybe1(processed_type_body)::out) is det. process_abstract_type_2(error(Error, Term), _, error(Error, Term)). process_abstract_type_2(ok(Functor, Params), IsSolverType, Result) :- Result = ok(processed_type_body(Functor, Params, abstract_type(IsSolverType))). %-----------------------------------------------------------------------------% parse_type_defn_head(ModuleName, Head, Body, Result) :- ( Head = term__variable(_) -> % `Head' has no term__context, so we need to get the % context from `Body' ( Body = term__functor(_, _, Context) -> dummy_term_with_context(Context, ErrorTerm) ; dummy_term(ErrorTerm) ), Result = error("variable on LHS of type definition", ErrorTerm) ; parse_implicitly_qualified_term(ModuleName, Head, Head, "type definition", R), parse_type_defn_head_2(R, Head, Result) ). :- pred parse_type_defn_head_2(maybe_functor::in, term::in, maybe2(sym_name, list(tvar))::out) is det. parse_type_defn_head_2(error(Msg, Term), _, error(Msg, Term)). parse_type_defn_head_2(ok(Name, Args), Head, Result) :- parse_type_defn_head_3(Name, Args, Head, Result). :- pred parse_type_defn_head_3(sym_name::in, list(term)::in, term::in, maybe2(sym_name, list(tvar))::out) is det. parse_type_defn_head_3(Name, Args, Head, Result) :- % Check that all the head args are variables. ( var_list_to_term_list(Params0, Args) -> % Check that all the head arg variables are distinct. ( list__member(_, Params0, [Param | OtherParams]), list__member(Param, OtherParams) -> Result = error("repeated type parameters " ++ "in LHS of type defn", Head) ; list__map(term__coerce_var, Params0, Params), Result = ok(Name, Params) ) ; Result = error("type parameters must be variables", Head) ). %-----------------------------------------------------------------------------% % Convert a list of terms separated by semi-colons (known as a % "disjunction", even thought the terms aren't goals in this case) % into a list of constructors. % :- func convert_constructors(module_name, term) = maybe1(list(constructor)). convert_constructors(ModuleName, Body) = Result :- disjunction_to_list(Body, List), Result0 = convert_constructors_2(ModuleName, List), ( Result0 = ok(Constructors), Result = ok(Constructors) ; Result0 = error(String, Term), Result = error(String, Term) ). % True if input argument is a valid list of constructors. % :- func convert_constructors_2(module_name, list(term)) = maybe1(list(constructor)). convert_constructors_2(_ModuleName, []) = ok([]). convert_constructors_2( ModuleName, [Term | Terms]) = Result :- Result0 = convert_constructor(ModuleName, Term), ( Result0 = error(String0, Term0), Result = error(String0, Term0) ; Result0 = ok(Constructor), Result1 = convert_constructors_2(ModuleName, Terms), ( Result1 = error(String1, Term1), Result = error(String1, Term1) ; Result1 = ok(Constructors), Result = ok([Constructor | Constructors]) ) ). :- func convert_constructor(module_name, term) = maybe1(constructor). convert_constructor(ModuleName, Term0) = Result :- ( Term0 = term__functor(term__atom("some"), [Vars, Term1], _Context) -> ( parse_list_of_vars(Vars, ExistQVars0) -> list__map(term__coerce_var, ExistQVars0, ExistQVars), Result = convert_constructor_2(ModuleName, ExistQVars, Term0, Term1) ; Result = error("syntax error in variable list", Term0) ) ; ExistQVars = [], Result = convert_constructor_2(ModuleName, ExistQVars, Term0, Term0) ). :- func convert_constructor_2(module_name, list(tvar), term, term) = maybe1(constructor). convert_constructor_2(ModuleName, ExistQVars, Term0, Term1) = Result :- get_existential_constraints_from_term(ModuleName, Term1, Term2, Result0), ( Result0 = error(String, Term), Result = error(String, Term) ; Result0 = ok(Constraints), ( % Note that as a special case, one level of curly braces around % the constructor are ignored. This is to allow you to define % ';'/2 and 'some'/2 constructors. Term2 = term__functor(term__atom("{}"), [Term3], _Context) -> Term4 = Term3 ; Term4 = Term2 ), Result = convert_constructor_3(ModuleName, ExistQVars, Constraints, Term0, Term4) ). :- func convert_constructor_3(module_name, list(tvar), list(prog_constraint), term, term) = maybe1(constructor). convert_constructor_3(ModuleName, ExistQVars, Constraints, Term0, Term1) = Result :- parse_implicitly_qualified_term(ModuleName, Term1, Term0, "constructor definition", Result0), ( Result0 = error(String, Term), Result = error(String, Term) ; Result0 = ok(F, As), Result1 = convert_constructor_arg_list(ModuleName, As), ( Result1 = error(String, Term), Result = error(String, Term) ; Result1 = ok(Args), Result = ok(ctor(ExistQVars, Constraints, F, Args)) ) ). %-----------------------------------------------------------------------------% % parse a `:- pred p(...)' declaration or a % `:- func f(...) `with_type` t' declaration % :- pred process_pred_or_func(pred_or_func::in, module_name::in, varset::in, term::in, condition::in, maybe(mer_type)::in, maybe(mer_inst)::in, maybe(determinism)::in, decl_attrs::in, maybe1(item)::out) is det. process_pred_or_func(PredOrFunc, ModuleName, VarSet, PredType, Cond, WithType, WithInst, MaybeDet, Attributes0, Result) :- get_class_context_and_inst_constraints(ModuleName, Attributes0, Attributes, MaybeContext), ( MaybeContext = ok(ExistQVars, Constraints, InstConstraints), parse_implicitly_qualified_term(ModuleName, PredType, PredType, pred_or_func_decl_string(PredOrFunc), R), process_pred_or_func_2(PredOrFunc, R, PredType, VarSet, WithType, WithInst, MaybeDet, Cond, ExistQVars, Constraints, InstConstraints, Attributes, Result) ; MaybeContext = error(String, Term), Result = error(String, Term) ). :- pred process_pred_or_func_2(pred_or_func::in, maybe_functor::in, term::in, varset::in, maybe(mer_type)::in, maybe(mer_inst)::in, maybe(determinism)::in, condition::in, existq_tvars::in, prog_constraints::in, inst_var_sub::in, decl_attrs::in, maybe1(item)::out) is det. process_pred_or_func_2(PredOrFunc, ok(F, As0), PredType, VarSet0, WithType, WithInst, MaybeDet, Cond, ExistQVars, ClassContext, InstConstraints, Attributes0, Result) :- ( convert_type_and_mode_list(InstConstraints, As0, As) -> ( verify_type_and_mode_list(As) -> ( WithInst = yes(_), As = [type_only(_) | _] -> Result = error("`with_inst` specified " ++ "without argument modes", PredType) ; WithInst = no, WithType = yes(_), As = [type_and_mode(_, _) | _] -> Result = error("arguments have modes but " ++ "`with_inst` not specified", PredType) ; \+ inst_var_constraints_are_consistent_in_type_and_modes(As) -> Result = error("inconsistent constraints " ++ "on inst variables in " ++ pred_or_func_decl_string(PredOrFunc), PredType) ; get_purity(Purity, Attributes0, Attributes), varset__coerce(VarSet0, TVarSet), varset__coerce(VarSet0, IVarSet), Result0 = ok(pred_or_func(TVarSet, IVarSet, ExistQVars, PredOrFunc, F, As, WithType, WithInst, MaybeDet, Cond, Purity, ClassContext)), check_no_attributes(Result0, Attributes, Result) ) ; Result = error("some but not all arguments " ++ "have modes", PredType) ) ; Result = error("syntax error in " ++ pred_or_func_decl_string(PredOrFunc), PredType) ). process_pred_or_func_2(_, error(M, T), _, _, _, _, _, _, _, _, _, _, error(M, T)). :- pred get_purity(purity::out, decl_attrs::in, decl_attrs::out) is det. get_purity(Purity, !Attributes) :- ( !.Attributes = [purity(Purity0) - _ | !:Attributes] -> Purity = Purity0 ; Purity = purity_pure ). :- func pred_or_func_decl_string(pred_or_func) = string. pred_or_func_decl_string(function) = "`:- func' declaration". pred_or_func_decl_string(predicate) = "`:- pred' declaration". %-----------------------------------------------------------------------------% % We could perhaps get rid of some code duplication between here and % prog_io_typeclass.m? % get_class_context_and_inst_constraints(ModuleName, Attributes0, % Attributes, MaybeContext, MaybeInstConstraints): % % Parse type quantifiers, type class constraints and inst constraints % from the declaration attributes in Attributes0. % MaybeContext is either bound to the correctly parsed context, or % an appropriate error message (if there was a syntax error). % MaybeInstConstraints is either bound to a map containing the inst % constraints or an appropriate error message (if there was a syntax % error). % Attributes is bound to the remaining attributes. % :- pred get_class_context_and_inst_constraints(module_name::in, decl_attrs::in, decl_attrs::out, maybe3(existq_tvars, prog_constraints, inst_var_sub)::out) is det. get_class_context_and_inst_constraints(ModuleName, RevAttributes0, RevAttributes, MaybeContext) :- % Constraints and quantifiers should occur in the following order % (outermost to innermost): % % operator precedence % -------- ---------- % 1. universal quantifiers all 950 % 2. existential quantifiers some 950 % 3. universal constraints <= 920 % 4. existential constraints => 920 [*] % 5. the decl itself pred or func 800 % % When we reach here, Attributes0 contains declaration attributes % in the opposite order -- innermost to outermost -- so we reverse % them before we start. % % [*] Note that the semantic meaning of `=>' is not quite the same % as implication; logically speaking it's more like conjunction. % Oh well, at least it has the right precedence. % % In theory it could make sense to allow the order of 2 & 3 to be % swapped, or (in the case of multiple constraints & multiple % quantifiers) to allow arbitrary interleaving of 2 & 3, but in % practice it seems there would be little benefit in allowing that % flexibility, so we don't. % % Universal quantification is the default, so we just ignore % universal quantifiers. (XXX It might be a good idea to check % that any universally quantified type variables do actually % occur somewhere in the type declaration, and are not also % existentially quantified, and if not, issue a warning or % error message.) list__reverse(RevAttributes0, Attributes0), get_quant_vars(univ, ModuleName, Attributes0, Attributes1, [], _UnivQVars), get_quant_vars(exist, ModuleName, Attributes1, Attributes2, [], ExistQVars0), list__map(term__coerce_var, ExistQVars0, ExistQVars), get_constraints(univ, ModuleName, Attributes2, Attributes3, MaybeUnivConstraints), get_constraints(exist, ModuleName, Attributes3, Attributes, MaybeExistConstraints), list__reverse(Attributes, RevAttributes), combine_quantifier_results(MaybeUnivConstraints, MaybeExistConstraints, ExistQVars, MaybeContext). :- pred combine_quantifier_results(maybe_class_and_inst_constraints::in, maybe_class_and_inst_constraints::in, existq_tvars::in, maybe3(existq_tvars, prog_constraints, inst_var_sub)::out) is det. combine_quantifier_results(error(Msg, Term), _, _, error(Msg, Term)). combine_quantifier_results(ok(_, _), error(Msg, Term), _, error(Msg, Term)). combine_quantifier_results(ok(UnivConstraints, InstConstraints0), ok(ExistConstraints, InstConstraints1), ExistQVars, ok(ExistQVars, constraints(UnivConstraints, ExistConstraints), InstConstraints0 `map__merge` InstConstraints1)). :- pred get_quant_vars(quantifier_type::in, module_name::in, decl_attrs::in, decl_attrs::out, list(var)::in, list(var)::out) is det. get_quant_vars(QuantType, ModuleName, !Attributes, !Vars) :- ( !.Attributes = [quantifier(QuantType, QuantVars) - _ | !:Attributes] -> list__append(!.Vars, QuantVars, !:Vars), get_quant_vars(QuantType, ModuleName, !Attributes, !Vars) ; true ). :- pred get_constraints(quantifier_type::in, module_name::in, decl_attrs::in, decl_attrs::out, maybe_class_and_inst_constraints::out) is det. get_constraints(QuantType, ModuleName, !Attributes, MaybeConstraints) :- ( !.Attributes = [constraints(QuantType, ConstraintsTerm) - _Term | !:Attributes] -> parse_class_and_inst_constraints(ModuleName, ConstraintsTerm, MaybeConstraints0), % there may be more constraints of the same type -- % collect them all and combine them get_constraints(QuantType, ModuleName, !Attributes, MaybeConstraints1), combine_constraint_list_results(MaybeConstraints1, MaybeConstraints0, MaybeConstraints) ; MaybeConstraints = ok([], map__init) ). :- pred combine_constraint_list_results(maybe_class_and_inst_constraints::in, maybe_class_and_inst_constraints::in, maybe_class_and_inst_constraints::out) is det. combine_constraint_list_results(error(Msg, Term), _, error(Msg, Term)). combine_constraint_list_results(ok(_, _), error(Msg, Term), error(Msg, Term)). combine_constraint_list_results(ok(CC0, IC0), ok(CC1, IC1), ok(CC0 ++ CC1, IC0 `map__merge` IC1)). :- pred get_existential_constraints_from_term(module_name::in, term::in, term::out, maybe1(list(prog_constraint))::out) is det. get_existential_constraints_from_term(ModuleName, !PredType, MaybeExistentialConstraints) :- ( !.PredType = term__functor(term__atom("=>"), [!:PredType, ExistentialConstraints], _) -> parse_class_constraints(ModuleName, ExistentialConstraints, MaybeExistentialConstraints) ; MaybeExistentialConstraints = ok([]) ). %-----------------------------------------------------------------------------% % Verify that among the arguments of a :- pred declaration, % either all arguments specify a mode or none of them do. % :- pred verify_type_and_mode_list(list(type_and_mode)::in) is semidet. verify_type_and_mode_list([]). verify_type_and_mode_list([First | Rest]) :- verify_type_and_mode_list_2(Rest, First). :- pred verify_type_and_mode_list_2(list(type_and_mode)::in, type_and_mode::in) is semidet. verify_type_and_mode_list_2([], _). verify_type_and_mode_list_2([Head | Tail], First) :- ( Head = type_only(_), First = type_only(_) ; Head = type_and_mode(_, _), First = type_and_mode(_, _) ), verify_type_and_mode_list_2(Tail, First). %-----------------------------------------------------------------------------% % Parse a `:- func p(...)' declaration. % :- pred process_func(module_name::in, varset::in, term::in, condition::in, maybe(determinism)::in, decl_attrs::in, maybe1(item)::out) is det. process_func(ModuleName, VarSet, Term, Cond, MaybeDet, Attributes0, Result) :- get_class_context_and_inst_constraints(ModuleName, Attributes0, Attributes, MaybeContext), ( MaybeContext = ok(ExistQVars, Constraints, InstConstraints), process_func_2(ModuleName, VarSet, Term, Cond, MaybeDet, ExistQVars, Constraints, InstConstraints, Attributes, Result) ; MaybeContext = error(String, ErrorTerm), Result = error(String, ErrorTerm) ). :- pred process_func_2(module_name::in, varset::in, term::in, condition::in, maybe(determinism)::in, existq_tvars::in, prog_constraints::in, inst_var_sub::in, decl_attrs::in, maybe1(item)::out) is det. process_func_2(ModuleName, VarSet, Term, Cond, MaybeDet, ExistQVars, Constraints, InstConstraints, Attributes, Result) :- ( Term = term__functor(term__atom("="), [FuncTerm0, ReturnTypeTerm], _Context), FuncTerm = desugar_field_access(FuncTerm0) -> parse_implicitly_qualified_term(ModuleName, FuncTerm, Term, "`:- func' declaration", R), process_func_3(R, FuncTerm, ReturnTypeTerm, Term, VarSet, MaybeDet, Cond, ExistQVars, Constraints, InstConstraints, Attributes, Result) ; Result = error("`=' expected in `:- func' declaration", Term) ). :- pred process_func_3(maybe_functor::in, term::in, term::in, term::in, varset::in, maybe(determinism)::in, condition::in, existq_tvars::in, prog_constraints::in, inst_var_sub::in, decl_attrs::in, maybe1(item)::out) is det. process_func_3(ok(F, As0), FuncTerm, ReturnTypeTerm, FullTerm, VarSet0, MaybeDet, Cond, ExistQVars, ClassContext, InstConstraints, Attributes0, Result) :- ( convert_type_and_mode_list(InstConstraints, As0, As) -> ( \+ verify_type_and_mode_list(As) -> Result = error("some but not all arguments have modes", FuncTerm) ; convert_type_and_mode(InstConstraints, ReturnTypeTerm, ReturnType) -> ( As = [type_and_mode(_, _) | _], ReturnType = type_only(_) -> Result = error("function arguments have modes, " ++ "but function result doesn't", FuncTerm) ; As = [type_only(_) | _], ReturnType = type_and_mode(_, _) -> Result = error("function result has mode, " ++ "but function arguments don't", FuncTerm) ; get_purity(Purity, Attributes0, Attributes), varset__coerce(VarSet0, TVarSet), varset__coerce(VarSet0, IVarSet), list__append(As, [ReturnType], Args), ( inst_var_constraints_are_consistent_in_type_and_modes(Args) -> Result0 = ok(pred_or_func(TVarSet, IVarSet, ExistQVars, function, F, Args, no, no, MaybeDet, Cond, Purity, ClassContext)), check_no_attributes(Result0, Attributes, Result) ; Result = error("inconsistent constraints on inst " ++ "variables in function declaration", FullTerm) ) ) ; Result = error("syntax error in return type of " ++ "`:- func' declaration", ReturnTypeTerm) ) ; Result = error("syntax error in arguments of `:- func' " ++ "declaration", FuncTerm) ). process_func_3(error(M, T), _, _, _, _, _, _, _, _, _, _, error(M, T)). %-----------------------------------------------------------------------------% % Perform one of the following field-access syntax rewrites if possible: % % A ^ f(B, ...) ---> f(B, ..., A) % (A ^ f(B, ...) := X) ---> 'f :='(B, ..., A, X) % :- func desugar_field_access(term) = term. desugar_field_access(Term) = ( Term = functor(atom("^"), [A, RHS], _), RHS = functor(atom(FieldName), Bs, Context) -> functor(atom(FieldName), Bs ++ [A], Context) ; Term = functor(atom(":="), [LHS, X], _), LHS = functor(atom("^"), [A, RHS], Context), RHS = functor(atom(FieldName), Bs, Context) -> functor(atom(FieldName ++ " :="), Bs ++ [A, X], Context) ; Term ). %-----------------------------------------------------------------------------% % Parse a `:- mode p(...)' declaration. % :- pred process_mode(module_name::in, varset::in, term::in, condition::in, decl_attrs::in, maybe(mer_inst)::in, maybe(determinism)::in, maybe1(item)::out) is det. process_mode(ModuleName, VarSet, Term, Cond, Attributes, WithInst, MaybeDet, Result) :- ( WithInst = no, Term = term__functor(term__atom("="), [FuncTerm0, ReturnTypeTerm], _Context), FuncTerm = desugar_field_access(FuncTerm0) -> parse_implicitly_qualified_term(ModuleName, FuncTerm, Term, "function `:- mode' declaration", R), process_func_mode(R, ModuleName, FuncTerm, ReturnTypeTerm, Term, VarSet, MaybeDet, Cond, Attributes, Result) ; parse_implicitly_qualified_term(ModuleName, Term, Term, "`:- mode' declaration", R), process_pred_or_func_mode(R, ModuleName, Term, VarSet, WithInst, MaybeDet, Cond, Attributes, Result) ). :- pred process_pred_or_func_mode(maybe_functor::in, module_name::in, term::in, varset::in, maybe(mer_inst)::in, maybe(determinism)::in, condition::in, decl_attrs::in, maybe1(item)::out) is det. process_pred_or_func_mode(ok(F, As0), ModuleName, PredMode, VarSet0, WithInst, MaybeDet, Cond, Attributes0, Result) :- ( convert_mode_list(allow_constrained_inst_var, As0, As1) -> get_class_context_and_inst_constraints(ModuleName, Attributes0, Attributes, MaybeConstraints), ( MaybeConstraints = ok(_, _, InstConstraints), list__map(constrain_inst_vars_in_mode(InstConstraints), As1, As), varset__coerce(VarSet0, VarSet), ( inst_var_constraints_are_consistent_in_modes(As) -> ( WithInst = no, PredOrFunc = yes(predicate) ; WithInst = yes(_), % We don't know whether it's a predicate or a function % until we expand out the inst. PredOrFunc = no ), Result0 = ok(pred_or_func_mode(VarSet, PredOrFunc, F, As, WithInst, MaybeDet, Cond)) ; Result0 = error("inconsistent constraints " ++ "on inst variables in predicate " ++ "mode declaration", PredMode) ) ; MaybeConstraints = error(String, Term), Result0 = error(String, Term) ), check_no_attributes(Result0, Attributes, Result) ; Result = error("syntax error in mode declaration", PredMode) ). process_pred_or_func_mode(error(M, T), _, _, _, _, _, _, _, error(M, T)). :- pred process_func_mode(maybe_functor::in, module_name::in, term::in, term::in, term::in, varset::in, maybe(determinism)::in, condition::in, decl_attrs::in, maybe1(item)::out) is det. process_func_mode(ok(F, As0), ModuleName, FuncMode, RetMode0, FullTerm, VarSet0, MaybeDet, Cond, Attributes0, Result) :- ( convert_mode_list(allow_constrained_inst_var, As0, As1) -> get_class_context_and_inst_constraints(ModuleName, Attributes0, Attributes, MaybeConstraints), ( MaybeConstraints = ok(_, _, InstConstraints), list__map(constrain_inst_vars_in_mode(InstConstraints), As1, As), ( convert_mode(allow_constrained_inst_var, RetMode0, RetMode1) -> constrain_inst_vars_in_mode(InstConstraints, RetMode1, RetMode), varset__coerce(VarSet0, VarSet), list__append(As, [RetMode], ArgModes), ( inst_var_constraints_are_consistent_in_modes(ArgModes) -> Result0 = ok(pred_or_func_mode(VarSet, yes(function), F, ArgModes, no, MaybeDet, Cond)) ; Result0 = error("inconsistent " ++ "constraints on inst " ++ "variables in function " ++ "mode declaration", FullTerm) ) ; Result0 = error("syntax error in return mode " ++ "of function mode declaration", RetMode0) ) ; MaybeConstraints = error(String, Term), Result0 = error(String, Term) ), check_no_attributes(Result0, Attributes, Result) ; Result = error("syntax error in arguments of function " ++ "mode declaration", FuncMode) ). process_func_mode(error(M, T), _, _, _, _, _, _, _, _, error(M, T)). %-----------------------------------------------------------------------------% constrain_inst_vars_in_mode(Mode0, Mode) :- constrain_inst_vars_in_mode(map__init, Mode0, Mode). constrain_inst_vars_in_mode(InstConstraints, I0 -> F0, I -> F) :- constrain_inst_vars_in_inst(InstConstraints, I0, I), constrain_inst_vars_in_inst(InstConstraints, F0, F). constrain_inst_vars_in_mode(InstConstraints, user_defined_mode(Name, Args0), user_defined_mode(Name, Args)) :- list__map(constrain_inst_vars_in_inst(InstConstraints), Args0, Args). :- pred constrain_inst_vars_in_inst(inst_var_sub::in, mer_inst::in, mer_inst::out) is det. constrain_inst_vars_in_inst(_, any(U), any(U)). constrain_inst_vars_in_inst(_, free, free). constrain_inst_vars_in_inst(_, free(T), free(T)). constrain_inst_vars_in_inst(InstConstraints, bound(U, BIs0), bound(U, BIs)) :- list__map((pred(functor(C, Is0)::in, functor(C, Is)::out) is det :- list__map(constrain_inst_vars_in_inst(InstConstraints), Is0, Is)), BIs0, BIs). constrain_inst_vars_in_inst(_, ground(U, none), ground(U, none)). constrain_inst_vars_in_inst(InstConstraints, ground(U, higher_order(PredInstInfo0)), ground(U, higher_order(PredInstInfo))) :- constrain_inst_vars_in_pred_inst_info(InstConstraints, PredInstInfo0, PredInstInfo). constrain_inst_vars_in_inst(InstConstraints, constrained_inst_vars(Vars0, Inst0), constrained_inst_vars(Vars, Inst)) :- constrain_inst_vars_in_inst(InstConstraints, Inst0, Inst1), ( Inst1 = constrained_inst_vars(Vars2, Inst2) -> Vars = Vars0 `set__union` Vars2, Inst = Inst2 ; Vars = Vars0, Inst = Inst1 ). constrain_inst_vars_in_inst(_, not_reached, not_reached). constrain_inst_vars_in_inst(InstConstraints, inst_var(Var), constrained_inst_vars(set__make_singleton_set(Var), Inst)) :- ( map__search(InstConstraints, Var, Inst0) -> Inst = Inst0 ; Inst = ground(shared, none) ). constrain_inst_vars_in_inst(InstConstraints, defined_inst(Name0), defined_inst(Name)) :- constrain_inst_vars_in_inst_name(InstConstraints, Name0, Name). constrain_inst_vars_in_inst(InstConstraints, abstract_inst(N, Is0), abstract_inst(N, Is)) :- list__map(constrain_inst_vars_in_inst(InstConstraints), Is0, Is). :- pred constrain_inst_vars_in_pred_inst_info(inst_var_sub::in, pred_inst_info::in, pred_inst_info::out) is det. constrain_inst_vars_in_pred_inst_info(InstConstraints, PII0, PII) :- PII0 = pred_inst_info(PredOrFunc, Modes0, Det), list__map(constrain_inst_vars_in_mode(InstConstraints), Modes0, Modes), PII = pred_inst_info(PredOrFunc, Modes, Det). :- pred constrain_inst_vars_in_inst_name(inst_var_sub::in, inst_name::in, inst_name::out) is det. constrain_inst_vars_in_inst_name(InstConstraints, Name0, Name) :- ( Name0 = user_inst(SymName, Args0) -> list__map(constrain_inst_vars_in_inst(InstConstraints), Args0, Args), Name = user_inst(SymName, Args) ; Name = Name0 ). %-----------------------------------------------------------------------------% inst_var_constraints_are_consistent_in_modes(Modes) :- inst_var_constraints_are_consistent_in_modes(Modes, map__init, _). :- pred inst_var_constraints_are_consistent_in_modes(list(mer_mode)::in, inst_var_sub::in, inst_var_sub::out) is semidet. inst_var_constraints_are_consistent_in_modes(Modes, !Sub) :- list__foldl(inst_var_constraints_are_consistent_in_mode, Modes, !Sub). :- pred inst_var_constraints_are_consistent_in_type_and_modes( list(type_and_mode)::in) is semidet. inst_var_constraints_are_consistent_in_type_and_modes(TypeAndModes) :- list__foldl((pred(TypeAndMode::in, in, out) is semidet --> ( { TypeAndMode = type_only(_) } ; { TypeAndMode = type_and_mode(_, Mode) }, inst_var_constraints_are_consistent_in_mode(Mode) )), TypeAndModes, map__init, _). :- pred inst_var_constraints_are_consistent_in_mode(mer_mode::in, inst_var_sub::in, inst_var_sub::out) is semidet. inst_var_constraints_are_consistent_in_mode(InitialInst -> FinalInst, !Sub) :- inst_var_constraints_are_consistent_in_inst(InitialInst, !Sub), inst_var_constraints_are_consistent_in_inst(FinalInst, !Sub). inst_var_constraints_are_consistent_in_mode(user_defined_mode(_, ArgInsts), !Sub) :- inst_var_constraints_are_consistent_in_insts(ArgInsts, !Sub). :- pred inst_var_constraints_are_consistent_in_insts(list(mer_inst)::in, inst_var_sub::in, inst_var_sub::out) is semidet. inst_var_constraints_are_consistent_in_insts(Insts, !Sub) :- list__foldl(inst_var_constraints_are_consistent_in_inst, Insts, !Sub). :- pred inst_var_constraints_are_consistent_in_inst(mer_inst::in, inst_var_sub::in, inst_var_sub::out) is semidet. inst_var_constraints_are_consistent_in_inst(any(_), !Sub). inst_var_constraints_are_consistent_in_inst(free, !Sub). inst_var_constraints_are_consistent_in_inst(free(_), !Sub). inst_var_constraints_are_consistent_in_inst(bound(_, BoundInsts), !Sub) :- list__foldl((pred(functor(_, Insts)::in, in, out) is semidet --> inst_var_constraints_are_consistent_in_insts(Insts)), BoundInsts, !Sub). inst_var_constraints_are_consistent_in_inst(ground(_, GroundInstInfo), !Sub) :- ( GroundInstInfo = none ; GroundInstInfo = higher_order(pred_inst_info(_, Modes, _)), inst_var_constraints_are_consistent_in_modes(Modes, !Sub) ). inst_var_constraints_are_consistent_in_inst(not_reached, !Sub). inst_var_constraints_are_consistent_in_inst(inst_var(_), !Sub) :- error("inst_var_constraints_are_consistent_in_inst: " ++ "unconstrained inst_var"). inst_var_constraints_are_consistent_in_inst(defined_inst(InstName), !Sub) :- ( InstName = user_inst(_, Insts) -> inst_var_constraints_are_consistent_in_insts(Insts, !Sub) ; true ). inst_var_constraints_are_consistent_in_inst(abstract_inst(_, Insts), !Sub) :- inst_var_constraints_are_consistent_in_insts(Insts, !Sub). inst_var_constraints_are_consistent_in_inst( constrained_inst_vars(InstVars, Inst), !Sub) :- set__fold((pred(InstVar::in, in, out) is semidet --> ( Inst0 =^ map__elem(InstVar) -> % Check that the inst_var constraint is consistent with % the previous constraint on this inst_var. { Inst = Inst0 } ; ^ map__elem(InstVar) := Inst )), InstVars, !Sub), inst_var_constraints_are_consistent_in_inst(Inst, !Sub). %-----------------------------------------------------------------------------% % Parse a `:- inst .' declaration. % :- pred parse_inst_decl(module_name::in, varset::in, term::in, maybe1(item)::out) is det. parse_inst_decl(ModuleName, VarSet, InstDefn, Result) :- ( InstDefn = term__functor(term__atom(Op), [H, B], _Context), Op = "==" -> get_condition(B, Body, Condition), convert_inst_defn(ModuleName, H, Body, R), process_maybe1(make_inst_defn(VarSet, Condition), R, Result) ; % XXX This is for `abstract inst' declarations, % which are not really supported. InstDefn = term__functor(term__atom("is"), [Head, term__functor(term__atom("private"), [], _)], _) -> Condition = true, convert_abstract_inst_defn(ModuleName, Head, R), process_maybe1(make_inst_defn(VarSet, Condition), R, Result) ; InstDefn = term__functor(term__atom("--->"), [H, B], Context) -> get_condition(B, Body, Condition), Body1 = term__functor(term__atom("bound"), [Body], Context), convert_inst_defn(ModuleName, H, Body1, R), % We should check the condition for errs (don't bother at the moment, % since we ignore conditions anyhow :-) process_maybe1(make_inst_defn(VarSet, Condition), R, Result) ; Result = error("`==' expected in `:- inst' definition", InstDefn) ). % Parse a `:- inst ---> .' definition. % :- pred convert_inst_defn(module_name::in, term::in, term::in, maybe1(processed_inst_body)::out) is det. convert_inst_defn(ModuleName, Head, Body, Result) :- parse_implicitly_qualified_term(ModuleName, Head, Body, "inst definition", R), convert_inst_defn_2(R, Head, Body, Result). :- pred convert_inst_defn_2(maybe_functor::in, term::in, term::in, maybe1(processed_inst_body)::out) is det. convert_inst_defn_2(error(M, T), _, _, error(M, T)). convert_inst_defn_2(ok(Name, ArgTerms), Head, Body, Result) :- ( % Check that all the head args are variables. term__var_list_to_term_list(Args, ArgTerms) -> ( % Check that all the head arg variables are distinct. list__member(Arg2, Args, [Arg2|OtherArgs]), list__member(Arg2, OtherArgs) -> Result = error("repeated inst parameters in LHS of inst defn", Head) ; % Check that all the variables in the body occur in the head. term__contains_var(Body, Var2), \+ list__member(Var2, Args) -> Result = error("free inst parameter in RHS of inst definition", Body) ; % Check that the inst is a valid user-defined inst, i.e. that it % does not have the form of one of the builtin insts. \+ ( convert_inst(no_allow_constrained_inst_var, Head, UserInst), UserInst = defined_inst(user_inst(_, _)) ) -> Result = error("attempt to redefine builtin inst", Head) ; % Should improve the error message here. ( convert_inst(no_allow_constrained_inst_var, Body, ConvertedBody) -> list__map(term__coerce_var, Args, InstArgs), Result = ok(processed_inst_body(Name, InstArgs, eqv_inst(ConvertedBody))) ; Result = error("syntax error in inst body", Body) ) ) ; Result = error("inst parameters must be variables", Head) ). :- type processed_inst_body ---> processed_inst_body( sym_name, list(inst_var), inst_defn ). :- pred convert_abstract_inst_defn(module_name::in, term::in, maybe1(processed_inst_body)::out) is det. convert_abstract_inst_defn(ModuleName, Head, Result) :- parse_implicitly_qualified_term(ModuleName, Head, Head, "inst definition", R), convert_abstract_inst_defn_2(R, Head, Result). :- pred convert_abstract_inst_defn_2(maybe_functor::in, term::in, maybe1(processed_inst_body)::out) is det. convert_abstract_inst_defn_2(error(M, T), _, error(M, T)). convert_abstract_inst_defn_2(ok(Name, ArgTerms), Head, Result) :- ( % Check that all the head args are variables. term__var_list_to_term_list(Args, ArgTerms) -> ( % Check that all the head arg variables are distinct. list__member(Arg2, Args, [Arg2|OtherArgs]), list__member(Arg2, OtherArgs) -> Result = error("repeated inst parameters " ++ "in abstract inst definition", Head) ; list__map(term__coerce_var, Args, InstArgs), Result = ok(processed_inst_body(Name, InstArgs, abstract_inst)) ) ; Result = error("inst parameters must be variables", Head) ). :- pred make_inst_defn(varset::in, condition::in, processed_inst_body::in, item::out) is det. make_inst_defn(VarSet0, Cond, processed_inst_body(Name, Params, InstDefn), inst_defn(VarSet, Name, Params, InstDefn, Cond)) :- varset__coerce(VarSet0, VarSet). %-----------------------------------------------------------------------------% % Parse a `:- mode foo == ...' definition. % :- pred parse_mode_decl(module_name::in, varset::in, term::in, decl_attrs::in, maybe1(item)::out) is det. parse_mode_decl(ModuleName, VarSet, ModeDefn, Attributes, Result) :- ( mode_op(ModeDefn, H, B) -> get_condition(B, Body, Condition), convert_mode_defn(ModuleName, H, Body, R), process_maybe1(make_mode_defn(VarSet, Condition), R, Result) ; parse_mode_decl_pred(ModuleName, VarSet, ModeDefn, Attributes, Result) ). :- pred mode_op(term::in, term::out, term::out) is semidet. mode_op(term__functor(term__atom(Op), [H, B], _), H, B) :- Op = "==". :- type processed_mode_body ---> processed_mode_body( sym_name, list(inst_var), mode_defn ). :- pred convert_mode_defn(module_name::in, term::in, term::in, maybe1(processed_mode_body)::out) is det. convert_mode_defn(ModuleName, Head, Body, Result) :- parse_implicitly_qualified_term(ModuleName, Head, Head, "mode definition", R), convert_mode_defn_2(R, Head, Body, Result). :- pred convert_mode_defn_2(maybe_functor::in, term::in, term::in, maybe1(processed_mode_body)::out) is det. convert_mode_defn_2(error(M, T), _, _, error(M, T)). convert_mode_defn_2(ok(Name, ArgTerms), Head, Body, Result) :- ( % Check that all the head args are variables. term__var_list_to_term_list(Args, ArgTerms) -> ( % Check that all the head arg variables are distinct. list__member(Arg2, Args, [Arg2|OtherArgs]), list__member(Arg2, OtherArgs) -> Result = error("repeated parameters in LHS of mode defn", Head) ; % Check that all the variables in the body occur in the head. term__contains_var(Body, Var2), \+ list__member(Var2, Args) -> Result = error("free inst parameter in RHS of mode definition", Body) ; % Should improve the error message here. ( convert_mode(no_allow_constrained_inst_var, Body, ConvertedBody) -> list__map(term__coerce_var, Args, InstArgs), Result = ok(processed_mode_body(Name, InstArgs, eqv_mode(ConvertedBody))) ; % Catch-all error message - we should do better than this. Result = error("syntax error in mode definition body", Body) ) ) ; Result = error("mode parameters must be variables", Head) ). :- pred convert_type_and_mode_list(inst_var_sub::in, list(term)::in, list(type_and_mode)::out) is semidet. convert_type_and_mode_list(_, [], []). convert_type_and_mode_list(InstConstraints, [H0|T0], [H|T]) :- convert_type_and_mode(InstConstraints, H0, H), convert_type_and_mode_list(InstConstraints, T0, T). :- pred convert_type_and_mode(inst_var_sub::in, term::in, type_and_mode::out) is semidet. convert_type_and_mode(InstConstraints, Term, Result) :- ( Term = term__functor(term__atom("::"), [TypeTerm, ModeTerm], _Context) -> parse_type(TypeTerm, ok(Type)), convert_mode(allow_constrained_inst_var, ModeTerm, Mode0), constrain_inst_vars_in_mode(InstConstraints, Mode0, Mode), Result = type_and_mode(Type, Mode) ; parse_type(Term, ok(Type)), Result = type_only(Type) ). :- pred make_mode_defn(varset::in, condition::in, processed_mode_body::in, item::out) is det. make_mode_defn(VarSet0, Cond, processed_mode_body(Name, Params, ModeDefn), mode_defn(VarSet, Name, Params, ModeDefn, Cond)) :- varset__coerce(VarSet0, VarSet). %-----------------------------------------------------------------------------% :- type maker(T1, T2) == pred(T1, T2). :- mode maker == (pred(in, out) is det). :- pred parse_symlist_decl(parser(T)::parser, maker(list(T), sym_list)::maker, maker(sym_list, module_defn)::maker, term::in, decl_attrs::in, varset::in, maybe1(item)::out) is det. parse_symlist_decl(ParserPred, MakeSymListPred, MakeModuleDefnPred, Term, Attributes, VarSet, Result) :- parse_list(ParserPred, Term, Result0), process_maybe1(make_module_defn(MakeSymListPred, MakeModuleDefnPred, VarSet), Result0, Result1), check_no_attributes(Result1, Attributes, Result). :- pred make_module_defn(maker(T, sym_list)::maker, maker(sym_list, module_defn)::maker, varset::in, T::in, item::out) is det. make_module_defn(MakeSymListPred, MakeModuleDefnPred, VarSet0, T, module_defn(VarSet, ModuleDefn)) :- varset__coerce(VarSet0, VarSet), call(MakeSymListPred, T, SymList), call(MakeModuleDefnPred, SymList, ModuleDefn). %-----------------------------------------------------------------------------% :- pred process_maybe1(maker(T1, T2)::maker, maybe1(T1)::in, maybe1(T2)::out) is det. process_maybe1(Maker, ok(X), ok(Y)) :- call(Maker, X, Y). process_maybe1(_, error(M, T), error(M, T)). :- pred process_maybe1_to_t(maker(T1, maybe1(T2))::maker, maybe1(T1)::in, maybe1(T2)::out) is det. process_maybe1_to_t(Maker, ok(X), Y) :- call(Maker, X, Y). process_maybe1_to_t(_, error(M, T), error(M, T)). %-----------------------------------------------------------------------------% :- pred make_module(list(module_specifier)::in, sym_list::out) is det. make_module(X, module(X)). :- pred make_sym(list(sym_specifier)::in, sym_list::out) is det. make_sym(X, sym(X)). :- pred make_pred(list(pred_specifier)::in, sym_list::out) is det. make_pred(X, pred(X)). :- pred make_func(list(func_specifier)::in, sym_list::out) is det. make_func(X, func(X)). :- pred make_cons(list(cons_specifier)::in, sym_list::out) is det. make_cons(X, cons(X)). :- pred make_type(list(type_specifier)::in, sym_list::out) is det. make_type(X, type(X)). :- pred make_adt(list(adt_specifier)::in, sym_list::out) is det. make_adt(X, adt(X)). :- pred make_op(list(op_specifier)::in, sym_list::out) is det. make_op(X, op(X)). %-----------------------------------------------------------------------------% % % A symbol specifier is one of % % SymbolNameSpecifier % Matches any symbol matched by the SymbolNameSpecifier. % TypedConstructorSpecifier % Matches any constructors matched by the % TypedConstructorSpecifier. % cons(ConstructorSpecifier) % Matches only constructors. % pred(PredSpecifier) % Matches only predicates, ie. constructors of type `pred'. % adt(SymbolNameSpecifier) % Matches only type names. % type(SymbolNameSpecifier) % Matches type names matched by the SymbolNameSpecifier, % and also matches any constructors for the matched type names. % op(SymbolNameSpecifier) % Matches only operators. % module(ModuleSpecifier) % Matches all symbols in the specified module. :- pred parse_symbol_specifier(term::in, maybe1(sym_specifier)::out) is det. parse_symbol_specifier(MainTerm, Result) :- ( MainTerm = term__functor(term__atom(Functor), [Term], _Context) -> ( Functor = "cons" -> parse_constructor_specifier(Term, Result0), process_maybe1(make_cons_symbol_specifier, Result0, Result) ; Functor = "pred" -> parse_predicate_specifier(Term, Result0), process_maybe1(make_pred_symbol_specifier, Result0, Result) ; Functor = "func" -> parse_function_specifier(Term, Result0), process_maybe1(make_func_symbol_specifier, Result0, Result) ; Functor = "type" -> parse_type_specifier(Term, Result0), process_maybe1(make_type_symbol_specifier, Result0, Result) ; Functor = "adt" -> parse_adt_specifier(Term, Result0), process_maybe1(make_adt_symbol_specifier, Result0, Result) ; Functor = "op" -> parse_op_specifier(Term, Result0), process_maybe1(make_op_symbol_specifier, Result0, Result) ; Functor = "module" -> parse_module_specifier(Term, Result0), process_maybe1(make_module_symbol_specifier, Result0, Result) ; parse_constructor_specifier(MainTerm, Result0), process_maybe1(make_cons_symbol_specifier, Result0, Result) ) ; parse_constructor_specifier(MainTerm, Result0), process_maybe1(make_cons_symbol_specifier, Result0, Result) ). % Once we've parsed the appropriate type of symbol specifier, we need to % convert it to a sym_specifier. % :- pred make_pred_symbol_specifier(pred_specifier::in, sym_specifier::out) is det. make_pred_symbol_specifier(PredSpec, pred(PredSpec)). :- pred make_func_symbol_specifier(func_specifier::in, sym_specifier::out) is det. make_func_symbol_specifier(FuncSpec, func(FuncSpec)). :- pred make_cons_symbol_specifier(cons_specifier::in, sym_specifier::out) is det. make_cons_symbol_specifier(ConsSpec, cons(ConsSpec)). :- pred make_type_symbol_specifier(type_specifier::in, sym_specifier::out) is det. make_type_symbol_specifier(TypeSpec, type(TypeSpec)). :- pred make_adt_symbol_specifier(adt_specifier::in, sym_specifier::out) is det. make_adt_symbol_specifier(ADT_Spec, adt(ADT_Spec)). :- pred make_op_symbol_specifier(op_specifier::in, sym_specifier::out) is det. make_op_symbol_specifier(OpSpec, op(OpSpec)). :- pred make_module_symbol_specifier(module_specifier::in, sym_specifier::out) is det. make_module_symbol_specifier(ModuleSpec, module(ModuleSpec)). :- pred cons_specifier_to_sym_specifier(cons_specifier::in, sym_specifier::out) is det. cons_specifier_to_sym_specifier(sym(SymSpec), sym(SymSpec)). cons_specifier_to_sym_specifier(typed(SymSpec), typed_sym(SymSpec)). %-----------------------------------------------------------------------------% % A ModuleSpecifier is just an sym_name. % :- pred parse_module_specifier(term::in, maybe1(module_specifier)::out) is det. parse_module_specifier(Term, Result) :- parse_symbol_name(Term, Result). % A ModuleName is an implicitly-quantified sym_name. % % We check for module names starting with capital letters as a special % case, so that we can report a better error message for that case. % :- pred parse_module_name(module_name::in, term::in, maybe1(module_name)::out) is det. parse_module_name(DefaultModuleName, Term, Result) :- ( Term = term__variable(_) -> dummy_term(ErrorContext), Result = error("module names starting with " ++ "capital letters must be quoted using " ++ "single quotes (e.g. "":- module 'Foo'."")", ErrorContext) ; parse_implicitly_qualified_symbol_name(DefaultModuleName, Term, Result) ). %-----------------------------------------------------------------------------% % A ConstructorSpecifier is one of % SymbolNameSpecifier % TypedConstructorSpecifier % % A TypedConstructorSpecifier is one of % SymbolNameSpecifier::Type % Matches only constructors with the specified result type. % SymbolName(ArgType1, ..., ArgTypeN) % Matches only constructors with the specified argument types. % SymbolName(ArgType1, ..., ArgTypeN)::Type % Matches only constructors with the specified argument % and result types. % :- pred parse_constructor_specifier(term::in, maybe1(cons_specifier)::out) is det. parse_constructor_specifier(Term, Result) :- ( Term = term__functor(term__atom("::"), [NameArgsTerm, TypeTerm], _Context) -> parse_arg_types_specifier(NameArgsTerm, NameArgsResult), parse_type(TypeTerm, TypeResult), process_typed_constructor_specifier(NameArgsResult, TypeResult, Result) ; parse_arg_types_specifier(Term, TermResult), process_maybe1(make_untyped_cons_spec, TermResult, Result) ). %-----------------------------------------------------------------------------% % A PredicateSpecifier is one of % SymbolName(ArgType1, ..., ArgTypeN) % Matches only predicates with the specified argument types. % SymbolNameSpecifier % :- pred parse_predicate_specifier(term::in, maybe1(pred_specifier)::out) is det. parse_predicate_specifier(Term, Result) :- ( Term = term__functor(term__atom("/"), [_,_], _Context) -> parse_symbol_name_specifier(Term, NameResult), process_maybe1(make_arity_predicate_specifier, NameResult, Result) ; parse_qualified_term(Term, Term, "predicate specifier", TermResult), process_typed_predicate_specifier(TermResult, Result) ). :- pred process_typed_predicate_specifier(maybe_functor::in, maybe1(pred_specifier)::out) is det. process_typed_predicate_specifier(ok(Name, Args0), Result) :- ( Args0 = [], Result = ok(sym(name(Name))) ; Args0 = [_ | _], parse_types(Args0, ArgsResult), ( ArgsResult = ok(Args), Result = ok(name_args(Name, Args)) ; ArgsResult = error(Msg, ErrorTerm), Result = error(Msg, ErrorTerm) ) ). process_typed_predicate_specifier(error(Msg, Term), error(Msg, Term)). :- pred make_arity_predicate_specifier(sym_name_specifier::in, pred_specifier::out) is det. make_arity_predicate_specifier(Result, sym(Result)). %-----------------------------------------------------------------------------% % Parsing the name & argument types of a constructor specifier is exactly % the same as parsing a predicate specifier... % :- pred parse_arg_types_specifier(term::in, maybe1(pred_specifier)::out) is det. parse_arg_types_specifier(Term, Result) :- ( Term = term__functor(term__atom("/"), [_,_], _Context) -> parse_symbol_name_specifier(Term, NameResult), process_maybe1(make_arity_predicate_specifier, NameResult, Result) ; parse_qualified_term(Term, Term, "constructor specifier", TermResult), process_typed_predicate_specifier(TermResult, Result) ). % ... but we have to convert the result back into the appropriate format. % :- pred process_typed_constructor_specifier(maybe1(pred_specifier)::in, maybe1(mer_type)::in, maybe1(cons_specifier)::out) is det. process_typed_constructor_specifier(error(Msg, Term), _, error(Msg, Term)). process_typed_constructor_specifier(ok(_), error(Msg, Term), error(Msg, Term)). process_typed_constructor_specifier(ok(NameArgs), ok(ResType), ok(Result)) :- process_typed_cons_spec_2(NameArgs, ResType, Result). :- pred process_typed_cons_spec_2(pred_specifier::in, mer_type::in, cons_specifier::out) is det. process_typed_cons_spec_2(sym(Name), Res, typed(name_res(Name, Res))). process_typed_cons_spec_2(name_args(Name, Args), Res, typed(name_args_res(Name, Args, Res))). :- pred make_untyped_cons_spec(pred_specifier::in, cons_specifier::out) is det. make_untyped_cons_spec(sym(Name), sym(Name)). make_untyped_cons_spec(name_args(Name, Args), typed(name_args(Name, Args))). %-----------------------------------------------------------------------------% % A SymbolNameSpecifier is one of % SymbolName % SymbolName/Arity % Matches only symbols of the specified arity. % :- pred parse_symbol_name_specifier(term::in, maybe1(sym_name_specifier)::out) is det. parse_symbol_name_specifier(Term, Result) :- root_module_name(DefaultModule), parse_implicitly_qualified_symbol_name_specifier(DefaultModule, Term, Result). :- pred parse_implicitly_qualified_symbol_name_specifier(module_name::in, term::in, maybe1(sym_name_specifier)::out) is det. parse_implicitly_qualified_symbol_name_specifier(DefaultModule, Term, Result) :- ( Term = term__functor(term__atom("/"), [NameTerm, ArityTerm], _Context) -> ( ArityTerm = term__functor(term__integer(Arity), [], _Context2) -> ( Arity >= 0 -> parse_implicitly_qualified_symbol_name(DefaultModule, NameTerm, NameResult), process_maybe1(make_name_arity_specifier(Arity), NameResult, Result) ; Result = error("arity in symbol name specifier " ++ "must be a non-negative integer", Term) ) ; Result = error("arity in symbol name " ++ "specifier must be an integer", Term) ) ; parse_implicitly_qualified_symbol_name(DefaultModule, Term, SymbolNameResult), process_maybe1(make_name_specifier, SymbolNameResult, Result) ). :- pred make_name_arity_specifier(arity::in, sym_name::in, sym_name_specifier::out) is det. make_name_arity_specifier(Arity, Name, name_arity(Name, Arity)). :- pred make_name_specifier(sym_name::in, sym_name_specifier::out) is det. make_name_specifier(Name, name(Name)). %-----------------------------------------------------------------------------% % A SymbolName is one of % Name % Matches symbols with the specified name in the % current namespace. % Module.Name % Matches symbols with the specified name exported % by the specified module (where Module is itself a SymbolName). % % We also allow the syntax `Module__Name' as an alternative % for `Module.Name'. % :- pred parse_symbol_name(term(T)::in, maybe1(sym_name)::out) is det. parse_symbol_name(Term, Result) :- ( Term = term__functor(term__atom(FunctorName), [ModuleTerm, NameTerm], _Context), ( FunctorName = ":" ; FunctorName = "." ) -> ( NameTerm = term__functor(term__atom(Name), [], _Context1) -> parse_symbol_name(ModuleTerm, ModuleResult), ( ModuleResult = ok(Module), Result = ok(qualified(Module, Name)) ; ModuleResult = error(_, _), term__coerce(Term, ErrorTerm), Result = error("module name identifier " ++ "expected before ':' in qualified " ++ "symbol name", ErrorTerm) ) ; term__coerce(Term, ErrorTerm), Result = error("identifier expected after ':' " ++ "in qualified symbol name", ErrorTerm) ) ; ( Term = term__functor(term__atom(Name), [], _Context3) -> string_to_sym_name(Name, "__", SymName), Result = ok(SymName) ; term__coerce(Term, ErrorTerm), Result = error("symbol name expected", ErrorTerm) ) ). :- pred parse_implicitly_qualified_symbol_name(module_name::in, term::in, maybe1(sym_name)::out) is det. parse_implicitly_qualified_symbol_name(DefaultModName, Term, Result) :- parse_symbol_name(Term, Result0), ( Result0 = ok(SymName) -> ( root_module_name(DefaultModName) -> Result = Result0 ; SymName = qualified(ModName, _), \+ match_sym_name(ModName, DefaultModName) -> Result = error("module qualifier in definition " ++ "does not match preceding `:- module' declaration", Term) ; unqualify_name(SymName, UnqualName), Result = ok(qualified(DefaultModName, UnqualName)) ) ; Result = Result0 ). %-----------------------------------------------------------------------------% sym_name_and_args(Term, SymName, Args) :- parse_qualified_term(Term, Term, "", ok(SymName, Args)). parse_implicitly_qualified_term(DefaultModName, Term, ContainingTerm, Msg, Result) :- parse_qualified_term(Term, ContainingTerm, Msg, Result0), ( Result0 = ok(SymName, Args) -> ( root_module_name(DefaultModName) -> Result = Result0 ; SymName = qualified(ModName, _), \+ match_sym_name(ModName, DefaultModName) -> term__coerce(Term, ErrorTerm), Result = error("module qualifier in definition " ++ "does not match preceding " ++ " `:- module' declaration", ErrorTerm) ; unqualify_name(SymName, UnqualName), Result = ok(qualified(DefaultModName, UnqualName), Args) ) ; Result = Result0 ). parse_qualified_term(Term, ContainingTerm, Msg, Result) :- ( Term = term__functor(term__atom(FunctorName), [ModuleTerm, NameArgsTerm], _), FunctorName = "." -> ( NameArgsTerm = term__functor(term__atom(Name), Args, _) -> parse_symbol_name(ModuleTerm, ModuleResult), ( ModuleResult = ok(Module), Result = ok(qualified(Module, Name), Args) ; ModuleResult = error(_, _), term__coerce(Term, ErrorTerm), Result = error("module name identifier " ++ "expected before '.' in " ++ "qualified symbol name", ErrorTerm) ) ; term__coerce(Term, ErrorTerm), Result = error("identifier expected after '.' " ++ "in qualified symbol name", ErrorTerm) ) ; ( Term = term__functor(term__atom(Name), Args, _) -> string_to_sym_name(Name, "__", SymName), Result = ok(SymName, Args) ; string__append("atom expected in ", Msg, ErrorMsg), % Since variables don't have any term__context, if Term is % a variable, we use ContainingTerm instead (hopefully that % _will_ have a term__context). ( Term = term__variable(_) -> ErrorTerm0 = ContainingTerm ; ErrorTerm0 = Term ), term__coerce(ErrorTerm0, ErrorTerm), Result = error(ErrorMsg, ErrorTerm) ) ). %-----------------------------------------------------------------------------% % % Predicates used to convert a sym_list to a program item. :- pred make_use(sym_list::in, module_defn::out) is det. make_use(Syms, use(Syms)). :- pred make_import(sym_list::in, module_defn::out) is det. make_import(Syms, import(Syms)). :- pred make_export(sym_list::in, module_defn::out) is det. make_export(Syms, export(Syms)). %-----------------------------------------------------------------------------% % A FuncSpecifier is just a constructur name specifier. % :- pred parse_function_specifier(term::in, maybe1(func_specifier)::out) is det. parse_function_specifier(Term, Result) :- parse_constructor_specifier(Term, Result). % A TypeSpecifier is just a symbol name specifier. % :- pred parse_type_specifier(term::in, maybe1(sym_name_specifier)::out) is det. parse_type_specifier(Term, Result) :- parse_symbol_name_specifier(Term, Result). % An ADT_Specifier is just a symbol name specifier. % :- pred parse_adt_specifier(term::in, maybe1(sym_name_specifier)::out) is det. parse_adt_specifier(Term, Result) :- parse_symbol_name_specifier(Term, Result). %-----------------------------------------------------------------------------% % For the moment, an OpSpecifier is just a symbol name specifier. % XXX We should allow specifying the fixity of an operator % :- pred parse_op_specifier(term::in, maybe1(op_specifier)::out) is det. parse_op_specifier(Term, Result) :- parse_symbol_name_specifier(Term, R), process_maybe1(make_op_specifier, R, Result). :- pred make_op_specifier(sym_name_specifier::in, op_specifier::out) is det. make_op_specifier(X, sym(X)). %-----------------------------------------------------------------------------% :- func convert_constructor_arg_list(module_name, list(term)) = maybe1(list(constructor_arg)). convert_constructor_arg_list(_ModuleName, []) = ok([]). convert_constructor_arg_list( ModuleName, [Term | Terms]) = Result :- ( Term = term__functor(term__atom("::"), [NameTerm, TypeTerm], _) -> parse_implicitly_qualified_term(ModuleName, NameTerm, Term, "field name", NameResult), ( NameResult = error(String1, Term1), Result = error(String1, Term1) ; NameResult = ok(_SymName, [_ | _]), Result = error("syntax error in constructor name", Term) ; NameResult = ok(SymName, []), MaybeFieldName = yes(SymName), Result = convert_constructor_arg_list_2(ModuleName, MaybeFieldName, TypeTerm, Terms) ) ; MaybeFieldName = no, TypeTerm = Term, Result = convert_constructor_arg_list_2(ModuleName, MaybeFieldName, TypeTerm, Terms) ). :- func convert_constructor_arg_list_2(module_name, maybe(sym_name), term, list(term)) = maybe1(list(constructor_arg)). convert_constructor_arg_list_2(ModuleName, MaybeFieldName, TypeTerm, Terms) = Result :- parse_type(TypeTerm, TypeResult), ( TypeResult = ok(Type), Arg = MaybeFieldName - Type, Result0 = convert_constructor_arg_list(ModuleName, Terms), ( Result0 = error(String, Term), Result = error(String, Term) ; Result0 = ok(Args), Result = ok([Arg | Args]) ) ; TypeResult = error(String, Term), Result = error(String, Term) ). %-----------------------------------------------------------------------------% % We use the empty module name ('') as the "root" module name; when adding % default module qualifiers in parse_implicitly_qualified_{term,symbol}, % if the default module is the root module then we don't add any qualifier. % :- pred root_module_name(module_name::out) is det. root_module_name(unqualified("")). %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------%