[m-rev.] diff: prog_io_{mode,type}_defn.m
Zoltan Somogyi
zs at csse.unimelb.edu.au
Wed Dec 3 16:01:01 AEDT 2008
Hopefully finish the breakup of the monster module prog_io.m. It is now way
out of the list of the ten biggest modules. More important, it now has much
more coherence: it consists mainly of
- the top level loop for reading in items, and
- the code for parsing predicate, function and mode declarations.
There are still some other misc things that don't fit here (e.g. checking insts
for consistency), but they don't fit that well in other modules either.
compiler/prog_io.m:
compiler/prog_io_mode_defn.m:
compiler/prog_io_type_defn.m:
Move the code in prog_io.m for dealing with definitions of insts, modes
and types into two new modules.
Delete some obsolete comments at the top of prog_io.m..
compiler/prog_io_util.m:
Move some generic stuff for dealing with declaration attributes and
(nonsupported) conditions here from prog_io.m, since the module
prog_io_type_defn.m also needs them.
compiler/parse_tree.m:
compiler/notes/compiler_design.html:
Add the new modules.
compiler/*.m:
Import the new modules where needed.
Zoltan.
cvs diff: Diffing .
cvs diff: Diffing analysis
cvs diff: Diffing bindist
cvs diff: Diffing boehm_gc
cvs diff: Diffing boehm_gc/Mac_files
cvs diff: Diffing boehm_gc/cord
cvs diff: Diffing boehm_gc/cord/private
cvs diff: Diffing boehm_gc/doc
cvs diff: Diffing boehm_gc/include
cvs diff: Diffing boehm_gc/include/private
cvs diff: Diffing boehm_gc/libatomic_ops-1.2
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/doc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/gcc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/hpc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/ibmc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/icc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/msftc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/src/atomic_ops/sysdeps/sunc
cvs diff: Diffing boehm_gc/libatomic_ops-1.2/tests
cvs diff: Diffing boehm_gc/tests
cvs diff: Diffing boehm_gc/windows-untested
cvs diff: Diffing boehm_gc/windows-untested/vc60
cvs diff: Diffing boehm_gc/windows-untested/vc70
cvs diff: Diffing boehm_gc/windows-untested/vc71
cvs diff: Diffing browser
cvs diff: Diffing bytecode
cvs diff: Diffing compiler
Index: compiler/parse_tree.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/parse_tree.m,v
retrieving revision 1.19
diff -u -b -r1.19 parse_tree.m
--- compiler/parse_tree.m 2 Dec 2008 04:30:24 -0000 1.19
+++ compiler/parse_tree.m 2 Dec 2008 05:33:17 -0000
@@ -30,9 +30,11 @@
:- include_module prog_io.
:- include_module prog_io_dcg.
:- include_module prog_io_goal.
+ :- include_module prog_io_mode_defn.
:- include_module prog_io_mutable.
:- include_module prog_io_pragma.
:- include_module prog_io_sym_name.
+ :- include_module prog_io_type_defn.
:- include_module prog_io_typeclass.
:- include_module prog_io_util.
Index: compiler/prog_io.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io.m,v
retrieving revision 1.295
diff -u -b -r1.295 prog_io.m
--- compiler/prog_io.m 2 Dec 2008 04:30:24 -0000 1.295
+++ compiler/prog_io.m 2 Dec 2008 06:47:53 -0000
@@ -32,16 +32,6 @@
% 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
@@ -162,24 +152,6 @@
:- pred parse_decl(module_name::in, varset::in, term::in, int::in,
maybe1(item)::out) is det.
- % parse_type_defn_head(ModuleName, VarSet, Head, HeadResult):
- %
- % Check the head of a type definition for errors.
- %
-:- pred parse_type_defn_head(module_name::in, varset::in, term::in,
- maybe2(sym_name, list(type_param))::out) is det.
-
- % parse_type_decl_where_part_if_present(TypeSymName, Arity,
- % IsSolverType, Inst, ModuleName, Term0, Term, Result):
- %
- % Checks if Term0 is a term of the form `<body> where <attributes>'.
- % If so, returns the `<body>' in Term and the parsed `<attributes>'
- % in Result. If not, returns Term = Term0 and Result = no.
- %
-:- pred parse_type_decl_where_part_if_present(is_solver_type::in,
- module_name::in, varset::in, term::in, term::out,
- maybe2(maybe(solver_type_details), maybe(unify_compare))::out) is det.
-
%-----------------------------------------------------------------------------%
% Replace all occurrences of inst_var(I) with
@@ -214,9 +186,11 @@
:- import_module parse_tree.mercury_to_mercury.
:- import_module parse_tree.prog_io_dcg.
:- import_module parse_tree.prog_io_goal.
+:- import_module parse_tree.prog_io_mode_defn.
:- import_module parse_tree.prog_io_mutable.
:- import_module parse_tree.prog_io_pragma.
:- import_module parse_tree.prog_io_sym_name.
+:- import_module parse_tree.prog_io_type_defn.
:- import_module parse_tree.prog_io_typeclass.
:- import_module parse_tree.prog_io_util.
:- import_module parse_tree.prog_mode.
@@ -1027,23 +1001,6 @@
%-----------------------------------------------------------------------------%
-:- type decl_attribute
- ---> decl_attr_purity(purity)
- ; decl_attr_quantifier(quantifier_type, list(var))
- ; decl_attr_constraints(quantifier_type, term)
- % the term here is the (not yet parsed) list of constraints
- ; decl_attr_solver_type.
-
-:- type quantifier_type
- ---> quant_type_exist
- ; quant_type_univ.
-
- % The term associated with each decl_attribute is the term containing
- % both the attribute and the declaration that that attribute modifies;
- % this term is used when printing out error messages for cases when
- % attributes are used on declarations where they are not allowed.
-:- type decl_attrs == assoc_list(decl_attribute, term.context).
-
parse_decl(ModuleName, VarSet, Term, SeqNum, MaybeItem) :-
parse_attrs_and_decl(ModuleName, VarSet, Term, [], SeqNum, MaybeItem).
@@ -1384,1401 +1341,6 @@
)
).
-:- pred parse_decl_attribute(string::in, list(term)::in, decl_attribute::out,
- term::out) is semidet.
-
-parse_decl_attribute(Functor, ArgTerms, Attribute, SubTerm) :-
- (
- Functor = "impure",
- ArgTerms = [SubTerm],
- Attribute = decl_attr_purity(purity_impure)
- ;
- Functor = "semipure",
- ArgTerms = [SubTerm],
- Attribute = decl_attr_purity(purity_semipure)
- ;
- Functor = "<=",
- ArgTerms = [SubTerm, ConstraintsTerm],
- Attribute = decl_attr_constraints(quant_type_univ, ConstraintsTerm)
- ;
- Functor = "=>",
- ArgTerms = [SubTerm, ConstraintsTerm],
- Attribute = decl_attr_constraints(quant_type_exist, ConstraintsTerm)
- ;
- Functor = "some",
- ArgTerms = [TVarsTerm, SubTerm],
- parse_list_of_vars(TVarsTerm, TVars),
- Attribute = decl_attr_quantifier(quant_type_exist, TVars)
- ;
- Functor = "all",
- ArgTerms = [TVarsTerm, SubTerm],
- parse_list_of_vars(TVarsTerm, TVars),
- Attribute = decl_attr_quantifier(quant_type_univ, TVars)
- ;
- Functor = "solver",
- ArgTerms = [SubTerm],
- Attribute = decl_attr_solver_type
- ).
-
-:- pred check_no_attributes(maybe1(T)::in, decl_attrs::in, maybe1(T)::out)
- is det.
-
-check_no_attributes(Result0, Attributes, Result) :-
- (
- Result0 = ok1(_),
- Attributes = [Attr - Context | _]
- ->
- % XXX Shouldn't we mention EVERY element of Attributes?
- Pieces = [words("Error:"), words(attribute_description(Attr)),
- words("not allowed here."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(Context, [always(Pieces)])]),
- Result = error1([Spec])
- ;
- Result = Result0
- ).
-
-:- func attribute_description(decl_attribute) = string.
-
-attribute_description(decl_attr_purity(_)) = "purity specifier".
-attribute_description(decl_attr_quantifier(quant_type_univ, _)) =
- "universal quantifier (`all')".
-attribute_description(decl_attr_quantifier(quant_type_exist, _)) =
- "existential quantifier (`some')".
-attribute_description(decl_attr_constraints(quant_type_univ, _)) =
- "type class constraint (`<=')".
-attribute_description(decl_attr_constraints(quant_type_exist, _)) =
- "existentially quantified type class constraint (`=>')".
-attribute_description(decl_attr_solver_type) = "solver type specifier".
-
-%-----------------------------------------------------------------------------%
-%-----------------------------------------------------------------------------%
-%
-% Parsing type definitions.
-%
-
- % parse_type_defn parses the definition of a type.
- %
-:- pred parse_type_defn(module_name::in, varset::in, term::in, decl_attrs::in,
- prog_context::in, int::in, maybe1(item)::out) is det.
-
-parse_type_defn(ModuleName, VarSet, TypeDefnTerm, Attributes, Context,
- SeqNum, MaybeItem) :-
- (
- TypeDefnTerm = term.functor(term.atom(Name), ArgTerms, _),
- ArgTerms = [HeadTerm, BodyTerm],
- ( Name = "--->"
- ; Name = "=="
- ; Name = "where"
- )
- ->
- parse_condition_suffix(BodyTerm, BeforeCondTerm, Condition),
- (
- Name = "--->",
- parse_du_type_defn(ModuleName, VarSet,
- HeadTerm, BeforeCondTerm, Attributes,
- Condition, Context, SeqNum, MaybeItem)
- ;
- Name = "==",
- parse_eqv_type_defn(ModuleName, VarSet,
- HeadTerm, BeforeCondTerm, Attributes,
- Condition, Context, SeqNum, MaybeItem)
- ;
- Name = "where",
- parse_solver_type_defn(ModuleName, VarSet,
- HeadTerm, BeforeCondTerm, Attributes,
- Condition, Context, SeqNum, MaybeItem)
- )
- ;
- parse_abstract_type_defn(ModuleName, VarSet, TypeDefnTerm, Attributes,
- Condition, Context, SeqNum, MaybeItem),
- Condition = cond_true
- ).
-
-%-----------------------------------------------------------------------------%
-%
-% Code dealing with definitions of discriminated union types.
-%
-
- % parse_du_type_defn parses the definition of a discriminated union type.
- %
-:- pred parse_du_type_defn(module_name::in, varset::in, term::in, term::in,
- decl_attrs::in, condition::in, prog_context::in, int::in,
- maybe1(item)::out) is det.
-
-parse_du_type_defn(ModuleName, VarSet, HeadTerm, BodyTerm, Attributes0,
- Condition, Context, SeqNum, MaybeItem) :-
- get_is_solver_type(IsSolverType, Attributes0, Attributes),
- (
- IsSolverType = solver_type,
- Pieces = [words("Error: a solver type"),
- words("cannot have data constructors."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(HeadTerm), [always(Pieces)])]),
- MaybeItem = error1([Spec])
- ;
- IsSolverType = non_solver_type,
- parse_type_defn_head(ModuleName, VarSet, HeadTerm,
- MaybeTypeCtorAndArgs),
- du_type_rhs_ctors_and_where_terms(BodyTerm, CtorsTerm, MaybeWhereTerm),
- MaybeCtors = parse_constructors(ModuleName, VarSet, CtorsTerm),
- MaybeWhere = parse_type_decl_where_term(non_solver_type,
- ModuleName, VarSet, MaybeWhereTerm),
- % The code to process `where' attributes will return an error
- % if solver attributes are given for a non-solver type. Because
- % this is a du type, if the unification with MaybeWhere succeeds
- % then _NoSolverTypeDetails is guaranteed to be `no'.
- (
- MaybeTypeCtorAndArgs = ok2(Name, Params),
- MaybeCtors = ok1(Ctors),
- MaybeWhere = ok2(_NoSolverTypeDetails, MaybeUserEqComp)
- ->
- process_du_ctors(Params, VarSet, BodyTerm, Ctors, [], CtorsSpecs),
- (
- CtorsSpecs = [],
- varset.coerce(VarSet, TypeVarSet),
- TypeDefn = parse_tree_du_type(Ctors, MaybeUserEqComp),
- ItemTypeDefn = item_type_defn_info(TypeVarSet, Name, Params,
- TypeDefn, Condition, Context, SeqNum),
- Item = item_type_defn(ItemTypeDefn),
- MaybeItem0 = ok1(Item),
- check_no_attributes(MaybeItem0, Attributes, MaybeItem)
- ;
- CtorsSpecs = [_ | _],
- MaybeItem = error1(CtorsSpecs)
- )
- ;
- Specs = get_any_errors2(MaybeTypeCtorAndArgs) ++
- get_any_errors1(MaybeCtors) ++ get_any_errors2(MaybeWhere),
- MaybeItem = error1(Specs)
- )
- ).
-
-:- pred du_type_rhs_ctors_and_where_terms(term::in,
- term::out, maybe(term)::out) is det.
-
-du_type_rhs_ctors_and_where_terms(Term, CtorsTerm, MaybeWhereTerm) :-
- (
- Term = term.functor(term.atom("where"), Args, _Context),
- Args = [CtorsTerm0, WhereTerm]
- ->
- CtorsTerm = CtorsTerm0,
- MaybeWhereTerm = yes(WhereTerm)
- ;
- CtorsTerm = Term,
- MaybeWhereTerm = no
- ).
-
- % Convert a list of terms separated by semi-colons (known as a
- % "disjunction", even thought the terms aren't goals in this case)
- % into a list of constructors.
- %
-:- func parse_constructors(module_name, varset, term) =
- maybe1(list(constructor)).
-
-parse_constructors(ModuleName, VarSet, Term) = MaybeConstructors :-
- disjunction_to_list(Term, BodyTermList),
- MaybeConstructors = parse_constructors_2(ModuleName, VarSet, BodyTermList).
-
- % True if the term is a valid list of constructors.
- %
-:- func parse_constructors_2(module_name, varset, list(term)) =
- maybe1(list(constructor)).
-
-parse_constructors_2(_ModuleName, _, []) = ok1([]).
-parse_constructors_2(ModuleName, VarSet, [Head | Tail]) = MaybeConstructors :-
- MaybeHeadConstructor = parse_constructor(ModuleName, VarSet, Head),
- MaybeTailConstructors = parse_constructors_2(ModuleName, VarSet, Tail),
- (
- MaybeHeadConstructor = ok1(HeadConstructor),
- MaybeTailConstructors = ok1(TailConstructors)
- ->
- Constructors = [HeadConstructor | TailConstructors],
- MaybeConstructors = ok1(Constructors)
- ;
- Specs = get_any_errors1(MaybeHeadConstructor) ++
- get_any_errors1(MaybeTailConstructors),
- MaybeConstructors = error1(Specs)
- ).
-
-:- func parse_constructor(module_name, varset, term) = maybe1(constructor).
-
-parse_constructor(ModuleName, VarSet, Term) = MaybeConstructor :-
- ( Term = term.functor(term.atom("some"), [VarsTerm, SubTerm], _) ->
- ( parse_list_of_vars(VarsTerm, ExistQVars) ->
- list.map(term.coerce_var, ExistQVars, ExistQTVars),
- MaybeConstructor = parse_constructor_2(ModuleName, VarSet,
- ExistQTVars, Term, SubTerm)
- ;
- TermStr = describe_error_term(VarSet, Term),
- Pieces = [words("Error: syntax error in variable list at"),
- words(TermStr), suffix("."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(VarsTerm), [always(Pieces)])]),
- MaybeConstructor = error1([Spec])
- )
- ;
- ExistQVars = [],
- MaybeConstructor = parse_constructor_2(ModuleName, VarSet, ExistQVars,
- Term, Term)
- ).
-
-:- func parse_constructor_2(module_name, varset, list(tvar), term, term) =
- maybe1(constructor).
-
-parse_constructor_2(ModuleName, VarSet, ExistQVars, ContainingTerm, Term)
- = MaybeConstructor :-
- get_existential_constraints_from_term(ModuleName, VarSet, Term,
- BeforeConstraintsTerm, MaybeConstraints),
- (
- MaybeConstraints = error1(Specs),
- MaybeConstructor = error1(Specs)
- ;
- MaybeConstraints = ok1(Constraints),
- (
- % Note that as a special case, one level of curly braces around
- % the constructor are ignored. This is to allow you to define
- % ';'/2 and 'some'/2 constructors.
- BeforeConstraintsTerm = term.functor(term.atom("{}"),
- [InsideBracesTerm], _Context)
- ->
- MainTerm = InsideBracesTerm
- ;
- MainTerm = BeforeConstraintsTerm
- ),
- ContextPieces = [words("In constructor definition:")],
- parse_implicitly_qualified_term(ModuleName, MainTerm, ContainingTerm,
- VarSet, ContextPieces, MaybeFunctorAndArgTerms),
- (
- MaybeFunctorAndArgTerms = error2(Specs),
- MaybeConstructor = error1(Specs)
- ;
- MaybeFunctorAndArgTerms = ok2(Functor, ArgTerms),
- MaybeConstructorArgs = convert_constructor_arg_list(ModuleName,
- VarSet, ArgTerms),
- (
- MaybeConstructorArgs = error1(Specs),
- MaybeConstructor = error1(Specs)
- ;
- MaybeConstructorArgs = ok1(ConstructorArgs),
- Ctor = ctor(ExistQVars, Constraints, Functor, ConstructorArgs,
- get_term_context(MainTerm)),
- MaybeConstructor = ok1(Ctor)
- )
- )
- ).
-
-:- pred get_existential_constraints_from_term(module_name::in, varset::in,
- term::in, term::out, maybe1(list(prog_constraint))::out) is det.
-
-get_existential_constraints_from_term(ModuleName, VarSet, !PredTypeTerm,
- MaybeExistentialConstraints) :-
- (
- !.PredTypeTerm = term.functor(term.atom("=>"),
- [!:PredTypeTerm, ExistentialConstraints], _)
- ->
- parse_class_constraints(ModuleName, VarSet, ExistentialConstraints,
- MaybeExistentialConstraints)
- ;
- MaybeExistentialConstraints = ok1([])
- ).
-
-:- func convert_constructor_arg_list(module_name, varset, list(term)) =
- maybe1(list(constructor_arg)).
-
-convert_constructor_arg_list(_, _, []) = ok1([]).
-convert_constructor_arg_list(ModuleName, VarSet, [Term | Terms])
- = MaybeConstructorArgs :-
- ( Term = term.functor(term.atom("::"), [NameTerm, TypeTerm], _) ->
- ContextPieces = [words("In field name:")],
- parse_implicitly_qualified_term(ModuleName, NameTerm, Term,
- VarSet, ContextPieces, MaybeSymNameAndArgs),
- (
- MaybeSymNameAndArgs = error2(Specs),
- MaybeConstructorArgs = error1(Specs)
- ;
- MaybeSymNameAndArgs = ok2(SymName, SymNameArgs),
- (
- SymNameArgs = [_ | _],
- % XXX Should we add "... at function symbol ..."?
- Pieces = [words("Error: syntax error in constructor name."),
- nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(Term), [always(Pieces)])]),
- MaybeConstructorArgs = error1([Spec])
- ;
- SymNameArgs = [],
- MaybeFieldName = yes(SymName),
- MaybeConstructorArgs =
- convert_constructor_arg_list_2(ModuleName,
- VarSet, MaybeFieldName, TypeTerm, Terms)
- )
- )
- ;
- MaybeFieldName = no,
- TypeTerm = Term,
- MaybeConstructorArgs = convert_constructor_arg_list_2(ModuleName,
- VarSet, MaybeFieldName, TypeTerm, Terms)
- ).
-
-:- func convert_constructor_arg_list_2(module_name, varset, maybe(sym_name),
- term, list(term)) = maybe1(list(constructor_arg)).
-
-convert_constructor_arg_list_2(ModuleName, VarSet, MaybeFieldName,
- TypeTerm, Terms) = MaybeArgs :-
- ContextPieces = [words("In type definition:")],
- parse_type(TypeTerm, VarSet, ContextPieces, MaybeType),
- (
- MaybeType = ok1(Type),
- Context = get_term_context(TypeTerm),
- Arg = ctor_arg(MaybeFieldName, Type, Context),
- MaybeTailArgs =
- convert_constructor_arg_list(ModuleName, VarSet, Terms),
- (
- MaybeTailArgs = error1(Specs),
- MaybeArgs = error1(Specs)
- ;
- MaybeTailArgs = ok1(Args),
- MaybeArgs = ok1([Arg | Args])
- )
- ;
- MaybeType = error1(Specs),
- MaybeArgs = error1(Specs)
- ).
-
-:- pred process_du_ctors(list(type_param)::in, varset::in, term::in,
- list(constructor)::in, list(error_spec)::in, list(error_spec)::out) is det.
-
-process_du_ctors(_Params, _, _, [], !Specs).
-process_du_ctors(Params, VarSet, BodyTerm, [Ctor | Ctors], !Specs) :-
- Ctor = ctor(ExistQVars, Constraints, _CtorName, CtorArgs, _Context),
- (
- % Check that all type variables in the ctor are either explicitly
- % existentially quantified or occur in the head of the type.
-
- CtorArgTypes = list.map(func(C) = C ^ arg_type, CtorArgs),
- type_vars_list(CtorArgTypes, VarsInCtorArgTypes0),
- list.sort_and_remove_dups(VarsInCtorArgTypes0, VarsInCtorArgTypes),
- list.filter(list.contains(ExistQVars ++ Params), VarsInCtorArgTypes,
- _ExistQOrParamVars, NotExistQOrParamVars),
- NotExistQOrParamVars = [_ | _]
- ->
- % There should be no duplicate names to remove.
- varset.coerce(VarSet, GenericVarSet),
- NotExistQOrParamVarsStr =
- mercury_vars_to_string(GenericVarSet, no, NotExistQOrParamVars),
- Pieces = [words("Error: free type"),
- words(choose_number(NotExistQOrParamVars,
- "parameter", "parameters")),
- words(NotExistQOrParamVarsStr),
- words("in RHS of type definition."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(BodyTerm), [always(Pieces)])]),
- !:Specs = [Spec | !.Specs]
- ;
- % Check that all type variables in existential quantifiers do not
- % occur in the head (maybe this should just be a warning, not an error?
- % If we were to allow it, we would need to rename them apart.)
-
- set.list_to_set(ExistQVars, ExistQVarsSet),
- set.list_to_set(Params, ParamsSet),
- set.intersect(ExistQVarsSet, ParamsSet, ExistQParamsSet),
- set.non_empty(ExistQParamsSet)
- ->
- % There should be no duplicate names to remove.
- set.to_sorted_list(ExistQParamsSet, ExistQParams),
- varset.coerce(VarSet, GenericVarSet),
- ExistQParamVarsStr =
- mercury_vars_to_string(GenericVarSet, no, ExistQParams),
- Pieces = [words("Error:"),
- words(choose_number(ExistQParams,
- "type variable", "type variables")),
- words(ExistQParamVarsStr),
- words(choose_number(ExistQParams, "has", "have")),
- words("overlapping scopes"),
- words("(explicit type quantifier shadows argument type)."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(BodyTerm), [always(Pieces)])]),
- !:Specs = [Spec | !.Specs]
- ;
- % Check that all type variables in existential quantifiers occur
- % somewhere in the constructor argument types or constraints.
-
- CtorArgTypes = list.map(func(C) = C ^ arg_type, CtorArgs),
- type_vars_list(CtorArgTypes, VarsInCtorArgTypes0),
- list.sort_and_remove_dups(VarsInCtorArgTypes0, VarsInCtorArgTypes),
- constraint_list_get_tvars(Constraints, ConstraintTVars),
- list.filter(list.contains(VarsInCtorArgTypes ++ ConstraintTVars),
- ExistQVars, _OccursExistQVars, NotOccursExistQVars),
- NotOccursExistQVars = [_ | _]
- ->
- % There should be no duplicate names to remove.
- varset.coerce(VarSet, GenericVarSet),
- NotOccursExistQVarsStr =
- mercury_vars_to_string(GenericVarSet, no, NotOccursExistQVars),
- Pieces = [words("Error:"),
- words(choose_number(NotOccursExistQVars,
- "type variable", "type variables")),
- words(NotOccursExistQVarsStr),
- words("in existential quantifier"),
- words(choose_number(NotOccursExistQVars,
- "does not occur", "do not occur")),
- words("in arguments or constraints of constructor."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(BodyTerm), [always(Pieces)])]),
- !:Specs = [Spec | !.Specs]
- ;
- % Check that all type variables in existential constraints occur in
- % the existential quantifiers.
-
- ConstraintArgTypeLists =
- list.map(prog_constraint_get_arg_types, Constraints),
- list.condense(ConstraintArgTypeLists, ConstraintArgTypes),
- type_vars_list(ConstraintArgTypes, VarsInCtorArgTypes0),
- list.sort_and_remove_dups(VarsInCtorArgTypes0, VarsInCtorArgTypes),
- list.filter(list.contains(ExistQVars), VarsInCtorArgTypes,
- _ExistQArgTypes, NotExistQArgTypes),
- NotExistQArgTypes = [_ | _]
- ->
- varset.coerce(VarSet, GenericVarSet),
- NotExistQArgTypesStr =
- mercury_vars_to_string(GenericVarSet, no, NotExistQArgTypes),
- Pieces = [words("Error:"),
- words(choose_number(NotExistQArgTypes,
- "type variable", "type variables")),
- words(NotExistQArgTypesStr),
- words("in class constraints,"),
- words(choose_number(NotExistQArgTypes,
- "which was", "which were")),
- words("introduced with"), quote("=>"),
- words("must be explicitly existentially quantified"),
- words("using"), quote("some"), suffix("."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(BodyTerm), [always(Pieces)])]),
- !:Specs = [Spec | !.Specs]
- ;
- true
- ),
- process_du_ctors(Params, VarSet, BodyTerm, Ctors, !Specs).
-
-%-----------------------------------------------------------------------------%
-
- % parse_eqv_type_defn parses the definition of an equivalence type.
- %
-:- pred parse_eqv_type_defn(module_name::in, varset::in, term::in, term::in,
- decl_attrs::in, condition::in, prog_context::in, int::in,
- maybe1(item)::out) is det.
-
-parse_eqv_type_defn(ModuleName, VarSet, HeadTerm, BodyTerm, Attributes,
- Condition, Context, SeqNum, MaybeItem) :-
- parse_type_defn_head(ModuleName, VarSet, HeadTerm,
- MaybeNameAndParams),
- (
- MaybeNameAndParams = error2(Specs),
- MaybeItem = error1(Specs)
- ;
- MaybeNameAndParams = ok2(Name, Params),
- % Check that all the variables in the body occur in the head.
- (
- term.contains_var(BodyTerm, Var),
- term.coerce_var(Var, TVar),
- not list.member(TVar, Params)
- ->
- BodyTermStr = describe_error_term(VarSet, BodyTerm),
- Pieces = [words("Error: free type parameter"),
- words("in RHS of type definition:"),
- words(BodyTermStr), suffix("."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(BodyTerm), [always(Pieces)])]),
- MaybeItem = error1([Spec])
- ;
- % XXX Should pass more correct ContextPieces.
- ContextPieces = [],
- parse_type(BodyTerm, VarSet, ContextPieces, MaybeType),
- (
- MaybeType = ok1(Type),
- varset.coerce(VarSet, TypeVarSet),
- TypeDefn = parse_tree_eqv_type(Type),
- ItemTypeDefn = item_type_defn_info(TypeVarSet, Name, Params,
- TypeDefn, Condition, Context, SeqNum),
- Item = item_type_defn(ItemTypeDefn),
- MaybeItem0 = ok1(Item),
- check_no_attributes(MaybeItem0, Attributes, MaybeItem)
- ;
- MaybeType = error1(Specs),
- MaybeItem = error1(Specs)
- )
- )
- ).
-
-%-----------------------------------------------------------------------------%
-
- % parse_solver_type_defn parses the definition of a solver type.
- %
-:- pred parse_solver_type_defn(module_name::in, varset::in, term::in, term::in,
- decl_attrs::in, condition::in, prog_context::in, int::in,
- maybe1(item)::out) is det.
-
-parse_solver_type_defn(ModuleName, VarSet, HeadTerm, BodyTerm, Attributes0,
- Condition, Context, SeqNum, MaybeItem) :-
- get_is_solver_type(IsSolverType, Attributes0, Attributes),
- (
- IsSolverType = non_solver_type,
- Pieces = [words("Error: only solver types can be defined"),
- words("by a `where' block alone."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(HeadTerm), [always(Pieces)])]),
- MaybeItem = error1([Spec])
- ;
- IsSolverType = solver_type,
- MaybeWhere = parse_type_decl_where_term(solver_type, ModuleName,
- VarSet, yes(BodyTerm)),
- (
- MaybeWhere = error2(Specs),
- MaybeItem = error1(Specs)
- ;
- MaybeWhere = ok2(MaybeSolverTypeDetails, MaybeUserEqComp),
- parse_solver_type_base(ModuleName, VarSet, HeadTerm,
- MaybeSolverTypeDetails, MaybeUserEqComp, Attributes,
- Condition, Context, SeqNum, MaybeItem)
- )
- ).
-
-:- pred parse_solver_type_base(module_name::in, varset::in, term::in,
- maybe(solver_type_details)::in, maybe(unify_compare)::in,
- decl_attrs::in, condition::in, prog_context::in, int::in,
- maybe1(item)::out) is det.
-
-parse_solver_type_base(ModuleName, VarSet, HeadTerm,
- MaybeSolverTypeDetails, MaybeUserEqComp, Attributes, Condition,
- Context, SeqNum, MaybeItem) :-
- (
- MaybeSolverTypeDetails = yes(SolverTypeDetails),
- parse_type_defn_head(ModuleName, VarSet, HeadTerm, MaybeNameParams),
- (
- MaybeNameParams = error2(Specs),
- MaybeItem = error1(Specs)
- ;
- MaybeNameParams = ok2(Name, Params),
- (
- RepnType = SolverTypeDetails ^ representation_type,
- type_contains_var(RepnType, Var),
- not list.member(Var, Params)
- ->
- HeadTermStr = describe_error_term(VarSet, HeadTerm),
- Pieces = [words("Error: free type variable"),
- words("in representation type:"),
- words(HeadTermStr), suffix("."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(HeadTerm),
- [always(Pieces)])]),
- MaybeItem = error1([Spec])
- ;
- varset.coerce(VarSet, TypeVarSet),
- TypeDefn = parse_tree_solver_type(SolverTypeDetails,
- MaybeUserEqComp),
- ItemTypeDefn = item_type_defn_info(TypeVarSet, Name, Params,
- TypeDefn, Condition, Context, SeqNum),
- Item = item_type_defn(ItemTypeDefn),
- MaybeItem0 = ok1(Item),
- check_no_attributes(MaybeItem0, Attributes, MaybeItem)
- )
- )
- ;
- MaybeSolverTypeDetails = no,
- Pieces = [words("Solver type with no solver_type_details."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(HeadTerm), [always(Pieces)])]),
- MaybeItem = error1([Spec])
- ).
-
-%-----------------------------------------------------------------------------%
-%
-% Parse an abstract type definition.
-%
-
-:- pred parse_abstract_type_defn(module_name::in, varset::in, term::in,
- decl_attrs::in, condition::in, prog_context::in, int::in,
- maybe1(item)::out) is det.
-
-parse_abstract_type_defn(ModuleName, VarSet, HeadTerm, Attributes0,
- Condition, Context, SeqNum, MaybeItem) :-
- parse_type_defn_head(ModuleName, VarSet, HeadTerm, MaybeTypeCtorAndArgs),
- get_is_solver_type(IsSolverType, Attributes0, Attributes),
- (
- MaybeTypeCtorAndArgs = error2(Specs),
- MaybeItem = error1(Specs)
- ;
- MaybeTypeCtorAndArgs = ok2(Name, Params),
- varset.coerce(VarSet, TypeVarSet),
- TypeDefn = parse_tree_abstract_type(IsSolverType),
- ItemTypeDefn = item_type_defn_info(TypeVarSet, Name, Params, TypeDefn,
- Condition, Context, SeqNum),
- Item = item_type_defn(ItemTypeDefn),
- MaybeItem0 = ok1(Item),
- check_no_attributes(MaybeItem0, Attributes, MaybeItem)
- ).
-
-%-----------------------------------------------------------------------------%
-%
-% Parse ... where ... clauses in type definitions. These clauses can specify
-% type-specific unify and/or compare predicates for discriminated union types
-% and solver type details for solver types.
-%
-
- % The optional `where ...' part of the type definition syntax
- % is a comma separated list of special type `attributes'.
- %
- % The possible attributes (in this order) are either
- % - `type_is_abstract_noncanonical' on its own appears only in .int2
- % files and indicates that the type has user-defined equality and/or
- % comparison, but that what these predicates are is not known at
- % this point
- % or
- % - `representation is <<type name>>' (required for solver types)
- % - `initialisation is <<pred name>>' (required for solver types)
- % - `ground is <<inst>>' (required for solver types)
- % - `any is <<inst>>' (required for solver types)
- % - `equality is <<pred name>>' (optional)
- % - `comparison is <<pred name>>' (optional).
- %
-parse_type_decl_where_part_if_present(IsSolverType, ModuleName, VarSet,
- Term, BeforeWhereTerm, MaybeWhereDetails) :-
- (
- Term = term.functor(term.atom("where"),
- [BeforeWhereTermPrime, WhereTerm], _)
- ->
- BeforeWhereTerm = BeforeWhereTermPrime,
- MaybeWhereDetails = parse_type_decl_where_term(IsSolverType,
- ModuleName, VarSet, yes(WhereTerm))
- ;
- BeforeWhereTerm = Term,
- MaybeWhereDetails = ok2(no, no)
- ).
-
- % The maybe2 wrapper allows us to return an error code or a pair
- % of results. Either result half may be empty, hence the maybe
- % wrapper around each of those.
- %
-:- func parse_type_decl_where_term(is_solver_type, module_name, varset,
- maybe(term)) = maybe2(maybe(solver_type_details), maybe(unify_compare)).
-
-parse_type_decl_where_term(IsSolverType, ModuleName, VarSet, MaybeTerm0) =
- MaybeWhereDetails :-
- (
- MaybeTerm0 = no,
- MaybeWhereDetails = ok2(no, no)
- ;
- MaybeTerm0 = yes(Term0),
- some [!MaybeTerm] (
- !:MaybeTerm = MaybeTerm0,
- parse_where_attribute(parse_where_type_is_abstract_noncanonical,
- MaybeTypeIsAbstractNoncanonical, !MaybeTerm),
- parse_where_attribute(parse_where_is("representation",
- parse_where_type_is(ModuleName, VarSet)),
- MaybeRepresentationIs, !MaybeTerm),
- parse_where_attribute(parse_where_initialisation_is(ModuleName,
- VarSet),
- MaybeInitialisationIs, !MaybeTerm),
- parse_where_attribute(parse_where_is("ground",
- parse_where_inst_is(ModuleName)),
- MaybeGroundIs, !MaybeTerm),
- parse_where_attribute(parse_where_is("any",
- parse_where_inst_is(ModuleName)),
- MaybeAnyIs, !MaybeTerm),
- parse_where_attribute(parse_where_is("constraint_store",
- parse_where_mutable_is(ModuleName)),
- MaybeCStoreIs, !MaybeTerm),
- parse_where_attribute(parse_where_is("equality",
- parse_where_pred_is(ModuleName, VarSet)),
- MaybeEqualityIs, !MaybeTerm),
- parse_where_attribute(parse_where_is("comparison",
- parse_where_pred_is(ModuleName, VarSet)),
- MaybeComparisonIs, !MaybeTerm),
- parse_where_end(!.MaybeTerm, MaybeWhereEnd)
- ),
- MaybeWhereDetails = make_maybe_where_details(
- IsSolverType,
- MaybeTypeIsAbstractNoncanonical,
- MaybeRepresentationIs,
- MaybeInitialisationIs,
- MaybeGroundIs,
- MaybeAnyIs,
- MaybeCStoreIs,
- MaybeEqualityIs,
- MaybeComparisonIs,
- MaybeWhereEnd,
- Term0
- )
- ).
-
- % parse_where_attribute(Parser, Result, MaybeTerm, MaybeTailTerm)
- % handles
- % - where MaybeTerm may contain nothing
- % - where MaybeTerm may be a comma-separated pair
- % - applies Parser to the appropriate (sub)term to obtain Result
- % - sets MaybeTailTerm depending upon whether the Result is an error
- % or not and whether there is more to parse because MaybeTerm
- % was a comma-separated pair.
- %
-:- pred parse_where_attribute((func(term) = maybe1(maybe(T)))::in,
- maybe1(maybe(T))::out, maybe(term)::in, maybe(term)::out) is det.
-
-parse_where_attribute(Parser, Result, MaybeTerm, MaybeTailTerm) :-
- (
- MaybeTerm = no,
- MaybeTailTerm = no,
- Result = ok1(no)
- ;
- MaybeTerm = yes(Term),
- (
- Term = term.functor(term.atom(","), [HeadTerm, TailTerm], _)
- ->
- Result = Parser(HeadTerm),
- MaybeTailTermIfYes = yes(TailTerm)
- ;
- Result = Parser(Term),
- MaybeTailTermIfYes = no
- ),
- (
- Result = error1(_),
- MaybeTailTerm = no
- ;
- Result = ok1(no),
- MaybeTailTerm = yes(Term)
- ;
- Result = ok1(yes(_)),
- MaybeTailTerm = MaybeTailTermIfYes
- )
- ).
-
- % Parser for `where ...' attributes of the form
- % `attributename is attributevalue'.
- %
-:- func parse_where_is(string, func(term) = maybe1(T), term) =
- maybe1(maybe(T)).
-
-parse_where_is(Name, Parser, Term) = Result :-
- ( Term = term.functor(term.atom("is"), [LHS, RHS], _) ->
- ( LHS = term.functor(term.atom(Name), [], _) ->
- RHSResult = Parser(RHS),
- (
- RHSResult = ok1(ParsedRHS),
- Result = ok1(yes(ParsedRHS))
- ;
- RHSResult = error1(Specs),
- Result = error1(Specs)
- )
- ;
- Result = ok1(no)
- )
- ;
- Pieces = [words("Error: expected"), quote("is"), suffix("."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(Term), [always(Pieces)])]),
- Result = error1([Spec])
- ).
-
-:- func parse_where_type_is_abstract_noncanonical(term) = maybe1(maybe(unit)).
-
-parse_where_type_is_abstract_noncanonical(Term) =
- ( Term = term.functor(term.atom("type_is_abstract_noncanonical"), [], _) ->
- ok1(yes(unit))
- ;
- ok1(no)
- ).
-
-:- func parse_where_initialisation_is(module_name, varset, term) =
- maybe1(maybe(sym_name)).
-
-parse_where_initialisation_is(ModuleName, VarSet, Term) = Result :-
- Result0 = parse_where_is("initialisation",
- parse_where_pred_is(ModuleName, VarSet), Term),
- (
- Result0 = ok1(no)
- ->
- Result1 = parse_where_is("initialization",
- parse_where_pred_is(ModuleName, VarSet), Term)
- ;
- Result1 = Result0
- ),
- promise_pure (
- (
- Result1 = ok1(yes(_)),
- semipure
- semipure_get_solver_auto_init_supported(AutoInitSupported),
- (
- AutoInitSupported = yes,
- Result = Result1
- ;
- AutoInitSupported = no,
- Pieces = [words("Error: unknown attribute"),
- words("in solver type definition."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(Term), [always(Pieces)])]),
- Result = error1([Spec])
- )
- ;
- ( Result1 = ok1(no)
- ; Result1 = error1(_)
- ),
- Result = Result1
- )
- ).
-
-:- func parse_where_pred_is(module_name, varset, term) = maybe1(sym_name).
-
-parse_where_pred_is(ModuleName, VarSet, Term) = MaybeSymName :-
- parse_implicitly_qualified_symbol_name(ModuleName, VarSet, Term,
- MaybeSymName).
-
-:- func parse_where_inst_is(module_name, term) = maybe1(mer_inst).
-
-parse_where_inst_is(_ModuleName, Term) = MaybeInst :-
- (
- convert_inst(no_allow_constrained_inst_var, Term, Inst),
- not inst_contains_unconstrained_var(Inst)
- ->
- MaybeInst = ok1(Inst)
- ;
- Pieces = [words("Error: expected a ground, unconstrained inst."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(Term), [always(Pieces)])]),
- MaybeInst = error1([Spec])
- ).
-
-:- func parse_where_type_is(module_name, varset, term) = maybe1(mer_type).
-
-parse_where_type_is(_ModuleName, VarSet, Term) = MaybeType :-
- % XXX We should pass meaningful ContextPieces.
- ContextPieces = [],
- parse_type(Term, VarSet, ContextPieces, MaybeType).
-
-:- func parse_where_mutable_is(module_name, term) = maybe1(list(item)).
-
-parse_where_mutable_is(ModuleName, Term) = MaybeItems :-
- ( Term = term.functor(term.atom("mutable"), _, _) ->
- parse_mutable_decl_term(ModuleName, Term, MaybeItem),
- (
- MaybeItem = ok1(Mutable),
- MaybeItems = ok1([Mutable])
- ;
- MaybeItem = error1(Specs),
- MaybeItems = error1(Specs)
- )
- ; list_term_to_term_list(Term, Terms) ->
- map_parser(parse_mutable_decl_term(ModuleName), Terms, MaybeItems)
- ;
- Pieces = [words("Error: expected a mutable declaration"),
- words("or a list of mutable declarations."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(Term), [always(Pieces)])]),
- MaybeItems = error1([Spec])
- ).
-
-:- pred parse_mutable_decl_term(module_name::in, term::in, maybe1(item)::out)
- is det.
-
-parse_mutable_decl_term(ModuleName, Term, MaybeItem) :-
- (
- Term = term.functor(term.atom("mutable"), Args, Context),
- varset.init(VarSet),
- parse_mutable_decl(ModuleName, VarSet, Args, Context, -1,
- MaybeItemPrime)
- ->
- MaybeItem = MaybeItemPrime
- ;
- Pieces = [words("Error: expected a mutable declaration."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(Term), [always(Pieces)])]),
- MaybeItem = error1([Spec])
- ).
-
-:- pred parse_where_end(maybe(term)::in, maybe1(maybe(unit))::out) is det.
-
-parse_where_end(no, ok1(yes(unit))).
-parse_where_end(yes(Term), error1([Spec])) :-
- Pieces = [words("Error: attributes are either badly ordered"),
- words("or contain an unrecognised attribute."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(Term), [always(Pieces)])]).
-
-:- func make_maybe_where_details(is_solver_type, maybe1(maybe(unit)),
- maybe1(maybe(mer_type)), maybe1(maybe(init_pred)),
- maybe1(maybe(mer_inst)), maybe1(maybe(mer_inst)),
- maybe1(maybe(list(item))),
- maybe1(maybe(equality_pred)), maybe1(maybe(comparison_pred)),
- maybe1(maybe(unit)), term)
- = maybe2(maybe(solver_type_details), maybe(unify_compare)).
-
-make_maybe_where_details(IsSolverType, MaybeTypeIsAbstractNoncanonical,
- MaybeRepresentationIs, MaybeInitialisationIs,
- MaybeGroundIs, MaybeAnyIs, MaybeCStoreIs,
- MaybeEqualityIs, MaybeComparisonIs, MaybeWhereEnd, WhereTerm)
- = MaybeSolverUC :-
- (
- MaybeTypeIsAbstractNoncanonical = ok1(TypeIsAbstractNoncanonical),
- MaybeRepresentationIs = ok1(RepresentationIs),
- MaybeInitialisationIs = ok1(InitialisationIs),
- MaybeGroundIs = ok1(GroundIs),
- MaybeAnyIs = ok1(AnyIs),
- MaybeCStoreIs = ok1(CStoreIs),
- MaybeEqualityIs = ok1(EqualityIs),
- MaybeComparisonIs = ok1(ComparisonIs),
- MaybeWhereEnd = ok1(WhereEnd)
- ->
- MaybeSolverUC = make_maybe_where_details_2(IsSolverType,
- TypeIsAbstractNoncanonical, RepresentationIs, InitialisationIs,
- GroundIs, AnyIs, CStoreIs, EqualityIs, ComparisonIs,
- WhereEnd, WhereTerm)
- ;
- Specs =
- get_any_errors1(MaybeTypeIsAbstractNoncanonical) ++
- get_any_errors1(MaybeRepresentationIs) ++
- get_any_errors1(MaybeInitialisationIs) ++
- get_any_errors1(MaybeGroundIs) ++
- get_any_errors1(MaybeAnyIs) ++
- get_any_errors1(MaybeCStoreIs) ++
- get_any_errors1(MaybeEqualityIs) ++
- get_any_errors1(MaybeComparisonIs) ++
- get_any_errors1(MaybeWhereEnd),
- MaybeSolverUC = error2(Specs)
- ).
-
-:- func make_maybe_where_details_2(is_solver_type, maybe(unit),
- maybe(mer_type), maybe(init_pred), maybe(mer_inst), maybe(mer_inst),
- maybe(list(item)), maybe(equality_pred), maybe(comparison_pred),
- maybe(unit), term)
- = maybe2(maybe(solver_type_details), maybe(unify_compare)).
-
-make_maybe_where_details_2(IsSolverType, TypeIsAbstractNoncanonical,
- RepresentationIs, InitialisationIs, GroundIs, AnyIs, CStoreIs,
- EqualityIs, ComparisonIs, _WhereEnd, WhereTerm) = MaybeSolverUC :-
- (
- TypeIsAbstractNoncanonical = yes(_),
- % rafe: XXX I think this is wrong. There isn't a problem with having
- % the solver_type_details and type_is_abstract_noncanonical.
- (
- RepresentationIs = maybe.no,
- InitialisationIs = maybe.no,
- GroundIs = maybe.no,
- AnyIs = maybe.no,
- EqualityIs = maybe.no,
- ComparisonIs = maybe.no,
- CStoreIs = maybe.no
- ->
- MaybeSolverUC =
- ok2(no, yes(abstract_noncanonical_type(IsSolverType)))
- ;
- Pieces = [words("Error:"),
- quote("where type_is_abstract_noncanonical"),
- words("excludes other"), quote("where ..."),
- words("attributes."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(WhereTerm), [always(Pieces)])]),
- MaybeSolverUC = error2([Spec])
- )
- ;
- TypeIsAbstractNoncanonical = maybe.no,
- (
- IsSolverType = solver_type,
- (
- RepresentationIs = yes(RepnType),
- InitialisationIs = MaybeInitialisation,
- GroundIs = MaybeGroundInst,
- AnyIs = MaybeAnyInst,
- EqualityIs = MaybeEqPred,
- ComparisonIs = MaybeCmpPred,
- CStoreIs = MaybeMutableItems
- ->
- (
- MaybeGroundInst = yes(GroundInst)
- ;
- MaybeGroundInst = no,
- GroundInst = ground_inst
- ),
- (
- MaybeAnyInst = yes(AnyInst)
- ;
- MaybeAnyInst = no,
- AnyInst = ground_inst
- ),
- (
- MaybeMutableItems = yes(MutableItems)
- ;
- MaybeMutableItems = no,
- MutableItems = []
- ),
- (
- MaybeInitialisation = yes(InitPred),
- HowToInit = solver_init_automatic(InitPred)
- ;
- MaybeInitialisation = no,
- HowToInit = solver_init_explicit
- ),
- SolverTypeDetails = solver_type_details(
- RepnType, HowToInit, GroundInst, AnyInst, MutableItems),
- MaybeSolverTypeDetails = yes(SolverTypeDetails),
- (
- MaybeEqPred = no,
- MaybeCmpPred = no
- ->
- MaybeUnifyCompare = no
- ;
- MaybeUnifyCompare = yes(unify_compare(
- MaybeEqPred, MaybeCmpPred))
- ),
- MaybeSolverUC = ok2(MaybeSolverTypeDetails, MaybeUnifyCompare)
- ;
- RepresentationIs = no
- ->
- Pieces = [words("Error: solver type definitions must have a"),
- quote("representation"), words("attribute."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(WhereTerm),
- [always(Pieces)])]),
- MaybeSolverUC = error2([Spec])
- ;
- unexpected(this_file, "make_maybe_where_details_2: " ++
- "shouldn't have reached this point! (1)")
- )
- ;
- IsSolverType = non_solver_type,
- (
- ( RepresentationIs = yes(_)
- ; InitialisationIs = yes(_)
- ; GroundIs = yes(_)
- ; AnyIs = yes(_)
- ; CStoreIs = yes(_)
- )
- ->
- Pieces = [words("Error: solver type attribute given"),
- words("for non-solver type."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(WhereTerm),
- [always(Pieces)])]),
- MaybeSolverUC = error2([Spec])
- ;
- EqualityIs = MaybeEqPred,
- ComparisonIs = MaybeCmpPred,
- MaybeSolverUC =
- ok2(no, yes(unify_compare(MaybeEqPred, MaybeCmpPred)))
- )
- )
- ).
-
-%-----------------------------------------------------------------------------%
-%
-% Predicates useful for parsing several kinds of type definitions.
-%
-
-parse_type_defn_head(ModuleName, VarSet, HeadTerm, MaybeTypeCtorAndArgs) :-
- (
- HeadTerm = term.variable(_, Context),
- Pieces = [words("Error: variable on LHS of type definition."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(Context, [always(Pieces)])]),
- MaybeTypeCtorAndArgs = error2([Spec])
- ;
- HeadTerm = term.functor(_, _, HeadContext),
- ContextPieces = [words("In type definition:")],
- parse_implicitly_qualified_term(ModuleName, HeadTerm, HeadTerm,
- VarSet, ContextPieces, HeadResult),
- (
- HeadResult = error2(Specs),
- MaybeTypeCtorAndArgs = error2(Specs)
- ;
- HeadResult = ok2(Name, ArgTerms),
- % Check that all the head args are variables.
- ( term_list_to_var_list(ArgTerms, Params0) ->
- % Check that all the head arg variables are distinct.
- (
- list.member(_, Params0, [Param | OtherParams]),
- list.member(Param, OtherParams)
- ->
- Pieces = [words("Error: repeated type parameters"),
- words("in LHS of type definition."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(HeadContext, [always(Pieces)])]),
- MaybeTypeCtorAndArgs = error2([Spec])
- ;
- list.map(term.coerce_var, Params0, Params),
- MaybeTypeCtorAndArgs = ok2(Name, Params)
- )
- ;
- HeadTermStr = describe_error_term(VarSet, HeadTerm),
- Pieces = [words("Error: type parameters must be variables:"),
- words(HeadTermStr), suffix(".") ,nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(HeadContext, [always(Pieces)])]),
- MaybeTypeCtorAndArgs = error2([Spec])
- )
- )
- ).
-
-%-----------------------------------------------------------------------------%
-%
-% Parsing inst definitions.
-%
-
- % Parse a `:- inst <InstDefn>.' declaration.
- %
-:- pred parse_inst_defn(module_name::in, varset::in, term::in,
- prog_context::in, int::in, maybe1(item)::out) is det.
-
-parse_inst_defn(ModuleName, VarSet, Term, Context, SeqNum, MaybeItem) :-
- % XXX Some of the tests here could be factored out.
- (
- Term = term.functor(term.atom("=="), [HeadTerm, BodyTerm], _)
- ->
- parse_condition_suffix(BodyTerm, BeforeCondTerm, Condition),
- parse_inst_defn_base(ModuleName, VarSet, HeadTerm, BeforeCondTerm,
- Condition, Context, SeqNum, MaybeItem)
- ;
- % XXX This is for `abstract inst' declarations,
- % which are not really supported.
- Term = term.functor(term.atom("is"), Args, _),
- Args = [HeadTerm, term.functor(term.atom("private"), [], _)]
- ->
- Condition = cond_true,
- parse_abstract_inst_defn(ModuleName, VarSet, HeadTerm,
- Condition, Context, SeqNum, MaybeItem)
- ;
- Term = term.functor(term.atom("--->"), [HeadTerm, BodyTerm], _)
- ->
- parse_condition_suffix(BodyTerm, BeforeCondTerm, Condition),
- BoundBeforeCondTerm =
- term.functor(term.atom("bound"), [BeforeCondTerm], Context),
- parse_inst_defn_base(ModuleName, VarSet, HeadTerm, BoundBeforeCondTerm,
- Condition, Context, SeqNum, MaybeItem)
- ;
- Pieces = [words("Error:"), quote("=="), words("expected in"),
- quote(":- inst"), words("definition."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(Term), [always(Pieces)])]),
- MaybeItem = error1([Spec])
- ).
-
-:- pred parse_inst_defn_base(module_name::in, varset::in, term::in, term::in,
- condition::in, prog_context::in, int::in, maybe1(item)::out) is det.
-
-parse_inst_defn_base(ModuleName, VarSet, HeadTerm, BodyTerm, Condition,
- Context, SeqNum, MaybeItem) :-
- ContextPieces = [words("In inst definition:")],
- parse_implicitly_qualified_term(ModuleName, HeadTerm, BodyTerm,
- VarSet, ContextPieces, MaybeNameAndArgs),
- (
- MaybeNameAndArgs = error2(Specs),
- MaybeItem = error1(Specs)
- ;
- MaybeNameAndArgs = ok2(Name, ArgTerms),
- (
- % Check that all the head args are variables.
- term.term_list_to_var_list(ArgTerms, Args)
- ->
- (
- % Check that all the head arg variables are distinct.
- list.member(Arg2, Args, [Arg2 | OtherArgs]),
- list.member(Arg2, OtherArgs)
- ->
- % XXX Should improve the error message here.
- Pieces = [words("Error: repeated inst parameters"),
- words("in LHS of inst definition."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(HeadTerm),
- [always(Pieces)])]),
- MaybeItem = error1([Spec])
- ;
- % Check that all the variables in the body occur in the head.
- term.contains_var(BodyTerm, Var2),
- \+ list.member(Var2, Args)
- ->
- Pieces = [words("Error: free inst parameter"),
- words("in RHS of inst definition."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(BodyTerm),
- [always(Pieces)])]),
- MaybeItem = error1([Spec])
- ;
- % Check that the inst is a valid user-defined inst, i.e. that it
- % does not have the form of one of the builtin insts.
- \+ (
- convert_inst(no_allow_constrained_inst_var, HeadTerm,
- UserInst),
- UserInst = defined_inst(user_inst(_, _))
- )
- ->
- % XXX Name the builtin inst.
- Pieces =
- [words("Error: attempt to redefine builtin inst."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(HeadTerm),
- [always(Pieces)])]),
- MaybeItem = error1([Spec])
- ;
- % Should improve the error message here.
- (
- convert_inst(no_allow_constrained_inst_var, BodyTerm, Inst)
- ->
- varset.coerce(VarSet, InstVarSet),
- list.map(term.coerce_var, Args, InstArgs),
- InstDefn = eqv_inst(Inst),
- ItemInstDefn = item_inst_defn_info(InstVarSet, Name,
- InstArgs, InstDefn, Condition, Context, SeqNum),
- Item = item_inst_defn(ItemInstDefn),
- MaybeItem = ok1(Item)
- ;
- BodyTermStr = describe_error_term(VarSet, BodyTerm),
- Pieces = [words("Error: syntax error in inst body at"),
- words(BodyTermStr), suffix("."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(BodyTerm),
- [always(Pieces)])]),
- MaybeItem = error1([Spec])
- )
- )
- ;
- % XXX If term_list_to_var_list returned the non-var's term
- % or context, we could use it here.
- Pieces = [words("Error: inst parameters must be variables."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(HeadTerm), [always(Pieces)])]),
- MaybeItem = error1([Spec])
- )
- ).
-
-:- pred parse_abstract_inst_defn(module_name::in, varset::in, term::in,
- condition::in, prog_context::in, int::in, maybe1(item)::out) is det.
-
-parse_abstract_inst_defn(ModuleName, VarSet, HeadTerm, Condition, Context,
- SeqNum, MaybeItem) :-
- ContextPieces = [words("In inst definition:")],
- parse_implicitly_qualified_term(ModuleName, HeadTerm, HeadTerm,
- VarSet, ContextPieces, MaybeNameAndArgs),
- (
- MaybeNameAndArgs = error2(Specs),
- MaybeItem = error1(Specs)
- ;
- MaybeNameAndArgs = ok2(Name, ArgTerms),
- (
- % Check that all the head args are variables.
- term.term_list_to_var_list(ArgTerms, Args)
- ->
- (
- % Check that all the head arg variables are distinct.
- list.member(Arg2, Args, [Arg2 | OtherArgs]),
- list.member(Arg2, OtherArgs)
- ->
- % XXX We should we list the repeated parameters.
- Pieces = [words("Error: repeated inst parameters"),
- words("in abstract inst definition."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(HeadTerm),
- [always(Pieces)])]),
- MaybeItem = error1([Spec])
- ;
- varset.coerce(VarSet, InstVarSet),
- list.map(term.coerce_var, Args, InstArgs),
- InstDefn = abstract_inst,
- ItemInstDefn = item_inst_defn_info(InstVarSet, Name,
- InstArgs, InstDefn, Condition, Context, SeqNum),
- Item = item_inst_defn(ItemInstDefn),
- MaybeItem = ok1(Item)
- )
- ;
- % XXX If term_list_to_var_list returned the non-var's term
- % or context, we could use it here.
- Pieces = [words("Error: inst parameters must be variables."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(HeadTerm), [always(Pieces)])]),
- MaybeItem = error1([Spec])
- )
- ).
-
-%-----------------------------------------------------------------------------%
-%
-% Parsing mode definitions.
-%
-
-:- type processed_mode_body
- ---> processed_mode_body(
- sym_name,
- list(inst_var),
- mode_defn
- ).
-
-:- pred parse_mode_defn(module_name::in, varset::in, term::in, term::in,
- condition::in, prog_context::in, int::in, maybe1(item)::out) is det.
-
-parse_mode_defn(ModuleName, VarSet, HeadTerm, BodyTerm, Condition, Context,
- SeqNum, MaybeItem) :-
- ContextPieces = [words("In mode definition:")],
- parse_implicitly_qualified_term(ModuleName, HeadTerm, HeadTerm,
- VarSet, ContextPieces, MaybeModeNameAndArgs),
- (
- MaybeModeNameAndArgs = error2(Specs),
- MaybeItem = error1(Specs)
- ;
- MaybeModeNameAndArgs = ok2(Name, ArgTerms),
- % Check that all the head args are variables.
- ( term.term_list_to_var_list(ArgTerms, Args) ->
- (
- % Check that all the head arg variables are distinct.
- list.member(Arg2, Args, [Arg2 | OtherArgs]),
- list.member(Arg2, OtherArgs)
- ->
- % Check that all the head arg variables are distinct.
- % XXX We should list the duplicated head arg variables.
- Pieces = [words("Error: repeated parameters"),
- words("in LHS of mode definition."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(HeadTerm),
- [always(Pieces)])]),
- MaybeItem = error1([Spec])
- ;
- % Check that all the variables in the body occur in the head.
- term.contains_var(BodyTerm, Var2),
- \+ list.member(Var2, Args)
- ->
- % XXX Shouldn't we be using the BodyTerm's context?
- % XXX We should list the Var2s for which the condition holds.
- Pieces = [words("Error: free inst parameter"),
- words("in RHS of mode definition."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(HeadTerm),
- [always(Pieces)])]),
- MaybeItem = error1([Spec])
- ;
- (
- convert_mode(no_allow_constrained_inst_var, BodyTerm, Mode)
- ->
- varset.coerce(VarSet, InstVarSet),
- list.map(term.coerce_var, Args, ModeArgs),
- ModeDefn = eqv_mode(Mode),
- ItemModeDefn = item_mode_defn_info(InstVarSet, Name,
- ModeArgs, ModeDefn, Condition, Context, SeqNum),
- Item = item_mode_defn(ItemModeDefn),
- MaybeItem = ok1(Item)
- ;
- % XXX We should improve the error message here.
- Pieces = [words("Error: syntax error"),
- words("in mode definition body."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(BodyTerm),
- [always(Pieces)])]),
- MaybeItem = error1([Spec])
- )
- )
- ;
- % XXX If term_list_to_var_list returned the non-var's term
- % or context, we could use it here.
- Pieces = [words("Error: mode parameters must be variables."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(HeadTerm), [always(Pieces)])]),
- MaybeItem = error1([Spec])
- )
- ).
-
%-----------------------------------------------------------------------------%
%
% Parsing ":- pred" and ":- func" declarations.
@@ -3517,38 +2079,6 @@
%-----------------------------------------------------------------------------%
- % parse_condition_suffix(Term, BeforeCondTerm, Condition):
- %
- % Bind Condition to a representation of the 'where' condition of Term,
- % if any, and bind BeforeCondTerm to the other part of Term. If Term
- % does not contain a condition, then set Condition to true.
- %
- % NU-Prolog supported type declarations of the form
- % :- pred p(T) where p(X) : sorted(X).
- % or
- % :- type sorted_list(T) = list(T) where X : sorted(X).
- % :- pred p(sorted_list(T).
- % There is some code here to support that sort of thing, but
- % probably we would now need to use a different syntax, since
- % Mercury now uses `where' for different purposes (e.g. specifying
- % user-defined equality predicates, and also for type classes ...)
- %
-:- pred parse_condition_suffix(term::in, term::out, condition::out) is det.
-
-parse_condition_suffix(Term, Term, cond_true).
-
-% parse_condition_suffix(B, Body, Condition) :-
-% (
-% B = term.functor(term.atom("where"), [Body1, Condition1],
-% _Context)
-% ->
-% Body = Body1,
-% Condition = where(Condition1)
-% ;
-% Body = B,
-% Condition = true
-% ).
-
% parse_determinism_suffix(VarSet, BodyTerm, BeforeDetismTerm,
% MaybeMaybeDetism):
%
@@ -3929,16 +2459,6 @@
%-----------------------------------------------------------------------------%
-:- pred get_is_solver_type(is_solver_type::out,
- decl_attrs::in, decl_attrs::out) is det.
-
-get_is_solver_type(IsSolverType, !Attributes) :-
- ( !.Attributes = [decl_attr_solver_type - _ | !:Attributes] ->
- IsSolverType = solver_type
- ;
- IsSolverType = non_solver_type
- ).
-
:- pred get_purity(purity::out, decl_attrs::in, decl_attrs::out) is det.
get_purity(Purity, !Attributes) :-
Index: compiler/prog_io_mode_defn.m
===================================================================
RCS file: compiler/prog_io_mode_defn.m
diff -N compiler/prog_io_mode_defn.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/prog_io_mode_defn.m 2 Dec 2008 06:40:00 -0000
@@ -0,0 +1,294 @@
+%-----------------------------------------------------------------------------e
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------e
+% Copyright (C) 2008 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+%
+% File: prog_io_type_defn.m.
+%
+% This module parses inst and mode definitions.
+%
+%-----------------------------------------------------------------------------%
+
+:- module parse_tree.prog_io_mode_defn.
+
+:- interface.
+
+:- import_module mdbcomp.prim_data.
+:- import_module parse_tree.prog_data.
+:- import_module parse_tree.prog_item.
+:- import_module parse_tree.prog_io_util.
+
+:- import_module term.
+:- import_module varset.
+
+ % Parse a `:- inst <InstDefn>.' declaration.
+ %
+:- pred parse_inst_defn(module_name::in, varset::in, term::in,
+ prog_context::in, int::in, maybe1(item)::out) is det.
+
+ % Parse a `:- mode <ModeDefn>.' declaration.
+ %
+:- pred parse_mode_defn(module_name::in, varset::in, term::in, term::in,
+ condition::in, prog_context::in, int::in, maybe1(item)::out) is det.
+
+%-----------------------------------------------------------------------------e
+
+:- implementation.
+
+:- import_module parse_tree.error_util.
+:- import_module parse_tree.mercury_to_mercury.
+:- import_module parse_tree.prog_io_sym_name.
+
+:- import_module list.
+
+parse_inst_defn(ModuleName, VarSet, Term, Context, SeqNum, MaybeItem) :-
+ % XXX Some of the tests here could be factored out.
+ (
+ Term = term.functor(term.atom("=="), [HeadTerm, BodyTerm], _)
+ ->
+ parse_condition_suffix(BodyTerm, BeforeCondTerm, Condition),
+ parse_inst_defn_base(ModuleName, VarSet, HeadTerm, BeforeCondTerm,
+ Condition, Context, SeqNum, MaybeItem)
+ ;
+ % XXX This is for `abstract inst' declarations,
+ % which are not really supported.
+ Term = term.functor(term.atom("is"), Args, _),
+ Args = [HeadTerm, term.functor(term.atom("private"), [], _)]
+ ->
+ Condition = cond_true,
+ parse_abstract_inst_defn(ModuleName, VarSet, HeadTerm,
+ Condition, Context, SeqNum, MaybeItem)
+ ;
+ Term = term.functor(term.atom("--->"), [HeadTerm, BodyTerm], _)
+ ->
+ parse_condition_suffix(BodyTerm, BeforeCondTerm, Condition),
+ BoundBeforeCondTerm =
+ term.functor(term.atom("bound"), [BeforeCondTerm], Context),
+ parse_inst_defn_base(ModuleName, VarSet, HeadTerm, BoundBeforeCondTerm,
+ Condition, Context, SeqNum, MaybeItem)
+ ;
+ Pieces = [words("Error:"), quote("=="), words("expected in"),
+ quote(":- inst"), words("definition."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ MaybeItem = error1([Spec])
+ ).
+
+:- pred parse_inst_defn_base(module_name::in, varset::in, term::in, term::in,
+ condition::in, prog_context::in, int::in, maybe1(item)::out) is det.
+
+parse_inst_defn_base(ModuleName, VarSet, HeadTerm, BodyTerm, Condition,
+ Context, SeqNum, MaybeItem) :-
+ ContextPieces = [words("In inst definition:")],
+ parse_implicitly_qualified_term(ModuleName, HeadTerm, BodyTerm,
+ VarSet, ContextPieces, MaybeNameAndArgs),
+ (
+ MaybeNameAndArgs = error2(Specs),
+ MaybeItem = error1(Specs)
+ ;
+ MaybeNameAndArgs = ok2(Name, ArgTerms),
+ (
+ % Check that all the head args are variables.
+ term.term_list_to_var_list(ArgTerms, Args)
+ ->
+ (
+ % Check that all the head arg variables are distinct.
+ list.member(Arg2, Args, [Arg2 | OtherArgs]),
+ list.member(Arg2, OtherArgs)
+ ->
+ % XXX Should improve the error message here.
+ Pieces = [words("Error: repeated inst parameters"),
+ words("in LHS of inst definition."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(HeadTerm),
+ [always(Pieces)])]),
+ MaybeItem = error1([Spec])
+ ;
+ % Check that all the variables in the body occur in the head.
+ term.contains_var(BodyTerm, Var2),
+ \+ list.member(Var2, Args)
+ ->
+ Pieces = [words("Error: free inst parameter"),
+ words("in RHS of inst definition."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(BodyTerm),
+ [always(Pieces)])]),
+ MaybeItem = error1([Spec])
+ ;
+ % Check that the inst is a valid user-defined inst, i.e. that it
+ % does not have the form of one of the builtin insts.
+ \+ (
+ convert_inst(no_allow_constrained_inst_var, HeadTerm,
+ UserInst),
+ UserInst = defined_inst(user_inst(_, _))
+ )
+ ->
+ % XXX Name the builtin inst.
+ Pieces =
+ [words("Error: attempt to redefine builtin inst."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(HeadTerm),
+ [always(Pieces)])]),
+ MaybeItem = error1([Spec])
+ ;
+ % Should improve the error message here.
+ (
+ convert_inst(no_allow_constrained_inst_var, BodyTerm, Inst)
+ ->
+ varset.coerce(VarSet, InstVarSet),
+ list.map(term.coerce_var, Args, InstArgs),
+ InstDefn = eqv_inst(Inst),
+ ItemInstDefn = item_inst_defn_info(InstVarSet, Name,
+ InstArgs, InstDefn, Condition, Context, SeqNum),
+ Item = item_inst_defn(ItemInstDefn),
+ MaybeItem = ok1(Item)
+ ;
+ BodyTermStr = describe_error_term(VarSet, BodyTerm),
+ Pieces = [words("Error: syntax error in inst body at"),
+ words(BodyTermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(BodyTerm),
+ [always(Pieces)])]),
+ MaybeItem = error1([Spec])
+ )
+ )
+ ;
+ % XXX If term_list_to_var_list returned the non-var's term
+ % or context, we could use it here.
+ Pieces = [words("Error: inst parameters must be variables."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(HeadTerm), [always(Pieces)])]),
+ MaybeItem = error1([Spec])
+ )
+ ).
+
+:- pred parse_abstract_inst_defn(module_name::in, varset::in, term::in,
+ condition::in, prog_context::in, int::in, maybe1(item)::out) is det.
+
+parse_abstract_inst_defn(ModuleName, VarSet, HeadTerm, Condition, Context,
+ SeqNum, MaybeItem) :-
+ ContextPieces = [words("In inst definition:")],
+ parse_implicitly_qualified_term(ModuleName, HeadTerm, HeadTerm,
+ VarSet, ContextPieces, MaybeNameAndArgs),
+ (
+ MaybeNameAndArgs = error2(Specs),
+ MaybeItem = error1(Specs)
+ ;
+ MaybeNameAndArgs = ok2(Name, ArgTerms),
+ (
+ % Check that all the head args are variables.
+ term.term_list_to_var_list(ArgTerms, Args)
+ ->
+ (
+ % Check that all the head arg variables are distinct.
+ list.member(Arg2, Args, [Arg2 | OtherArgs]),
+ list.member(Arg2, OtherArgs)
+ ->
+ % XXX We should we list the repeated parameters.
+ Pieces = [words("Error: repeated inst parameters"),
+ words("in abstract inst definition."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(HeadTerm),
+ [always(Pieces)])]),
+ MaybeItem = error1([Spec])
+ ;
+ varset.coerce(VarSet, InstVarSet),
+ list.map(term.coerce_var, Args, InstArgs),
+ InstDefn = abstract_inst,
+ ItemInstDefn = item_inst_defn_info(InstVarSet, Name,
+ InstArgs, InstDefn, Condition, Context, SeqNum),
+ Item = item_inst_defn(ItemInstDefn),
+ MaybeItem = ok1(Item)
+ )
+ ;
+ % XXX If term_list_to_var_list returned the non-var's term
+ % or context, we could use it here.
+ Pieces = [words("Error: inst parameters must be variables."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(HeadTerm), [always(Pieces)])]),
+ MaybeItem = error1([Spec])
+ )
+ ).
+
+%-----------------------------------------------------------------------------%
+
+:- type processed_mode_body
+ ---> processed_mode_body(
+ sym_name,
+ list(inst_var),
+ mode_defn
+ ).
+
+parse_mode_defn(ModuleName, VarSet, HeadTerm, BodyTerm, Condition, Context,
+ SeqNum, MaybeItem) :-
+ ContextPieces = [words("In mode definition:")],
+ parse_implicitly_qualified_term(ModuleName, HeadTerm, HeadTerm,
+ VarSet, ContextPieces, MaybeModeNameAndArgs),
+ (
+ MaybeModeNameAndArgs = error2(Specs),
+ MaybeItem = error1(Specs)
+ ;
+ MaybeModeNameAndArgs = ok2(Name, ArgTerms),
+ % Check that all the head args are variables.
+ ( term.term_list_to_var_list(ArgTerms, Args) ->
+ (
+ % Check that all the head arg variables are distinct.
+ list.member(Arg2, Args, [Arg2 | OtherArgs]),
+ list.member(Arg2, OtherArgs)
+ ->
+ % Check that all the head arg variables are distinct.
+ % XXX We should list the duplicated head arg variables.
+ Pieces = [words("Error: repeated parameters"),
+ words("in LHS of mode definition."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(HeadTerm),
+ [always(Pieces)])]),
+ MaybeItem = error1([Spec])
+ ;
+ % Check that all the variables in the body occur in the head.
+ term.contains_var(BodyTerm, Var2),
+ \+ list.member(Var2, Args)
+ ->
+ % XXX Shouldn't we be using the BodyTerm's context?
+ % XXX We should list the Var2s for which the condition holds.
+ Pieces = [words("Error: free inst parameter"),
+ words("in RHS of mode definition."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(HeadTerm),
+ [always(Pieces)])]),
+ MaybeItem = error1([Spec])
+ ;
+ (
+ convert_mode(no_allow_constrained_inst_var, BodyTerm, Mode)
+ ->
+ varset.coerce(VarSet, InstVarSet),
+ list.map(term.coerce_var, Args, ModeArgs),
+ ModeDefn = eqv_mode(Mode),
+ ItemModeDefn = item_mode_defn_info(InstVarSet, Name,
+ ModeArgs, ModeDefn, Condition, Context, SeqNum),
+ Item = item_mode_defn(ItemModeDefn),
+ MaybeItem = ok1(Item)
+ ;
+ % XXX We should improve the error message here.
+ Pieces = [words("Error: syntax error"),
+ words("in mode definition body."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(BodyTerm),
+ [always(Pieces)])]),
+ MaybeItem = error1([Spec])
+ )
+ )
+ ;
+ % XXX If term_list_to_var_list returned the non-var's term
+ % or context, we could use it here.
+ Pieces = [words("Error: mode parameters must be variables."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(HeadTerm), [always(Pieces)])]),
+ MaybeItem = error1([Spec])
+ )
+ ).
+
+%-----------------------------------------------------------------------------e
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.137
diff -u -b -r1.137 prog_io_pragma.m
--- compiler/prog_io_pragma.m 2 Dec 2008 04:30:24 -0000 1.137
+++ compiler/prog_io_pragma.m 2 Dec 2008 06:48:33 -0000
@@ -49,6 +49,7 @@
:- import_module parse_tree.mercury_to_mercury.
:- import_module parse_tree.prog_ctgc.
:- import_module parse_tree.prog_io.
+:- import_module parse_tree.prog_io_type_defn.
:- import_module parse_tree.prog_io_sym_name.
:- import_module parse_tree.prog_out.
:- import_module parse_tree.prog_util.
Index: compiler/prog_io_type_defn.m
===================================================================
RCS file: compiler/prog_io_type_defn.m
diff -N compiler/prog_io_type_defn.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ compiler/prog_io_type_defn.m 2 Dec 2008 05:14:47 -0000
@@ -0,0 +1,1144 @@
+%-----------------------------------------------------------------------------e
+% vim: ft=mercury ts=4 sw=4 et
+%-----------------------------------------------------------------------------e
+% Copyright (C) 2008 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+%
+% File: prog_io_type_defn.m.
+%
+% This module parses type definitions.
+%
+%-----------------------------------------------------------------------------%
+
+:- module parse_tree.prog_io_type_defn.
+
+:- interface.
+
+:- import_module mdbcomp.prim_data.
+:- import_module parse_tree.prog_data.
+:- import_module parse_tree.prog_item.
+:- import_module parse_tree.prog_io_util.
+
+:- import_module list.
+:- import_module maybe.
+:- import_module term.
+:- import_module varset.
+
+ % Parse the definition of a type.
+ %
+:- pred parse_type_defn(module_name::in, varset::in, term::in, decl_attrs::in,
+ prog_context::in, int::in, maybe1(item)::out) is det.
+
+ % parse_type_defn_head(ModuleName, VarSet, Head, HeadResult):
+ %
+ % Check the head of a type definition for errors.
+ %
+:- pred parse_type_defn_head(module_name::in, varset::in, term::in,
+ maybe2(sym_name, list(type_param))::out) is det.
+
+ % parse_type_decl_where_part_if_present(TypeSymName, Arity,
+ % IsSolverType, Inst, ModuleName, Term0, Term, Result):
+ %
+ % Checks if Term0 is a term of the form `<body> where <attributes>'.
+ % If so, returns the `<body>' in Term and the parsed `<attributes>'
+ % in Result. If not, returns Term = Term0 and Result = no.
+ %
+:- pred parse_type_decl_where_part_if_present(is_solver_type::in,
+ module_name::in, varset::in, term::in, term::out,
+ maybe2(maybe(solver_type_details), maybe(unify_compare))::out) is det.
+
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module libs.compiler_util.
+:- import_module libs.globals.
+:- import_module parse_tree.error_util.
+:- import_module parse_tree.mercury_to_mercury.
+:- import_module parse_tree.prog_io_mutable.
+:- import_module parse_tree.prog_io_sym_name.
+:- import_module parse_tree.prog_io_typeclass.
+:- import_module parse_tree.prog_mode.
+:- import_module parse_tree.prog_type.
+
+:- import_module bool.
+:- import_module pair.
+:- import_module set.
+:- import_module string.
+:- import_module unit.
+
+parse_type_defn(ModuleName, VarSet, TypeDefnTerm, Attributes, Context,
+ SeqNum, MaybeItem) :-
+ (
+ TypeDefnTerm = term.functor(term.atom(Name), ArgTerms, _),
+ ArgTerms = [HeadTerm, BodyTerm],
+ ( Name = "--->"
+ ; Name = "=="
+ ; Name = "where"
+ )
+ ->
+ parse_condition_suffix(BodyTerm, BeforeCondTerm, Condition),
+ (
+ Name = "--->",
+ parse_du_type_defn(ModuleName, VarSet,
+ HeadTerm, BeforeCondTerm, Attributes,
+ Condition, Context, SeqNum, MaybeItem)
+ ;
+ Name = "==",
+ parse_eqv_type_defn(ModuleName, VarSet,
+ HeadTerm, BeforeCondTerm, Attributes,
+ Condition, Context, SeqNum, MaybeItem)
+ ;
+ Name = "where",
+ parse_solver_type_defn(ModuleName, VarSet,
+ HeadTerm, BeforeCondTerm, Attributes,
+ Condition, Context, SeqNum, MaybeItem)
+ )
+ ;
+ parse_abstract_type_defn(ModuleName, VarSet, TypeDefnTerm, Attributes,
+ Condition, Context, SeqNum, MaybeItem),
+ Condition = cond_true
+ ).
+
+%-----------------------------------------------------------------------------%
+%
+% Code dealing with definitions of discriminated union types.
+%
+
+ % parse_du_type_defn parses the definition of a discriminated union type.
+ %
+:- pred parse_du_type_defn(module_name::in, varset::in, term::in, term::in,
+ decl_attrs::in, condition::in, prog_context::in, int::in,
+ maybe1(item)::out) is det.
+
+parse_du_type_defn(ModuleName, VarSet, HeadTerm, BodyTerm, Attributes0,
+ Condition, Context, SeqNum, MaybeItem) :-
+ get_is_solver_type(IsSolverType, Attributes0, Attributes),
+ (
+ IsSolverType = solver_type,
+ Pieces = [words("Error: a solver type"),
+ words("cannot have data constructors."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(HeadTerm), [always(Pieces)])]),
+ MaybeItem = error1([Spec])
+ ;
+ IsSolverType = non_solver_type,
+ parse_type_defn_head(ModuleName, VarSet, HeadTerm,
+ MaybeTypeCtorAndArgs),
+ du_type_rhs_ctors_and_where_terms(BodyTerm, CtorsTerm, MaybeWhereTerm),
+ MaybeCtors = parse_constructors(ModuleName, VarSet, CtorsTerm),
+ MaybeWhere = parse_type_decl_where_term(non_solver_type,
+ ModuleName, VarSet, MaybeWhereTerm),
+ % The code to process `where' attributes will return an error
+ % if solver attributes are given for a non-solver type. Because
+ % this is a du type, if the unification with MaybeWhere succeeds
+ % then _NoSolverTypeDetails is guaranteed to be `no'.
+ (
+ MaybeTypeCtorAndArgs = ok2(Name, Params),
+ MaybeCtors = ok1(Ctors),
+ MaybeWhere = ok2(_NoSolverTypeDetails, MaybeUserEqComp)
+ ->
+ process_du_ctors(Params, VarSet, BodyTerm, Ctors, [], CtorsSpecs),
+ (
+ CtorsSpecs = [],
+ varset.coerce(VarSet, TypeVarSet),
+ TypeDefn = parse_tree_du_type(Ctors, MaybeUserEqComp),
+ ItemTypeDefn = item_type_defn_info(TypeVarSet, Name, Params,
+ TypeDefn, Condition, Context, SeqNum),
+ Item = item_type_defn(ItemTypeDefn),
+ MaybeItem0 = ok1(Item),
+ check_no_attributes(MaybeItem0, Attributes, MaybeItem)
+ ;
+ CtorsSpecs = [_ | _],
+ MaybeItem = error1(CtorsSpecs)
+ )
+ ;
+ Specs = get_any_errors2(MaybeTypeCtorAndArgs) ++
+ get_any_errors1(MaybeCtors) ++ get_any_errors2(MaybeWhere),
+ MaybeItem = error1(Specs)
+ )
+ ).
+
+:- pred du_type_rhs_ctors_and_where_terms(term::in,
+ term::out, maybe(term)::out) is det.
+
+du_type_rhs_ctors_and_where_terms(Term, CtorsTerm, MaybeWhereTerm) :-
+ (
+ Term = term.functor(term.atom("where"), Args, _Context),
+ Args = [CtorsTerm0, WhereTerm]
+ ->
+ CtorsTerm = CtorsTerm0,
+ MaybeWhereTerm = yes(WhereTerm)
+ ;
+ CtorsTerm = Term,
+ MaybeWhereTerm = no
+ ).
+
+ % Convert a list of terms separated by semi-colons (known as a
+ % "disjunction", even thought the terms aren't goals in this case)
+ % into a list of constructors.
+ %
+:- func parse_constructors(module_name, varset, term) =
+ maybe1(list(constructor)).
+
+parse_constructors(ModuleName, VarSet, Term) = MaybeConstructors :-
+ disjunction_to_list(Term, BodyTermList),
+ MaybeConstructors = parse_constructors_2(ModuleName, VarSet, BodyTermList).
+
+ % True if the term is a valid list of constructors.
+ %
+:- func parse_constructors_2(module_name, varset, list(term)) =
+ maybe1(list(constructor)).
+
+parse_constructors_2(_ModuleName, _, []) = ok1([]).
+parse_constructors_2(ModuleName, VarSet, [Head | Tail]) = MaybeConstructors :-
+ MaybeHeadConstructor = parse_constructor(ModuleName, VarSet, Head),
+ MaybeTailConstructors = parse_constructors_2(ModuleName, VarSet, Tail),
+ (
+ MaybeHeadConstructor = ok1(HeadConstructor),
+ MaybeTailConstructors = ok1(TailConstructors)
+ ->
+ Constructors = [HeadConstructor | TailConstructors],
+ MaybeConstructors = ok1(Constructors)
+ ;
+ Specs = get_any_errors1(MaybeHeadConstructor) ++
+ get_any_errors1(MaybeTailConstructors),
+ MaybeConstructors = error1(Specs)
+ ).
+
+:- func parse_constructor(module_name, varset, term) = maybe1(constructor).
+
+parse_constructor(ModuleName, VarSet, Term) = MaybeConstructor :-
+ ( Term = term.functor(term.atom("some"), [VarsTerm, SubTerm], _) ->
+ ( parse_list_of_vars(VarsTerm, ExistQVars) ->
+ list.map(term.coerce_var, ExistQVars, ExistQTVars),
+ MaybeConstructor = parse_constructor_2(ModuleName, VarSet,
+ ExistQTVars, Term, SubTerm)
+ ;
+ TermStr = describe_error_term(VarSet, Term),
+ Pieces = [words("Error: syntax error in variable list at"),
+ words(TermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(VarsTerm), [always(Pieces)])]),
+ MaybeConstructor = error1([Spec])
+ )
+ ;
+ ExistQVars = [],
+ MaybeConstructor = parse_constructor_2(ModuleName, VarSet, ExistQVars,
+ Term, Term)
+ ).
+
+:- func parse_constructor_2(module_name, varset, list(tvar), term, term) =
+ maybe1(constructor).
+
+parse_constructor_2(ModuleName, VarSet, ExistQVars, ContainingTerm, Term)
+ = MaybeConstructor :-
+ get_existential_constraints_from_term(ModuleName, VarSet, Term,
+ BeforeConstraintsTerm, MaybeConstraints),
+ (
+ MaybeConstraints = error1(Specs),
+ MaybeConstructor = error1(Specs)
+ ;
+ MaybeConstraints = ok1(Constraints),
+ (
+ % Note that as a special case, one level of curly braces around
+ % the constructor are ignored. This is to allow you to define
+ % ';'/2 and 'some'/2 constructors.
+ BeforeConstraintsTerm = term.functor(term.atom("{}"),
+ [InsideBracesTerm], _Context)
+ ->
+ MainTerm = InsideBracesTerm
+ ;
+ MainTerm = BeforeConstraintsTerm
+ ),
+ ContextPieces = [words("In constructor definition:")],
+ parse_implicitly_qualified_term(ModuleName, MainTerm, ContainingTerm,
+ VarSet, ContextPieces, MaybeFunctorAndArgTerms),
+ (
+ MaybeFunctorAndArgTerms = error2(Specs),
+ MaybeConstructor = error1(Specs)
+ ;
+ MaybeFunctorAndArgTerms = ok2(Functor, ArgTerms),
+ MaybeConstructorArgs = convert_constructor_arg_list(ModuleName,
+ VarSet, ArgTerms),
+ (
+ MaybeConstructorArgs = error1(Specs),
+ MaybeConstructor = error1(Specs)
+ ;
+ MaybeConstructorArgs = ok1(ConstructorArgs),
+ Ctor = ctor(ExistQVars, Constraints, Functor, ConstructorArgs,
+ get_term_context(MainTerm)),
+ MaybeConstructor = ok1(Ctor)
+ )
+ )
+ ).
+
+:- pred get_existential_constraints_from_term(module_name::in, varset::in,
+ term::in, term::out, maybe1(list(prog_constraint))::out) is det.
+
+get_existential_constraints_from_term(ModuleName, VarSet, !PredTypeTerm,
+ MaybeExistentialConstraints) :-
+ (
+ !.PredTypeTerm = term.functor(term.atom("=>"),
+ [!:PredTypeTerm, ExistentialConstraints], _)
+ ->
+ parse_class_constraints(ModuleName, VarSet, ExistentialConstraints,
+ MaybeExistentialConstraints)
+ ;
+ MaybeExistentialConstraints = ok1([])
+ ).
+
+:- func convert_constructor_arg_list(module_name, varset, list(term)) =
+ maybe1(list(constructor_arg)).
+
+convert_constructor_arg_list(_, _, []) = ok1([]).
+convert_constructor_arg_list(ModuleName, VarSet, [Term | Terms])
+ = MaybeConstructorArgs :-
+ ( Term = term.functor(term.atom("::"), [NameTerm, TypeTerm], _) ->
+ ContextPieces = [words("In field name:")],
+ parse_implicitly_qualified_term(ModuleName, NameTerm, Term,
+ VarSet, ContextPieces, MaybeSymNameAndArgs),
+ (
+ MaybeSymNameAndArgs = error2(Specs),
+ MaybeConstructorArgs = error1(Specs)
+ ;
+ MaybeSymNameAndArgs = ok2(SymName, SymNameArgs),
+ (
+ SymNameArgs = [_ | _],
+ % XXX Should we add "... at function symbol ..."?
+ Pieces = [words("Error: syntax error in constructor name."),
+ nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ MaybeConstructorArgs = error1([Spec])
+ ;
+ SymNameArgs = [],
+ MaybeFieldName = yes(SymName),
+ MaybeConstructorArgs =
+ convert_constructor_arg_list_2(ModuleName,
+ VarSet, MaybeFieldName, TypeTerm, Terms)
+ )
+ )
+ ;
+ MaybeFieldName = no,
+ TypeTerm = Term,
+ MaybeConstructorArgs = convert_constructor_arg_list_2(ModuleName,
+ VarSet, MaybeFieldName, TypeTerm, Terms)
+ ).
+
+:- func convert_constructor_arg_list_2(module_name, varset, maybe(sym_name),
+ term, list(term)) = maybe1(list(constructor_arg)).
+
+convert_constructor_arg_list_2(ModuleName, VarSet, MaybeFieldName,
+ TypeTerm, Terms) = MaybeArgs :-
+ ContextPieces = [words("In type definition:")],
+ parse_type(TypeTerm, VarSet, ContextPieces, MaybeType),
+ (
+ MaybeType = ok1(Type),
+ Context = get_term_context(TypeTerm),
+ Arg = ctor_arg(MaybeFieldName, Type, Context),
+ MaybeTailArgs =
+ convert_constructor_arg_list(ModuleName, VarSet, Terms),
+ (
+ MaybeTailArgs = error1(Specs),
+ MaybeArgs = error1(Specs)
+ ;
+ MaybeTailArgs = ok1(Args),
+ MaybeArgs = ok1([Arg | Args])
+ )
+ ;
+ MaybeType = error1(Specs),
+ MaybeArgs = error1(Specs)
+ ).
+
+:- pred process_du_ctors(list(type_param)::in, varset::in, term::in,
+ list(constructor)::in, list(error_spec)::in, list(error_spec)::out) is det.
+
+process_du_ctors(_Params, _, _, [], !Specs).
+process_du_ctors(Params, VarSet, BodyTerm, [Ctor | Ctors], !Specs) :-
+ Ctor = ctor(ExistQVars, Constraints, _CtorName, CtorArgs, _Context),
+ (
+ % Check that all type variables in the ctor are either explicitly
+ % existentially quantified or occur in the head of the type.
+
+ CtorArgTypes = list.map(func(C) = C ^ arg_type, CtorArgs),
+ type_vars_list(CtorArgTypes, VarsInCtorArgTypes0),
+ list.sort_and_remove_dups(VarsInCtorArgTypes0, VarsInCtorArgTypes),
+ list.filter(list.contains(ExistQVars ++ Params), VarsInCtorArgTypes,
+ _ExistQOrParamVars, NotExistQOrParamVars),
+ NotExistQOrParamVars = [_ | _]
+ ->
+ % There should be no duplicate names to remove.
+ varset.coerce(VarSet, GenericVarSet),
+ NotExistQOrParamVarsStr =
+ mercury_vars_to_string(GenericVarSet, no, NotExistQOrParamVars),
+ Pieces = [words("Error: free type"),
+ words(choose_number(NotExistQOrParamVars,
+ "parameter", "parameters")),
+ words(NotExistQOrParamVarsStr),
+ words("in RHS of type definition."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(BodyTerm), [always(Pieces)])]),
+ !:Specs = [Spec | !.Specs]
+ ;
+ % Check that all type variables in existential quantifiers do not
+ % occur in the head (maybe this should just be a warning, not an error?
+ % If we were to allow it, we would need to rename them apart.)
+
+ set.list_to_set(ExistQVars, ExistQVarsSet),
+ set.list_to_set(Params, ParamsSet),
+ set.intersect(ExistQVarsSet, ParamsSet, ExistQParamsSet),
+ set.non_empty(ExistQParamsSet)
+ ->
+ % There should be no duplicate names to remove.
+ set.to_sorted_list(ExistQParamsSet, ExistQParams),
+ varset.coerce(VarSet, GenericVarSet),
+ ExistQParamVarsStr =
+ mercury_vars_to_string(GenericVarSet, no, ExistQParams),
+ Pieces = [words("Error:"),
+ words(choose_number(ExistQParams,
+ "type variable", "type variables")),
+ words(ExistQParamVarsStr),
+ words(choose_number(ExistQParams, "has", "have")),
+ words("overlapping scopes"),
+ words("(explicit type quantifier shadows argument type)."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(BodyTerm), [always(Pieces)])]),
+ !:Specs = [Spec | !.Specs]
+ ;
+ % Check that all type variables in existential quantifiers occur
+ % somewhere in the constructor argument types or constraints.
+
+ CtorArgTypes = list.map(func(C) = C ^ arg_type, CtorArgs),
+ type_vars_list(CtorArgTypes, VarsInCtorArgTypes0),
+ list.sort_and_remove_dups(VarsInCtorArgTypes0, VarsInCtorArgTypes),
+ constraint_list_get_tvars(Constraints, ConstraintTVars),
+ list.filter(list.contains(VarsInCtorArgTypes ++ ConstraintTVars),
+ ExistQVars, _OccursExistQVars, NotOccursExistQVars),
+ NotOccursExistQVars = [_ | _]
+ ->
+ % There should be no duplicate names to remove.
+ varset.coerce(VarSet, GenericVarSet),
+ NotOccursExistQVarsStr =
+ mercury_vars_to_string(GenericVarSet, no, NotOccursExistQVars),
+ Pieces = [words("Error:"),
+ words(choose_number(NotOccursExistQVars,
+ "type variable", "type variables")),
+ words(NotOccursExistQVarsStr),
+ words("in existential quantifier"),
+ words(choose_number(NotOccursExistQVars,
+ "does not occur", "do not occur")),
+ words("in arguments or constraints of constructor."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(BodyTerm), [always(Pieces)])]),
+ !:Specs = [Spec | !.Specs]
+ ;
+ % Check that all type variables in existential constraints occur in
+ % the existential quantifiers.
+
+ ConstraintArgTypeLists =
+ list.map(prog_constraint_get_arg_types, Constraints),
+ list.condense(ConstraintArgTypeLists, ConstraintArgTypes),
+ type_vars_list(ConstraintArgTypes, VarsInCtorArgTypes0),
+ list.sort_and_remove_dups(VarsInCtorArgTypes0, VarsInCtorArgTypes),
+ list.filter(list.contains(ExistQVars), VarsInCtorArgTypes,
+ _ExistQArgTypes, NotExistQArgTypes),
+ NotExistQArgTypes = [_ | _]
+ ->
+ varset.coerce(VarSet, GenericVarSet),
+ NotExistQArgTypesStr =
+ mercury_vars_to_string(GenericVarSet, no, NotExistQArgTypes),
+ Pieces = [words("Error:"),
+ words(choose_number(NotExistQArgTypes,
+ "type variable", "type variables")),
+ words(NotExistQArgTypesStr),
+ words("in class constraints,"),
+ words(choose_number(NotExistQArgTypes,
+ "which was", "which were")),
+ words("introduced with"), quote("=>"),
+ words("must be explicitly existentially quantified"),
+ words("using"), quote("some"), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(BodyTerm), [always(Pieces)])]),
+ !:Specs = [Spec | !.Specs]
+ ;
+ true
+ ),
+ process_du_ctors(Params, VarSet, BodyTerm, Ctors, !Specs).
+
+%-----------------------------------------------------------------------------%
+
+ % parse_eqv_type_defn parses the definition of an equivalence type.
+ %
+:- pred parse_eqv_type_defn(module_name::in, varset::in, term::in, term::in,
+ decl_attrs::in, condition::in, prog_context::in, int::in,
+ maybe1(item)::out) is det.
+
+parse_eqv_type_defn(ModuleName, VarSet, HeadTerm, BodyTerm, Attributes,
+ Condition, Context, SeqNum, MaybeItem) :-
+ parse_type_defn_head(ModuleName, VarSet, HeadTerm,
+ MaybeNameAndParams),
+ (
+ MaybeNameAndParams = error2(Specs),
+ MaybeItem = error1(Specs)
+ ;
+ MaybeNameAndParams = ok2(Name, Params),
+ % Check that all the variables in the body occur in the head.
+ (
+ term.contains_var(BodyTerm, Var),
+ term.coerce_var(Var, TVar),
+ not list.member(TVar, Params)
+ ->
+ BodyTermStr = describe_error_term(VarSet, BodyTerm),
+ Pieces = [words("Error: free type parameter"),
+ words("in RHS of type definition:"),
+ words(BodyTermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(BodyTerm), [always(Pieces)])]),
+ MaybeItem = error1([Spec])
+ ;
+ % XXX Should pass more correct ContextPieces.
+ ContextPieces = [],
+ parse_type(BodyTerm, VarSet, ContextPieces, MaybeType),
+ (
+ MaybeType = ok1(Type),
+ varset.coerce(VarSet, TypeVarSet),
+ TypeDefn = parse_tree_eqv_type(Type),
+ ItemTypeDefn = item_type_defn_info(TypeVarSet, Name, Params,
+ TypeDefn, Condition, Context, SeqNum),
+ Item = item_type_defn(ItemTypeDefn),
+ MaybeItem0 = ok1(Item),
+ check_no_attributes(MaybeItem0, Attributes, MaybeItem)
+ ;
+ MaybeType = error1(Specs),
+ MaybeItem = error1(Specs)
+ )
+ )
+ ).
+
+%-----------------------------------------------------------------------------%
+
+ % parse_solver_type_defn parses the definition of a solver type.
+ %
+:- pred parse_solver_type_defn(module_name::in, varset::in, term::in, term::in,
+ decl_attrs::in, condition::in, prog_context::in, int::in,
+ maybe1(item)::out) is det.
+
+parse_solver_type_defn(ModuleName, VarSet, HeadTerm, BodyTerm, Attributes0,
+ Condition, Context, SeqNum, MaybeItem) :-
+ get_is_solver_type(IsSolverType, Attributes0, Attributes),
+ (
+ IsSolverType = non_solver_type,
+ Pieces = [words("Error: only solver types can be defined"),
+ words("by a `where' block alone."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(HeadTerm), [always(Pieces)])]),
+ MaybeItem = error1([Spec])
+ ;
+ IsSolverType = solver_type,
+ MaybeWhere = parse_type_decl_where_term(solver_type, ModuleName,
+ VarSet, yes(BodyTerm)),
+ (
+ MaybeWhere = error2(Specs),
+ MaybeItem = error1(Specs)
+ ;
+ MaybeWhere = ok2(MaybeSolverTypeDetails, MaybeUserEqComp),
+ parse_solver_type_base(ModuleName, VarSet, HeadTerm,
+ MaybeSolverTypeDetails, MaybeUserEqComp, Attributes,
+ Condition, Context, SeqNum, MaybeItem)
+ )
+ ).
+
+:- pred parse_solver_type_base(module_name::in, varset::in, term::in,
+ maybe(solver_type_details)::in, maybe(unify_compare)::in,
+ decl_attrs::in, condition::in, prog_context::in, int::in,
+ maybe1(item)::out) is det.
+
+parse_solver_type_base(ModuleName, VarSet, HeadTerm,
+ MaybeSolverTypeDetails, MaybeUserEqComp, Attributes, Condition,
+ Context, SeqNum, MaybeItem) :-
+ (
+ MaybeSolverTypeDetails = yes(SolverTypeDetails),
+ parse_type_defn_head(ModuleName, VarSet, HeadTerm, MaybeNameParams),
+ (
+ MaybeNameParams = error2(Specs),
+ MaybeItem = error1(Specs)
+ ;
+ MaybeNameParams = ok2(Name, Params),
+ (
+ RepnType = SolverTypeDetails ^ representation_type,
+ type_contains_var(RepnType, Var),
+ not list.member(Var, Params)
+ ->
+ HeadTermStr = describe_error_term(VarSet, HeadTerm),
+ Pieces = [words("Error: free type variable"),
+ words("in representation type:"),
+ words(HeadTermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(HeadTerm),
+ [always(Pieces)])]),
+ MaybeItem = error1([Spec])
+ ;
+ varset.coerce(VarSet, TypeVarSet),
+ TypeDefn = parse_tree_solver_type(SolverTypeDetails,
+ MaybeUserEqComp),
+ ItemTypeDefn = item_type_defn_info(TypeVarSet, Name, Params,
+ TypeDefn, Condition, Context, SeqNum),
+ Item = item_type_defn(ItemTypeDefn),
+ MaybeItem0 = ok1(Item),
+ check_no_attributes(MaybeItem0, Attributes, MaybeItem)
+ )
+ )
+ ;
+ MaybeSolverTypeDetails = no,
+ Pieces = [words("Solver type with no solver_type_details."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(HeadTerm), [always(Pieces)])]),
+ MaybeItem = error1([Spec])
+ ).
+
+%-----------------------------------------------------------------------------%
+%
+% Parse an abstract type definition.
+%
+
+:- pred parse_abstract_type_defn(module_name::in, varset::in, term::in,
+ decl_attrs::in, condition::in, prog_context::in, int::in,
+ maybe1(item)::out) is det.
+
+parse_abstract_type_defn(ModuleName, VarSet, HeadTerm, Attributes0,
+ Condition, Context, SeqNum, MaybeItem) :-
+ parse_type_defn_head(ModuleName, VarSet, HeadTerm, MaybeTypeCtorAndArgs),
+ get_is_solver_type(IsSolverType, Attributes0, Attributes),
+ (
+ MaybeTypeCtorAndArgs = error2(Specs),
+ MaybeItem = error1(Specs)
+ ;
+ MaybeTypeCtorAndArgs = ok2(Name, Params),
+ varset.coerce(VarSet, TypeVarSet),
+ TypeDefn = parse_tree_abstract_type(IsSolverType),
+ ItemTypeDefn = item_type_defn_info(TypeVarSet, Name, Params, TypeDefn,
+ Condition, Context, SeqNum),
+ Item = item_type_defn(ItemTypeDefn),
+ MaybeItem0 = ok1(Item),
+ check_no_attributes(MaybeItem0, Attributes, MaybeItem)
+ ).
+
+%-----------------------------------------------------------------------------%
+%
+% Parse ... where ... clauses in type definitions. These clauses can specify
+% type-specific unify and/or compare predicates for discriminated union types
+% and solver type details for solver types.
+%
+
+ % The optional `where ...' part of the type definition syntax
+ % is a comma separated list of special type `attributes'.
+ %
+ % The possible attributes (in this order) are either
+ % - `type_is_abstract_noncanonical' on its own appears only in .int2
+ % files and indicates that the type has user-defined equality and/or
+ % comparison, but that what these predicates are is not known at
+ % this point
+ % or
+ % - `representation is <<type name>>' (required for solver types)
+ % - `initialisation is <<pred name>>' (required for solver types)
+ % - `ground is <<inst>>' (required for solver types)
+ % - `any is <<inst>>' (required for solver types)
+ % - `equality is <<pred name>>' (optional)
+ % - `comparison is <<pred name>>' (optional).
+ %
+parse_type_decl_where_part_if_present(IsSolverType, ModuleName, VarSet,
+ Term, BeforeWhereTerm, MaybeWhereDetails) :-
+ (
+ Term = term.functor(term.atom("where"),
+ [BeforeWhereTermPrime, WhereTerm], _)
+ ->
+ BeforeWhereTerm = BeforeWhereTermPrime,
+ MaybeWhereDetails = parse_type_decl_where_term(IsSolverType,
+ ModuleName, VarSet, yes(WhereTerm))
+ ;
+ BeforeWhereTerm = Term,
+ MaybeWhereDetails = ok2(no, no)
+ ).
+
+ % The maybe2 wrapper allows us to return an error code or a pair
+ % of results. Either result half may be empty, hence the maybe
+ % wrapper around each of those.
+ %
+:- func parse_type_decl_where_term(is_solver_type, module_name, varset,
+ maybe(term)) = maybe2(maybe(solver_type_details), maybe(unify_compare)).
+
+parse_type_decl_where_term(IsSolverType, ModuleName, VarSet, MaybeTerm0) =
+ MaybeWhereDetails :-
+ (
+ MaybeTerm0 = no,
+ MaybeWhereDetails = ok2(no, no)
+ ;
+ MaybeTerm0 = yes(Term0),
+ some [!MaybeTerm] (
+ !:MaybeTerm = MaybeTerm0,
+ parse_where_attribute(parse_where_type_is_abstract_noncanonical,
+ MaybeTypeIsAbstractNoncanonical, !MaybeTerm),
+ parse_where_attribute(parse_where_is("representation",
+ parse_where_type_is(ModuleName, VarSet)),
+ MaybeRepresentationIs, !MaybeTerm),
+ parse_where_attribute(parse_where_initialisation_is(ModuleName,
+ VarSet),
+ MaybeInitialisationIs, !MaybeTerm),
+ parse_where_attribute(parse_where_is("ground",
+ parse_where_inst_is(ModuleName)),
+ MaybeGroundIs, !MaybeTerm),
+ parse_where_attribute(parse_where_is("any",
+ parse_where_inst_is(ModuleName)),
+ MaybeAnyIs, !MaybeTerm),
+ parse_where_attribute(parse_where_is("constraint_store",
+ parse_where_mutable_is(ModuleName)),
+ MaybeCStoreIs, !MaybeTerm),
+ parse_where_attribute(parse_where_is("equality",
+ parse_where_pred_is(ModuleName, VarSet)),
+ MaybeEqualityIs, !MaybeTerm),
+ parse_where_attribute(parse_where_is("comparison",
+ parse_where_pred_is(ModuleName, VarSet)),
+ MaybeComparisonIs, !MaybeTerm),
+ parse_where_end(!.MaybeTerm, MaybeWhereEnd)
+ ),
+ MaybeWhereDetails = make_maybe_where_details(
+ IsSolverType,
+ MaybeTypeIsAbstractNoncanonical,
+ MaybeRepresentationIs,
+ MaybeInitialisationIs,
+ MaybeGroundIs,
+ MaybeAnyIs,
+ MaybeCStoreIs,
+ MaybeEqualityIs,
+ MaybeComparisonIs,
+ MaybeWhereEnd,
+ Term0
+ )
+ ).
+
+ % parse_where_attribute(Parser, Result, MaybeTerm, MaybeTailTerm)
+ % handles
+ % - where MaybeTerm may contain nothing
+ % - where MaybeTerm may be a comma-separated pair
+ % - applies Parser to the appropriate (sub)term to obtain Result
+ % - sets MaybeTailTerm depending upon whether the Result is an error
+ % or not and whether there is more to parse because MaybeTerm
+ % was a comma-separated pair.
+ %
+:- pred parse_where_attribute((func(term) = maybe1(maybe(T)))::in,
+ maybe1(maybe(T))::out, maybe(term)::in, maybe(term)::out) is det.
+
+parse_where_attribute(Parser, Result, MaybeTerm, MaybeTailTerm) :-
+ (
+ MaybeTerm = no,
+ MaybeTailTerm = no,
+ Result = ok1(no)
+ ;
+ MaybeTerm = yes(Term),
+ (
+ Term = term.functor(term.atom(","), [HeadTerm, TailTerm], _)
+ ->
+ Result = Parser(HeadTerm),
+ MaybeTailTermIfYes = yes(TailTerm)
+ ;
+ Result = Parser(Term),
+ MaybeTailTermIfYes = no
+ ),
+ (
+ Result = error1(_),
+ MaybeTailTerm = no
+ ;
+ Result = ok1(no),
+ MaybeTailTerm = yes(Term)
+ ;
+ Result = ok1(yes(_)),
+ MaybeTailTerm = MaybeTailTermIfYes
+ )
+ ).
+
+ % Parser for `where ...' attributes of the form
+ % `attributename is attributevalue'.
+ %
+:- func parse_where_is(string, func(term) = maybe1(T), term) =
+ maybe1(maybe(T)).
+
+parse_where_is(Name, Parser, Term) = Result :-
+ ( Term = term.functor(term.atom("is"), [LHS, RHS], _) ->
+ ( LHS = term.functor(term.atom(Name), [], _) ->
+ RHSResult = Parser(RHS),
+ (
+ RHSResult = ok1(ParsedRHS),
+ Result = ok1(yes(ParsedRHS))
+ ;
+ RHSResult = error1(Specs),
+ Result = error1(Specs)
+ )
+ ;
+ Result = ok1(no)
+ )
+ ;
+ Pieces = [words("Error: expected"), quote("is"), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ Result = error1([Spec])
+ ).
+
+:- func parse_where_type_is_abstract_noncanonical(term) = maybe1(maybe(unit)).
+
+parse_where_type_is_abstract_noncanonical(Term) =
+ ( Term = term.functor(term.atom("type_is_abstract_noncanonical"), [], _) ->
+ ok1(yes(unit))
+ ;
+ ok1(no)
+ ).
+
+:- func parse_where_initialisation_is(module_name, varset, term) =
+ maybe1(maybe(sym_name)).
+
+parse_where_initialisation_is(ModuleName, VarSet, Term) = Result :-
+ Result0 = parse_where_is("initialisation",
+ parse_where_pred_is(ModuleName, VarSet), Term),
+ (
+ Result0 = ok1(no)
+ ->
+ Result1 = parse_where_is("initialization",
+ parse_where_pred_is(ModuleName, VarSet), Term)
+ ;
+ Result1 = Result0
+ ),
+ promise_pure (
+ (
+ Result1 = ok1(yes(_)),
+ semipure
+ semipure_get_solver_auto_init_supported(AutoInitSupported),
+ (
+ AutoInitSupported = yes,
+ Result = Result1
+ ;
+ AutoInitSupported = no,
+ Pieces = [words("Error: unknown attribute"),
+ words("in solver type definition."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ Result = error1([Spec])
+ )
+ ;
+ ( Result1 = ok1(no)
+ ; Result1 = error1(_)
+ ),
+ Result = Result1
+ )
+ ).
+
+:- func parse_where_pred_is(module_name, varset, term) = maybe1(sym_name).
+
+parse_where_pred_is(ModuleName, VarSet, Term) = MaybeSymName :-
+ parse_implicitly_qualified_symbol_name(ModuleName, VarSet, Term,
+ MaybeSymName).
+
+:- func parse_where_inst_is(module_name, term) = maybe1(mer_inst).
+
+parse_where_inst_is(_ModuleName, Term) = MaybeInst :-
+ (
+ convert_inst(no_allow_constrained_inst_var, Term, Inst),
+ not inst_contains_unconstrained_var(Inst)
+ ->
+ MaybeInst = ok1(Inst)
+ ;
+ Pieces = [words("Error: expected a ground, unconstrained inst."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ MaybeInst = error1([Spec])
+ ).
+
+:- func parse_where_type_is(module_name, varset, term) = maybe1(mer_type).
+
+parse_where_type_is(_ModuleName, VarSet, Term) = MaybeType :-
+ % XXX We should pass meaningful ContextPieces.
+ ContextPieces = [],
+ parse_type(Term, VarSet, ContextPieces, MaybeType).
+
+:- func parse_where_mutable_is(module_name, term) = maybe1(list(item)).
+
+parse_where_mutable_is(ModuleName, Term) = MaybeItems :-
+ ( Term = term.functor(term.atom("mutable"), _, _) ->
+ parse_mutable_decl_term(ModuleName, Term, MaybeItem),
+ (
+ MaybeItem = ok1(Mutable),
+ MaybeItems = ok1([Mutable])
+ ;
+ MaybeItem = error1(Specs),
+ MaybeItems = error1(Specs)
+ )
+ ; list_term_to_term_list(Term, Terms) ->
+ map_parser(parse_mutable_decl_term(ModuleName), Terms, MaybeItems)
+ ;
+ Pieces = [words("Error: expected a mutable declaration"),
+ words("or a list of mutable declarations."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ MaybeItems = error1([Spec])
+ ).
+
+:- pred parse_mutable_decl_term(module_name::in, term::in, maybe1(item)::out)
+ is det.
+
+parse_mutable_decl_term(ModuleName, Term, MaybeItem) :-
+ (
+ Term = term.functor(term.atom("mutable"), Args, Context),
+ varset.init(VarSet),
+ parse_mutable_decl(ModuleName, VarSet, Args, Context, -1,
+ MaybeItemPrime)
+ ->
+ MaybeItem = MaybeItemPrime
+ ;
+ Pieces = [words("Error: expected a mutable declaration."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ MaybeItem = error1([Spec])
+ ).
+
+:- pred parse_where_end(maybe(term)::in, maybe1(maybe(unit))::out) is det.
+
+parse_where_end(no, ok1(yes(unit))).
+parse_where_end(yes(Term), error1([Spec])) :-
+ Pieces = [words("Error: attributes are either badly ordered"),
+ words("or contain an unrecognised attribute."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]).
+
+:- func make_maybe_where_details(is_solver_type, maybe1(maybe(unit)),
+ maybe1(maybe(mer_type)), maybe1(maybe(init_pred)),
+ maybe1(maybe(mer_inst)), maybe1(maybe(mer_inst)),
+ maybe1(maybe(list(item))),
+ maybe1(maybe(equality_pred)), maybe1(maybe(comparison_pred)),
+ maybe1(maybe(unit)), term)
+ = maybe2(maybe(solver_type_details), maybe(unify_compare)).
+
+make_maybe_where_details(IsSolverType, MaybeTypeIsAbstractNoncanonical,
+ MaybeRepresentationIs, MaybeInitialisationIs,
+ MaybeGroundIs, MaybeAnyIs, MaybeCStoreIs,
+ MaybeEqualityIs, MaybeComparisonIs, MaybeWhereEnd, WhereTerm)
+ = MaybeSolverUC :-
+ (
+ MaybeTypeIsAbstractNoncanonical = ok1(TypeIsAbstractNoncanonical),
+ MaybeRepresentationIs = ok1(RepresentationIs),
+ MaybeInitialisationIs = ok1(InitialisationIs),
+ MaybeGroundIs = ok1(GroundIs),
+ MaybeAnyIs = ok1(AnyIs),
+ MaybeCStoreIs = ok1(CStoreIs),
+ MaybeEqualityIs = ok1(EqualityIs),
+ MaybeComparisonIs = ok1(ComparisonIs),
+ MaybeWhereEnd = ok1(WhereEnd)
+ ->
+ MaybeSolverUC = make_maybe_where_details_2(IsSolverType,
+ TypeIsAbstractNoncanonical, RepresentationIs, InitialisationIs,
+ GroundIs, AnyIs, CStoreIs, EqualityIs, ComparisonIs,
+ WhereEnd, WhereTerm)
+ ;
+ Specs =
+ get_any_errors1(MaybeTypeIsAbstractNoncanonical) ++
+ get_any_errors1(MaybeRepresentationIs) ++
+ get_any_errors1(MaybeInitialisationIs) ++
+ get_any_errors1(MaybeGroundIs) ++
+ get_any_errors1(MaybeAnyIs) ++
+ get_any_errors1(MaybeCStoreIs) ++
+ get_any_errors1(MaybeEqualityIs) ++
+ get_any_errors1(MaybeComparisonIs) ++
+ get_any_errors1(MaybeWhereEnd),
+ MaybeSolverUC = error2(Specs)
+ ).
+
+:- func make_maybe_where_details_2(is_solver_type, maybe(unit),
+ maybe(mer_type), maybe(init_pred), maybe(mer_inst), maybe(mer_inst),
+ maybe(list(item)), maybe(equality_pred), maybe(comparison_pred),
+ maybe(unit), term)
+ = maybe2(maybe(solver_type_details), maybe(unify_compare)).
+
+make_maybe_where_details_2(IsSolverType, TypeIsAbstractNoncanonical,
+ RepresentationIs, InitialisationIs, GroundIs, AnyIs, CStoreIs,
+ EqualityIs, ComparisonIs, _WhereEnd, WhereTerm) = MaybeSolverUC :-
+ (
+ TypeIsAbstractNoncanonical = yes(_),
+ % rafe: XXX I think this is wrong. There isn't a problem with having
+ % the solver_type_details and type_is_abstract_noncanonical.
+ (
+ RepresentationIs = maybe.no,
+ InitialisationIs = maybe.no,
+ GroundIs = maybe.no,
+ AnyIs = maybe.no,
+ EqualityIs = maybe.no,
+ ComparisonIs = maybe.no,
+ CStoreIs = maybe.no
+ ->
+ MaybeSolverUC =
+ ok2(no, yes(abstract_noncanonical_type(IsSolverType)))
+ ;
+ Pieces = [words("Error:"),
+ quote("where type_is_abstract_noncanonical"),
+ words("excludes other"), quote("where ..."),
+ words("attributes."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(WhereTerm), [always(Pieces)])]),
+ MaybeSolverUC = error2([Spec])
+ )
+ ;
+ TypeIsAbstractNoncanonical = maybe.no,
+ (
+ IsSolverType = solver_type,
+ (
+ RepresentationIs = yes(RepnType),
+ InitialisationIs = MaybeInitialisation,
+ GroundIs = MaybeGroundInst,
+ AnyIs = MaybeAnyInst,
+ EqualityIs = MaybeEqPred,
+ ComparisonIs = MaybeCmpPred,
+ CStoreIs = MaybeMutableItems
+ ->
+ (
+ MaybeGroundInst = yes(GroundInst)
+ ;
+ MaybeGroundInst = no,
+ GroundInst = ground_inst
+ ),
+ (
+ MaybeAnyInst = yes(AnyInst)
+ ;
+ MaybeAnyInst = no,
+ AnyInst = ground_inst
+ ),
+ (
+ MaybeMutableItems = yes(MutableItems)
+ ;
+ MaybeMutableItems = no,
+ MutableItems = []
+ ),
+ (
+ MaybeInitialisation = yes(InitPred),
+ HowToInit = solver_init_automatic(InitPred)
+ ;
+ MaybeInitialisation = no,
+ HowToInit = solver_init_explicit
+ ),
+ SolverTypeDetails = solver_type_details(
+ RepnType, HowToInit, GroundInst, AnyInst, MutableItems),
+ MaybeSolverTypeDetails = yes(SolverTypeDetails),
+ (
+ MaybeEqPred = no,
+ MaybeCmpPred = no
+ ->
+ MaybeUnifyCompare = no
+ ;
+ MaybeUnifyCompare = yes(unify_compare(
+ MaybeEqPred, MaybeCmpPred))
+ ),
+ MaybeSolverUC = ok2(MaybeSolverTypeDetails, MaybeUnifyCompare)
+ ;
+ RepresentationIs = no
+ ->
+ Pieces = [words("Error: solver type definitions must have a"),
+ quote("representation"), words("attribute."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(WhereTerm),
+ [always(Pieces)])]),
+ MaybeSolverUC = error2([Spec])
+ ;
+ unexpected(this_file, "make_maybe_where_details_2: " ++
+ "shouldn't have reached this point! (1)")
+ )
+ ;
+ IsSolverType = non_solver_type,
+ (
+ ( RepresentationIs = yes(_)
+ ; InitialisationIs = yes(_)
+ ; GroundIs = yes(_)
+ ; AnyIs = yes(_)
+ ; CStoreIs = yes(_)
+ )
+ ->
+ Pieces = [words("Error: solver type attribute given"),
+ words("for non-solver type."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(WhereTerm),
+ [always(Pieces)])]),
+ MaybeSolverUC = error2([Spec])
+ ;
+ EqualityIs = MaybeEqPred,
+ ComparisonIs = MaybeCmpPred,
+ MaybeSolverUC =
+ ok2(no, yes(unify_compare(MaybeEqPred, MaybeCmpPred)))
+ )
+ )
+ ).
+
+%-----------------------------------------------------------------------------%
+%
+% Predicates useful for parsing several kinds of type definitions.
+%
+
+parse_type_defn_head(ModuleName, VarSet, HeadTerm, MaybeTypeCtorAndArgs) :-
+ (
+ HeadTerm = term.variable(_, Context),
+ Pieces = [words("Error: variable on LHS of type definition."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ MaybeTypeCtorAndArgs = error2([Spec])
+ ;
+ HeadTerm = term.functor(_, _, HeadContext),
+ ContextPieces = [words("In type definition:")],
+ parse_implicitly_qualified_term(ModuleName, HeadTerm, HeadTerm,
+ VarSet, ContextPieces, HeadResult),
+ (
+ HeadResult = error2(Specs),
+ MaybeTypeCtorAndArgs = error2(Specs)
+ ;
+ HeadResult = ok2(Name, ArgTerms),
+ % Check that all the head args are variables.
+ ( term_list_to_var_list(ArgTerms, Params0) ->
+ % Check that all the head arg variables are distinct.
+ (
+ list.member(_, Params0, [Param | OtherParams]),
+ list.member(Param, OtherParams)
+ ->
+ Pieces = [words("Error: repeated type parameters"),
+ words("in LHS of type definition."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(HeadContext, [always(Pieces)])]),
+ MaybeTypeCtorAndArgs = error2([Spec])
+ ;
+ list.map(term.coerce_var, Params0, Params),
+ MaybeTypeCtorAndArgs = ok2(Name, Params)
+ )
+ ;
+ HeadTermStr = describe_error_term(VarSet, HeadTerm),
+ Pieces = [words("Error: type parameters must be variables:"),
+ words(HeadTermStr), suffix(".") ,nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(HeadContext, [always(Pieces)])]),
+ MaybeTypeCtorAndArgs = error2([Spec])
+ )
+ )
+ ).
+
+%-----------------------------------------------------------------------------e
+
+:- pred get_is_solver_type(is_solver_type::out,
+ decl_attrs::in, decl_attrs::out) is det.
+
+get_is_solver_type(IsSolverType, !Attributes) :-
+ ( !.Attributes = [decl_attr_solver_type - _ | !:Attributes] ->
+ IsSolverType = solver_type
+ ;
+ IsSolverType = non_solver_type
+ ).
+
+%-----------------------------------------------------------------------------e
+
+:- func this_file = string.
+
+this_file = "prog_io_type_defn".
+
+%-----------------------------------------------------------------------------e
Index: compiler/prog_io_util.m
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/prog_io_util.m,v
retrieving revision 1.64
diff -u -b -r1.64 prog_io_util.m
--- compiler/prog_io_util.m 2 Dec 2008 04:30:25 -0000 1.64
+++ compiler/prog_io_util.m 2 Dec 2008 05:15:50 -0000
@@ -32,6 +32,7 @@
:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_data.
+:- import_module assoc_list.
:- import_module list.
:- import_module map.
:- import_module maybe.
@@ -180,6 +181,53 @@
:- pred list_term_to_term_list(term::in, list(term)::out) is semidet.
%-----------------------------------------------------------------------------%
+
+:- type decl_attribute
+ ---> decl_attr_purity(purity)
+ ; decl_attr_quantifier(quantifier_type, list(var))
+ ; decl_attr_constraints(quantifier_type, term)
+ % the term here is the (not yet parsed) list of constraints
+ ; decl_attr_solver_type.
+
+:- type quantifier_type
+ ---> quant_type_exist
+ ; quant_type_univ.
+
+ % The term associated with each decl_attribute is the term containing
+ % both the attribute and the declaration that that attribute modifies;
+ % this term is used when printing out error messages for cases when
+ % attributes are used on declarations where they are not allowed.
+:- type decl_attrs == assoc_list(decl_attribute, term.context).
+
+:- pred parse_decl_attribute(string::in, list(term)::in, decl_attribute::out,
+ term::out) is semidet.
+
+:- pred check_no_attributes(maybe1(T)::in, decl_attrs::in, maybe1(T)::out)
+ is det.
+
+:- func attribute_description(decl_attribute) = string.
+
+%-----------------------------------------------------------------------------%
+
+ % parse_condition_suffix(Term, BeforeCondTerm, Condition):
+ %
+ % Bind Condition to a representation of the 'where' condition of Term,
+ % if any, and bind BeforeCondTerm to the other part of Term. If Term
+ % does not contain a condition, then set Condition to true.
+ %
+ % NU-Prolog supported type declarations of the form
+ % :- pred p(T) where p(X) : sorted(X).
+ % or
+ % :- type sorted_list(T) = list(T) where X : sorted(X).
+ % :- pred p(sorted_list(T).
+ % There is some code here to support that sort of thing, but
+ % probably we would now need to use a different syntax, since
+ % Mercury now uses `where' for different purposes (e.g. specifying
+ % user-defined equality predicates, and also for type classes ...)
+ %
+:- pred parse_condition_suffix(term::in, term::out, condition::out) is det.
+
+%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
@@ -1004,6 +1052,83 @@
%-----------------------------------------------------------------------------%
+parse_decl_attribute(Functor, ArgTerms, Attribute, SubTerm) :-
+ (
+ Functor = "impure",
+ ArgTerms = [SubTerm],
+ Attribute = decl_attr_purity(purity_impure)
+ ;
+ Functor = "semipure",
+ ArgTerms = [SubTerm],
+ Attribute = decl_attr_purity(purity_semipure)
+ ;
+ Functor = "<=",
+ ArgTerms = [SubTerm, ConstraintsTerm],
+ Attribute = decl_attr_constraints(quant_type_univ, ConstraintsTerm)
+ ;
+ Functor = "=>",
+ ArgTerms = [SubTerm, ConstraintsTerm],
+ Attribute = decl_attr_constraints(quant_type_exist, ConstraintsTerm)
+ ;
+ Functor = "some",
+ ArgTerms = [TVarsTerm, SubTerm],
+ parse_list_of_vars(TVarsTerm, TVars),
+ Attribute = decl_attr_quantifier(quant_type_exist, TVars)
+ ;
+ Functor = "all",
+ ArgTerms = [TVarsTerm, SubTerm],
+ parse_list_of_vars(TVarsTerm, TVars),
+ Attribute = decl_attr_quantifier(quant_type_univ, TVars)
+ ;
+ Functor = "solver",
+ ArgTerms = [SubTerm],
+ Attribute = decl_attr_solver_type
+ ).
+
+check_no_attributes(Result0, Attributes, Result) :-
+ (
+ Result0 = ok1(_),
+ Attributes = [Attr - Context | _]
+ ->
+ % XXX Shouldn't we mention EVERY element of Attributes?
+ Pieces = [words("Error:"), words(attribute_description(Attr)),
+ words("not allowed here."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(Context, [always(Pieces)])]),
+ Result = error1([Spec])
+ ;
+ Result = Result0
+ ).
+
+attribute_description(decl_attr_purity(_)) = "purity specifier".
+attribute_description(decl_attr_quantifier(quant_type_univ, _)) =
+ "universal quantifier (`all')".
+attribute_description(decl_attr_quantifier(quant_type_exist, _)) =
+ "existential quantifier (`some')".
+attribute_description(decl_attr_constraints(quant_type_univ, _)) =
+ "type class constraint (`<=')".
+attribute_description(decl_attr_constraints(quant_type_exist, _)) =
+ "existentially quantified type class constraint (`=>')".
+attribute_description(decl_attr_solver_type) = "solver type specifier".
+
+%-----------------------------------------------------------------------------%
+
+parse_condition_suffix(Term, Term, cond_true).
+
+% parse_condition_suffix(B, Body, Condition) :-
+% (
+% B = term.functor(term.atom("where"), [Body1, Condition1],
+% _Context)
+% ->
+% Body = Body1,
+% Condition = where(Condition1)
+% ;
+% Body = B,
+% Condition = true
+% ).
+
+%-----------------------------------------------------------------------------%
+
:- func this_file = string.
this_file = "prog_io_util.m".
cvs diff: Diffing compiler/notes
Index: compiler/notes/compiler_design.html
===================================================================
RCS file: /home/mercury/mercury1/repository/mercury/compiler/notes/compiler_design.html,v
retrieving revision 1.139
diff -u -b -r1.139 compiler_design.html
--- compiler/notes/compiler_design.html 2 Dec 2008 04:30:29 -0000 1.139
+++ compiler/notes/compiler_design.html 2 Dec 2008 05:17:47 -0000
@@ -268,7 +268,8 @@
clauses using Definite Clause Grammar notation), prog_io_goal.m (which
handles goals), prog_io_pragma.m (which handles pragma declarations),
prog_io_typeclass.m (which handles typeclass and instance
- declarations), prog_io_mutable.m (which handles initialize, finalize
+ declarations), prog_io_type_defn.m (which handles type definitions),
+ prog_io_mutable.m (which handles initialize, finalize
and mutable declarations), prog_io_sym_name.m (which handles parsing
symbol names and specifiers) and prog_io_util.m (which defines
types and predicates needed by the other prog_io*.m modules.
cvs diff: Diffing debian
cvs diff: Diffing debian/patches
cvs diff: Diffing deep_profiler
cvs diff: Diffing deep_profiler/notes
cvs diff: Diffing doc
cvs diff: Diffing extras
cvs diff: Diffing extras/base64
cvs diff: Diffing extras/cgi
cvs diff: Diffing extras/complex_numbers
cvs diff: Diffing extras/complex_numbers/samples
cvs diff: Diffing extras/complex_numbers/tests
cvs diff: Diffing extras/concurrency
cvs diff: Diffing extras/curs
cvs diff: Diffing extras/curs/samples
cvs diff: Diffing extras/curses
cvs diff: Diffing extras/curses/sample
cvs diff: Diffing extras/dynamic_linking
cvs diff: Diffing extras/error
cvs diff: Diffing extras/fixed
cvs diff: Diffing extras/gator
cvs diff: Diffing extras/gator/generations
cvs diff: Diffing extras/gator/generations/1
cvs diff: Diffing extras/graphics
cvs diff: Diffing extras/graphics/easyx
cvs diff: Diffing extras/graphics/easyx/samples
cvs diff: Diffing extras/graphics/mercury_allegro
cvs diff: Diffing extras/graphics/mercury_allegro/examples
cvs diff: Diffing extras/graphics/mercury_allegro/samples
cvs diff: Diffing extras/graphics/mercury_allegro/samples/demo
cvs diff: Diffing extras/graphics/mercury_allegro/samples/mandel
cvs diff: Diffing extras/graphics/mercury_allegro/samples/pendulum2
cvs diff: Diffing extras/graphics/mercury_allegro/samples/speed
cvs diff: Diffing extras/graphics/mercury_glut
cvs diff: Diffing extras/graphics/mercury_opengl
cvs diff: Diffing extras/graphics/mercury_tcltk
cvs diff: Diffing extras/graphics/samples
cvs diff: Diffing extras/graphics/samples/calc
cvs diff: Diffing extras/graphics/samples/gears
cvs diff: Diffing extras/graphics/samples/maze
cvs diff: Diffing extras/graphics/samples/pent
cvs diff: Diffing extras/lazy_evaluation
cvs diff: Diffing extras/lex
cvs diff: Diffing extras/lex/samples
cvs diff: Diffing extras/lex/tests
cvs diff: Diffing extras/log4m
cvs diff: Diffing extras/logged_output
cvs diff: Diffing extras/moose
cvs diff: Diffing extras/moose/samples
cvs diff: Diffing extras/moose/tests
cvs diff: Diffing extras/mopenssl
cvs diff: Diffing extras/morphine
cvs diff: Diffing extras/morphine/non-regression-tests
cvs diff: Diffing extras/morphine/scripts
cvs diff: Diffing extras/morphine/source
cvs diff: Diffing extras/net
cvs diff: Diffing extras/odbc
cvs diff: Diffing extras/posix
cvs diff: Diffing extras/posix/samples
cvs diff: Diffing extras/quickcheck
cvs diff: Diffing extras/quickcheck/tutes
cvs diff: Diffing extras/references
cvs diff: Diffing extras/references/samples
cvs diff: Diffing extras/references/tests
cvs diff: Diffing extras/solver_types
cvs diff: Diffing extras/solver_types/library
cvs diff: Diffing extras/trailed_update
cvs diff: Diffing extras/trailed_update/samples
cvs diff: Diffing extras/trailed_update/tests
cvs diff: Diffing extras/windows_installer_generator
cvs diff: Diffing extras/windows_installer_generator/sample
cvs diff: Diffing extras/windows_installer_generator/sample/images
cvs diff: Diffing extras/xml
cvs diff: Diffing extras/xml/samples
cvs diff: Diffing extras/xml_stylesheets
cvs diff: Diffing java
cvs diff: Diffing java/runtime
cvs diff: Diffing library
cvs diff: Diffing mdbcomp
cvs diff: Diffing profiler
cvs diff: Diffing robdd
cvs diff: Diffing runtime
cvs diff: Diffing runtime/GETOPT
cvs diff: Diffing runtime/machdeps
cvs diff: Diffing samples
cvs diff: Diffing samples/c_interface
cvs diff: Diffing samples/c_interface/c_calls_mercury
cvs diff: Diffing samples/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/c_interface/mercury_calls_c
cvs diff: Diffing samples/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/c_interface/standalone_c
cvs diff: Diffing samples/diff
cvs diff: Diffing samples/muz
cvs diff: Diffing samples/rot13
cvs diff: Diffing samples/solutions
cvs diff: Diffing samples/solver_types
cvs diff: Diffing samples/tests
cvs diff: Diffing samples/tests/c_interface
cvs diff: Diffing samples/tests/c_interface/c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/tests/c_interface/mercury_calls_c
cvs diff: Diffing samples/tests/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/tests/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/tests/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/tests/diff
cvs diff: Diffing samples/tests/muz
cvs diff: Diffing samples/tests/rot13
cvs diff: Diffing samples/tests/solutions
cvs diff: Diffing samples/tests/toplevel
cvs diff: Diffing scripts
cvs diff: Diffing slice
cvs diff: Diffing ssdb
cvs diff: Diffing tests
cvs diff: Diffing tests/analysis
cvs diff: Diffing tests/analysis/ctgc
cvs diff: Diffing tests/analysis/excp
cvs diff: Diffing tests/analysis/ext
cvs diff: Diffing tests/analysis/sharing
cvs diff: Diffing tests/analysis/table
cvs diff: Diffing tests/analysis/trail
cvs diff: Diffing tests/analysis/unused_args
cvs diff: Diffing tests/benchmarks
cvs diff: Diffing tests/debugger
cvs diff: Diffing tests/debugger/declarative
cvs diff: Diffing tests/dppd
cvs diff: Diffing tests/general
cvs diff: Diffing tests/general/accumulator
cvs diff: Diffing tests/general/string_format
cvs diff: Diffing tests/general/structure_reuse
cvs diff: Diffing tests/grade_subdirs
cvs diff: Diffing tests/hard_coded
cvs diff: Diffing tests/hard_coded/exceptions
cvs diff: Diffing tests/hard_coded/purity
cvs diff: Diffing tests/hard_coded/sub-modules
cvs diff: Diffing tests/hard_coded/typeclasses
cvs diff: Diffing tests/invalid
cvs diff: Diffing tests/invalid/purity
cvs diff: Diffing tests/misc_tests
cvs diff: Diffing tests/mmc_make
cvs diff: Diffing tests/mmc_make/lib
cvs diff: Diffing tests/par_conj
cvs diff: Diffing tests/recompilation
cvs diff: Diffing tests/tabling
cvs diff: Diffing tests/term
cvs diff: Diffing tests/trailing
cvs diff: Diffing tests/valid
cvs diff: Diffing tests/warnings
cvs diff: Diffing tools
cvs diff: Diffing trace
cvs diff: Diffing util
cvs diff: Diffing vim
cvs diff: Diffing vim/after
cvs diff: Diffing vim/ftplugin
cvs diff: Diffing vim/syntax
--------------------------------------------------------------------------
mercury-reviews mailing list
Post messages to: mercury-reviews at csse.unimelb.edu.au
Administrative Queries: owner-mercury-reviews at csse.unimelb.edu.au
Subscriptions: mercury-reviews-request at csse.unimelb.edu.au
--------------------------------------------------------------------------
More information about the reviews
mailing list