%-----------------------------------------------------------------------------% % Copyright (C) 1995 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 a data structure for representing Mercury % programs, and predicates for parsing them. % % 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 Mercury-to-Goedel converters, pretty-printers, etc. % 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). % % Question: should we allow `:- rule' declarations??? %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- module prog_io. :- interface. :- import_module string, int, list, varset, term, std_util, require. :- import_module globals, options. %-----------------------------------------------------------------------------% % This is how programs (and parse errors) are represented. :- type message_list == list(pair(string, term)). % the error/warning message, and the % term to which it relates :- type program ---> module( module_name, item_list ). :- type item_list == list(item_and_context). :- type item_and_context == pair(item, term_context). :- type item ---> clause(varset, sym_name, list(term), goal) % VarNames, PredName, HeadArgs, ClauseBody ; type_defn(varset, type_defn, condition) ; inst_defn(varset, inst_defn, condition) ; mode_defn(varset, mode_defn, condition) ; module_defn(varset, module_defn) ; pred(varset, sym_name, list(type_and_mode), maybe(determinism), condition) % VarNames, PredName, ArgTypes, % Deterministicness, Cond /***** OBSOLETE ; rule(varset, sym_name, list(type), condition) % VarNames, PredName, ArgTypes, Cond *******/ ; mode(varset, sym_name, list(mode), maybe(determinism), condition) % VarNames, PredName, ArgModes, % Deterministicness, Cond ; pragma(pragma) ; nothing. % used for items that should be ignored % (currently only NU-Prolog `when' declarations, % which are silently ignored for backwards % compatibility). :- type type_and_mode ---> type_only(type) ; type_and_mode(type, mode). :- type determinism ---> det ; semidet ; nondet ; multidet ; erroneous ; failure. :- type pragma ---> c_header_code(c_header_code) ; c_code(sym_name, list(pragma_var), varset, c_code) % PredName, Vars/Mode, VarNames, C Code ; inline(sym_name, int). % Predname, Arity :- type pragma_var ---> pragma_var(var, string, mode). % variable, name, mode % we explicitly store the name because we % need the real name in code_gen :- type c_header_code == string. :- type c_code == string. %-----------------------------------------------------------------------------% % Here's how clauses and goals are represented. % a => b --> implies(vars, a, b) % a <= b --> implies(vars, b, a) [just flips the goals around!] % a <=> b --> equivalent(vars, a, b) % clause/4 defined above :- type goal == pair(goal_expr, term_context). :- type goal_expr ---> (goal,goal) ; true % could use conj(goals) instead ; {goal;goal} % {...} quotes ';'/2. ; fail % could use disj(goals) instead ; not(goal) ; some(vars,goal) ; all(vars,goal) ; implies(goal,goal) ; equivalent(goal,goal) ; if_then(vars,goal,goal) ; if_then_else(vars,goal,goal,goal) ; call(sym_name, list(term)) ; unify(term, term). :- type goals == list(goal). :- type vars == list(var). %-----------------------------------------------------------------------------% % This is how types are represented. % one day we might allow types to take % value parameters as well as type parameters. % type_defn/3 define above :- type type_defn ---> du_type(sym_name, list(type_param), list(constructor)) ; uu_type(sym_name, list(type_param), list(type)) ; eqv_type(sym_name, list(type_param), type) ; abstract_type(sym_name, list(type_param)). :- type constructor == pair(sym_name, list(type)). % probably type parameters should be variables not terms. :- type type_param == term. :- type (type) == term. :- type tvar == var. % used for type variables :- type tvarset == varset. % used for sets of type variables :- type tsubst == map(tvar, type). % used for type substitutions % Types may have arbitrary assertions associated with them % (eg. you can define a type which represents sorted lists). % The compiler will ignore these assertions - they are intended % to be used by other tools, such as the debugger. :- type condition ---> true ; where(term). %-----------------------------------------------------------------------------% % This is how instantiatednesses and modes are represented. % Note that while we use the normal term data structure to represent % type terms (see above), we need a separate data structure for inst % terms. % inst_defn/3 defined above :- type inst_defn ---> eqv_inst(sym_name, list(inst_param), inst) ; abstract_inst(sym_name, list(inst_param)). % probably inst parameters should be variables not terms :- type inst_param == term. :- type (inst) ---> free ; free(type) ; bound(uniqueness, list(bound_inst)) % The list(bound_inst) must be sorted ; ground(uniqueness, maybe(pred_inst_info)) % The pred_inst_info is used for % higher-order pred modes ; not_reached ; inst_var(var) ; defined_inst(inst_name) % An abstract inst is a defined inst which % has been declared but not actually been % defined (yet). ; abstract_inst(sym_name, list(inst)). :- type uniqueness ---> shared % there might be other references ; unique % there is only one reference ; clobbered. % this was the only reference, but % the data has already been reused % higher-order predicate terms are given the inst % `ground(shared, yes(PredInstInfo))' % where the PredInstInfo contains the extra modes and the determinism % for the predicate. Note that the higher-order predicate term % itself must be ground. :- type pred_inst_info ---> pred_inst_info( list(mode), % the modes of the additional % (i.e. not-yet-supplied) % arguments of the pred determinism % the determinism of the pred ). :- type bound_inst ---> functor(const, list(inst)). :- type inst_name ---> user_inst(sym_name, list(inst)) ; merge_inst(inst, inst) ; unify_inst(is_live, inst, inst, unify_is_real) ; ground_inst(inst_name, is_live, uniqueness, unify_is_real) ; shared_inst(inst_name) ; typed_ground(uniqueness, type) ; typed_inst(type, inst_name). :- type is_live ---> live ; dead. % Unifications of insts fall into two categories, "real" and "fake". % The "real" inst unifications correspond to real unifications, % and are not allowed to unify with `clobbered' insts. % "Fake" inst unifications are used for procedure calls in implied % modes, where the final inst of the var must be computed by % unifying its initial inst with the procedure's final inst, % so that if you pass a ground var to a procedure whose mode % is `free -> list_skeleton', the result is ground, not list_skeleton. % But these fake unifications must be allowed to unify with `clobbered' % insts. Hence we pass down a flag to `abstractly_unify_inst' which % specifies whether or not to allow unifications with clobbered values. :- type unify_is_real ---> real_unify ; fake_unify. % mode_defn/3 defined above :- type mode_defn ---> eqv_mode(sym_name, list(inst_param), mode). :- type (mode) ---> ((inst) -> (inst)) ; user_defined_mode(sym_name, list(inst)). % mode/4 defined above %-----------------------------------------------------------------------------% % This is how module-system declarations (such as imports % and exports) are represented. :- type module_defn ---> module(module_name) ; interface ; implementation ; imported % this is used internally by the compiler, % to identify declarations which originally % came from some other module ; external(sym_name_specifier) ; end_module(module_name) ; export(sym_list) ; import(sym_list) ; use(sym_list). :- type sym_list ---> sym(list(sym_specifier)) ; pred(list(pred_specifier)) ; cons(list(cons_specifier)) ; op(list(op_specifier)) ; adt(list(sym_name_specifier)) ; type(list(sym_name_specifier)) ; module(list(module_specifier)). :- type sym_specifier ---> sym(sym_name_specifier) ; typed_sym(typed_cons_specifier) ; pred(pred_specifier) ; cons(cons_specifier) ; op(op_specifier) ; adt(sym_name_specifier) ; type(sym_name_specifier) ; module(module_specifier). :- type pred_specifier ---> sym(sym_name_specifier) ; name_args(sym_name, list(type)). :- type cons_specifier ---> sym(sym_name_specifier) ; typed(typed_cons_specifier). :- type typed_cons_specifier ---> name_args(sym_name, list(type)) ; name_res(sym_name_specifier, type) ; name_args_res(sym_name, list(type), type). :- type op_specifier ---> sym(sym_name_specifier) % operator fixity specifiers not yet implemented ; fixity(sym_name_specifier, fixity). :- type fixity ---> infix ; prefix ; postfix. :- type sym_name_specifier ---> name(sym_name) ; name_arity(sym_name, arity). :- type sym_name ---> unqualified(string) ; qualified(module_specifier, string). :- type module_specifier == string. :- type module_name == string. :- type arity == int. %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% % This module (prog_io) exports the following predicates: %-----------------------------------------------------------------------------% % read_module(ModuleName, Error, Messages, Program) % reads and parses the module 'ModuleName'. Error is `fatal' % if the file coudn't be opened, `yes' % if a syntax error was detected, and `no' otherwise. % Messages is a list of warning/error messages. % Program is the parse tree. :- type module_error ---> no % no errors ; yes % some syntax errors ; fatal. % couldn't open the file :- pred prog_io__read_module(string, string, module_error, message_list, item_list, io__state, io__state). :- mode prog_io__read_module(in, in, out, out, out, di, uo) is det. %-----------------------------------------------------------------------------% % Convert a single term into a goal. :- pred parse_goal(term, varset, goal, varset). :- mode parse_goal(in, in, out, out) is det. % parse_lambda_expression/3 converts the first argument to a lambda/2 % expression into a list of variables, a list of their corresponding % modes, and a determinism. % The syntax is `[Var1::Mode1, ..., VarN::ModeN] is Det'. :- pred parse_lambda_expression(term, list(var), list(mode), determinism). :- mode parse_lambda_expression(in, out, out, out) is semidet. %-----------------------------------------------------------------------------% % The following /3, /4 and /5 predicates are to be used for reporting % warnings to stderr. This is preferable to using io__write_string, as % this checks the halt-at-warn option % % This predicate is best used by predicates that do not have access to % module_info for a particular module. It sets the exit status to error % when a warning is encountered in a module, and the --halt-at-warn % option is set. :- pred report_warning(string::in, io__state::di, io__state::uo) is det. :- pred report_warning(io__output_stream::in, string::in, io__state::di, io__state::uo) is det. :- pred report_warning(string::in, int::in, string::in, io__state::di, io__state::uo) is det. %-----------------------------------------------------------------------------% :- implementation. :- import_module io, term_io, dir, require. %-----------------------------------------------------------------------------% % When actually reading in type declarations, we need to % check for errors. :- type maybe1(T) ---> error(string, term) ; ok(T). :- type maybe2(T1, T2) ---> error(string, term) ; ok(T1, T2). :- type maybe_functor == maybe2(sym_name, list(term)). :- type maybe_item_and_context == maybe2(item, term_context). % 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.) prog_io__read_module(FileName, ModuleName, Error, Messages, Items) --> globals__io_lookup_accumulating_option(search_directories, Dirs), search_for_file(Dirs, FileName, R), ( { R = yes } -> read_all_items(ModuleName, RevMessages, RevItems0, Error0), { get_end_module(RevItems0, RevItems, EndModule), list__reverse(RevMessages, Messages0), list__reverse(RevItems, Items0), check_begin_module(ModuleName, Messages0, Items0, Error0, EndModule, FileName, Messages, Items, Error) }, io__seen ; 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, Items = [] } ). :- pred search_for_file(list(string), string, bool, io__state, io__state). :- mode search_for_file(in, in, out, di, uo) is det. 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, term_context). :- pred get_end_module(item_list, item_list, module_end). :- mode get_end_module(in, out, out) is det. get_end_module(RevItems0, RevItems, EndModule) :- ( 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_begin_module(string, message_list, item_list, module_error, module_end, string, message_list, item_list, module_error). :- mode check_begin_module(in, in, in, in, in, in, out, out, out) is det. check_begin_module(ModuleName, Messages0, Items0, Error0, EndModule, FileName, Messages, Items, Error) :- % check that the first item is a `:- module ModuleName' % declaration ( Items0 = [module_defn(_VarSet, module(ModuleName1)) - Context | Items1] -> % check that the end module declaration (if any) % matches the begin module declaration ( %%% some [ModuleName2, Context2] ( EndModule = yes(ModuleName2, Context2), ModuleName1 \= ModuleName2 ) -> dummy_term_with_context(Context2, Term), ThisError = "Error: `:- end_module' declaration doesn't match `:- module' declaration" - Term, list__append([ThisError], Messages0, Messages), Items = Items1, Error = yes ; % check that the begin module declaration matches the expected name % of the module ModuleName1 \= ModuleName -> dummy_term_with_context(Context, Term2), ThisError = "Warning: incorrect module name in `:- module' declaration" - Term2, Messages = [ThisError | Messages0], Items = Items1, Error = Error0 ; Messages = Messages0, Items = Items1, Error = Error0 ) ; term_context_init(FileName, 1, Context), dummy_term_with_context(Context, Term2), ThisError = "Error: module should start with a `:- module' declaration" - Term2, Messages = [ThisError | Messages0], Items = Items0, Error = yes ). % 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. :- pred read_all_items(string, message_list, item_list, module_error, io__state, io__state). :- mode read_all_items(in, out, out, out, di, uo) is det. read_all_items(ModuleName, Messages, Items, Error) --> read_items_loop(ModuleName, [], [], no, Messages, Items, Error). %-----------------------------------------------------------------------------% % The loop is arranged somewhat carefully: we want it to % be tail recursive, and we want to do a small garbage collection % after we have read each item to minimize memory usage % and improve cache locality. So each iteration calls % read_item(MaybeItem) - which does all the work for a single item - % via io__gc_call/1, which calls the goal with garbage collection. % This manual garbage collection won't be strictly necessary % when (if) we implement automatic garbage collection, but % it will probably still improve performance. % % Note: the following will NOT be tail recursive with our % implementation unless the compiler is smart enough to inline % read_items_loop_2. :- pred read_items_loop(string, message_list, item_list, module_error, message_list, item_list, module_error, io__state, io__state). :- mode read_items_loop(in, in, in, in, out, out, out, di, uo) is det. read_items_loop(ModuleName, Msgs1, Items1, Error1, Msgs, Items, Error) --> io__gc_call(read_item(ModuleName, MaybeItem)), read_items_loop_2(ModuleName, MaybeItem, Msgs1, Items1, Error1, Msgs, Items, Error). %-----------------------------------------------------------------------------% :- pred read_items_loop_2(string, maybe_item_or_eof, 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, out, out, out, di, uo) is det. % do a switch on the type of the next item read_items_loop_2(_ModuleName, eof, Msgs, Items, Error, Msgs, Items, Error) --> []. % if the next item was end-of-file, then we're done. read_items_loop_2(ModuleName, syntax_error(ErrorMsg, LineNumber), 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 io__input_stream(Stream), io__input_stream_name(Stream, StreamName), { term_context_init(StreamName, LineNumber, Context), dummy_term_with_context(Context, Term), ThisError = ErrorMsg - Term, Msgs1 = [ThisError | Msgs0], Items1 = Items0, Error1 = yes }, read_items_loop(ModuleName, Msgs1, Items1, Error1, Msgs, Items, Error). read_items_loop_2(ModuleName, error(M,T), 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 = yes }, read_items_loop(ModuleName, Msgs1, Items1, Error1, Msgs, Items, Error). read_items_loop_2(ModuleName, ok(Item, Context), Msgs0, Items0, Error0, Msgs, Items, Error) --> % if the next item was a valid item, then insert it in % the list of items and continue looping { Msgs1 = Msgs0, Items1 = [Item - Context | Items0], Error1 = Error0 }, read_items_loop(ModuleName, 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(string, int) ; error(string, term) ; ok(item, term_context). :- pred read_item(string, maybe_item_or_eof, io__state, io__state). :- mode read_item(in, out, di, uo) is det. read_item(ModuleName, MaybeItem) --> term_io__read_term(MaybeTerm), { process_read_term(ModuleName, MaybeTerm, MaybeItem) }. :- pred process_read_term(string, 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)). :- pred parse_item(string, varset, term, maybe_item_and_context). :- mode parse_item(in, in, in, out) is det. 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, R), add_context(R, DeclContext, 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) ), parse_goal(Body, VarSet, Body2, VarSet2), parse_qualified_term(ModuleName, Head, "clause head", R2), process_clause(R2, VarSet2, Body2, R3), add_context(R3, TheContext, Result) ). :- pred add_context(maybe1(item), term_context, maybe_item_and_context). :- mode add_context(in, in, out) is det. add_context(error(M, T), _, error(M, T)). add_context(ok(Item), Context, ok(Item, Context)). :- pred process_clause(maybe_functor, varset, goal, maybe1(item)). :- mode process_clause(in, in, in, out) is det. process_clause(ok(Name, Args), VarSet, Body, ok(clause(VarSet, Name, Args, Body))). process_clause(error(ErrMessage, Term), _, _, error(ErrMessage, Term)). %-----------------------------------------------------------------------------% % Parse a goal. % We just check if it matches the appropriate pattern % for one of the builtins. If it doesn't match any of the % builtins, then it's just a predicate call. % XXX we should do more parsing here - type qualification % should be parsed here. % % We could do some error-checking here, but all errors are picked up % in either the type-checker or parser anyway. parse_goal(Term, VarSet0, Goal, VarSet) :- ( Term = term_functor(term_atom(Name), Args, Context), parse_goal_2(Name, Args, VarSet0, GoalExpr, VarSet1) -> Goal = GoalExpr - Context, VarSet = VarSet1 ; ( Term = term_functor(term_atom(Name), Terms, Context) -> VarSet = VarSet0, ( Name = ":" -> ( Terms = [term_functor(term_atom( ModuleName), [], _), term_functor(term_atom( PredName), Args, _)] -> Goal = call(qualified(ModuleName, PredName), Args) - Context ; Term0 = term_functor(term_atom("call"), [Term], Context), Goal = call(unqualified("call"), [Term0]) - Context % Goal contains ill-formed qualified % predicate calls.. ) ; Goal = call(unqualified(Name), Terms) - Context ) ; ( Term = term_functor(_, _, Context) ; Term = term_variable(_), term_context_init(Context) ), Term0 = term_functor(term_atom("call"), [Term], Context), Goal = call(unqualified("call"), [Term0]) - Context, VarSet = VarSet0 % Term in Goal above is a term__constant or % term_variable that is definately not a function call. ) ). :- pred parse_goal_2(string, list(term), varset, goal_expr, varset). :- mode parse_goal_2(in, in, in, out, out) is semidet. parse_goal_2("true", [], V, true, V). parse_goal_2("fail", [], V, fail, V). parse_goal_2("=", [A,B], V, unify(A,B), V). /****** Since (A -> B) has different semantics in standard Prolog (A -> B ; fail) than it does in NU-Prolog or Mercury (A -> B ; true), for the moment we'll just disallow it. parse_goal_2("->", [A0,B0], V0, if_then(Vars,A,B), V) :- parse_some_vars_goal(A0, V0, Vars, A, V1), parse_goal(B0, V1, B, V). ******/ parse_goal_2(",", [A0,B0], V0, (A,B), V) :- parse_goal(A0, V0, A, V1), parse_goal(B0, V1, B, V). parse_goal_2(";", [A0,B0], V0, R, V) :- ( A0 = term_functor(term_atom("->"), [X0,Y0], _Context) -> parse_some_vars_goal(X0, V0, Vars, X, V1), parse_goal(Y0, V1, Y, V2), parse_goal(B0, V2, B, V), R = if_then_else(Vars, X, Y, B) ; parse_goal(A0, V0, A, V1), parse_goal(B0, V1, B, V), R = (A;B) ). /**** For consistency we also disallow if-then parse_goal_2("if", [term_functor(term_atom("then"),[A0,B0],_)], V0, if_then(Vars,A,B), V) :- parse_some_vars_goal(A0, V0, Vars, A, V1), parse_goal(B0, V1, B, V). ****/ parse_goal_2("else",[ term_functor(term_atom("if"),[ term_functor(term_atom("then"),[A0,B0],_) ],_), C0 ], V0, if_then_else(Vars,A,B,C), V) :- parse_some_vars_goal(A0, V0, Vars, A, V1), parse_goal(B0, V1, B, V2), parse_goal(C0, V2, C, V). parse_goal_2("not", [A0], V0, not(A), V) :- parse_goal(A0, V0, A, V). parse_goal_2("\\+", [A0], V0, not(A), V) :- parse_goal(A0, V0, A, V). parse_goal_2("all", [Vars0,A0], V0, all(Vars,A), V):- term__vars(Vars0, Vars), parse_goal(A0, V0, A, V). % handle implication parse_goal_2("<=", [A0,B0], V0, implies(B,A), V):- parse_goal(A0, V0, A, V1), parse_goal(B0, V1, B, V). parse_goal_2("=>", [A0,B0], V0, implies(A,B), V):- parse_goal(A0, V0, A, V1), parse_goal(B0, V1, B, V). % handle equivalence parse_goal_2("<=>", [A0,B0], V0, equivalent(A,B), V):- parse_goal(A0, V0, A, V1), parse_goal(B0, V1, B, V). parse_goal_2("some", [Vars0,A0], V0, some(Vars,A), V):- term__vars(Vars0, Vars), parse_goal(A0, V0, A, V). % The following is a temporary and gross hack to handle `is' in % the parser - we ought to handle it in the code generation - % but then `is/2' itself is a bit of a hack % parse_goal_2("is", [Destination, Expression], VarSet0, Goal, VarSet) :- parse_expression(Expression, Destination, VarSet0, Goal, VarSet). :- pred parse_expression(term, term, varset, goal_expr, varset). :- mode parse_expression(in, in, in, out, out) is semidet. parse_expression(Expression, Destination, VarSet0, Goal, VarSet) :- ( Expression = term_functor(term_atom(Operator), Args0, Context), list__length(Args0, Arity), parse_arith_expression(Operator, Arity, BuiltinPredName) -> parse_expression_list(Args0, VarSet0, Context, Args1, ArgGoal, VarSet), list__append(Args1, [Destination], Args), ExprGoal = call(unqualified(BuiltinPredName), Args) - Context, %%% XXX or qualified("builtin", )?? Goal = (ArgGoal, ExprGoal) ; VarSet = VarSet0, ( Destination = term_variable(Var), Expression = term_variable(Var) -> Goal = true ; Goal = unify(Destination, Expression) ) ). :- pred parse_expression_list(list(term), varset, term_context, list(term), goal, varset). :- mode parse_expression_list(in, in, in, out, out, out) is semidet. parse_expression_list([], VarSet, Context, [], true - Context, VarSet). parse_expression_list([Expr0 | Exprs0], VarSet0, Context, [Expr | Exprs], Goal - Context, VarSet) :- ( Expr0 = term_variable(_) -> Expr = Expr0, VarSet1 = VarSet0 ; varset__new_var(VarSet0, Var, VarSet1), Expr = term_variable(Var) ), parse_expression(Expr0, Expr, VarSet1, ThisGoal, VarSet2), Goal = (ThisGoal - Context, Goals), parse_expression_list(Exprs0, VarSet2, Context, Exprs, Goals, VarSet). :- pred parse_arith_expression(string, int, string). :- mode parse_arith_expression(in, in, out) is semidet. parse_arith_expression("+", 2, "builtin_plus"). parse_arith_expression("+", 1, "builtin_unary_plus"). parse_arith_expression("-", 2, "builtin_minus"). parse_arith_expression("-", 1, "builtin_unary_minus"). parse_arith_expression("*", 2, "builtin_times"). parse_arith_expression("//", 2, "builtin_div"). parse_arith_expression("mod", 2, "builtin_mod"). parse_arith_expression("<<", 2, "builtin_left_shift"). parse_arith_expression(">>", 2, "builtin_right_shift"). parse_arith_expression("\\/", 2, "builtin_bit_or"). parse_arith_expression("/\\", 2, "builtin_bit_and"). parse_arith_expression("^", 2, "builtin_bit_xor"). parse_arith_expression("\\", 1, "builtin_bit_neg"). :- pred parse_some_vars_goal(term, varset, vars, goal, varset). :- mode parse_some_vars_goal(in, in, out, out, out) is det. parse_some_vars_goal(A0, VarSet0, Vars, A, VarSet) :- ( A0 = term_functor(term_atom("some"), [Vars0,A1], _Context) -> term__vars(Vars0, Vars), parse_goal(A1, VarSet0, A, VarSet) ; Vars = [], parse_goal(A0, VarSet0, A, VarSet) ). %-----------------------------------------------------------------------------% parse_lambda_expression(LambdaExpressionTerm, Vars, Modes, Det) :- LambdaExpressionTerm = term_functor(term_atom("is"), [LambdaArgsTerm, DetTerm], _), DetTerm = term_functor(term_atom(DetString), [], _), standard_det(DetString, Det), parse_lambda_args(LambdaArgsTerm, Vars, Modes). :- pred parse_lambda_args(term, list(var), list(mode)). :- mode parse_lambda_args(in, out, out) is semidet. parse_lambda_args(Term, Vars, Modes) :- ( Term = term_functor(term_atom("."), [Head, Tail], _Context) -> parse_lambda_arg(Head, Var, Mode), Vars = [Var | Vars1], Modes = [Mode | Modes1], parse_lambda_args(Tail, Vars1, Modes1) ; Term = term_functor(term_atom("[]"), [], _) -> Vars = [], Modes = [] ; Vars = [Var], Modes = [Mode], parse_lambda_arg(Term, Var, Mode) ). :- pred parse_lambda_arg(term, var, mode). :- mode parse_lambda_arg(in, out, out) is semidet. parse_lambda_arg(Term, Var, Mode) :- Term = term_functor(term_atom("::"), [VarTerm, ModeTerm], _), VarTerm = term_variable(Var), convert_mode(ModeTerm, Mode). %-----------------------------------------------------------------------------% :- pred parse_dcg_clause(string, varset, term, term, term_context, maybe_item_and_context). :- mode parse_dcg_clause(in, in, in, in, in, out) is det. parse_dcg_clause(ModuleName, VarSet0, DCG_Head, DCG_Body, DCG_Context, Result) :- new_dcg_var(VarSet0, 0, VarSet1, N0, DCG_0_Var), parse_dcg_goal(DCG_Body, VarSet1, N0, DCG_0_Var, Body, VarSet, _N, DCG_Var), parse_qualified_term(ModuleName, DCG_Head, "DCG clause head", HeadResult), process_dcg_clause(HeadResult, VarSet, DCG_0_Var, DCG_Var, Body, R), add_context(R, DCG_Context, Result). %-----------------------------------------------------------------------------% % Used to allocate fresh variables needed for the DCG expansion. :- pred new_dcg_var(varset, int, varset, int, var). :- mode new_dcg_var(in, in, out, out, out) is det. new_dcg_var(VarSet0, N0, VarSet, N, DCG_0_Var) :- string__int_to_string(N0, StringN), string__append("DCG_", StringN, VarName), varset__new_var(VarSet0, DCG_0_Var, VarSet1), varset__name_var(VarSet1, DCG_0_Var, VarName, VarSet), N is N0 + 1. %-----------------------------------------------------------------------------% % Expand a DCG goal. :- pred parse_dcg_goal(term, varset, int, var, goal, varset, int, var). :- mode parse_dcg_goal(in, in, in, in, out, out, out, out) is det. parse_dcg_goal(Term0, VarSet0, N0, Var0, Goal, VarSet, N, Var) :- ( Term0 = term_functor(term_atom(Functor), Args0, Context) -> % First check for the special cases: ( parse_dcg_goal_2(Functor, Args0, Context, VarSet0, N0, Var0, Goal1, VarSet1, N1, Var1) -> Goal = Goal1, VarSet = VarSet1, N = N1, Var = Var1 ; % It's the ordinary case of non-terminal. % Create a fresh var as the DCG output var from this % goal, and append the DCG argument pair to the % non-terminal's argument list. new_dcg_var(VarSet0, N0, VarSet, N, Var), ( Functor = ":" , Args0 = [term_functor(term_atom(ModuleName), [], _), term_functor(term_atom(PredName), Args_of_pred0, _)] -> list__append(Args_of_pred0, [ term_variable(Var0), term_variable(Var) ], Args_of_pred), Goal = call(qualified(ModuleName, PredName), Args_of_pred) - Context ; list__append(Args0, [ term_variable(Var0), term_variable(Var) ], Args), Goal = call(unqualified(Functor), Args) - Context ) ) ; % A call to a free variable, or to a number or string. % Just translate it into a call to call/2 - the typecheck will % catch calls to numbers and strings. new_dcg_var(VarSet0, N0, VarSet, N, Var), term_context_init(CallContext), Term = term_functor(term_atom("call"), [ Term0, term_variable(Var0), term_variable(Var) ], CallContext), Goal = call(unqualified("call"), [Term]) - CallContext ). % parse_dcg_goal_2(Functor, Args, Context, VarSet0, N0, Var0, % Goal, VarSet, N, Var): % VarSet0/VarSet are an accumulator pair which we use to % allocate fresh DCG variables; N0 and N are an accumulator pair % we use to keep track of the number to give to the next DCG % variable (so that we can give it a semi-meaningful name "DCG_" % for use in error messages, debugging, etc.). % Var0 and Var are an accumulator pair we use to keep track of % the current DCG variable. :- pred parse_dcg_goal_2(string, list(term), term_context, varset, int, var, goal, varset, int, var). :- mode parse_dcg_goal_2(in, in, in, in, in, in, out, out, out, out) is semidet. % The following is a temporary and gross hack to strip out % calls to `io__gc_call', since the mode checker can't handle % them yet. parse_dcg_goal_2("io__gc_call", [Goal0], _, VarSet0, N0, Var0, Goal, VarSet, N, Var) :- parse_dcg_goal(Goal0, VarSet0, N0, Var0, Goal, VarSet, N, Var). % Ordinary goal inside { curly braces }. parse_dcg_goal_2("{}", [G], _, VarSet0, N, Var, Goal, VarSet, N, Var) :- parse_goal(G, VarSet0, Goal, VarSet). % Empty list - just unify the input and output DCG args. parse_dcg_goal_2("[]", [], Context, VarSet0, N0, Var0, Goal, VarSet, N, Var) :- new_dcg_var(VarSet0, N0, VarSet, N, Var), Goal = unify(term_variable(Var0), term_variable(Var)) - Context. % Non-empty list of terminals. Append the DCG output arg % as the new tail of the list, and unify the result with % the DCG input arg. parse_dcg_goal_2(".", [X,Xs], Context, VarSet0, N0, Var0, Goal, VarSet, N, Var) :- new_dcg_var(VarSet0, N0, VarSet, N, Var), term_list_append_term(term_functor(term_atom("."), [X,Xs], Context), term_variable(Var), Term), Goal = unify(term_variable(Var0), Term) - Context. % Call to '='/1 - unify argument with DCG input arg. parse_dcg_goal_2("=", [A], Context, VarSet, N, Var, Goal, VarSet, N, Var) :- Goal = unify(A, term_variable(Var)) - Context. % If-then (Prolog syntax). % We need to add an else part to unify the DCG args. /****** Since (A -> B) has different semantics in standard Prolog (A -> B ; fail) than it does in NU-Prolog or Mercury (A -> B ; true), for the moment we'll just disallow it. parse_dcg_goal_2("->", [A0,B0], Context, VarSet0, N0, Var0, Goal, VarSet, N, Var) :- parse_dcg_if_then(A0, B0, Context, VarSet0, N0, Var0, SomeVars, A, B, VarSet, N, Var), ( Var = Var0 -> Goal = if_then(SomeVars, A, B) - Context ; Goal = if_then_else(SomeVars, A, B, unify(term_variable(Var), term_variable(Var0)) - Context) - Context ). ******/ % If-then (NU-Prolog syntax). parse_dcg_goal_2("if", [ term_functor(term_atom("then"),[A0,B0],_) ], Context, VarSet0, N0, Var0, Goal, VarSet, N, Var) :- parse_dcg_if_then(A0, B0, Context, VarSet0, N0, Var0, SomeVars, A, B, VarSet, N, Var), ( Var = Var0 -> Goal = if_then(SomeVars, A, B) - Context ; Goal = if_then_else(SomeVars, A, B, unify(term_variable(Var), term_variable(Var0)) - Context) - Context ). % Conjunction. parse_dcg_goal_2(",", [A0,B0], Context, VarSet0, N0, Var0, (A,B) - Context, VarSet, N, Var) :- parse_dcg_goal(A0, VarSet0, N0, Var0, A, VarSet1, N1, Var1), parse_dcg_goal(B0, VarSet1, N1, Var1, B, VarSet, N, Var). % Disjunction or if-then-else (Prolog syntax). parse_dcg_goal_2(";", [A0,B0], Cx, VarSet0, N0, Var0, Goal, VarSet, N, Var) :- ( A0 = term_functor(term_atom("->"), [X0,Y0], _Context) -> parse_dcg_if_then(X0, Y0, Cx, VarSet0, N0, Var0, SomeVars, X, Y, VarSet1, N1, VarA), parse_dcg_goal(B0, VarSet1, N1, Var0, B, VarSet, N, VarB), ( VarA = Var0, VarB = Var0 -> Var = Var0, Goal = if_then_else(SomeVars, X, Y, B) - Cx ; VarA = Var0 -> Var = VarB, Goal = if_then_else(SomeVars, X, (Y, unify( term_variable(Var), term_variable(VarA) ) - Cx) - Cx, B ) - Cx ; Var = VarA, Goal = if_then_else(SomeVars, X, Y, (B, unify(term_variable(Var), term_variable(VarB)) - Cx) - Cx) - Cx ) ; parse_dcg_goal(A0, VarSet0, N0, Var0, A, VarSet1, N1, VarA), parse_dcg_goal(B0, VarSet1, N1, Var0, B, VarSet, N, VarB), ( VarA = Var0, VarB = Var0 -> Var = Var0, Goal = (A ; B) - Cx ; VarA = Var0 -> Var = VarB, append_to_disjunct(A, unify(term_variable(Var), term_variable(VarA)), Cx, A1), Goal = (A1 ; B) - Cx ; Var = VarA, append_to_disjunct(B, unify(term_variable(Var), term_variable(VarB)), Cx, B1), Goal = (A ; B1) - Cx ) ). % If-then-else (NU-Prolog syntax). parse_dcg_goal_2( "else", [ term_functor(term_atom("if"),[ term_functor(term_atom("then"),[A0,B0],_) ], Context), C0 ], _, VarSet0, N0, Var0, Goal, VarSet, N, Var) :- parse_dcg_if_then(A0, B0, Context, VarSet0, N0, Var0, SomeVars, A, B, VarSet1, N1, VarAB), parse_dcg_goal(C0, VarSet1, N1, Var0, C, VarSet, N, VarC), ( VarAB = Var0, VarC = Var0 -> Var = Var0, Goal = if_then_else(SomeVars, A, B, C) - Context ; VarAB = Var0 -> Var = VarC, Goal = if_then_else(SomeVars, A, (B, unify(term_variable(Var), term_variable(VarAB)) - Context) - Context, C) - Context ; Var = VarAB, Goal = if_then_else(SomeVars, A, B, (C, unify(term_variable(Var), term_variable(VarC)) - Context) - Context) - Context ). % Negation (NU-Prolog syntax). parse_dcg_goal_2( "not", [A0], Context, VarSet0, N0, Var0, not(A) - Context, VarSet, N, Var ) :- parse_dcg_goal(A0, VarSet0, N0, Var0, A, VarSet, N, _), Var = Var0. % Negation (Prolog syntax). parse_dcg_goal_2( "\\+", [A0], Context, VarSet0, N0, Var0, not(A) - Context, VarSet, N, Var ) :- parse_dcg_goal(A0, VarSet0, N0, Var0, A, VarSet, N, _), Var = Var0. % Universal quantification. parse_dcg_goal_2("all", [Vars0,A0], Context, VarSet0, N0, Var0, all(Vars,A) - Context, VarSet, N, Var) :- term__vars(Vars0, Vars), parse_dcg_goal(A0, VarSet0, N0, Var0, A, VarSet, N, Var). % Existential quantification. parse_dcg_goal_2("some", [Vars0,A0], Context, VarSet0, N0, Var0, some(Vars,A) - Context, VarSet, N, Var) :- term__vars(Vars0, Vars), parse_dcg_goal(A0, VarSet0, N0, Var0, A, VarSet, N, Var). :- pred append_to_disjunct(goal, goal_expr, term_context, goal). :- mode append_to_disjunct(in, in, in, out) is det. append_to_disjunct(Disjunct0, Goal, Context, Disjunct) :- ( Disjunct0 = (A0 ; B0) - Context2 -> append_to_disjunct(A0, Goal, Context, A), append_to_disjunct(B0, Goal, Context, B), Disjunct = (A ; B) - Context2 ; Disjunct = (Disjunct0, Goal - Context) - Context ). :- pred parse_some_vars_dcg_goal(term, vars, varset, int, var, goal, varset, int, var). :- mode parse_some_vars_dcg_goal(in, out, in, in, in, out, out, out, out) is det. parse_some_vars_dcg_goal(A0, SomeVars, VarSet0, N0, Var0, A, VarSet, N, Var) :- ( A0 = term_functor(term_atom("some"), [SomeVars0,A1], _Context) -> term__vars(SomeVars0, SomeVars), parse_dcg_goal(A1, VarSet0, N0, Var0, A, VarSet, N, Var) ; SomeVars = [], parse_dcg_goal(A0, VarSet0, N0, Var0, A, VarSet, N, Var) ). % Parse the "if" and the "then" part of an if-then or an % if-then-else. % If the condition is a DCG goal, but then "then" part % is not, then we need to translate % ( a -> { b } ; c ) % as % ( a(DCG_1, DCG_2) -> % b, % DCG_3 = DCG_2 % ; % c(DCG_1, DCG_3) % ) % rather than % ( a(DCG_1, DCG_2) -> % b % ; % c(DCG_1, DCG_2) % ) % so that the implicit quantification of DCG_2 is correct. :- pred parse_dcg_if_then(term, term, term_context, varset, int, var, list(var), goal, goal, varset, int, var). :- mode parse_dcg_if_then(in, in, in, in, in, in, out, out, out, out, out, out) is det. parse_dcg_if_then(A0, B0, Context, VarSet0, N0, Var0, SomeVars, A, B, VarSet, N, Var) :- parse_some_vars_dcg_goal(A0, SomeVars, VarSet0, N0, Var0, A, VarSet1, N1, Var1), parse_dcg_goal(B0, VarSet1, N1, Var1, B1, VarSet2, N2, Var2), ( Var0 \= Var1, Var1 = Var2 -> new_dcg_var(VarSet2, N2, VarSet, N, Var), B = (B1, unify( term_variable(Var), term_variable(Var2) ) - Context) - Context ; B = B1, N = N2, Var = Var2, VarSet = VarSet2 ). % term_list_append_term(ListTerm, Term, Result): % if ListTerm is a term representing a proper list, % this predicate will append the term Term % onto the end of the list :- pred term_list_append_term(term, term, term). :- mode term_list_append_term(in, in, out) is semidet. term_list_append_term(List0, Term, List) :- ( List0 = term_functor(term_atom("[]"), [], _Context) -> List = Term ; List0 = term_functor(term_atom("."), [Head, Tail0], Context2), List = term_functor(term_atom("."), [Head, Tail], Context2), term_list_append_term(Tail0, Term, Tail) ). :- pred process_dcg_clause(maybe_functor, varset, var, var, goal, maybe1(item)). :- mode process_dcg_clause(in, in, in, in, in, out) is det. process_dcg_clause(ok(Name, Args0), VarSet, Var0, Var, Body, ok(clause(VarSet, Name, Args, Body))) :- list__append(Args0, [term_variable(Var0), term_variable(Var)], Args). process_dcg_clause(error(ErrMessage, Term), _, _, _, _, error(ErrMessage, Term)). %-----------------------------------------------------------------------------% % parse a declaration :- pred parse_decl(string, varset, term, maybe1(item)). :- mode parse_decl(in, in, in, out) is det. parse_decl(ModuleName, VarSet, F, Result) :- ( F = term_functor(term_atom(Atom), As, _Context) -> ( process_decl(ModuleName, VarSet, Atom, As, R) -> Result = R ; Result = error("Unrecognized declaration", F) ) ; Result = error("Atom expected after `:-'", F) ). % process_decl(VarSet, Atom, Args, Result) succeeds if Atom(Args) % is a declaration and binds Result to a representation of that % declaration. :- pred process_decl(string, varset, string, list(term), maybe1(item)). :- mode process_decl(in, in, in, in, out) is semidet. process_decl(_ModuleName, VarSet, "type", [TypeDecl], Result) :- parse_type_decl(VarSet, TypeDecl, Result). process_decl(ModuleName, VarSet, "pred", [PredDecl], Result) :- parse_type_decl_pred(ModuleName, VarSet, PredDecl, Result). /*** OBSOLETE process_decl(_ModuleName, VarSet, "rule", [RuleDecl], Result) :- parse_type_decl_rule(VarSet, RuleDecl, Result). ***/ process_decl(ModuleName, VarSet, "mode", [ModeDecl], Result) :- parse_mode_decl(ModuleName, VarSet, ModeDecl, Result). process_decl(_ModuleName, VarSet, "inst", [InstDecl], Result) :- parse_inst_decl(VarSet, InstDecl, Result). process_decl(_ModuleName, VarSet, "import_module", [ModuleSpec], Result) :- parse_import_module_decl(VarSet, ModuleSpec, Result). process_decl(_ModuleName, VarSet, "use_module", [ModuleSpec], Result) :- parse_use_module_decl(VarSet, ModuleSpec, Result). process_decl(_ModuleName, VarSet, "export_module", [ModuleSpec], Result) :- parse_export_module_decl(VarSet, ModuleSpec, Result). process_decl(_ModuleName, VarSet, "import_sym", [SymSpec], Result) :- parse_import_sym_decl(VarSet, SymSpec, Result). process_decl(_ModuleName, VarSet, "use_sym", [SymSpec], Result) :- parse_use_sym_decl(VarSet, SymSpec, Result). process_decl(_ModuleName, VarSet, "export_sym", [SymSpec], Result) :- parse_export_sym_decl(VarSet, SymSpec, Result). process_decl(_ModuleName, VarSet, "import_pred", [PredSpec], Result) :- parse_import_pred_decl(VarSet, PredSpec, Result). process_decl(_ModuleName, VarSet, "use_pred", [PredSpec], Result) :- parse_use_pred_decl(VarSet, PredSpec, Result). process_decl(_ModuleName, VarSet, "export_pred", [PredSpec], Result) :- parse_export_pred_decl(VarSet, PredSpec, Result). process_decl(_ModuleName, VarSet, "import_cons", [ConsSpec], Result) :- parse_import_cons_decl(VarSet, ConsSpec, Result). process_decl(_ModuleName, VarSet, "use_cons", [ConsSpec], Result) :- parse_use_cons_decl(VarSet, ConsSpec, Result). process_decl(_ModuleName, VarSet, "export_cons", [ConsSpec], Result) :- parse_export_cons_decl(VarSet, ConsSpec, Result). process_decl(_ModuleName, VarSet, "import_type", [TypeSpec], Result) :- parse_import_type_decl(VarSet, TypeSpec, Result). process_decl(_ModuleName, VarSet, "use_type", [TypeSpec], Result) :- parse_use_type_decl(VarSet, TypeSpec, Result). process_decl(_ModuleName, VarSet, "export_type", [TypeSpec], Result) :- parse_export_type_decl(VarSet, TypeSpec, Result). process_decl(_ModuleName, VarSet, "import_adt", [ADT_Spec], Result) :- parse_import_adt_decl(VarSet, ADT_Spec, Result). process_decl(_ModuleName, VarSet, "use_adt", [ADT_Spec], Result) :- parse_use_adt_decl(VarSet, ADT_Spec, Result). process_decl(_ModuleName, VarSet, "export_adt", [ADT_Spec], Result) :- parse_export_adt_decl(VarSet, ADT_Spec, Result). process_decl(_ModuleName, VarSet, "import_op", [OpSpec], Result) :- parse_import_op_decl(VarSet, OpSpec, Result). process_decl(_ModuleName, VarSet, "use_op", [OpSpec], Result) :- parse_use_op_decl(VarSet, OpSpec, Result). process_decl(_ModuleName, VarSet, "export_op", [OpSpec], Result) :- parse_export_op_decl(VarSet, OpSpec, Result). process_decl(_ModuleName, VarSet, "interface", [], ok(module_defn(VarSet, interface))). process_decl(_ModuleName, VarSet, "implementation", [], ok(module_defn(VarSet, implementation))). process_decl(_ModuleName, VarSet, "external", [PredSpec], Result) :- parse_symbol_name_specifier(PredSpec, Result0), process_external(Result0, VarSet, Result). process_decl(_ModuleName0, VarSet, "module", [ModuleName], Result) :- ( ModuleName = term_functor(term_atom(Module), [], _Context) -> Result = ok(module_defn(VarSet, module(Module))) ; ModuleName = term_variable(_) -> dummy_term(ErrorContext), Result = error("Module names starting with capital letters must be quoted using single quotes (e.g. "":- module 'Foo'."")", ErrorContext) ; Result = error("Module name expected", ModuleName) ). process_decl(_ModuleName0, VarSet, "end_module", [ModuleName], Result) :- ( ModuleName = term_functor(term_atom(Module), [], _Context) -> Result = ok(module_defn(VarSet, end_module(Module))) ; Result = error("Module name expected", ModuleName) ). % NU-Prolog `when' declarations are silently ignored for % backwards compatibility. process_decl(_ModuleName, _VarSet, "when", [_Goal, _Cond], Result) :- Result = ok(nothing). process_decl(_ModuleName, VarSet, "pragma", Pragma, Result):- parse_pragma(VarSet, Pragma, Result). :- pred parse_type_decl(varset, term, maybe1(item)). :- mode parse_type_decl(in, in, out) is det. parse_type_decl(VarSet, TypeDecl, Result) :- ( TypeDecl = term_functor(term_atom(Name), Args, _), parse_type_decl_type(Name, Args, Cond, R) -> R1 = R, Cond1 = Cond ; process_abstract_type(TypeDecl, R1), Cond1 = true ), parse_type_decl_2(R1, VarSet, Cond1, Result). :- pred parse_type_decl_2(maybe1(type_defn), varset, condition, maybe1(item)). :- mode parse_type_decl_2(in, in, in, out) is det. parse_type_decl_2(error(Error, Term), _, _, error(Error, Term)). parse_type_decl_2(ok(TypeDefn), VarSet, Cond, ok(type_defn(VarSet, TypeDefn, Cond))). % we should check the condition for errs % (don't bother at the moment, since we ignore % conditions anyhow :-) :- pred process_external(maybe1(sym_name_specifier), varset, maybe1(item)). :- mode process_external(in, in, out) is det. process_external(ok(SymSpec), VarSet, ok(module_defn(VarSet, external(SymSpec)))). process_external(error(Error, Term), _, error(Error, Term)). %-----------------------------------------------------------------------------% % add a warning message to the list of messages :- pred add_warning(string, term, message_list, message_list). :- mode add_warning(in, in, out, in) is det. add_warning(Warning, Term, [Msg - Term | Msgs], 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(string, list(term), condition, maybe1(type_defn)). :- mode parse_type_decl_type(in, in, out, out) is semidet. :- parse_type_decl_type([A|B], _, _, _) when A and B. parse_type_decl_type("--->", [H,B], Condition, R) :- get_condition(B, Body, Condition), process_du_type(H, Body, R). parse_type_decl_type("=", [H,B], Condition, R) :- get_condition(B, Body, Condition), process_uu_type(H, Body, R). parse_type_decl_type("==", [H,B], Condition, R) :- get_condition(B, Body, Condition), process_eqv_type(H, Body, R). %-----------------------------------------------------------------------------% % parse_type_decl_pred(Pred, Condition, Result) succeeds % if Pred is a predicate 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_pred(string, varset, term, maybe1(item)). :- mode parse_type_decl_pred(in, in, in, out) is det. parse_type_decl_pred(ModuleName, VarSet, Pred, R) :- get_condition(Pred, Body, Condition), get_determinism(Body, Body2, MaybeDeterminism), process_type_decl_pred(ModuleName, MaybeDeterminism, VarSet, Body2, Condition, R). :- pred process_type_decl_pred(string, maybe1(maybe(determinism)), varset, term, condition, maybe1(item)). :- mode process_type_decl_pred(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, R) :- process_pred(ModuleName, VarSet, Body, MaybeDeterminism, Condition, R). %-----------------------------------------------------------------------------% /*** OBSOLETE % parse_type_decl_rule(VarSet, Rule, Result) succeeds % if Rule is a "rule" type declaration, and binds Result to % a representation of the declaration. % ("rule" here means DCG predicate, not horn clause.) :- pred parse_type_decl_rule(varset, term, maybe1(item)). :- mode parse_type_decl_rule(in, in, out) is det. parse_type_decl_rule(VarSet, Rule, R) :- get_condition(Rule, Body, Condition), process_mode(VarSet, Body, Condition, 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(string, 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), parse_mode_decl_pred_2(ModuleName, MaybeDeterminism, VarSet, Body2, Condition, Result). :- pred parse_mode_decl_pred_2(string, maybe1(maybe(determinism)), varset, term, condition, maybe1(item)). :- mode parse_mode_decl_pred_2(in, in, in, in, in, out) is det. parse_mode_decl_pred_2(ModuleName, ok(MaybeDet), VarSet, Body, Condition, R) :- process_mode(ModuleName, VarSet, Body, MaybeDet, Condition, R). parse_mode_decl_pred_2(_ModuleName, error(Term, Reason), _, _, _, error(Term, Reason)). % just pass the error up (after conversion to the right type) %-----------------------------------------------------------------------------% % parse the pragma declaration. (At the moment, the only pragmas % supported are c_header_code and c_code). It fails if the arguments % to the declaration were empty (ie. a pragma dec. with arity 0). :- pred parse_pragma(varset, list(term), maybe1(item)). :- mode parse_pragma(in, in, out) is semidet. parse_pragma(VarSet, Pragma, Result) :- Pragma = [PragmaType | PragmaTerms], ( PragmaType = term_functor(term_atom("c_header_code"),[], _) -> ( PragmaTerms = [HeaderTerm] -> ( HeaderTerm = term_functor(term_string(HeaderCode), [], _) -> Result = ok(pragma(c_header_code(HeaderCode))) ; Result = error("Expected string for C header code", HeaderTerm) ) ; Result = error("wrong number of arguments in pragma(c_header_code, ...) declaration.", PragmaType) ) ; PragmaType = term_functor(term_atom("c_code"),[], _) -> ( PragmaTerms = [PredAndVarsTerm, C_CodeTerm] -> ( PredAndVarsTerm =term_functor(term_atom(PredName), VarList, _) -> ( C_CodeTerm = term_functor(term_string(C_Code), [], _) -> parse_pragma_c_code_varlist(VarSet, VarList, PragmaVars, Error), ( Error = no, Result = ok(pragma(c_code(unqualified(PredName), PragmaVars, VarSet, C_Code))) ; Error = yes(ErrorMessage), Result = error(ErrorMessage, PredAndVarsTerm) ) ; Result = error("Expected string for C code", C_CodeTerm) ) ; Result = error("Term is not a predicate", PredAndVarsTerm) ) ; Result = error("wrong number of arguments in pragma(c_code, ...) declaration.", PragmaType) ) ; PragmaType = term_functor(term_atom("inline"),[], _) -> ( PragmaTerms = [PredAndArityTerm] -> ( PredAndArityTerm = term_functor(term_atom("/"), [PredNameTerm, ArityTerm], _) -> ( ( PredNameTerm = term_functor(term_atom(PredName), [], _), ArityTerm = term_functor(term_integer(Arity), [], _) ) -> Result = ok(pragma(inline(unqualified(PredName), Arity))) ; Result = error("Expected predname/arity for pragma(inline,...)", PredAndArityTerm) ) ; Result = error("Expected predname/arity for pragma(inline...)", PredAndArityTerm) ) ; Result = error( "wrong number of arguments in pragma(inline, ...) declaration.", PragmaType) ) ; Result = error("Unknown pragma declaration type", PragmaType) ). %-----------------------------------------------------------------------------% % parse the variable list in the pragma c code declaration. % The final argument is 'no' for no error, or 'yes(ErrorMessage)'. :- pred parse_pragma_c_code_varlist(varset, list(term), list(pragma_var), maybe(string)). :- mode parse_pragma_c_code_varlist(in, in, out, out) is det. parse_pragma_c_code_varlist(_, [], [], no). parse_pragma_c_code_varlist(VarSet, [V|Vars], PragmaVars, Error):- ( V = term_functor(term_atom("::"), [VarTerm, ModeTerm], _), VarTerm = term_variable(Var) -> ( varset__lookup_name(VarSet, Var, VarName) -> ( convert_mode(ModeTerm, Mode) -> P = (pragma_var(Var, VarName, Mode)), parse_pragma_c_code_varlist(VarSet, Vars, PragmaVars0, Error), PragmaVars = [P|PragmaVars0] ; PragmaVars = [], Error = yes("unknown mode in pragma(c_code, ...") ) ; % if the variable wasn't in the varset it must be an % underscore variable. PragmaVars = [], % return any old junk for that. Error = yes( "sorry, not implemented: anonymous `_' variable in pragma(c_code, ...)") ) ; PragmaVars = [], % return any old junk in PragmaVars Error = yes("arguments not in form 'Var :: mode'") ). %-----------------------------------------------------------------------------% % 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) ). :- pred standard_det(string, determinism). :- mode standard_det(in, out) is semidet. standard_det("det", det). standard_det("nondet", nondet). standard_det("multi", multidet). standard_det("multidet", multidet). standard_det("semidet", semidet). standard_det("erroneous", erroneous). standard_det("failure", failure). %-----------------------------------------------------------------------------% % 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(B, Body, Condition) :- ( B = term_functor(term_atom("where"), [Body1, Condition1], _Context) -> Body = Body1, Condition = where(Condition1) ; Body = B, Condition = true ). %-----------------------------------------------------------------------------% % This is for "Head = Body" (undiscriminated union) definitions. :- pred process_uu_type(term, term, maybe1(type_defn)). :- mode process_uu_type(in, in, out) is det. process_uu_type(Head, Body, Result) :- check_for_errors(Head, Body, Result0), process_uu_type_2(Result0, Body, Result). :- pred process_uu_type_2(maybe_functor, term, maybe1(type_defn)). :- 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, Args), Body, ok(uu_type(Name,Args,List))) :- sum_to_list(Body, List). %-----------------------------------------------------------------------------% % This is for "Head == Body" (equivalence) definitions. :- pred process_eqv_type(term, term, maybe1(type_defn)). :- mode process_eqv_type(in, in, out) is det. process_eqv_type(Head, Body, Result) :- check_for_errors(Head, Body, Result0), process_eqv_type_2(Result0, Body, Result). :- pred process_eqv_type_2(maybe_functor, term, maybe1(type_defn)). :- 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, Args), Body, ok(eqv_type(Name,Args,Body))). %-----------------------------------------------------------------------------% % process_du_type(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(term, term, maybe1(type_defn)). :- mode process_du_type(in, in, out) is det. process_du_type(Head, Body, Result) :- check_for_errors(Head, Body, Result0), process_du_type_2(Result0, Body, Result). :- pred process_du_type_2(maybe_functor, term, maybe1(type_defn)). :- mode process_du_type_2(in, in, out) is det. process_du_type_2(error(Error, Term), _, error(Error, Term)). process_du_type_2(ok(Functor,Args), Body, Result) :- % check that body is a disjunction of constructors ( %%% some [Constrs] convert_constructors(Body, Constrs) -> Result = ok(du_type(Functor, Args, Constrs)) ; Result = error("Invalid RHS of type definition", Body) ). %-----------------------------------------------------------------------------% % process_abstract_type(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(term, maybe1(type_defn)). :- mode process_abstract_type(in, out) is det. process_abstract_type(Head, Result) :- dummy_term(Body), check_for_errors(Head, Body, Result0), process_abstract_type_2(Result0, Result). :- pred process_abstract_type_2(maybe_functor, maybe1(type_defn)). :- 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, Args), ok(abstract_type(Functor, Args))). %-----------------------------------------------------------------------------% % check a type definition for errors :- pred check_for_errors(term, term, maybe_functor). :- mode check_for_errors(in, in, out) is det. check_for_errors(Head, Body, Result) :- ( Head = term_variable(_) -> Result = error("Variable on LHS of type definition", Head) ; parse_qualified_term(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) % check that all the variables in the body occur in the head ; %%% some [Var2] ( term__contains_var(Body, Var2), \+ term__contains_var_list(Args, Var2) ) -> Result = error("Free type parameter in RHS of type definition", Body) ; 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(term, list(constructor)). :- mode convert_constructors(in, out) is semidet. convert_constructors(Body, Constrs) :- disjunction_to_list(Body, List), convert_constructors_2(List, Constrs). % true if input argument is a valid list of constructors :- pred convert_constructors_2(list(term), list(constructor)). :- mode convert_constructors_2(in, out) is semidet. convert_constructors_2([], []). convert_constructors_2([Term | Terms], [Constr | Constrs]) :- convert_constructor(Term, Constr), convert_constructors_2(Terms, Constrs). % true if input argument is a valid constructor. % Note that as a special case, one level of % curly braces around the constructor are ignored. % This is to allow you to define ';'/2 constructors. :- pred convert_constructor(term, constructor). :- mode convert_constructor(in, out) is semidet. convert_constructor(Term, Result) :- ( Term = term_functor(term_atom("{}"), [Term1], _Context) -> Term2 = Term1 ; Term2 = Term ), parse_qualified_term(Term2, "convert_constructor/2", ok(F, As)), convert_type_list(As, ArgTypes), Result = F - ArgTypes. %-----------------------------------------------------------------------------% % convert a "disjunction" (bunch of terms separated by ';'s) to a list :- pred disjunction_to_list(term, list(term)). :- mode disjunction_to_list(in, out) is det. disjunction_to_list(Term, List) :- binop_term_to_list(";", Term, List). % convert a "conjunction" (bunch of terms separated by ','s) to a list :- pred conjunction_to_list(term, list(term)). :- mode conjunction_to_list(in, out) is det. conjunction_to_list(Term, List) :- binop_term_to_list(",", Term, List). % convert a "sum" (bunch of terms separated by '+' operators) to a list :- pred sum_to_list(term, list(term)). :- mode sum_to_list(in, out) is det. sum_to_list(Term, List) :- binop_term_to_list("+", Term, List). % general predicate to convert terms separated by any specified % operator into a list :- pred binop_term_to_list(string, term, list(term)). :- mode binop_term_to_list(in, in, out) is det. binop_term_to_list(Op, Term, List) :- binop_term_to_list_2(Op, Term, [], List). :- pred binop_term_to_list_2(string, term, list(term), list(term)). :- mode binop_term_to_list_2(in, in, in, out) is det. binop_term_to_list_2(Op, Term, List0, List) :- ( Term = term_functor(term_atom(Op), [L, R], _Context) -> binop_term_to_list_2(Op, R, List0, List1), binop_term_to_list_2(Op, L, List1, List) ; List = [Term|List0] ). %-----------------------------------------------------------------------------% % parse a `:- pred p(...)' declaration :- pred process_pred(string, varset, term, maybe(determinism), condition, maybe1(item)). :- mode process_pred(in, in, in, in, in, out) is det. process_pred(ModuleName, VarSet, PredType, MaybeDet, Cond, Result) :- parse_qualified_term(ModuleName, PredType, "`:- pred' declaration", R), process_pred_2(R, PredType, VarSet, MaybeDet, Cond, Result). :- pred process_pred_2(maybe_functor, term, varset, maybe(determinism), condition, maybe1(item)). :- mode process_pred_2(in, in, in, in, in, out) is det. process_pred_2(ok(F, As0), PredType, VarSet, MaybeDet, Cond, Result) :- ( %%% some [As] convert_type_and_mode_list(As0, As) -> Result = ok(pred(VarSet, F, As, MaybeDet, Cond)) ; Result = error("Syntax error in :- pred declaration", PredType) ). process_pred_2(error(M, T), _, _, _, _, error(M, T)). % parse a `:- mode p(...)' declaration :- pred process_mode(string, varset, term, maybe(determinism), condition, maybe1(item)). :- mode process_mode(in, in, in, in, in, out) is det. process_mode(ModuleName, VarSet, PredMode, MaybeDet, Cond, Result) :- parse_qualified_term(ModuleName, PredMode, "`:- mode' declaration", R), process_mode_2(R, PredMode, VarSet, MaybeDet, Cond, Result). :- pred process_mode_2(maybe_functor, term, varset, maybe(determinism), condition, maybe1(item)). :- mode process_mode_2(in, in, in, in, in, out) is det. process_mode_2(ok(F, As0), PredMode, VarSet, MaybeDet, Cond, Result) :- ( %%% some [As] convert_mode_list(As0, As) -> Result = ok(mode(VarSet, F, As, MaybeDet, Cond)) ; Result = error("Syntax error in predicate mode declaration", PredMode) ). process_mode_2(error(M, T), _, _, _, _, error(M, T)). /*** OBSOLETE % A rule declaration is just the same as a pred declaration, % except that it is for DCG rules, so there are two hidden arguments. :- pred process_rule(varset, term, condition, maybe1(item)). :- mode process_rule(in, in, in, out) is det. process_rule(VarSet, RuleType, Cond, Result) :- parse_qualified_term(RuleType, "`:- rule' declaration", R), process_rule_2(R, VarSet, Cond, Result). :- pred process_rule_2(maybe_functor, varset, condition, maybe1(item)). :- mode process_rule_2(in, in, in, out) is det. process_rule_2(ok(F, As), VarSet, Cond, ok(rule(VarSet, F, As, Cond))). process_rule_2(error(M, T), _, _, error(M, T)). ***/ /*** JUNK process_rule(VarSet, RuleType, Cond, Result) :- varset__new_var(VarSet, Var, VarSet1), RuleType = term_functor(F, RuleArgs, _), list__append(RuleArgs, [Var, Var], PredArgs), PredType = term_functor(F, PredArgs, _), process_pred(VarSet1, PredType, Cond, Result). ***/ %-----------------------------------------------------------------------------% % parse a `:- inst foo = ...' definition :- pred parse_inst_decl(varset, term, maybe1(item)). :- mode parse_inst_decl(in, in, out) is det. parse_inst_decl(VarSet, InstDefn, Result) :- ( InstDefn = term_functor(term_atom("="), [H,B], _Context) -> get_condition(B, Body, Condition), convert_inst_defn(H, Body, R), process_inst_defn(R, VarSet, Condition, Result) ; InstDefn = term_functor(term_atom("is"), [ Head, term_functor(term_atom("private"), [], _) ], _) -> Condition = true, convert_abstract_inst_defn(Head, R), process_inst_defn(R, VarSet, Condition, 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 :-) :- pred convert_inst_defn(term, term, maybe1(inst_defn)). :- mode convert_inst_defn(in, in, out) is det. convert_inst_defn(Head, Body, Result) :- parse_qualified_term(Head, "inst definition", R), convert_inst_defn_2(R, Head, Body, Result). :- pred convert_inst_defn_2(maybe_functor, term, term, maybe1(inst_defn)). :- 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, Args), Head, Body, Result) :- % check that all the head args are variables ( %%% some [Arg] ( list__member(Arg, Args), Arg \= term_variable(_) ) -> Result = error("Inst 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 inst parameters in LHS of inst defn", Head) ; % check that all the variables in the body occur in the head %%% some [Var2] ( term__contains_var(Body, Var2), \+ term__contains_var_list(Args, Var2) ) -> Result = error("Free inst parameter in RHS of inst definition", Body) ; % should improve the error message here ( %%% some [ConvertedBody] convert_inst(Body, ConvertedBody) -> Result = ok(eqv_inst(Name, Args, ConvertedBody)) ; Result = error("Syntax error in inst body", Body) ) ). :- pred convert_abstract_inst_defn(term, maybe1(inst_defn)). :- mode convert_abstract_inst_defn(in, out) is det. convert_abstract_inst_defn(Head, Result) :- parse_qualified_term(Head, "inst definition", R), convert_abstract_inst_defn_2(R, Head, Result). :- pred convert_abstract_inst_defn_2(maybe_functor, term, maybe1(inst_defn)). :- 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, Args), Head, Result) :- % check that all the head args are variables ( %%% some [Arg] ( list__member(Arg, Args), Arg \= term_variable(_) ) -> Result = error("Inst 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 inst parameters in abstract inst definition", Head) ; Result = ok(abstract_inst(Name, Args)) ). :- pred convert_inst_list(list(term), list(inst)). :- mode convert_inst_list(in, out) is semidet. convert_inst_list([], []). convert_inst_list([H0|T0], [H|T]) :- convert_inst(H0, H), convert_inst_list(T0, T). :- pred convert_inst(term, inst). :- mode convert_inst(in, out) is semidet. convert_inst(term_variable(V), inst_var(V)). convert_inst(term_functor(Name, Args0, Context), Result) :- ( Name = term_atom("free"), Args0 = [] -> Result = free ; Name = term_atom("ground"), Args0 = [] -> Result = ground(shared, no) ; Name = term_atom("unique"), Args0 = [] -> Result = ground(unique, no) ; Name = term_atom("clobbered"), Args0 = [] -> Result = ground(clobbered, no) ; % The syntax for a higher-order pred inst is % % pred_initial(, , ...) is % or % pred_final(, , ...) is % % where , , ... are a list of modes, % and is a determinism. Name = term_atom("is"), Args0 = [PredTerm, DetTerm], PredTerm = term_functor(term_atom("pred"), ArgModesTerm, _) -> DetTerm = term_functor(term_atom(DetString), [], _), standard_det(DetString, Detism), convert_mode_list(ArgModesTerm, ArgModes), PredInst = pred_inst_info(ArgModes, Detism), Result = ground(shared, yes(PredInst)) ; Name = term_atom("not_reached"), Args0 = [] -> Result = not_reached ; Name = term_atom("bound"), Args0 = [Disj] -> disjunction_to_list(Disj, List), convert_bound_inst_list(List, Functors0), list__sort_and_remove_dups(Functors0, Functors), Result = bound(shared, Functors) /* backwards compatibility */ ; Name = term_atom("bound_unique"), Args0 = [Disj] -> disjunction_to_list(Disj, List), convert_bound_inst_list(List, Functors0), list__sort_and_remove_dups(Functors0, Functors), Result = bound(unique, Functors) ; Name = term_atom("unique"), Args0 = [Disj] -> disjunction_to_list(Disj, List), convert_bound_inst_list(List, Functors0), list__sort_and_remove_dups(Functors0, Functors), Result = bound(unique, Functors) ; parse_qualified_term(term_functor(Name, Args0, Context), "", ok(QualifiedName, Args1)), convert_inst_list(Args1, Args), Result = defined_inst(user_inst(QualifiedName, Args)) ). :- pred convert_bound_inst_list(list(term), list(bound_inst)). :- mode convert_bound_inst_list(in, out) is semidet. convert_bound_inst_list([], []). convert_bound_inst_list([H0|T0], [H|T]) :- convert_bound_inst(H0, H), convert_bound_inst_list(T0, T). :- pred convert_bound_inst(term, bound_inst). :- mode convert_bound_inst(in, out) is semidet. convert_bound_inst(term_functor(Name, Args0, _), functor(Name, Args)) :- convert_inst_list(Args0, Args). :- pred process_inst_defn(maybe1(inst_defn), varset, condition, maybe1(item)). :- mode process_inst_defn(in, in, in, out) is det. process_inst_defn(error(Error, Term), _, _, error(Error, Term)). process_inst_defn(ok(InstDefn), VarSet, Cond, ok(inst_defn(VarSet, InstDefn, Cond))). %-----------------------------------------------------------------------------% % parse a `:- mode foo :: ...' or `:- mode foo = ...' definition. :- pred parse_mode_decl(string, 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(H, Body, R), process_mode_defn(R, VarSet, Condition, Result) ; parse_mode_decl_pred(ModuleName, VarSet, ModeDefn, Result) ). :- 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 = "::" -> true ; Op = "=" ). :- pred convert_mode_defn(term, term, maybe1(mode_defn)). :- mode convert_mode_defn(in, in, out) is det. convert_mode_defn(Head, Body, Result) :- parse_qualified_term(Head, "mode definition", R), convert_mode_defn_2(R, Head, Body, Result). :- pred convert_mode_defn_2(maybe_functor, term, term, maybe1(mode_defn)). :- 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, Args), Head, Body, Result) :- % check that all the head args are variables ( %%% some [Arg] ( list__member(Arg, Args), Arg \= term_variable(_) ) -> Result = error("Mode 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 parameters in LHS of mode defn", Head) % check that all the variables in the body occur in the head ; %%% some [Var2] ( term__contains_var(Body, Var2), \+ term__contains_var_list(Args, Var2) ) -> Result = error("Free inst parameter in RHS of mode definition", Body) ; % should improve the error message here ( %%% some [ConvertedBody] convert_mode(Body, ConvertedBody) -> Result = ok(eqv_mode(Name, Args, ConvertedBody)) ; % catch-all error message - we should do % better than this Result = error("Syntax error in mode definition body", Body) ) ). :- 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, Mode), Result = type_and_mode(Type, Mode) ; convert_type(Term, Type), Result = type_only(Type) ). :- pred convert_mode_list(list(term), list(mode)). :- mode convert_mode_list(in, out) is semidet. convert_mode_list([], []). convert_mode_list([H0|T0], [H|T]) :- convert_mode(H0, H), convert_mode_list(T0, T). :- pred convert_mode(term, mode). :- mode convert_mode(in, out) is semidet. convert_mode(Term, Mode) :- ( Term = term_functor(term_atom("->"), [InstA, InstB], _Context) -> convert_inst(InstA, ConvertedInstA), convert_inst(InstB, ConvertedInstB), Mode = (ConvertedInstA -> ConvertedInstB) ; % Handle higher-order predicate modes: % a mode of the form % pred(, , ...) is det % is an abbreviation for the inst mapping % ( pred(, , ...) is det' % -> pred(, , ...) is det' % ) Term = term_functor(term_atom("is"), [PredTerm, DetTerm], _), PredTerm = term_functor(term_atom("pred"), ArgModesTerms, _) -> DetTerm = term_functor(term_atom(DetString), [], _), standard_det(DetString, Detism), convert_mode_list(ArgModesTerms, ArgModes), PredInstInfo = pred_inst_info(ArgModes, Detism), Inst = ground(shared, yes(PredInstInfo)), Mode = (Inst -> Inst) ; parse_qualified_term(Term, "mode definition", R), R = ok(Name, Args), % should improve error reporting convert_inst_list(Args, ConvertedArgs), Mode = user_defined_mode(Name, ConvertedArgs) ). :- pred process_mode_defn(maybe1(mode_defn), varset, condition, maybe1(item)). :- mode process_mode_defn(in, in, in, out) is det. process_mode_defn(error(Error, Term), _, _, error(Error, Term)). process_mode_defn(ok(ModeDefn), VarSet, Cond, ok(mode_defn(VarSet, ModeDefn, Cond))). %-----------------------------------------------------------------------------% % parse {import,use,export}_module declarations :- pred parse_import_module_decl(varset, term, maybe1(item)). :- mode parse_import_module_decl(in, in, out) is det. parse_import_module_decl(VarSet, ModuleSpec, Result) :- parse_module_spec_list(ModuleSpec, R), process_import(R, VarSet, Result). :- pred parse_use_module_decl(varset, term, maybe1(item)). :- mode parse_use_module_decl(in, in, out) is det. parse_use_module_decl(VarSet, ModuleSpec, Result) :- parse_module_spec_list(ModuleSpec, R), process_use(R, VarSet, Result). :- pred parse_export_module_decl(varset, term, maybe1(item)). :- mode parse_export_module_decl(in, in, out) is det. parse_export_module_decl(VarSet, ModuleSpec, Result) :- parse_module_spec_list(ModuleSpec, R), process_export(R, VarSet, Result). % parse {import,use,export}_sym declarations :- pred parse_export_sym_decl(varset, term, maybe1(item)). :- mode parse_export_sym_decl(in, in, out) is det. parse_export_sym_decl(VarSet, SymSpec, Result) :- parse_sym_spec_list(SymSpec, R), process_export(R, VarSet, Result). :- pred parse_import_sym_decl(varset, term, maybe1(item)). :- mode parse_import_sym_decl(in, in, out) is det. parse_import_sym_decl(VarSet, SymSpec, Result) :- parse_sym_spec_list(SymSpec, R), process_import(R, VarSet, Result). :- pred parse_use_sym_decl(varset, term, maybe1(item)). :- mode parse_use_sym_decl(in, in, out) is det. parse_use_sym_decl(VarSet, SymSpec, Result) :- parse_sym_spec_list(SymSpec, R), process_use(R, VarSet, Result). % parse {import,use,export}_pred declarations :- pred parse_import_pred_decl(varset, term, maybe1(item)). :- mode parse_import_pred_decl(in, in, out) is det. parse_import_pred_decl(VarSet, PredSpec, Result) :- parse_pred_spec_list(PredSpec, R), process_import(R, VarSet, Result). :- pred parse_use_pred_decl(varset, term, maybe1(item)). :- mode parse_use_pred_decl(in, in, out) is det. parse_use_pred_decl(VarSet, PredSpec, Result) :- parse_pred_spec_list(PredSpec, R), process_use(R, VarSet, Result). :- pred parse_export_pred_decl(varset, term, maybe1(item)). :- mode parse_export_pred_decl(in, in, out) is det. parse_export_pred_decl(VarSet, PredSpec, Result) :- parse_pred_spec_list(PredSpec, R), process_export(R, VarSet, Result). % parse {import,use,export}_cons declarations :- pred parse_import_cons_decl(varset, term, maybe1(item)). :- mode parse_import_cons_decl(in, in, out) is det. parse_import_cons_decl(VarSet, ConsSpec, Result) :- parse_cons_spec_list(ConsSpec, R), process_import(R, VarSet, Result). :- pred parse_use_cons_decl(varset, term, maybe1(item)). :- mode parse_use_cons_decl(in, in, out) is det. parse_use_cons_decl(VarSet, ConsSpec, Result) :- parse_cons_spec_list(ConsSpec, R), process_use(R, VarSet, Result). :- pred parse_export_cons_decl(varset, term, maybe1(item)). :- mode parse_export_cons_decl(in, in, out) is det. parse_export_cons_decl(VarSet, ConsSpec, Result) :- parse_cons_spec_list(ConsSpec, R), process_export(R, VarSet, Result). % parse {import,use,export}_type declarations :- pred parse_import_type_decl(varset, term, maybe1(item)). :- mode parse_import_type_decl(in, in, out) is det. parse_import_type_decl(VarSet, TypeSpec, Result) :- parse_type_spec_list(TypeSpec, R), process_import(R, VarSet, Result). :- pred parse_use_type_decl(varset, term, maybe1(item)). :- mode parse_use_type_decl(in, in, out) is det. parse_use_type_decl(VarSet, TypeSpec, Result) :- parse_type_spec_list(TypeSpec, R), process_use(R, VarSet, Result). :- pred parse_export_type_decl(varset, term, maybe1(item)). :- mode parse_export_type_decl(in, in, out) is det. parse_export_type_decl(VarSet, TypeSpec, Result) :- parse_type_spec_list(TypeSpec, R), process_export(R, VarSet, Result). % parse {import,use,export}_adt declarations :- pred parse_import_adt_decl(varset, term, maybe1(item)). :- mode parse_import_adt_decl(in, in, out) is det. parse_import_adt_decl(VarSet, ADT_Spec, Result) :- parse_adt_spec_list(ADT_Spec, R), process_import(R, VarSet, Result). :- pred parse_use_adt_decl(varset, term, maybe1(item)). :- mode parse_use_adt_decl(in, in, out) is det. parse_use_adt_decl(VarSet, ADT_Spec, Result) :- parse_adt_spec_list(ADT_Spec, R), process_use(R, VarSet, Result). :- pred parse_export_adt_decl(varset, term, maybe1(item)). :- mode parse_export_adt_decl(in, in, out) is det. parse_export_adt_decl(VarSet, ADT_Spec, Result) :- parse_adt_spec_list(ADT_Spec, R), process_export(R, VarSet, Result). % parse {import,use,export}_op declarations :- pred parse_import_op_decl(varset, term, maybe1(item)). :- mode parse_import_op_decl(in, in, out) is det. parse_import_op_decl(VarSet, OpSpec, Result) :- parse_op_spec_list(OpSpec, R), process_import(R, VarSet, Result). :- pred parse_use_op_decl(varset, term, maybe1(item)). :- mode parse_use_op_decl(in, in, out) is det. parse_use_op_decl(VarSet, OpSpec, Result) :- parse_op_spec_list(OpSpec, R), process_use(R, VarSet, Result). :- pred parse_export_op_decl(varset, term, maybe1(item)). :- mode parse_export_op_decl(in, in, out) is det. parse_export_op_decl(VarSet, OpSpec, Result) :- parse_op_spec_list(OpSpec, R), process_export(R, VarSet, Result). %-----------------------------------------------------------------------------% % Parse a comma-separated list (misleading described as % a "conjunction") of module specifiers. :- pred parse_module_spec_list(term, maybe1(sym_list)). :- mode parse_module_spec_list(in, out) is det. parse_module_spec_list(Term, Result) :- conjunction_to_list(Term, List), parse_module_spec_list_2(List, R), process_module_spec_list(R, Result). :- pred parse_module_spec_list_2(list(term), maybe1(list(module_specifier))). :- mode parse_module_spec_list_2(in, out) is det. parse_module_spec_list_2([], ok([])). parse_module_spec_list_2([X|Xs], Result) :- parse_module_specifier(X, X_Result), parse_module_spec_list_2(Xs, Xs_Result), combine_list_results(X_Result, Xs_Result, Result). :- pred process_module_spec_list(maybe1(list(module_specifier)), maybe1(sym_list)). :- mode process_module_spec_list(in, out) is det. process_module_spec_list(ok(X), ok(module(X))). process_module_spec_list(error(M, T), error(M, T)). % Parse a comma-separated list (misleading described as % a "conjunction") of symbol specifiers. :- pred parse_sym_spec_list(term, maybe1(sym_list)). :- mode parse_sym_spec_list(in, out) is det. parse_sym_spec_list(Term, Result) :- conjunction_to_list(Term, List), parse_sym_spec_list_2(List, R), process_sym_spec_list(R, Result). :- pred parse_sym_spec_list_2(list(term), maybe1(list(sym_specifier))). :- mode parse_sym_spec_list_2(in, out) is det. parse_sym_spec_list_2([], ok([])). parse_sym_spec_list_2([X|Xs], Result) :- parse_symbol_specifier(X, X_Result), parse_sym_spec_list_2(Xs, Xs_Result), combine_list_results(X_Result, Xs_Result, Result). :- pred process_sym_spec_list(maybe1(list(sym_specifier)), maybe1(sym_list)). :- mode process_sym_spec_list(in, out) is det. process_sym_spec_list(ok(X), ok(sym(X))). process_sym_spec_list(error(M, T), error(M, T)). % Parse a comma-separated list (misleading described as % a "conjunction") of predicate specifiers. :- pred parse_pred_spec_list(term, maybe1(sym_list)). :- mode parse_pred_spec_list(in, out) is det. parse_pred_spec_list(Term, Result) :- conjunction_to_list(Term, List), parse_pred_spec_list_2(List, R), process_pred_spec_list(R, Result). :- pred parse_pred_spec_list_2(list(term), maybe1(list(pred_specifier))). :- mode parse_pred_spec_list_2(in, out) is det. parse_pred_spec_list_2([], ok([])). parse_pred_spec_list_2([X|Xs], Result) :- parse_predicate_specifier(X, X_Result), parse_pred_spec_list_2(Xs, Xs_Result), combine_list_results(X_Result, Xs_Result, Result). :- pred process_pred_spec_list(maybe1(list(pred_specifier)), maybe1(sym_list)). :- mode process_pred_spec_list(in, out) is det. process_pred_spec_list(ok(X), ok(pred(X))). process_pred_spec_list(error(M, T), error(M, T)). % Parse a comma-separated list (misleading described as % a "conjunction") of constructor specifiers. :- pred parse_cons_spec_list(term, maybe1(sym_list)). :- mode parse_cons_spec_list(in, out) is det. parse_cons_spec_list(Term, Result) :- conjunction_to_list(Term, List), parse_cons_spec_list_2(List, R), process_cons_spec_list(R, Result). :- pred parse_cons_spec_list_2(list(term), maybe1(list(cons_specifier))). :- mode parse_cons_spec_list_2(in, out) is det. parse_cons_spec_list_2([], ok([])). parse_cons_spec_list_2([X|Xs], Result) :- parse_constructor_specifier(X, X_Result), parse_cons_spec_list_2(Xs, Xs_Result), combine_list_results(X_Result, Xs_Result, Result). :- pred process_cons_spec_list(maybe1(list(cons_specifier)), maybe1(sym_list)). :- mode process_cons_spec_list(in, out) is det. process_cons_spec_list(ok(X), ok(cons(X))). process_cons_spec_list(error(M, T), error(M, T)). % Parse a comma-separated list (misleading described as % a "conjunction") of type specifiers. :- pred parse_type_spec_list(term, maybe1(sym_list)). :- mode parse_type_spec_list(in, out) is det. parse_type_spec_list(Term, Result) :- conjunction_to_list(Term, List), parse_type_spec_list_2(List, R), process_type_spec_list(R, Result). :- pred parse_type_spec_list_2(list(term), maybe1(list(sym_name_specifier))). :- mode parse_type_spec_list_2(in, out) is det. parse_type_spec_list_2([], ok([])). parse_type_spec_list_2([X|Xs], Result) :- parse_type_specifier(X, X_Result), parse_type_spec_list_2(Xs, Xs_Result), combine_list_results(X_Result, Xs_Result, Result). :- pred process_type_spec_list(maybe1(list(sym_name_specifier)), maybe1(sym_list)). :- mode process_type_spec_list(in, out) is det. process_type_spec_list(ok(X), ok(type(X))). process_type_spec_list(error(M, T), error(M, T)). % Parse a comma-separated list (misleading described as % a "conjunction") of adt specifiers. :- pred parse_adt_spec_list(term, maybe1(sym_list)). :- mode parse_adt_spec_list(in, out) is det. parse_adt_spec_list(Term, Result) :- conjunction_to_list(Term, List), parse_adt_spec_list_2(List, R), process_adt_spec_list(R, Result). :- pred parse_adt_spec_list_2(list(term), maybe1(list(sym_name_specifier))). :- mode parse_adt_spec_list_2(in, out) is det. parse_adt_spec_list_2([], ok([])). parse_adt_spec_list_2([X|Xs], Result) :- parse_adt_specifier(X, X_Result), parse_adt_spec_list_2(Xs, Xs_Result), combine_list_results(X_Result, Xs_Result, Result). :- pred process_adt_spec_list(maybe1(list(sym_name_specifier)), maybe1(sym_list)). :- mode process_adt_spec_list(in, out) is det. process_adt_spec_list(ok(X), ok(adt(X))). process_adt_spec_list(error(M, T), error(M, T)). % Parse a comma-separated list (misleading described as % a "conjunction") of operator specifiers. :- pred parse_op_spec_list(term, maybe1(sym_list)). :- mode parse_op_spec_list(in, out) is det. parse_op_spec_list(Term, Result) :- conjunction_to_list(Term, List), parse_op_spec_list_2(List, R), process_op_spec_list(R, Result). :- pred parse_op_spec_list_2(list(term), maybe1(list(op_specifier))). :- mode parse_op_spec_list_2(in, out) is det. parse_op_spec_list_2([], ok([])). parse_op_spec_list_2([X|Xs], Result) :- parse_op_specifier(X, X_Result), parse_op_spec_list_2(Xs, Xs_Result), combine_list_results(X_Result, Xs_Result, Result). :- pred process_op_spec_list(maybe1(list(op_specifier)), maybe1(sym_list)). :- mode process_op_spec_list(in, out) is det. process_op_spec_list(ok(X), ok(op(X))). process_op_spec_list(error(M, T), error(M, T)). %-----------------------------------------------------------------------------% % If a list of things contains multiple errors, then we only % report the first one. :- pred combine_list_results(maybe1(T), maybe1(list(T)), maybe1(list(T))). :- mode combine_list_results(in, in, out) is det. combine_list_results(error(Msg, Term), _, error(Msg, Term)). combine_list_results(ok(_), error(Msg, Term), error(Msg, Term)). combine_list_results(ok(X), ok(Xs), ok([X|Xs])). %-----------------------------------------------------------------------------% % % 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(Term, Result) :- ( Term = term_functor(term_atom("cons"), [ConsSpecTerm], _Context1) -> parse_constructor_specifier(ConsSpecTerm, ConsSpecResult), process_cons_symbol_specifier(ConsSpecResult, Result) ; Term = term_functor(term_atom("pred"), [PredSpecTerm], _Context2) -> parse_predicate_specifier(PredSpecTerm, PredSpecResult), process_pred_symbol_specifier(PredSpecResult, Result) ; Term = term_functor(term_atom("type"), [TypeSpecTerm], _Context3) -> parse_type_specifier(TypeSpecTerm, TypeSpecResult), process_type_symbol_specifier(TypeSpecResult, Result) ; Term = term_functor(term_atom("adt"), [AdtSpecTerm], _Context4) -> parse_adt_specifier(AdtSpecTerm, AdtSpecResult), process_adt_symbol_specifier(AdtSpecResult, Result) ; Term = term_functor(term_atom("op"), [OpSpecTerm], _Context5) -> parse_op_specifier(OpSpecTerm, OpSpecResult), process_op_symbol_specifier(OpSpecResult, Result) ; Term = term_functor(term_atom("module"), [ModuleSpecTerm], _Context6) -> parse_module_specifier(ModuleSpecTerm, ModuleSpecResult), process_module_symbol_specifier(ModuleSpecResult, Result) ; parse_constructor_specifier(Term, TermResult), process_any_symbol_specifier(TermResult, Result) ). % Once we've parsed the appropriate type of symbol specifier, we % need to convert it to a sym_specifier, propagating errors upwards. :- pred process_module_symbol_specifier(maybe1(module_specifier), maybe1(sym_specifier)). :- mode process_module_symbol_specifier(in, out) is det. process_module_symbol_specifier(ok(OpSpec), ok(module(OpSpec))). process_module_symbol_specifier(error(Msg, Term), error(Msg, Term)). :- pred process_any_symbol_specifier(maybe1(cons_specifier), maybe1(sym_specifier)). :- mode process_any_symbol_specifier(in, out) is det. process_any_symbol_specifier(error(Msg, Term), error(Msg, Term)). process_any_symbol_specifier(ok(ConsSpec), ok(SymSpec)) :- cons_specifier_to_sym_specifier(ConsSpec, SymSpec). :- 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)). :- pred process_pred_symbol_specifier(maybe1(pred_specifier), maybe1(sym_specifier)). :- mode process_pred_symbol_specifier(in, out) is det. process_pred_symbol_specifier(error(Msg, Term), error(Msg, Term)). process_pred_symbol_specifier(ok(PredSpec), ok(pred(PredSpec))). :- pred process_cons_symbol_specifier(maybe1(cons_specifier), maybe1(sym_specifier)). :- mode process_cons_symbol_specifier(in, out) is det. process_cons_symbol_specifier(error(Msg, Term), error(Msg, Term)). process_cons_symbol_specifier(ok(ConsSpec), ok(cons(ConsSpec))). :- pred process_type_symbol_specifier(maybe1(sym_name_specifier), maybe1(sym_specifier)). :- mode process_type_symbol_specifier(in, out) is det. process_type_symbol_specifier(ok(SymSpec), ok(type(SymSpec))). process_type_symbol_specifier(error(Msg, Term), error(Msg, Term)). :- pred process_adt_symbol_specifier(maybe1(sym_name_specifier), maybe1(sym_specifier)). :- mode process_adt_symbol_specifier(in, out) is det. process_adt_symbol_specifier(ok(SymSpec), ok(adt(SymSpec))). process_adt_symbol_specifier(error(Msg, Term), error(Msg, Term)). :- pred process_op_symbol_specifier(maybe1(op_specifier), maybe1(sym_specifier)). :- mode process_op_symbol_specifier(in, out) is det. process_op_symbol_specifier(ok(OpSpec), ok(op(OpSpec))). process_op_symbol_specifier(error(Msg, Term), error(Msg, Term)). %-----------------------------------------------------------------------------% % A ModuleSpecifier is just an identifier. :- pred parse_module_specifier(term, maybe1(module_specifier)). :- mode parse_module_specifier(in, out) is det. parse_module_specifier(Term, Result) :- ( Term = term_functor(term_atom(ModuleName), [], _Context) -> Result = ok(ModuleName) ; Result = error("Module specifier should be an identifier", Term) ). %-----------------------------------------------------------------------------% % 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_untyped_constructor_specifier(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_arity_predicate_specifier(NameResult, Result) ; parse_qualified_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, Args), ok(Result)) :- ( Args = [] -> Result = sym(name(Name)) ; Result = name_args(Name, Args) ). process_typed_predicate_specifier(error(Msg, Term), error(Msg, Term)). :- pred process_arity_predicate_specifier(maybe1(sym_name_specifier), maybe1(pred_specifier)). :- mode process_arity_predicate_specifier(in, out) is det. process_arity_predicate_specifier(ok(Result), ok(sym(Result))). process_arity_predicate_specifier(error(Msg, Term), error(Msg, Term)). %-----------------------------------------------------------------------------% % 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_arity_predicate_specifier(NameResult, Result) ; parse_qualified_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 process_untyped_constructor_specifier(maybe1(pred_specifier), maybe1(cons_specifier)). :- mode process_untyped_constructor_specifier(in, out) is det. process_untyped_constructor_specifier(error(Msg, Term), error(Msg, Term)). process_untyped_constructor_specifier(ok(NameArgs), ok(Result)) :- process_untyped_cons_spec_2(NameArgs, Result). :- pred process_untyped_cons_spec_2(pred_specifier, cons_specifier). :- mode process_untyped_cons_spec_2(in, out) is det. process_untyped_cons_spec_2(sym(Name), sym(Name)). process_untyped_cons_spec_2(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_name_arity_specifier(NameResult, Arity, 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_name_specifier(SymbolNameResult, Result) ). :- pred process_name_arity_specifier(maybe1(sym_name), arity, maybe1(sym_name_specifier)). :- mode process_name_arity_specifier(in, in, out) is det. process_name_arity_specifier(ok(Name), Arity, ok(name_arity(Name, Arity))). process_name_arity_specifier(error(Error, Term), _, error(Error, Term)). :- pred process_name_specifier(maybe1(sym_name), maybe1(sym_name_specifier)). :- mode process_name_specifier(in, out) is det. process_name_specifier(ok(Name), ok(name(Name))). process_name_specifier(error(Error, Term), error(Error, Term)). %-----------------------------------------------------------------------------% % A QualifiedTerm is one of % Name(Args) % Module:Name(Args) % (or if Args is empty, one of % Name % Module:Name) :- pred parse_qualified_term(string, term, string, maybe_functor). :- mode parse_qualified_term(in, in, in, out) is det. parse_qualified_term(DefaultModName, Term, Msg, Result) :- ( Term = term_functor(term_atom(":"), [ModuleTerm, NameArgsTerm], _Context) -> ( NameArgsTerm = term_functor(term_atom(Name), Args, _Context2) -> ( ModuleTerm = term_functor(term_atom(Module), [], _Context3) -> ( Module = DefaultModName -> Result = ok(qualified(Module, Name), Args) ; Result = error("Module qualifier in predicate definition does not match preceding `:- module' declaration", Term) ) ; Result = error("Module name identifier expected before ':' in qualified symbol name", Term) ) ; Result = error("Identifier expected after ':' in qualified symbol name", Term) ) ; ( Term = term_functor(term_atom(Name2), Args2, _Context4) -> ( DefaultModName = "" -> Result = ok(unqualified(Name2), Args2) ; Result = ok(qualified(DefaultModName, Name2), Args2) ) ; string__append("atom expected in ", Msg, ErrorMsg), Result = error(ErrorMsg, Term) ) ). % parse_qualified_term/3 calls parse_qualified_term/4, and is used when % no default module name exists. :- pred parse_qualified_term(term, string, maybe_functor). :- mode parse_qualified_term(in, in, out) is det. parse_qualified_term(Term, Msg, Result) :- parse_qualified_term("", Term, Msg, Result). %-----------------------------------------------------------------------------% % 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. :- pred parse_symbol_name(string, term, maybe1(sym_name)). :- mode parse_symbol_name(in, in, out) is det. parse_symbol_name(DefaultModName, Term, Result) :- ( Term = term_functor(term_atom(":"), [ModuleTerm, NameTerm], _Context) -> ( NameTerm = term_functor(term_atom(Name), [], _Context1) -> ( ModuleTerm = term_functor(term_atom(Module), [], _Context2) -> Result = ok(qualified(Module, Name)) ; Result = error("Module name identifier expected before ':' in qualified symbol name", Term) ) ; Result = error("Identifier expected after ':' in qualified symbol name", Term) ) ; ( Term = term_functor(term_atom(Name2), [], _Context3) -> ( DefaultModName = "" -> Result = ok(unqualified(Name2)) ; Result = ok(qualified(DefaultModName, Name2)) ) ; Result = error("Symbol name specifier expected", Term) ) ). :- pred parse_symbol_name(term, maybe1(sym_name)). :- mode parse_symbol_name(in, out) is det. parse_symbol_name(Term, Result) :- parse_symbol_name("", Term, Result). %-----------------------------------------------------------------------------% % convert a module definition to a program item, % propagating errors upwards :- pred process_import(maybe1(sym_list), varset, maybe1(item)). :- mode process_import(in, in, out) is det. process_import(ok(X), VarSet, ok(module_defn(VarSet, import(X)))). process_import(error(Msg, Term), _, error(Msg, Term)). :- pred process_use(maybe1(sym_list), varset, maybe1(item)). :- mode process_use(in, in, out) is det. process_use(ok(X), VarSet, ok(module_defn(VarSet, use(X)))). process_use(error(Msg, Term), _, error(Msg, Term)). :- pred process_export(maybe1(sym_list), varset, maybe1(item)). :- mode process_export(in, in, out) is det. process_export(ok(X), VarSet, ok(module_defn(VarSet, export(X)))). process_export(error(Msg, Term), _, error(Msg, Term)). %-----------------------------------------------------------------------------% % 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_op_specifier(R, Result). :- pred process_op_specifier(maybe1(sym_name_specifier), maybe1(op_specifier)). :- mode process_op_specifier(in, out) is det. process_op_specifier(ok(X), ok(sym(X))). process_op_specifier(error(M,T), error(M,T)). %-----------------------------------------------------------------------------% % types are represented just as ordinary terms :- pred parse_type(term, maybe1(type)). :- mode parse_type(in, out) is det. parse_type(T, ok(T)). :- pred convert_type_list(list(term), list(type)). :- mode convert_type_list(in, out) is det. convert_type_list([], []). convert_type_list([H0|T0], [H|T]) :- convert_type(H0, H), convert_type_list(T0, T). :- pred convert_type(term, type). :- mode convert_type(in, out) is det. convert_type(T, T). %-----------------------------------------------------------------------------% report_warning(Message) --> io__stderr_stream(StdErr), ( globals__io_lookup_bool_option(halt_at_warn, yes) -> io__set_exit_status(1) ; [] ), io__write_string(StdErr, Message). report_warning(Stream, Message) --> ( globals__io_lookup_bool_option(halt_at_warn, yes) -> io__set_exit_status(1) ; [] ), io__write_string(Stream, Message). report_warning(Module_name, Line_num, Message) --> { string__int_to_string(Line_num, Line_str) }, { string__append_list([Module_name, ".m:", Line_str, ": Warning: ", Message, "\n"], Message_0) }, io__stderr_stream(StdErr), io__write_string(StdErr, Message_0), ( globals__io_lookup_bool_option(halt_at_warn, yes) -> io__set_exit_status(1) ; [] ).