%-----------------------------------------------------------------------------% % Copyright (C) 1993-2001 The University of Melbourne. % This file may only be copied under the terms of the GNU General % Public License - see the file COPYING in the Mercury distribution. %-----------------------------------------------------------------------------% % % File: prog_io.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 prog_io. :- interface. :- import_module prog_data, prog_io_util, timestamp. :- import_module bool, varset, term, list, io, std_util. %-----------------------------------------------------------------------------% % This module (prog_io) exports the following predicates: % prog_io__read_module(FileName, DefaultModuleName, Search, % ReturnTimestamp, Error, ActualModuleName, % Messages, Program, MaybeModuleTimestamp) % Reads and parses the module in file `FileName', % using the default module name `DefaultModuleName'. % If Search is `yes', search directories given by the option % search_directories. % If ReturnTimestamp is `yes', attempt to return the % modification timestamp in MaybeModuleTimestamp. % Error is `fatal' if the file coudn't be opened, `yes' % if a syntax error was detected, and `no' otherwise. % 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. :- type module_error ---> no_module_errors % no errors ; some_module_errors % some syntax errors ; fatal_module_errors. % couldn't open the file :- type file_name == string. :- type dir_name == string. :- pred prog_io__read_module(file_name, module_name, bool, bool, module_error, module_name, message_list, item_list, maybe(io__res(timestamp)), io__state, io__state). :- mode prog_io__read_module(in, in, in, in, out, out, out, out, out, di, uo) is det. :- pred prog_io__read_module_if_changed(file_name, module_name, bool, timestamp, module_error, module_name, message_list, item_list, maybe(io__res(timestamp)), io__state, io__state). :- mode prog_io__read_module_if_changed(in, in, in, in, out, out, out, out, out, di, uo) is det. % Same as prog_io__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 prog_io__read_opt_file(file_name, module_name, bool, module_error, message_list, item_list, io__state, io__state). :- mode prog_io__read_opt_file(in, in, in, out, out, out, di, 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, module_name, module_name, io__state, io__state). :- mode check_module_has_expected_name(in, in, in, di, uo) is det. % search_for_file(Dirs, FileName, Found, IO0, IO) % % Search Dirs for FileName, opening the file if it is found. :- pred search_for_file(list(dir_name), file_name, bool, io__state, io__state). :- mode search_for_file(in, in, out, di, 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, varset, term, maybe_item_and_context). :- mode parse_item(in, in, in, 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, varset, term, maybe_item_and_context). :- mode parse_decl(in, in, in, 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), sym_name, list(term(T))). :- mode sym_name_and_args(in, out, 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), term(T), string, maybe_functor(T)). :- mode parse_qualified_term(in, in, in, 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, term(T), term(T), string, maybe_functor(T)). :- mode parse_implicitly_qualified_term(in, in, in, in, out) is det. %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- implementation. :- import_module prog_io_goal, prog_io_dcg, prog_io_pragma, prog_io_util. :- import_module prog_io_typeclass. :- import_module hlds_data, hlds_pred, prog_util, prog_out. :- import_module globals, options, (inst). :- import_module recompilation, recompilation_version. :- import_module int, string, std_util, parser, term_io, dir, require. :- import_module assoc_list, map, time. %-----------------------------------------------------------------------------% prog_io__read_module(FileName, DefaultModuleName, Search, ReturnTimestamp, Error, ModuleName, Messages, Items, MaybeModuleTimestamp) --> prog_io__read_module_2(FileName, DefaultModuleName, Search, search_directories, no, ReturnTimestamp, Error, ModuleName, Messages, Items, MaybeModuleTimestamp). prog_io__read_module_if_changed(FileName, DefaultModuleName, Search, OldTimestamp, Error, ModuleName, Messages, Items, MaybeModuleTimestamp) --> prog_io__read_module_2(FileName, DefaultModuleName, Search, search_directories, yes(OldTimestamp), yes, Error, ModuleName, Messages, Items, MaybeModuleTimestamp). prog_io__read_opt_file(FileName, DefaultModuleName, Search, Error, Messages, Items) --> prog_io__read_module_2(FileName, DefaultModuleName, Search, intermod_directories, no, no, Error, ModuleName, Messages, Items, _), check_module_has_expected_name(FileName, DefaultModuleName, ModuleName). check_module_has_expected_name(FileName, ExpectedName, ActualName) --> ( { ActualName \= ExpectedName } -> { prog_out__sym_name_to_string(ActualName, ActualString) }, { prog_out__sym_name_to_string(ExpectedName, ExpectedString) }, io__stderr_stream(ErrStream), io__write_strings(ErrStream, [ "Error: file `", FileName, "' contains the wrong module.\n", "Expected module `", ExpectedString, "', found module `", ActualString, "'.\n" ]), io__set_exit_status(1) ; [] ). % This implementation uses io__read_term to read in the program % 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 prog_io__read_module_2(file_name, module_name, bool, option, maybe(timestamp), bool, module_error, module_name, message_list, item_list, maybe(io__res(timestamp)), io__state, io__state). :- mode prog_io__read_module_2(in, in, in, in, in, in, out, out, out, out, out, di, uo) is det. prog_io__read_module_2(FileName, DefaultModuleName, Search, SearchOpt, MaybeOldTimestamp, ReturnTimestamp, Error, ModuleName, Messages, Items, MaybeModuleTimestamp) --> ( { Search = yes } -> globals__io_lookup_accumulating_option(SearchOpt, Dirs) ; { dir__this_directory(CurrentDir) }, { Dirs = [CurrentDir] } ), io__input_stream(OldInputStream), search_for_file(Dirs, FileName, R), ( { R = yes } -> ( { ReturnTimestamp = yes } -> io__input_stream_name(InputStreamName), io__file_modification_time(InputStreamName, TimestampResult), ( { 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 prog_io__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__seen, io__set_input_stream(OldInputStream, _) ; io__progname_base("prog_io.m", Progname), { string__append(Progname, ": can't open file `", Message1), string__append(Message1, FileName, Message2), string__append(Message2, "'", Message), dummy_term(Term), Messages = [Message - Term], Error = fatal_module_errors, Items = [], ModuleName = DefaultModuleName, MaybeModuleTimestamp = no } ). search_for_file([], _, no) --> []. search_for_file([Dir | Dirs], FileName, R) --> { dir__this_directory(Dir) -> ThisFileName = FileName ; dir__directory_separator(Separator), string__first_char(Tmp1, Separator, FileName), string__append(Dir, Tmp1, ThisFileName) }, io__see(ThisFileName, R0), ( { R0 = ok } -> { R = yes } ; search_for_file(Dirs, FileName, R) ). %-----------------------------------------------------------------------------% % extract the final `:- end_module' declaration if any :- type module_end ---> no ; yes(module_name, prog_context). :- pred get_end_module(item_list, module_name, item_list, module_end). :- mode get_end_module(in, in, out, out) is det. get_end_module(RevItems0, ModuleName, 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.m. % RevItems0 = [ module_defn(_VarSet, end_module(ModuleName)) - Context | RevItems1] -> RevItems = RevItems1, 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, message_list, item_list, module_error, message_list, item_list, module_error, io__state, io__state). :- mode check_end_module(in, in, in, in, out, out, out, di, uo) is det. check_end_module(EndModule, Messages0, Items0, Error0, Messages, Items, Error) --> % % double-check that the first item is a `:- module ModuleName' % declaration, and remove it from the front of the item list % { Items0 = [module_defn(_VarSet, module(ModuleName1)) - _Context1 | Items1] -> Items = Items1, % % 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, Messages0, Messages), Error = some_module_errors ; Messages = Messages0, Error = Error0 ) ; % 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). :- mode dummy_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, term). :- mode dummy_term_with_context(in, out) is det. dummy_term_with_context(Context, Term) :- Term = term__functor(term__atom(""), [], Context). %-----------------------------------------------------------------------------% % 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, module_name, message_list, item_list, module_error, io__state, io__state). :- mode read_all_items(in, out, out, out, out, di, uo) is det. read_all_items(DefaultModuleName, ModuleName, Messages, Items, Error) --> % % read all the items (the first one is handled specially) % io__input_stream(Stream), io__input_stream_name(Stream, SourceFileName), read_first_item(DefaultModuleName, SourceFileName, ModuleName, RevMessages, RevItems0, Error0), % % 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(RevItems0, ModuleName, RevItems, EndModule) }, { list__reverse(RevMessages, Messages0) }, { list__reverse(RevItems, Items0) }, check_end_module(EndModule, Messages0, Items0, Error0, Messages, Items, Error). % % 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, file_name, module_name, message_list, item_list, module_error, io__state, io__state). :- mode read_first_item(in, in, out, out, out, out, di, uo) is det. read_first_item(DefaultModuleName, SourceFileName, ModuleName, Messages, Items, Error) --> globals__io_lookup_bool_option(warn_missing_module_name, WarnMissing), globals__io_lookup_bool_option(warn_wrong_module_name, WarnWrong), % % 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), { 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, Error) ; % % 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, Messages0 = [] ; match_sym_name(DefaultModuleName, StartModuleName) -> ModuleName = StartModuleName, Messages0 = [] ; prog_out__sym_name_to_string(StartModuleName, StartModuleNameString), string__append_list(["source file `", SourceFileName, "' contains module named `", StartModuleNameString, "'"], WrongModuleWarning), maybe_add_warning(WarnWrong, MaybeFirstTerm, FirstContext, WrongModuleWarning, [], Messages0), % 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) }, { Items0 = [FixedFirstItem] }, { Error0 = no_module_errors }, read_items_loop(ModuleName, SourceFileName, Messages0, Items0, Error0, Messages, Items, Error) ; % % 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, [], Messages0) ; Messages0 = [] }, { 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 = MaybeFirstTerm }, { process_read_term(ModuleName, MaybeSecondTerm, MaybeSecondItem) }, { Items0 = [FixedFirstItem] }, { Error0 = no_module_errors }, read_items_loop_2(MaybeSecondItem, ModuleName, SourceFileName, Messages0, Items0, Error0, Messages, Items, Error) ). :- pred make_module_decl(module_name, term__context, item_and_context). :- mode make_module_decl(in, in, 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, read_term, term__context, string, message_list, message_list). :- mode maybe_add_warning(in, in, in, in, in, out) is det. maybe_add_warning(DoWarn, MaybeTerm, Context, Warning, Messages0, Messages) :- ( DoWarn = yes -> ( MaybeTerm = term(_VarSet, Term) -> WarningTerm = Term ; dummy_term_with_context(Context, WarningTerm) ), add_warning(Warning, WarningTerm, Messages0, Messages) ; Messages = Messages0 ). %-----------------------------------------------------------------------------% % 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 big priority... :- pred read_items_loop(module_name, file_name, message_list, item_list, module_error, message_list, item_list, module_error, io__state, io__state). :- mode read_items_loop(in, in, in, in, in, out, out, out, di, uo) is det. read_items_loop(ModuleName, SourceFileName, Msgs1, Items1, Error1, Msgs, Items, Error) --> read_item(ModuleName, SourceFileName, MaybeItem), read_items_loop_2(MaybeItem, ModuleName, SourceFileName, Msgs1, Items1, Error1, Msgs, Items, Error). %-----------------------------------------------------------------------------% :- pred read_items_loop_2(maybe_item_or_eof, module_name, file_name, message_list, item_list, module_error, message_list, item_list, module_error, io__state, io__state). :- mode read_items_loop_2(in, in, in, in, in, in, out, out, out, di, uo) is det. % do a switch on the type of the next item read_items_loop_2(eof, _ModuleName, _SourceFileName, Msgs, Items, Error, Msgs, Items, Error) --> []. % if the next item was end-of-file, then we're done. read_items_loop_2(syntax_error(ErrorMsg, LineNumber), ModuleName, SourceFileName, Msgs0, Items0, _Error0, Msgs, Items, Error) --> % 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, Msgs1 = [ThisError | Msgs0], Items1 = Items0, Error1 = some_module_errors }, read_items_loop(ModuleName, SourceFileName, Msgs1, Items1, Error1, Msgs, Items, Error). read_items_loop_2(error(M, T), ModuleName, SourceFileName, Msgs0, Items0, _Error0, Msgs, Items, Error) --> % if the next item was a semantic error, then insert it in % the list of messages and continue looping { add_error(M, T, Msgs0, Msgs1), Items1 = Items0, Error1 = some_module_errors }, read_items_loop(ModuleName, SourceFileName, Msgs1, Items1, Error1, Msgs, Items, Error). read_items_loop_2(ok(Item0, Context), ModuleName0, SourceFileName0, Msgs0, Items0, Error0, Msgs, Items, Error) --> ( { Item0 = nothing(yes(Warning)) } -> { Warning = item_warning(MaybeOption, Msg, Term) }, ( { MaybeOption = yes(Option) } -> globals__io_lookup_bool_option(Option, Warn) ; { Warn = yes } ), ( { Warn = yes } -> { add_warning(Msg, Term, Msgs0, Msgs1) }, globals__io_lookup_bool_option(halt_at_warn, Halt), { Halt = yes -> Error1 = some_module_errors ; Error1 = Error0 } ; { Error1 = Error0 }, { Msgs1 = Msgs0 } ), { Item = nothing(no) } ; { Error1 = Error0 }, { Msgs1 = Msgs0 }, { 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, Items1 = Items0 ; Item = module_defn(_VarSet, module(NestedModuleName)) -> ModuleName = NestedModuleName, SourceFileName = SourceFileName0, Items1 = [Item - Context | Items0] ; Item = module_defn(_VarSet, end_module(NestedModuleName)) -> root_module_name(RootModuleName), sym_name_get_module_name(NestedModuleName, RootModuleName, ParentModuleName), ModuleName = ParentModuleName, SourceFileName = SourceFileName0, Items1 = [Item - Context | Items0] ; SourceFileName = SourceFileName0, ModuleName = ModuleName0, Items1 = [Item - Context | Items0] }, read_items_loop(ModuleName, SourceFileName, Msgs1, Items1, Error1, Msgs, Items, Error). %-----------------------------------------------------------------------------% % read_item/1 reads a single item, and if it is a valid term % parses it. :- type maybe_item_or_eof ---> eof ; syntax_error(file_name, int) ; error(string, term) ; ok(item, term__context). :- pred read_item(module_name, file_name, maybe_item_or_eof, io__state, io__state). :- mode read_item(in, in, out, di, uo) is det. read_item(ModuleName, SourceFileName, MaybeItem) --> parser__read_term(SourceFileName, MaybeTerm), { process_read_term(ModuleName, MaybeTerm, MaybeItem) }. :- pred process_read_term(module_name, read_term, maybe_item_or_eof). :- mode process_read_term(in, in, 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, maybe_item_or_eof). :- mode convert_item(in, 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) :- ( %%% some [Decl, DeclContext] Term = term__functor(term__atom(":-"), [Decl], _DeclContext) -> % It's a declaration parse_decl(ModuleName, VarSet, Decl, Result) ; %%% some [DCG_H, DCG_B, DCG_Context] % It's a DCG clause Term = term__functor(term__atom("-->"), [DCG_H, DCG_B], DCG_Context) -> parse_dcg_clause(ModuleName, VarSet, DCG_H, DCG_B, DCG_Context, Result) ; % It's either a fact or a rule ( %%% some [H, B, TermContext] 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, ProgVarSet, Body2, ProgVarSet2), ( Head = term__functor(term__atom("="), [FuncHead, FuncResult], _) -> 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, prog_varset, goal, maybe1(item)). :- mode process_pred_clause(in, in, in, out) is det. process_pred_clause(ok(Name, Args0), VarSet, Body, ok(clause(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, term, prog_varset, goal, maybe1(item)). :- mode process_func_clause(in, in, in, in, out) is det. process_func_clause(ok(Name, Args0), Result0, VarSet, Body, ok(clause(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(tvar)) ; constraints(quantifier_type, term). % the term here is the (not yet parsed) list of constraints :- type quantifier_type ---> exist ; univ. :- type decl_attrs == list(pair(decl_attribute, term)). % 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. 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, varset, term, decl_attrs, maybe_item_and_context). :- mode parse_decl_2(in, in, in, in, 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, varset, string, list(term), decl_attrs, maybe1(item)). :- mode process_decl(in, in, in, in, in, out) is semidet. process_decl(ModuleName, VarSet, "type", [TypeDecl], Attributes, Result) :- parse_type_decl(ModuleName, VarSet, TypeDecl, Result0), check_no_attributes(Result0, 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, Result0), check_no_attributes(Result0, 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", [PredSpec], Attributes, Result) :- parse_symbol_name_specifier(PredSpec, Result0), process_maybe1(make_external(VarSet), 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). % NU-Prolog `when' declarations used to be silently ignored for % backwards compatibility. We now issue a warning that they % are deprecated. We should eventually drop support for them % entirely. process_decl(_ModuleName, _VarSet, "when", [Goal, _Cond], Attributes, Result) :- ( Goal = term__functor(_, _, Context0) -> Context = Context0 ; term__context_init(Context) ), dummy_term_with_context(Context, DummyTerm), Result0 = ok(nothing(yes(item_warning(no, "NU-Prolog `when' declarations are deprecated", DummyTerm )))), check_no_attributes(Result0, 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_assertion(ModuleName, VarSet, Assertion, Result0), check_no_attributes(Result0, 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) ) ). :- pred parse_decl_attribute(string, list(term), decl_attribute, term). :- mode parse_decl_attribute(in, in, out, out) is semidet. parse_decl_attribute("impure", [Decl], purity(impure), Decl). parse_decl_attribute("semipure", [Decl], 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", [TVars0, Decl], quantifier(exist, TVarsList), Decl) :- term__coerce(TVars0, TVars), parse_list_of_vars(TVars, TVarsList). parse_decl_attribute("all", [TVars0, Decl], quantifier(univ, TVarsList), Decl) :- term__coerce(TVars0, TVars), parse_list_of_vars(TVars, TVarsList). :- pred check_no_attributes(maybe1(item), decl_attrs, maybe1(item)). :- mode check_no_attributes(in, in, 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, string). :- mode attribute_description(in, 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 (`=>')"). %-----------------------------------------------------------------------------% % parse the assertion declaration. :- pred parse_assertion(module_name, varset, list(term), maybe1(item)). :- mode parse_assertion(in, in, in, out) is semidet. parse_assertion(_ModuleName, VarSet, [AssertionTerm], Result) :- varset__coerce(VarSet, ProgVarSet), parse_goal(AssertionTerm, ProgVarSet, AssertGoal, AssertVarSet), Result = ok(assertion(AssertGoal, AssertVarSet)). %-----------------------------------------------------------------------------% :- pred parse_type_decl(module_name, varset, term, maybe1(item)). :- mode parse_type_decl(in, in, in, out) is det. parse_type_decl(ModuleName, VarSet, TypeDecl, Result) :- ( TypeDecl = term__functor(term__atom(Name), Args, _), parse_type_decl_type(ModuleName, Name, Args, Cond, R) -> R1 = R, Cond1 = Cond ; process_abstract_type(ModuleName, TypeDecl, R1), Cond1 = true ), process_maybe1(make_type_defn(VarSet, Cond1), R1, Result). % we should check the condition for errs % (don't bother at the moment, since we ignore % conditions anyhow :-) :- pred make_type_defn(varset, condition, processed_type_body, item). :- mode make_type_defn(in, in, in, 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, sym_name_specifier, item). :- mode make_external(in, in, out) is det. make_external(VarSet0, SymSpec, module_defn(VarSet, external(SymSpec))) :- varset__coerce(VarSet0, VarSet). %-----------------------------------------------------------------------------% % add a warning message to the list of messages :- pred add_warning(string, term, message_list, message_list). :- mode add_warning(in, in, in, 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, term, message_list, message_list). :- mode add_error(in, in, in, 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, string, list(term), condition, maybe1(processed_type_body)). :- mode parse_type_decl_type(in, in, in, out, out) is semidet. parse_type_decl_type(ModuleName, "--->", [H, B], Condition, R) :- /* get_condition(...), */ Condition = true, get_maybe_equality_pred(B, Body, EqualityPred), process_du_type(ModuleName, H, Body, EqualityPred, R). parse_type_decl_type(ModuleName, "=", [H, B], Condition, R) :- get_condition(B, Body, Condition), process_uu_type(ModuleName, H, Body, R). parse_type_decl_type(ModuleName, "==", [H, B], Condition, R) :- get_condition(B, Body, Condition), process_eqv_type(ModuleName, H, Body, R). %-----------------------------------------------------------------------------% % 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, varset, term, decl_attrs, maybe1(item)). :- mode parse_type_decl_pred(in, in, in, in, out) is det. parse_type_decl_pred(ModuleName, VarSet, Pred, Attributes, R) :- get_condition(Pred, Body, Condition), get_determinism(Body, Body2, MaybeDeterminism), process_type_decl_pred(ModuleName, MaybeDeterminism, VarSet, Body2, Condition, Attributes, R). :- pred process_type_decl_pred(module_name, maybe1(maybe(determinism)), varset, term, condition, decl_attrs, maybe1(item)). :- mode process_type_decl_pred(in, in, in, in, in, in, out) is det. process_type_decl_pred(_MNm, error(Term, Reason), _, _, _, _, error(Term, Reason)). process_type_decl_pred(ModuleName, ok(MaybeDeterminism), VarSet, Body, Condition, Attributes, R) :- process_pred(ModuleName, VarSet, Body, Condition, MaybeDeterminism, Attributes, R). %-----------------------------------------------------------------------------% % 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, varset, term, decl_attrs, maybe1(item)). :- mode parse_type_decl_func(in, in, in, in, out) is det. parse_type_decl_func(ModuleName, VarSet, Func, Attributes, R) :- get_condition(Func, Body, Condition), get_determinism(Body, Body2, MaybeDeterminism), process_maybe1_to_t(process_func(ModuleName, VarSet, Body2, Condition, Attributes), MaybeDeterminism, R). %-----------------------------------------------------------------------------% % 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, varset, term, maybe1(item)). :- mode parse_mode_decl_pred(in, in, in, out) is det. parse_mode_decl_pred(ModuleName, VarSet, Pred, Result) :- get_condition(Pred, Body, Condition), get_determinism(Body, Body2, MaybeDeterminism), process_maybe1_to_t(process_mode(ModuleName, VarSet, Body2, Condition), MaybeDeterminism, Result). %-----------------------------------------------------------------------------% % get_maybe_equality_pred(Body0, Body, MaybeEqualPred): % Checks if `Body0' is a term of the form % ` where equality is ' % If so, returns the `' in Body and the in % MaybeEqualPred. If not, returns Body = Body0 % and `no' in MaybeEqualPred. :- pred get_maybe_equality_pred(term, term, maybe1(maybe(sym_name))). :- mode get_maybe_equality_pred(in, out, out) is det. get_maybe_equality_pred(B, Body, MaybeEqualityPred) :- ( B = term__functor(term__atom("where"), Args, _Context1), Args = [Body1, Equality_Is_PredName] -> Body = Body1, ( Equality_Is_PredName = term__functor(term__atom("is"), [Equality, PredName], _), Equality = term__functor(term__atom("equality"), [], _) -> parse_symbol_name(PredName, MaybeEqualityPred0), process_maybe1(make_yes, MaybeEqualityPred0, MaybeEqualityPred) ; MaybeEqualityPred = error("syntax error after `where'", Body) ) ; Body = B, MaybeEqualityPred = ok(no) ). :- pred make_yes(T::in, maybe(T)::out) is det. make_yes(T, yes(T)). % 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, term, maybe1(maybe(determinism))). :- mode get_determinism(in, out, 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) ). %-----------------------------------------------------------------------------% % 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, term, condition). :- mode get_condition(in, out, 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; also for type classes, eventually...) % 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 ). % This is for "Head = Body" (undiscriminated union) definitions. :- pred process_uu_type(module_name, term, term, maybe1(processed_type_body)). :- mode process_uu_type(in, in, in, out) is det. process_uu_type(ModuleName, Head, Body, Result) :- check_for_errors(ModuleName, Head, Body, Result0), process_uu_type_2(Result0, Body, Result). :- pred process_uu_type_2(maybe_functor, term, maybe1(processed_type_body)). :- mode process_uu_type_2(in, in, out) is det. process_uu_type_2(error(Error, Term), _, error(Error, Term)). process_uu_type_2(ok(Name, Args0), Body, ok(processed_type_body(Name, Args, uu_type(List)))) :- list__map(term__coerce, Args0, Args), sum_to_list(Body, List0), list__map(convert_type, List0, List). %-----------------------------------------------------------------------------% % This is for "Head == Body" (equivalence) definitions. :- pred process_eqv_type(module_name, term, term, maybe1(processed_type_body)). :- mode process_eqv_type(in, in, in, out) is det. process_eqv_type(ModuleName, Head, Body, Result) :- check_for_errors(ModuleName, Head, Body, Result0), process_eqv_type_2(Result0, Body, Result). :- pred process_eqv_type_2(maybe_functor, term, maybe1(processed_type_body)). :- mode process_eqv_type_2(in, in, out) is det. process_eqv_type_2(error(Error, Term), _, error(Error, Term)). process_eqv_type_2(ok(Name, Args0), Body0, Result) :- % check that all the variables in the body occur in the head ( ( term__contains_var(Body0, Var2), \+ term__contains_var_list(Args0, Var2) ) -> Result = error("free type parameter in RHS of type definition", Body0) ; list__map(term__coerce, Args0, Args), convert_type(Body0, Body), Result = ok(processed_type_body(Name, Args, eqv_type(Body))) ). %-----------------------------------------------------------------------------% % process_du_type(ModuleName, TypeHead, TypeBody, 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" (constructor) definitions. :- pred process_du_type(module_name, term, term, maybe1(maybe(equality_pred)), maybe1(processed_type_body)). :- mode process_du_type(in, in, in, in, out) is det. process_du_type(ModuleName, Head, Body, EqualityPred, Result) :- check_for_errors(ModuleName, Head, Body, Result0), process_du_type_2(ModuleName, Result0, Body, EqualityPred, Result). :- pred process_du_type_2(module_name, maybe_functor, term, maybe1(maybe(equality_pred)), maybe1(processed_type_body)). :- mode process_du_type_2(in, in, in, in, out) is det. process_du_type_2(_, error(Error, Term), _, _, error(Error, Term)). process_du_type_2(ModuleName, ok(Functor, Args0), Body, MaybeEqualityPred, Result) :- % check that body is a disjunction of constructors list__map(term__coerce, Args0, Args), ( convert_constructors(ModuleName, Body, Constrs) -> % check that all type variables in the body % are either explicitly existentially quantified % or occur in the head. ( list__member(Ctor, Constrs), Ctor = ctor(ExistQVars, _Constraints, _CtorName, CtorArgs), assoc_list__values(CtorArgs, CtorArgTypes), term__contains_var_list(CtorArgTypes, Var), \+ list__member(Var, ExistQVars), \+ term__contains_var_list(Args, Var) -> 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, Constrs), Ctor = ctor(ExistQVars, _Constraints, _CtorName, _CtorArgs), list__member(Var, ExistQVars), term__contains_var_list(Args, Var) -> 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 % (not just the constraints) ; list__member(Ctor, Constrs), Ctor = ctor(ExistQVars, _Constraints, _CtorName, CtorArgs), list__member(Var, ExistQVars), assoc_list__values(CtorArgs, CtorArgTypes), \+ term__contains_var_list(CtorArgTypes, Var) -> Result = error( "type variable in existential quantifier does not occur in arguments of constructor", Body) % check that all type variables in existential constraints % occur in the existential quantifiers % (XXX is this check overly conservative? Perhaps we should % allow existential constraints so long as they contain % at least one type variable which is existentially quantified, % rather than requiring all variables in them to be % existentially quantified.) ; list__member(Ctor, Constrs), Ctor = ctor(ExistQVars, Constraints, _CtorName, _CtorArgs), list__member(Constraint, Constraints), Constraint = constraint(_Name, ConstraintArgs), term__contains_var_list(ConstraintArgs, Var), \+ list__member(Var, ExistQVars) -> Result = error("type variables in class constraints introduced with `=>' must be explicitly existentially quantified using `some'", Body) ; ( MaybeEqualityPred = ok(EqualityPred), Result = ok(processed_type_body(Functor, Args, du_type(Constrs, EqualityPred))) ; MaybeEqualityPred = error(Error, Term), Result = error(Error, Term) ) ) ; Result = error("invalid RHS of type definition", Body) ). %-----------------------------------------------------------------------------% % 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, term, maybe1(processed_type_body)). :- mode process_abstract_type(in, in, out) is det. process_abstract_type(ModuleName, Head, Result) :- dummy_term(Body), check_for_errors(ModuleName, Head, Body, Result0), process_abstract_type_2(Result0, Result). :- pred process_abstract_type_2(maybe_functor, maybe1(processed_type_body)). :- mode process_abstract_type_2(in, out) is det. process_abstract_type_2(error(Error, Term), error(Error, Term)). process_abstract_type_2(ok(Functor, Args0), ok(processed_type_body(Functor, Args, abstract_type))) :- list__map(term__coerce, Args0, Args). %-----------------------------------------------------------------------------% % check a type definition for errors :- pred check_for_errors(module_name, term, term, maybe_functor). :- mode check_for_errors(in, in, in, out) is det. check_for_errors(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), check_for_errors_2(R, Body, Head, Result) ). :- pred check_for_errors_2(maybe_functor, term, term, maybe_functor). :- mode check_for_errors_2(in, in, in, out) is det. check_for_errors_2(error(Msg, Term), _, _, error(Msg, Term)). check_for_errors_2(ok(Name, Args), Body, Head, Result) :- check_for_errors_3(Name, Args, Body, Head, Result). :- pred check_for_errors_3(sym_name, list(term), term, term, maybe_functor). :- mode check_for_errors_3(in, in, in, in, out) is det. check_for_errors_3(Name, Args, _Body, Head, Result) :- % check that all the head args are variables ( %%% some [Arg] ( list__member(Arg, Args), Arg \= term__variable(_) ) -> Result = error("type parameters must be variables", Head) ; % check that all the head arg variables are distinct %%% some [Arg2, OtherArgs] ( list__member(Arg2, Args, [Arg2|OtherArgs]), list__member(Arg2, OtherArgs) ) -> Result = error("repeated type parameters in LHS of type defn", Head) ; Result = ok(Name, Args) ). %-----------------------------------------------------------------------------% % 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 :- pred convert_constructors(module_name, term, list(constructor)). :- mode convert_constructors(in, in, out) is semidet. convert_constructors(ModuleName, Body, Constrs) :- disjunction_to_list(Body, List), convert_constructors_2(ModuleName, List, Constrs). % true if input argument is a valid list of constructors :- pred convert_constructors_2(module_name, list(term), list(constructor)). :- mode convert_constructors_2(in, in, out) is semidet. convert_constructors_2(_, [], []). convert_constructors_2(ModuleName, [Term | Terms], [Constr | Constrs]) :- convert_constructor(ModuleName, Term, Constr), convert_constructors_2(ModuleName, Terms, Constrs). % true if input argument is a valid constructor. :- pred convert_constructor(module_name, term, constructor). :- mode convert_constructor(in, in, out) is semidet. convert_constructor(ModuleName, Term0, Result) :- ( Term0 = term__functor(term__atom("some"), [Vars, Term1], _) -> parse_list_of_vars(Vars, ExistQVars0), list__map(term__coerce_var, ExistQVars0, ExistQVars), Term2 = Term1 ; ExistQVars = [], Term2 = Term0 ), get_existential_constraints_from_term(ModuleName, Term2, Term3, 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. Term3 = term__functor(term__atom("{}"), [Term4], _Context) -> Term5 = Term4 ; Term5 = Term3 ), parse_implicitly_qualified_term(ModuleName, Term5, Term0, "constructor definition", ok(F, As)), convert_constructor_arg_list(ModuleName, As, Args), Result = ctor(ExistQVars, Constraints, F, Args). %-----------------------------------------------------------------------------% % parse a `:- pred p(...)' declaration :- pred process_pred(module_name, varset, term, condition, maybe(determinism), decl_attrs, maybe1(item)). :- mode process_pred(in, in, in, in, in, in, out) is det. process_pred(ModuleName, VarSet, PredType, Cond, MaybeDet, Attributes0, Result) :- get_class_context(ModuleName, Attributes0, Attributes, MaybeContext), ( MaybeContext = ok(ExistQVars, Constraints), parse_implicitly_qualified_term(ModuleName, PredType, PredType, "`:- pred' declaration", R), process_pred_2(R, PredType, VarSet, MaybeDet, Cond, ExistQVars, Constraints, Attributes, Result) ; MaybeContext = error(String, Term), Result = error(String, Term) ). :- pred process_pred_2(maybe_functor, term, varset, maybe(determinism), condition, existq_tvars, class_constraints, decl_attrs, maybe1(item)). :- mode process_pred_2(in, in, in, in, in, in, in, in, out) is det. process_pred_2(ok(F, As0), PredType, VarSet0, MaybeDet, Cond, ExistQVars, ClassContext, Attributes0, Result) :- ( convert_type_and_mode_list(As0, As) -> ( verify_type_and_mode_list(As) -> get_purity(Attributes0, Purity, Attributes), varset__coerce(VarSet0, TVarSet), varset__coerce(VarSet0, IVarSet), Result0 = ok(pred_or_func(TVarSet, IVarSet, ExistQVars, predicate, F, As, 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' declaration", PredType) ). process_pred_2(error(M, T), _, _, _, _, _, _, _, error(M, T)). :- pred get_purity(decl_attrs, purity, decl_attrs). :- mode get_purity(in, out, out) is det. get_purity(Attributes0, Purity, Attributes) :- ( Attributes0 = [purity(Purity0) - _ | Attributes1] -> Purity = Purity0, Attributes = Attributes1 ; Purity = (pure), Attributes = Attributes0 ). %-----------------------------------------------------------------------------% % We could perhaps get rid of some code duplication between here and % prog_io_typeclass.m? % get_class_context(ModuleName, Attributes0, Attributes, MaybeContext): % Parse type quantifiers and type class 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). % Attributes is bound to the remaining attributes. :- pred get_class_context(module_name, decl_attrs, decl_attrs, maybe2(existq_tvars, class_constraints)). :- mode get_class_context(in, in, out, out) is det. get_class_context(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_tvars(univ, ModuleName, Attributes0, [], Attributes1, _UnivQVars), get_quant_tvars(exist, ModuleName, Attributes1, [], Attributes2, 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(maybe1(list(class_constraint)), maybe1(list(class_constraint)), existq_tvars, maybe2(existq_tvars, class_constraints)). :- mode combine_quantifier_results(in, in, in, 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), ok(ExistConstraints), ExistQVars, ok(ExistQVars, constraints(UnivConstraints, ExistConstraints))). :- pred get_quant_tvars(quantifier_type, module_name, decl_attrs, list(tvar), decl_attrs, list(tvar)). :- mode get_quant_tvars(in, in, in, in, out, out) is det. get_quant_tvars(QuantType, ModuleName, Attributes0, TVars0, Attributes, TVars) :- ( Attributes0 = [quantifier(QuantType, TVars1) - _ | Attributes1] -> list__append(TVars0, TVars1, TVars2), get_quant_tvars(QuantType, ModuleName, Attributes1, TVars2, Attributes, TVars) ; Attributes = Attributes0, TVars = TVars0 ). :- pred get_constraints(quantifier_type, module_name, decl_attrs, decl_attrs, maybe1(list(class_constraint))). :- mode get_constraints(in, in, in, out, out) is det. get_constraints(QuantType, ModuleName, Attributes0, Attributes, MaybeConstraints) :- ( Attributes0 = [constraints(QuantType, ConstraintsTerm) - _Term | Attributes1] -> parse_class_constraints(ModuleName, ConstraintsTerm, MaybeConstraints0), % there may be more constraints of the same type -- % collect them all and combine them get_constraints(QuantType, ModuleName, Attributes1, Attributes, MaybeConstraints1), combine_constraint_list_results(MaybeConstraints1, MaybeConstraints0, MaybeConstraints) ; Attributes = Attributes0, MaybeConstraints = ok([]) ). :- pred combine_constraint_list_results(maybe1(list(class_constraint)), maybe1(list(class_constraint)), maybe1(list(class_constraint))). :- mode combine_constraint_list_results(in, in, 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(Constraints0), ok(Constraints1), ok(Constraints)) :- list__append(Constraints0, Constraints1, Constraints). :- pred get_existential_constraints_from_term(module_name, term, term, maybe1(list(class_constraint))). :- mode get_existential_constraints_from_term(in, in, out, out) is det. get_existential_constraints_from_term(ModuleName, PredType0, PredType, MaybeExistentialConstraints) :- ( PredType0 = term__functor(term__atom("=>"), [PredType1, ExistentialConstraints], _) -> PredType = PredType1, parse_class_constraints(ModuleName, ExistentialConstraints, MaybeExistentialConstraints) ; PredType = PredType0, 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)). :- mode verify_type_and_mode_list(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), type_and_mode). :- mode verify_type_and_mode_list_2(in, 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, varset, term, condition, decl_attrs, maybe(determinism), maybe1(item)). :- mode process_func(in, in, in, in, in, in, out) is det. process_func(ModuleName, VarSet, Term, Cond, Attributes0, MaybeDet, Result) :- get_class_context(ModuleName, Attributes0, Attributes, MaybeContext), ( MaybeContext = ok(ExistQVars, Constraints), process_func_2(ModuleName, VarSet, Term, Cond, MaybeDet, ExistQVars, Constraints, Attributes, Result) ; MaybeContext = error(String, ErrorTerm), Result = error(String, ErrorTerm) ). :- pred process_func_2(module_name, varset, term, condition, maybe(determinism), existq_tvars, class_constraints, decl_attrs, maybe1(item)). :- mode process_func_2(in, in, in, in, in, in, in, in, out) is det. process_func_2(ModuleName, VarSet, Term, Cond, MaybeDet, ExistQVars, Constraints, Attributes, Result) :- ( Term = term__functor(term__atom("="), [FuncTerm, ReturnTypeTerm], _Context) -> parse_implicitly_qualified_term(ModuleName, FuncTerm, Term, "`:- func' declaration", R), process_func_3(R, FuncTerm, ReturnTypeTerm, VarSet, MaybeDet, Cond, ExistQVars, Constraints, Attributes, Result) ; Result = error("`=' expected in `:- func' declaration", Term) ). :- pred process_func_3(maybe_functor, term, term, varset, maybe(determinism), condition, existq_tvars, class_constraints, decl_attrs, maybe1(item)). :- mode process_func_3(in, in, in, in, in, in, in, in, in, out) is det. process_func_3(ok(F, As0), FuncTerm, ReturnTypeTerm, VarSet0, MaybeDet, Cond, ExistQVars, ClassContext, Attributes0, Result) :- ( convert_type_and_mode_list(As0, As) -> ( \+ verify_type_and_mode_list(As) -> Result = error("some but not all arguments have modes", FuncTerm) ; convert_type_and_mode(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(Attributes0, Purity, Attributes), varset__coerce(VarSet0, TVarSet), varset__coerce(VarSet0, IVarSet), list__append(As, [ReturnType], Args), Result0 = ok(pred_or_func(TVarSet, IVarSet, ExistQVars, function, F, Args, MaybeDet, Cond, Purity, ClassContext)), check_no_attributes(Result0, Attributes, Result) ) ; 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)). %-----------------------------------------------------------------------------% % parse a `:- mode p(...)' declaration :- pred process_mode(module_name, varset, term, condition, maybe(determinism), maybe1(item)). :- mode process_mode(in, in, in, in, in, out) is det. process_mode(ModuleName, VarSet, Term, Cond, MaybeDet, Result) :- ( Term = term__functor(term__atom("="), [FuncTerm, ReturnTypeTerm], _Context) -> parse_implicitly_qualified_term(ModuleName, FuncTerm, Term, "function `:- mode' declaration", R), process_func_mode(R, FuncTerm, ReturnTypeTerm, VarSet, MaybeDet, Cond, Result) ; parse_implicitly_qualified_term(ModuleName, Term, Term, "predicate `:- mode' declaration", R), process_pred_mode(R, Term, VarSet, MaybeDet, Cond, Result) ). :- pred process_pred_mode(maybe_functor, term, varset, maybe(determinism), condition, maybe1(item)). :- mode process_pred_mode(in, in, in, in, in, out) is det. process_pred_mode(ok(F, As0), PredMode, VarSet0, MaybeDet, Cond, Result) :- ( convert_mode_list(As0, As1) -> list__map(constrain_inst_vars_in_mode, As1, As), varset__coerce(VarSet0, VarSet), Result = ok(pred_or_func_mode(VarSet, predicate, F, As, MaybeDet, Cond)) ; Result = error("syntax error in predicate mode declaration", PredMode) ). process_pred_mode(error(M, T), _, _, _, _, error(M, T)). :- pred process_func_mode(maybe_functor, term, term, varset, maybe(determinism), condition, maybe1(item)). :- mode process_func_mode(in, in, in, in, in, in, out) is det. process_func_mode(ok(F, As0), FuncMode, RetMode0, VarSet0, MaybeDet, Cond, Result) :- ( convert_mode_list(As0, As1) -> list__map(constrain_inst_vars_in_mode, As1, As), ( convert_mode(RetMode0, RetMode1) -> constrain_inst_vars_in_mode(RetMode1, RetMode), varset__coerce(VarSet0, VarSet), list__append(As, [RetMode], ArgModes), Result = ok(pred_or_func_mode(VarSet, function, F, ArgModes, MaybeDet, Cond)) ; Result = error( "syntax error in return mode of function mode declaration", RetMode0) ) ; Result = error( "syntax error in arguments of function mode declaration", FuncMode) ). process_func_mode(error(M, T), _, _, _, _, _, error(M, T)). %-----------------------------------------------------------------------------% % Replace all occurrences of inst_var(I) with % ground(shared, constrained_inst_var(I)). :- pred constrain_inst_vars_in_mode(mode, mode). :- mode constrain_inst_vars_in_mode(in, out) is det. constrain_inst_vars_in_mode(I0 -> F0, I -> F) :- constrain_inst_vars_in_inst(I0, I), constrain_inst_vars_in_inst(F0, F). constrain_inst_vars_in_mode(user_defined_mode(Name, Args0), user_defined_mode(Name, Args)) :- list__map(constrain_inst_vars_in_inst, Args0, Args). :- pred constrain_inst_vars_in_inst(inst, inst). :- mode constrain_inst_vars_in_inst(in, 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(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, Is0, Is)), BIs0, BIs). constrain_inst_vars_in_inst(ground(U, none), ground(U, none)). constrain_inst_vars_in_inst(ground(U, higher_order(PredInstInfo0)), ground(U, higher_order(PredInstInfo))) :- constrain_inst_vars_in_pred_inst_info(PredInstInfo0, PredInstInfo). constrain_inst_vars_in_inst(ground(U, constrained_inst_var(V)), ground(U, constrained_inst_var(V))). constrain_inst_vars_in_inst(not_reached, not_reached). constrain_inst_vars_in_inst(inst_var(V), ground(shared, constrained_inst_var(V))). constrain_inst_vars_in_inst(defined_inst(Name0), defined_inst(Name)) :- constrain_inst_vars_in_inst_name(Name0, Name). constrain_inst_vars_in_inst(abstract_inst(N, Is0), abstract_inst(N, Is)) :- list__map(constrain_inst_vars_in_inst, Is0, Is). :- pred constrain_inst_vars_in_pred_inst_info(pred_inst_info, pred_inst_info). :- mode constrain_inst_vars_in_pred_inst_info(in, out) is det. constrain_inst_vars_in_pred_inst_info(PII0, PII) :- PII0 = pred_inst_info(PredOrFunc, Modes0, Det), list__map(constrain_inst_vars_in_mode, Modes0, Modes), PII = pred_inst_info(PredOrFunc, Modes, Det). :- pred constrain_inst_vars_in_inst_name(inst_name, inst_name). :- mode constrain_inst_vars_in_inst_name(in, out) is det. constrain_inst_vars_in_inst_name(Name0, Name) :- ( Name0 = user_inst(SymName, Args0) -> list__map(constrain_inst_vars_in_inst, Args0, Args), Name = user_inst(SymName, Args) ; Name = Name0 ). %-----------------------------------------------------------------------------% % Parse a `:- inst .' declaration. % % `==' is the correct operator to use, although we accept % `=' as well. Since `=' was once the standard operator, make % sure warnings are given before it is phased out. % :- pred parse_inst_decl(module_name, varset, term, maybe1(item)). :- mode parse_inst_decl(in, in, in, out) is det. parse_inst_decl(ModuleName, VarSet, InstDefn, Result) :- ( InstDefn = term__functor(term__atom(Op), [H, B], _Context), ( Op = "=" ; 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), process_maybe1(make_inst_defn(VarSet, Condition), R, Result) ; Result = error("`==' expected in `:- inst' definition", InstDefn) ). % we should check the condition for errs % (don't bother at the moment, since we ignore % conditions anyhow :-) % Parse a `:- inst ---> .' definition. % :- pred convert_inst_defn(module_name, term, term, maybe1(processed_inst_body)). :- mode convert_inst_defn(in, in, in, 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, term, term, maybe1(processed_inst_body)). :- mode convert_inst_defn_2(in, in, in, 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(Head, UserInst), UserInst = defined_inst(user_inst(_, _)) ) -> Result = error("attempt to redefine builtin inst", Head) ; % should improve the error message here ( convert_inst(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, term, maybe1(processed_inst_body)). :- mode convert_abstract_inst_defn(in, in, 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, term, maybe1(processed_inst_body)). :- mode convert_abstract_inst_defn_2(in, in, 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, condition, processed_inst_body, item). :- mode make_inst_defn(in, in, in, 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 :: ...' or `:- mode foo = ...' definition. :- pred parse_mode_decl(module_name, varset, term, maybe1(item)). :- mode parse_mode_decl(in, in, in, out) is det. parse_mode_decl(ModuleName, VarSet, ModeDefn, Result) :- ( %%% some [H, B] 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, Result) ). % People never seemed to remember what the right operator to use % in a `:- mode' declaration is, so the syntax is accepted both % `::' and `==', with `::' formerly the standard operator. % % % Old syntax % :- mode foo :: someinst -> someotherinst. % % But using `==' was a pain, because the precedence of `->' was % too high. We now accept `>>' as an alternative to `->', and % `==' is now the standard operator to use in a `:- mode' % declaration. This is part of a long term plan to free up % `::' as an operator so we can use it for mode qualification. % % % New syntax % :- mode foo == someinst >> someotherinst. % % We still support `::' in mode declarations for backwards % compatibility, but it might be removed one day. % Before phasing it out, a deprecated syntax warning should be % given for a version or two. % :- pred mode_op(term, term, term). :- mode mode_op(in, out, out) is semidet. mode_op(term__functor(term__atom(Op), [H, B], _), H, B) :- ( Op = "==" ; Op = "::" ). :- type processed_mode_body ---> processed_mode_body( sym_name, list(inst_var), mode_defn ). :- pred convert_mode_defn(module_name, term, term, maybe1(processed_mode_body)). :- mode convert_mode_defn(in, in, in, 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, term, term, maybe1(processed_mode_body)). :- mode convert_mode_defn_2(in, in, in, 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(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(list(term), list(type_and_mode)). :- mode convert_type_and_mode_list(in, out) is semidet. convert_type_and_mode_list([], []). convert_type_and_mode_list([H0|T0], [H|T]) :- convert_type_and_mode(H0, H), convert_type_and_mode_list(T0, T). :- pred convert_type_and_mode(term, type_and_mode). :- mode convert_type_and_mode(in, out) is semidet. convert_type_and_mode(Term, Result) :- ( Term = term__functor(term__atom("::"), [TypeTerm, ModeTerm], _Context) -> convert_type(TypeTerm, Type), convert_mode(ModeTerm, Mode0), constrain_inst_vars_in_mode(Mode0, Mode), Result = type_and_mode(Type, Mode) ; convert_type(Term, Type), Result = type_only(Type) ). :- pred make_mode_defn(varset, condition, processed_mode_body, item). :- mode make_mode_defn(in, in, in, 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), maker(list(T), sym_list), maker(sym_list, module_defn), term, decl_attrs, varset, maybe1(item)). :- mode parse_symlist_decl(parser, maker, maker, in, in, in, 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(sym_list, module_defn), varset, T, item). :- mode make_module_defn(maker, maker, in, in, 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), maybe1(T1), maybe1(T2)). :- mode process_maybe1(maker, in, 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)), maybe1(T1), maybe1(T2)). :- mode process_maybe1_to_t(maker, in, 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, maybe1(sym_specifier)). :- mode parse_symbol_specifier(in, 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, sym_specifier). :- mode cons_specifier_to_sym_specifier(in, 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, maybe1(module_specifier)). :- mode parse_module_specifier(in, 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, term, maybe1(module_name)). :- mode parse_module_name(in, in, 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, maybe1(cons_specifier)). :- mode parse_constructor_specifier(in, 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, maybe1(pred_specifier)). :- mode parse_predicate_specifier(in, 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, maybe1(pred_specifier)). :- mode process_typed_predicate_specifier(in, out) is det. process_typed_predicate_specifier(ok(Name, Args0), ok(Result)) :- ( Args0 = [] -> Result = sym(name(Name)) ; list__map(term__coerce, Args0, Args), Result = name_args(Name, Args) ). process_typed_predicate_specifier(error(Msg, Term), error(Msg, Term)). :- pred make_arity_predicate_specifier(sym_name_specifier, pred_specifier). :- mode make_arity_predicate_specifier(in, 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, maybe1(pred_specifier)). :- mode parse_arg_types_specifier(in, 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), maybe1(type), maybe1(cons_specifier)). :- mode process_typed_constructor_specifier(in, in, 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, type, cons_specifier). :- mode process_typed_cons_spec_2(in, in, 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, maybe1(sym_name_specifier)). :- mode parse_symbol_name_specifier(in, out) is det. parse_symbol_name_specifier(Term, Result) :- ( %%% some [NameTerm, ArityTerm, Context] Term = term__functor(term__atom("/"), [NameTerm, ArityTerm], _Context) -> ( %%% some [Arity, Context2] ArityTerm = term__functor(term__integer(Arity), [], _Context2) -> ( Arity >= 0 -> parse_symbol_name(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_symbol_name(Term, SymbolNameResult), process_maybe1(make_name_specifier, SymbolNameResult, Result) ). :- pred make_name_arity_specifier(arity, sym_name, sym_name_specifier). :- mode make_name_arity_specifier(in, in, 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), maybe1(sym_name)). :- mode parse_symbol_name(in, out) is det. parse_symbol_name(Term, Result) :- ( Term = term__functor(term__atom(":"), [ModuleTerm, NameTerm], _Context) -> ( 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, term, maybe1(sym_name)). :- mode parse_implicitly_qualified_symbol_name(in, in, 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 ). %-----------------------------------------------------------------------------% % 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(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(":"), [ModuleTerm, NameArgsTerm], _Context) -> ( NameArgsTerm = term__functor(term__atom(Name), Args, _Context2) -> 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, _Context4) -> 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, maybe1(func_specifier)). :- mode parse_function_specifier(in, 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, maybe1(sym_name_specifier)). :- mode parse_type_specifier(in, 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, maybe1(sym_name_specifier)). :- mode parse_adt_specifier(in, 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, maybe1(op_specifier)). :- mode parse_op_specifier(in, 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)). %-----------------------------------------------------------------------------% % types are represented just as ordinary terms :- pred parse_type(term, maybe1(type)). :- mode parse_type(in, out) is det. parse_type(T0, ok(T)) :- convert_type(T0, T). :- pred convert_constructor_arg_list(module_name, list(term), list(constructor_arg)). :- mode convert_constructor_arg_list(in, in, out) is semidet. convert_constructor_arg_list(_, [], []). convert_constructor_arg_list(ModuleName, [Term | Terms], [Arg | Args]) :- ( Term = term__functor(term__atom("::"), [NameTerm, TypeTerm], _) -> parse_implicitly_qualified_term(ModuleName, NameTerm, Term, "field name", NameResult), NameResult = ok(SymName, []), convert_type(TypeTerm, Type), Arg = yes(SymName) - Type ; convert_type(Term, Type), Arg = no - Type ), convert_constructor_arg_list(ModuleName, Terms, Args). %-----------------------------------------------------------------------------% % 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("")). %-----------------------------------------------------------------------------%