[m-rev.] diff: representation of types in the compiler
Mark Brown
mark at cs.mu.OZ.AU
Mon Sep 12 15:22:24 AEST 2005
Estimated hours taken: 30
Branches: main
Change the representation of types in the compiler.
We also add some support for handling kinds, which will be used later when we
have a kind system. There are a number of places where kinds are not yet
handled correctly -- we assume that all kinds will be `star'. Each of these
locations is flagged with a comment that contains "XXX kind inference:".
compiler/prog_data.m:
Implement the new version of type (type).
Change the definition of type_param to be a variable instead of a
term, since all parameters must be variables anyway.
Implement versions of varset.merge_* which work with tvarsets and
produce renamings instead of substitutions. Renamings are more
convenient than substitutions because we don't need to know the
kinds of type variables in order to build the renaming, and in any
case the substitutions shouldn't have anything other than variables
in the range so renamings will be more efficient and safe.
Define the type of kinds, and provide a couple of utility predicates
to operate on them.
compiler/prog_io.m:
Parse type definition heads as a sym_name and list of type_params,
rather than a functor. Handle this change in other predicates.
Allow parse errors to be returned by get_with_type/3, and handle
these errors.
Remove parse_type/2. This predicate didn't do any processing, it
just forwarded handling to convert_type/2.
compiler/prog_io_typeclass.m:
Change type_is_functor_and_vars to handle the new representation
of types. In doing so, we retain the old behaviour that pure
predicates pass this test, but no other pred or func types. This
behaviour is arguably incorrect, but there is little point changing
the behaviour at the moment. Instead we should remove these kind of
restrictions entirely, but that should be done later.
compiler/prog_io_util.m:
Provide predicates to both parse and unparse types. We need to
unparse types before printing them out, since we do a lot of special
case handling when printing out terms and we don't want to duplicate
this functionality for types.
compiler/module_qual.m:
Remove report_invalid_type. We now report ill-formed types during
parsing.
compiler/superhomogeneous.m:
Handle errors from the parsing of type expressions.
compiler/prog_out.m:
Provide a predicate to convert builtin_types to their string names,
and vice-versa.
compiler/prog_type.m:
Add a bunch of simple tests to use on types which may have kind
annotations present. In such cases, types do not have a canonical
representation so the simple handling of these tests is not what we
want. (Note that these are only required in early phases. The kind
annotations -- when they are implemented -- will be removed before
type checking.)
Consistently handle the application of renamings, substitutions and
recursive substitutions to various data structures.
compiler/mercury_to_mercury.m:
Implement mercury_output_type, mercury_format_type and
mercury_type_to_string. These convert the type to a term before
formatting -- the reason for this is so that appropriate parentheses
are used when formatting operators. This results in some slight
changes to error messages, which are reflected in changes to the
expected output files in the tests.
Remove the old version of mercury_type_to_string.
Change the argument ordering of mercury_format_var to be consistent
with mercury_format_type. (Other predicates in this module should
probably be changed in a similar way, since this argument ordering
is more amenable to higher-order programming. But that can be left
for another change.)
compiler/type_util.m:
Implement type unification. The behaviour is much the same as the
previous behaviour, except that we now handle apply/N types properly,
and we also allow for kind annotations.
Implement an occurs check for types.
Remove the example definition of replace_eqv_type. It isn't used and
would no longer work anyway even if it would have worked before.
Add a tvar_kind_map field to ctor_defn.
The functions type_info_type and type_ctor_info_type now return
types with `void' as their argument, rather than the type that the
type_info or type_ctor_info was for.
Remove type_util.real_vars/2, since it no longer does anything
different from prog_type.vars/2.
Remove the commented out implementation of type_to_ctor_and_args/3.
Its implementation is in prog_type.m, and has changed significantly
in any case.
compiler/add_clause.m:
Move parse_purity_annotation/3 to prog_io_util.m.
compiler/check_typeclass.m:
Remove apply_substitution_to_var_list/3, since we now have predicates
in prog_type.m to handle such things.
compiler/continuation_info.m:
compiler/trace.m:
Use prog_type.vars/2 instead of type_util.real_vars/2. The two
predicates have the same meaning now since type_infos don't contain
any type variables.
compiler/hlds_data.m:
Add tvar_kind_map fields to hlds_type_defn and hlds_class_defn.
compiler/hlds_pred.m:
Add a tvar_kind_map field to pred_info.
compiler/polymorphism.m:
Add a tvar_kind_map field to poly_info.
Remove unify_corresponding_types, which is no longer used.
compiler/hlds_out.m:
Use mercury_output_type/5 instead of term_io__write_term/4 and
mercury_output_term/5.
compiler/post_typecheck.m:
Build the void substitution directly rather than building intermediate
lists.
compiler/recompilation.version.m:
Use term__list_subsumes instead of type_list_subsumes, which now
operates only on types. This follows up on what was suggested in
an XXX comment.
compiler/typecheck_errors.m:
Use unparse_type/2 to format error messages.
compiler/typecheck_info.m:
Don't export write_type_with_bindings/5. It is no longer used
outside of this module.
compiler/*.m:
Conform to the above changes.
library/rtti_implementation.m:
Fix a syntax error that went undetected in our previous
implementation, and amazingly enough was compiled correctly anyway.
library/term.m:
Move the versions of term__unify, term__unify_list and
term__list_subsumes that were implemented specifically for types
to here. The version of term_unify that takes a list of bound
variables (i.e., variables that should not be bound any further)
is used by the subsumption check, which in turn is used by
recompilation.version.m.
tests/invalid/kind.err_exp:
tests/invalid/tc_err1.err_exp:
tests/invalid/tc_err2.err_exp:
tests/misc_tests/pretty_print_test.exp:
Update the expected output of these tests to match what we now do.
Index: compiler/add_class.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/add_class.m,v
retrieving revision 1.3
diff -u -r1.3 add_class.m
--- compiler/add_class.m 12 Sep 2005 03:05:42 -0000 1.3
+++ compiler/add_class.m 12 Sep 2005 04:07:41 -0000
@@ -86,8 +86,8 @@
map__search(Classes0, ClassId, OldDefn)
->
OldDefn = hlds_class_defn(OldStatus, OldConstraints, OldFunDeps,
- _OldAncestors, OldVars, OldInterface, OldMethods, OldVarSet,
- OldContext),
+ _OldAncestors, OldVars, _OldKinds, OldInterface, OldMethods,
+ OldVarSet, OldContext),
combine_status(ImportStatus1, OldStatus, ImportStatus),
(
OldInterface = concrete(_),
@@ -169,8 +169,13 @@
% Ancestors is not set until check_typeclass.
Ancestors = [],
+ % XXX kind inference:
+ % We set all the kinds to `star' at the moment. This should be
+ % done differently when we have a proper kind system.
+ Kinds = map.init,
Defn = hlds_class_defn(ImportStatus, Constraints, HLDSFunDeps,
- Ancestors, Vars, ClassInterface, ClassMethods, VarSet, Context),
+ Ancestors, Vars, Kinds, ClassInterface, ClassMethods, VarSet,
+ Context),
map__set(Classes0, ClassId, Defn, Classes),
module_info_set_classes(Classes, !ModuleInfo),
@@ -223,10 +228,10 @@
superclass_constraints_are_identical(OldVars0, OldVarSet, OldConstraints0,
Vars, VarSet, Constraints) :-
- varset__merge_subst(VarSet, OldVarSet, _, Subst),
- apply_subst_to_prog_constraint_list(Subst, OldConstraints0,
+ tvarset_merge_renaming(VarSet, OldVarSet, _, Renaming),
+ apply_variable_renaming_to_prog_constraint_list(Renaming, OldConstraints0,
OldConstraints1),
- OldVars = term__term_list_to_var_list(map__apply_to_list(OldVars0, Subst)),
+ apply_variable_renaming_to_tvar_list(Renaming, OldVars0, OldVars),
map__from_corresponding_lists(OldVars, Vars, VarRenaming),
apply_variable_renaming_to_prog_constraint_list(VarRenaming,
@@ -277,9 +282,12 @@
Method = pred_or_func(TypeVarSet, InstVarSet, ExistQVars, PredOrFunc,
PredName, TypesAndModes, _WithType, _WithInst, MaybeDet, _Cond,
Purity, ClassContext, Context),
- term__var_list_to_term_list(Vars, VarTerms),
+ % XXX kind inference:
+ % We set the kinds to `star' at the moment. This will be different
+ % when we have a kind system.
+ prog_type.var_list_to_type_list(map.init, Vars, Args),
ClassContext = constraints(UnivCnstrs, ExistCnstrs),
- NewUnivCnstrs = [constraint(Name, VarTerms) | UnivCnstrs],
+ NewUnivCnstrs = [constraint(Name, Args) | UnivCnstrs],
NewClassContext = constraints(NewUnivCnstrs, ExistCnstrs),
init_markers(Markers0),
add_marker(class_method, Markers0, Markers),
@@ -424,7 +432,8 @@
OtherInstanceDefn = hlds_instance_defn(_, _OtherStatus,
OtherContext, _, OtherTypes, OtherBody, _, OtherVarSet, _),
OtherBody \= abstract, % XXX
- varset__merge(VarSet, OtherVarSet, OtherTypes, _NewVarSet,
+ tvarset_merge_renaming(VarSet, OtherVarSet, _NewVarSet, Renaming),
+ apply_variable_renaming_to_type_list(Renaming, OtherTypes,
NewOtherTypes),
type_list_subsumes(Types, NewOtherTypes, _)
),
Index: compiler/add_clause.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/add_clause.m,v
retrieving revision 1.5
diff -u -r1.5 add_clause.m
--- compiler/add_clause.m 30 Aug 2005 04:11:45 -0000 1.5
+++ compiler/add_clause.m 7 Sep 2005 13:48:23 -0000
@@ -20,7 +20,6 @@
:- import_module io.
:- import_module list.
-:- import_module term.
:- pred module_add_clause(prog_varset::in, pred_or_func::in, sym_name::in,
list(prog_term)::in, goal::in, import_status::in, prog_context::in,
@@ -47,8 +46,6 @@
module_info::in, module_info::out, qual_info::in, qual_info::out,
svar_info::in, svar_info::out, io::di, io::uo) is det.
-:- pred parse_purity_annotation(term(T)::in, purity::out, term(T)::out) is det.
-
:- pred qualify_lambda_mode_list(list(mode)::in, list(mode)::out,
prog_context::in, qual_info::in, qual_info::out, io::di, io::uo) is det.
@@ -939,18 +936,6 @@
error("make_hlds__do_transform_dcg_record_syntax")
).
-parse_purity_annotation(Term0, Purity, Term) :-
- (
- Term0 = term__functor(term__atom(PurityName), [Term1], _),
- purity_name(Purity0, PurityName)
- ->
- Purity = Purity0,
- Term = Term1
- ;
- Purity = (pure),
- Term = Term0
- ).
-
qualify_lambda_mode_list(Modes0, Modes, Context, !QualInfo, !IO) :-
% The modes in `.opt' files are already fully module qualified.
qual_info_get_import_status(!.QualInfo, ImportStatus),
Index: compiler/add_pragma.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/add_pragma.m,v
retrieving revision 1.7
diff -u -r1.7 add_pragma.m
--- compiler/add_pragma.m 12 Sep 2005 04:37:14 -0000 1.7
+++ compiler/add_pragma.m 12 Sep 2005 04:41:11 -0000
@@ -806,7 +806,7 @@
set__list_to_set(VarsToSub, VarsToSubSet),
assoc_list__values(Subst, SubstTypes0),
- term__vars_list(SubstTypes0, TVarsInSubstTypes0),
+ prog_type__vars_list(SubstTypes0, TVarsInSubstTypes0),
set__list_to_set(TVarsInSubstTypes0,
TVarsInSubstTypes),
@@ -830,8 +830,8 @@
(
SubExistQVars = [],
map__init(TypeSubst0),
- term__apply_variable_renaming_to_list(SubstTypes0,
- TVarRenaming, SubstTypes),
+ apply_variable_renaming_to_type_list(TVarRenaming,
+ SubstTypes0, SubstTypes),
assoc_list__from_corresponding_lists(RenamedVarsToSub,
SubstTypes, SubAL),
list__foldl(map_set_from_pair, SubAL,
@@ -840,8 +840,7 @@
% Apply the substitution.
pred_info_arg_types(PredInfo0, Types0),
pred_info_get_class_context(PredInfo0, ClassContext0),
- term__apply_rec_substitution_to_list(Types0, TypeSubst,
- Types),
+ apply_rec_subst_to_type_list(TypeSubst, Types0, Types),
apply_rec_subst_to_prog_constraints(TypeSubst,
ClassContext0, ClassContext),
SubstOk = yes(TypeSubst)
Index: compiler/add_pred.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/add_pred.m,v
retrieving revision 1.2
diff -u -r1.2 add_pred.m
--- compiler/add_pred.m 30 Aug 2005 04:11:46 -0000 1.2
+++ compiler/add_pred.m 11 Sep 2005 15:31:15 -0000
@@ -70,6 +70,7 @@
:- import_module parse_tree__error_util.
:- import_module parse_tree__prog_mode.
:- import_module parse_tree__prog_out.
+:- import_module parse_tree__prog_type.
:- import_module parse_tree__prog_util.
:- import_module map.
@@ -410,7 +411,7 @@
Status, Context, Origin, PredOrFunc, PredId, !PredicateTable) :-
varset__init(TVarSet0),
make_n_fresh_vars("T", Arity, TypeVars, TVarSet0, TVarSet),
- term__var_list_to_term_list(TypeVars, Types),
+ prog_type.var_list_to_type_list(map__init, TypeVars, Types),
map__init(Proofs),
map__init(ConstraintMap),
% The class context is empty since this is an implicit
Index: compiler/add_solver.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/add_solver.m,v
retrieving revision 1.3
diff -u -r1.3 add_solver.m
--- compiler/add_solver.m 12 Sep 2005 03:05:42 -0000 1.3
+++ compiler/add_solver.m 12 Sep 2005 04:07:41 -0000
@@ -54,9 +54,11 @@
:- import_module hlds__make_hlds__add_pred.
:- import_module libs__globals.
:- import_module parse_tree__prog_mode.
+:- import_module parse_tree__prog_type.
:- import_module parse_tree__prog_util.
:- import_module bool.
+:- import_module map.
:- import_module require.
:- import_module string.
:- import_module std_util.
@@ -65,8 +67,11 @@
add_solver_type_decl_items(TVarSet, TypeSymName, TypeParams,
SolverTypeDetails, Context, !Status, !ModuleInfo, !IO) :-
- SolverType = sym_name_and_args_to_term(TypeSymName, TypeParams,
- Context),
+ % XXX kind inference:
+ % We set the kinds to `star'. This will be different when we have a
+ % kind system.
+ prog_type.var_list_to_type_list(map__init, TypeParams, Args),
+ SolverType = defined(TypeSymName, Args, star),
Arity = length(TypeParams),
RepnType = SolverTypeDetails ^ representation_type,
Index: compiler/add_type.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/add_type.m,v
retrieving revision 1.2
diff -u -r1.2 add_type.m
--- compiler/add_type.m 30 Aug 2005 04:11:46 -0000 1.2
+++ compiler/add_type.m 11 Sep 2005 10:54:21 -0000
@@ -125,8 +125,12 @@
Status = Status1,
Body = Body0
),
- hlds_data__set_type_defn(TVarSet, Args, Body, Status, no, NeedQual,
- Context, T),
+ % XXX kind inference:
+ % We set the kinds to `star'. This will be different when we have a
+ % kind system.
+ map__init(KindMap),
+ hlds_data__set_type_defn(TVarSet, Args, KindMap, Body, Status, no,
+ NeedQual, Context, T),
(
MaybeOldDefn = no,
Body = foreign_type(_)
@@ -161,6 +165,7 @@
MaybeOldDefn = yes(T2),
hlds_data__get_type_defn_tvarset(T2, TVarSet_2),
hlds_data__get_type_defn_tparams(T2, Params_2),
+ hlds_data__get_type_defn_kind_map(T2, KindMap_2),
hlds_data__get_type_defn_body(T2, Body_2),
hlds_data__get_type_defn_context(T2, OrigContext),
hlds_data__get_type_defn_status(T2, OrigStatus),
@@ -184,8 +189,9 @@
( Status = OrigStatus ->
true
;
- hlds_data__set_type_defn(TVarSet_2, Params_2, Body_2, Status,
- OrigInExportedEqv, OrigNeedQual, OrigContext, T3),
+ hlds_data__set_type_defn(TVarSet_2, Params_2, KindMap_2,
+ Body_2, Status, OrigInExportedEqv, OrigNeedQual,
+ OrigContext, T3),
map__det_update(Types0, TypeCtor, T3, Types),
module_info_set_types(Types, !ModuleInfo)
)
@@ -194,8 +200,8 @@
NewBody)
->
( check_foreign_type_visibility(OrigStatus, Status1) ->
- hlds_data__set_type_defn(TVarSet_2, Params_2, NewBody, Status,
- OrigInExportedEqv, NeedQual, Context, T3),
+ hlds_data__set_type_defn(TVarSet_2, Params_2, KindMap_2,
+ NewBody, Status, OrigInExportedEqv, NeedQual, Context, T3),
map__det_update(Types0, TypeCtor, T3, Types),
module_info_set_types(Types, !ModuleInfo)
;
@@ -231,8 +237,8 @@
% but the callee expects no type_infos
Body = eqv_type(EqvType),
Status = abstract_exported,
- term__contains_var_list(Args, Var),
- \+ term__contains_var(EqvType, Var)
+ list__member(Var, Args),
+ \+ type_contains_var(EqvType, Var)
->
Pieces = [words("Sorry, not implemented:"),
words("polymorphic equivalence type,"),
@@ -378,7 +384,11 @@
->
true
;
- construct_type(TypeCtor, Args, Type),
+ % XXX kind inference:
+ % We set the kinds to `star'. This will be different when we have
+ % a kind system.
+ prog_type.var_list_to_type_list(map__init, Args, ArgTypes),
+ construct_type(TypeCtor, ArgTypes, Type),
add_special_preds(TVarSet, Type, TypeCtor, Body, Context, Status,
!ModuleInfo)
).
Index: compiler/base_typeclass_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/base_typeclass_info.m,v
retrieving revision 1.35
diff -u -r1.35 base_typeclass_info.m
--- compiler/base_typeclass_info.m 20 Apr 2005 12:57:09 -0000 1.35
+++ compiler/base_typeclass_info.m 5 Sep 2005 14:16:16 -0000
@@ -121,7 +121,7 @@
error("pred_proc_ids should have been filled in by check_typeclass.m").
base_typeclass_info__gen_body(yes(PredProcIds0), Types, Constraints,
ModuleInfo, ClassId, BaseTypeClassInfo) :-
- term__vars_list(Types, TypeVars),
+ prog_type__vars_list(Types, TypeVars),
get_unconstrained_tvars(TypeVars, Constraints, Unconstrained),
list__length(Constraints, NumConstraints),
list__length(Unconstrained, NumUnconstrained),
Index: compiler/check_typeclass.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/check_typeclass.m,v
retrieving revision 1.76
diff -u -r1.76 check_typeclass.m
--- compiler/check_typeclass.m 26 Jul 2005 01:56:21 -0000 1.76
+++ compiler/check_typeclass.m 11 Sep 2005 10:56:22 -0000
@@ -198,8 +198,8 @@
map__lookup(ClassTable, ClassId, ClassDefn),
ClassDefn = hlds_class_defn(ImportStatus, SuperClasses, _FunDeps,
- _Ancestors, ClassVars, Interface, ClassInterface, ClassVarSet,
- TermContext),
+ _Ancestors, ClassVars, _Kinds, Interface, ClassInterface,
+ ClassVarSet, TermContext),
(
status_defined_in_this_module(ImportStatus, yes),
Interface = abstract
@@ -714,30 +714,29 @@
ArgModes, Errors, ArgTypeVars0, Status0, PredOrFunc),
% Rename the instance variables apart from the class variables
- varset__merge_subst(ArgTypeVars0, InstanceVarSet, ArgTypeVars1,
- RenameSubst),
- term__apply_substitution_to_list(InstanceTypes0, RenameSubst,
+ tvarset_merge_renaming(ArgTypeVars0, InstanceVarSet, ArgTypeVars1,
+ Renaming),
+ apply_variable_renaming_to_type_list(Renaming, InstanceTypes0,
InstanceTypes1),
- apply_subst_to_prog_constraint_list(RenameSubst, InstanceConstraints0,
- InstanceConstraints1),
+ apply_variable_renaming_to_prog_constraint_list(Renaming,
+ InstanceConstraints0, InstanceConstraints1),
% Work out what the type variables are bound to for this
% instance, and update the class types appropriately.
map__from_corresponding_lists(ClassVars, InstanceTypes1, TypeSubst),
- term__apply_substitution_to_list(ArgTypes0, TypeSubst, ArgTypes1),
+ apply_subst_to_type_list(TypeSubst, ArgTypes0, ArgTypes1),
apply_subst_to_prog_constraints(TypeSubst, ClassMethodClassContext0,
ClassMethodClassContext1),
% Get rid of any unwanted type variables
- term__vars_list(ArgTypes1, VarsToKeep0),
+ prog_type__vars_list(ArgTypes1, VarsToKeep0),
list__sort_and_remove_dups(VarsToKeep0, VarsToKeep),
varset__squash(ArgTypeVars1, VarsToKeep, ArgTypeVars, SquashSubst),
- term__apply_variable_renaming_to_list(ArgTypes1, SquashSubst,
- ArgTypes),
+ apply_variable_renaming_to_type_list(SquashSubst, ArgTypes1, ArgTypes),
apply_variable_renaming_to_prog_constraints(SquashSubst,
ClassMethodClassContext1, ClassMethodClassContext),
apply_partial_map_to_list(ExistQVars0, SquashSubst, ExistQVars),
- apply_variable_renaming_to_list(InstanceTypes1, SquashSubst,
+ apply_variable_renaming_to_type_list(SquashSubst, InstanceTypes1,
InstanceTypes),
apply_variable_renaming_to_prog_constraint_list(SquashSubst,
InstanceConstraints1, InstanceConstraints),
@@ -815,14 +814,6 @@
ExistQVars, ArgTypes, ClassContext, ArgModes, Errors,
ArgTypeVars, Status, PredOrFunc).
-:- pred apply_substitution_to_var_list(list(var(T))::in,
- map(var(T), term(T))::in, list(var(T))::out) is det.
-
-apply_substitution_to_var_list(Vars0, RenameSubst, Vars) :-
- term__var_list_to_term_list(Vars0, Terms0),
- term__apply_substitution_to_list(Terms0, RenameSubst, Terms),
- term__term_list_to_var_list(Terms, Vars).
-
%---------------------------------------------------------------------------%
% Make the name of the introduced pred used to check a particular
@@ -876,20 +867,15 @@
InstanceDefn0 = hlds_instance_defn(A, B, Context,
InstanceProgConstraints, InstanceTypes, F, G, InstanceVarSet0,
Proofs0),
- varset__merge_subst(InstanceVarSet0, ClassVarSet, InstanceVarSet1,
- RenameSubst),
+ tvarset_merge_renaming(InstanceVarSet0, ClassVarSet, InstanceVarSet1,
+ Renaming),
% Make the constraints in terms of the instance variables
- apply_subst_to_prog_constraint_list(RenameSubst, ProgSuperClasses0,
- ProgSuperClasses),
+ apply_variable_renaming_to_prog_constraint_list(Renaming,
+ ProgSuperClasses0, ProgSuperClasses),
% Now handle the class variables
- map__apply_to_list(ClassVars0, RenameSubst, ClassVarTerms),
- ( term__var_list_to_term_list(ClassVars1, ClassVarTerms) ->
- ClassVars = ClassVars1
- ;
- unexpected(this_file, "ClassVarTerms are not vars.")
- ),
+ apply_variable_renaming_to_tvar_list(Renaming, ClassVars0, ClassVars),
% Calculate the bindings
map__from_corresponding_lists(ClassVars, InstanceTypes, TypeSubst),
@@ -1164,6 +1150,7 @@
!Cycles) :-
ClassDefn0 = map.lookup(!.ClassTable, ClassId),
Params = ClassDefn0 ^ class_vars,
+ Kinds = ClassDefn0 ^ class_kinds,
( set.member(ClassId, !.Visited) ->
(
find_cycle(ClassId, Path, [ClassId], Cycle)
@@ -1187,8 +1174,8 @@
;
FunDeps = [_ | _],
ClassId = class_id(ClassName, _),
- term.var_list_to_term_list(Params, ParamTerms),
- Ancestors0 = [constraint(ClassName, ParamTerms)]
+ prog_type.var_list_to_type_list(Kinds, Params, Args),
+ Ancestors0 = [constraint(ClassName, Args)]
),
Superclasses = ClassDefn0 ^ class_supers,
foldl4(find_cycles_3([ClassId | Path]), Superclasses,
@@ -1329,9 +1316,9 @@
Types = InstanceDefn ^ instance_types,
FunDep = fundep(Domain, Range),
DomainTypes = restrict_list_elements(Domain, Types),
- DomainVars = term.vars_list(DomainTypes),
+ prog_type.vars_list(DomainTypes, DomainVars),
RangeTypes = restrict_list_elements(Range, Types),
- RangeVars = term.vars_list(RangeTypes),
+ prog_type.vars_list(RangeTypes, RangeVars),
solutions((pred(V::out) is nondet :-
list.member(V, RangeVars),
\+ list.member(V, DomainVars)
@@ -1416,11 +1403,11 @@
!ModuleInfo, !FoundError, !IO) :-
TVarSetA = InstanceA ^ instance_tvarset,
TVarSetB = InstanceB ^ instance_tvarset,
- varset.merge_subst(TVarSetA, TVarSetB, _, RenameSubst),
+ tvarset_merge_renaming(TVarSetA, TVarSetB, _, Renaming),
TypesA = InstanceA ^ instance_types,
TypesB0 = InstanceB ^ instance_types,
- TypesB = term.apply_substitution_to_list(TypesB0, RenameSubst),
+ apply_variable_renaming_to_type_list(Renaming, TypesB0, TypesB),
FunDep = fundep(Domain, Range),
DomainA = restrict_list_elements(Domain, TypesA),
@@ -1431,8 +1418,8 @@
->
RangeA0 = restrict_list_elements(Range, TypesA),
RangeB0 = restrict_list_elements(Range, TypesB),
- term.apply_rec_substitution_to_list(RangeA0, Subst, RangeA),
- term.apply_rec_substitution_to_list(RangeB0, Subst, RangeB),
+ apply_rec_subst_to_type_list(Subst, RangeA0, RangeA),
+ apply_rec_subst_to_type_list(Subst, RangeB0, RangeB),
(
RangeA = RangeB
->
@@ -1534,7 +1521,7 @@
check_pred_type_ambiguities(PredInfo, !ModuleInfo, !FoundError, !IO) :-
pred_info_arg_types(PredInfo, ArgTypes),
pred_info_get_class_context(PredInfo, Constraints),
- TVars = term.vars_list(ArgTypes),
+ prog_type.vars_list(ArgTypes, TVars),
get_unbound_tvars(TVars, Constraints, !.ModuleInfo, UnboundTVars),
(
UnboundTVars = []
@@ -1570,7 +1557,7 @@
!FoundError, !IO) :-
Ctor = ctor(ExistQVars, Constraints, _, CtorArgs),
assoc_list.values(CtorArgs, ArgTypes),
- ArgTVars = term.vars_list(ArgTypes),
+ prog_type.vars_list(ArgTypes, ArgTVars),
list.filter((pred(V::in) is semidet :- list.member(V, ExistQVars)),
ArgTVars, ExistQArgTVars),
get_unbound_tvars(ExistQArgTVars, constraints([], Constraints),
@@ -1644,7 +1631,8 @@
induced_vars(Args, ArgNum, Vars) = union(Vars, NewVars) :-
Arg = list.index1_det(Args, ArgNum),
- NewVars = set.list_to_set(term.vars(Arg)).
+ prog_type.vars(Arg, ArgVars),
+ NewVars = set.list_to_set(ArgVars).
:- func fundeps_closure(induced_fundeps, set(tvar)) = set(tvar).
Index: compiler/clause_to_proc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/clause_to_proc.m,v
retrieving revision 1.54
diff -u -r1.54 clause_to_proc.m
--- compiler/clause_to_proc.m 30 Aug 2005 04:11:46 -0000 1.54
+++ compiler/clause_to_proc.m 3 Sep 2005 04:41:25 -0000
@@ -439,7 +439,7 @@
introduce_exists_casts_for_arg(ModuleInfo, Subn, ExternalType, ArgMode,
HeadVar0, HeadVar, !VarSet, !VarTypes, !ExtraGoals) :-
- term__apply_rec_substitution(ExternalType, Subn, InternalType),
+ apply_rec_subst_to_type(Subn, ExternalType, InternalType),
(
% Add an exists_cast for the head variable if its type
% inside the procedure is different from its type at the
@@ -483,7 +483,7 @@
% respective arguments.
%
map__lookup(ExternalTypes, Var0, ExternalType),
- term__apply_rec_substitution(ExternalType, Subn, InternalType),
+ apply_rec_subst_to_type(Subn, ExternalType, InternalType),
svmap__det_update(Var0, InternalType, !VarTypes),
% Create the exists_cast goal.
@@ -501,7 +501,7 @@
rtti_varmaps_var_info(!.RttiVarMaps, Var0, VarInfo),
(
VarInfo = type_info_var(TypeInfoType0),
- term__apply_rec_substitution(TypeInfoType0, Subn, TypeInfoType),
+ apply_rec_subst_to_type(Subn, TypeInfoType0, TypeInfoType),
rtti_set_type_info_type(Var0, TypeInfoType, !RttiVarMaps),
rtti_det_insert_type_info_type(Var, TypeInfoType0, !RttiVarMaps)
;
Index: compiler/common.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/common.m,v
retrieving revision 1.81
diff -u -r1.81 common.m
--- compiler/common.m 27 Aug 2005 09:41:54 -0000 1.81
+++ compiler/common.m 11 Sep 2005 15:26:32 -0000
@@ -780,13 +780,27 @@
:- pred common__types_match_exactly((type)::in, (type)::in) is semidet.
-common__types_match_exactly(term__variable(Var), term__variable(Var)).
-common__types_match_exactly(Type1, Type2) :-
- % XXX should succeed for embedded constraints
- type_to_ctor_and_args(Type1, TypeCtor1, Args1),
- type_to_ctor_and_args(Type2, TypeCtor2, Args2),
- TypeCtor1 = TypeCtor2,
- common__types_match_exactly_list(Args1, Args2).
+common__types_match_exactly(variable(TVar, _), variable(TVar, _)).
+common__types_match_exactly(defined(Name, As, _), defined(Name, Bs, _)) :-
+ common__types_match_exactly_list(As, Bs).
+common__types_match_exactly(builtin(BuiltinType), builtin(BuiltinType)).
+common__types_match_exactly(higher_order(As, AR, P, E),
+ higher_order(Bs, BR, P, E)) :-
+ common__types_match_exactly_list(As, Bs),
+ (
+ AR = yes(A),
+ BR = yes(B),
+ common__types_match_exactly(A, B)
+ ;
+ AR = no,
+ BR = no
+ ).
+common__types_match_exactly(tuple(As, _), tuple(Bs, _)) :-
+ common__types_match_exactly_list(As, Bs).
+common__types_match_exactly(apply_n(TVar, As, _), apply_n(TVar, Bs, _)) :-
+ common__types_match_exactly_list(As, Bs).
+common__types_match_exactly(kinded(_, _), _) :-
+ unexpected(this_file, "kind annotation").
:- pred common__types_match_exactly_list(list(type)::in, list(type)::in)
is semidet.
Index: compiler/continuation_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/continuation_info.m,v
retrieving revision 1.60
diff -u -r1.60 continuation_info.m
--- compiler/continuation_info.m 22 Jul 2005 12:31:52 -0000 1.60
+++ compiler/continuation_info.m 11 Sep 2005 14:59:47 -0000
@@ -739,7 +739,7 @@
LldsInst = partial(Inst)
),
LiveValueType = var(Var, Name, Type, LldsInst),
- type_util__real_vars(Type, TypeVars).
+ prog_type__vars(Type, TypeVars).
%---------------------------------------------------------------------------%
@@ -783,7 +783,7 @@
Layout = closure_arg_info(Type, Inst),
set__singleton_set(Locations, reg(r, ArgLoc)),
map__det_insert(VarLocs0, Var, Locations, VarLocs1),
- type_util__real_vars(Type, VarTypeVars),
+ prog_type__vars(Type, VarTypeVars),
set__insert_list(TypeVars0, VarTypeVars, TypeVars1),
continuation_info__build_closure_info(Vars, Types, ArgInfos, Layouts,
InstMap, VarLocs1, VarLocs, TypeVars1, TypeVars).
@@ -850,7 +850,7 @@
TypeVars0, TypeVars) :-
map__lookup(VarTypes, Var, Type),
ArgLayout = table_arg_info(Var, SlotNum, Type),
- type_util__real_vars(Type, VarTypeVars),
+ prog_type__vars(Type, VarTypeVars),
set__insert_list(TypeVars0, VarTypeVars, TypeVars1),
continuation_info__build_table_arg_info(VarTypes,
NumberedVars, ArgLayouts, TypeVars1, TypeVars).
Index: compiler/cse_detection.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/cse_detection.m,v
retrieving revision 1.85
diff -u -r1.85 cse_detection.m
--- compiler/cse_detection.m 30 Aug 2005 04:11:47 -0000 1.85
+++ compiler/cse_detection.m 3 Sep 2005 06:08:51 -0000
@@ -778,25 +778,25 @@
% merged.
%
list__foldl(find_merged_tvars(RttiVarMaps0, LaterOldNewMap, NewTvarMap),
- TvarsList, map__init, TSubst),
+ TvarsList, map__init, Renaming),
% Apply the full old->new map and the type substitution to the
% rtti_varmaps, and apply the type substitution to the vartypes.
%
list__append(FirstOldNew, LaterOldNew, OldNew),
map__from_assoc_list(OldNew, OldNewMap),
- apply_substitutions_to_rtti_varmaps(TSubst, map__init, OldNewMap,
+ apply_substitutions_to_rtti_varmaps(Renaming, map__init, OldNewMap,
RttiVarMaps0, RttiVarMaps),
- map__map_values(apply_tvar_rename(TSubst), VarTypes0, VarTypes),
+ map__map_values(apply_tvar_rename(Renaming), VarTypes0, VarTypes),
!:CseInfo = !.CseInfo ^ rtti_varmaps := RttiVarMaps,
!:CseInfo = !.CseInfo ^ vartypes := VarTypes.
-:- pred apply_tvar_rename(tsubst::in, prog_var::in, (type)::in, (type)::out)
- is det.
+:- pred apply_tvar_rename(tvar_renaming::in, prog_var::in,
+ (type)::in, (type)::out) is det.
-apply_tvar_rename(TSubst, _Var, Type0, Type) :-
- Type = term__apply_substitution(Type0, TSubst).
+apply_tvar_rename(Renaming, _Var, Type0, Type) :-
+ apply_variable_renaming_to_type(Renaming, Type0, Type).
:- pred find_type_info_locn_tvar_map(rtti_varmaps::in,
map(prog_var, prog_var)::in, tvar::in,
@@ -813,10 +813,10 @@
).
:- pred find_merged_tvars(rtti_varmaps::in, map(prog_var, prog_var)::in,
- map(type_info_locn, tvar)::in, tvar::in, tsubst::in, tsubst::out)
- is det.
+ map(type_info_locn, tvar)::in, tvar::in,
+ tvar_renaming::in, tvar_renaming::out) is det.
-find_merged_tvars(RttiVarMaps, LaterOldNewMap, NewTvarMap, Tvar, !TSubst) :-
+find_merged_tvars(RttiVarMaps, LaterOldNewMap, NewTvarMap, Tvar, !Renaming) :-
rtti_lookup_type_info_locn(RttiVarMaps, Tvar, TypeInfoLocn0),
type_info_locn_var(TypeInfoLocn0, Old),
( map__search(LaterOldNewMap, Old, New) ->
@@ -825,7 +825,7 @@
( NewTvar = Tvar ->
true
;
- svmap__det_insert(Tvar, term__variable(NewTvar), !TSubst)
+ svmap__det_insert(Tvar, NewTvar, !Renaming)
)
;
true
Index: compiler/deforest.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/deforest.m,v
retrieving revision 1.50
diff -u -r1.50 deforest.m
--- compiler/deforest.m 30 Aug 2005 04:11:48 -0000 1.50
+++ compiler/deforest.m 8 Sep 2005 05:57:23 -0000
@@ -70,6 +70,7 @@
:- import_module parse_tree__error_util.
:- import_module parse_tree__prog_data.
:- import_module parse_tree__prog_out.
+:- import_module parse_tree__prog_type.
:- import_module parse_tree__prog_util.
:- import_module transform_hlds__dependency_graph.
:- import_module transform_hlds__inlining.
@@ -1217,10 +1218,10 @@
pred_info_typevarset(PredInfo0, TVarSet0),
% Rename the argument types using the current pred's tvarset.
- varset__merge_subst(TVarSet0, CalledTVarSet, TVarSet, TypeRenaming),
+ tvarset_merge_renaming(TVarSet0, CalledTVarSet, TVarSet, TypeRenaming),
pred_info_set_typevarset(TVarSet, PredInfo0, PredInfo),
pd_info_set_pred_info(PredInfo, !PDInfo),
- term__apply_substitution_to_list(ArgTypes0, TypeRenaming, ArgTypes1),
+ apply_variable_renaming_to_type_list(TypeRenaming, ArgTypes0, ArgTypes1),
deforest__create_deforest_call_args(OldArgs, ArgTypes1, Renaming,
TypeSubn, Args, VarSet0, VarSet, VarTypes0, VarTypes),
@@ -1258,7 +1259,7 @@
;
% The variable is local to the call. Create a fresh variable.
varset__new_var(!.VarSet, Arg, !:VarSet),
- term__apply_substitution(ArgType, TypeSubn, SubnArgType),
+ apply_subst_to_type(TypeSubn, ArgType, SubnArgType),
map__det_insert(!.VarTypes, Arg, SubnArgType, !:VarTypes)
),
deforest__create_deforest_call_args(OldArgs, ArgTypes, Renaming,
Index: compiler/equiv_type.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/equiv_type.m,v
retrieving revision 1.48
diff -u -r1.48 equiv_type.m
--- compiler/equiv_type.m 5 Sep 2005 03:45:54 -0000 1.48
+++ compiler/equiv_type.m 7 Sep 2005 10:31:51 -0000
@@ -627,61 +627,133 @@
tvarset::in, tvarset::out, equiv_type_info::in, equiv_type_info::out)
is det.
-equiv_type__replace_in_type_2(_EqvMap, _Seen,
- term__variable(V), term__variable(V), no, no, !VarSet, !Info).
equiv_type__replace_in_type_2(EqvMap, TypeCtorsAlreadyExpanded, Type0, Type,
Changed, Circ, !VarSet, !Info) :-
- Type0 = term__functor(_, _, _),
- ( type_to_ctor_and_args(Type0, EqvTypeCtor, TArgs0) ->
- equiv_type__replace_in_type_list_2(EqvMap,
- TypeCtorsAlreadyExpanded, TArgs0, TArgs1,
- ArgsChanged, no, Circ0, !VarSet, !Info),
-
- ( list__member(EqvTypeCtor, TypeCtorsAlreadyExpanded) ->
- Circ1 = yes
+ (
+ Type0 = variable(Var, Kind),
+ Type = variable(Var, Kind),
+ Changed = no,
+ Circ = no
+ ;
+ Type0 = defined(SymName, TArgs0, Kind),
+ equiv_type__replace_in_type_list_2(EqvMap, TypeCtorsAlreadyExpanded,
+ TArgs0, TArgs, ArgsChanged, no, Circ0, !VarSet, !Info),
+ Arity = list__length(TArgs),
+ TypeCtor = SymName - Arity,
+ equiv_type__replace_type_ctor(EqvMap, TypeCtorsAlreadyExpanded,
+ Type0, TypeCtor, TArgs, Kind, Type, ArgsChanged, Changed,
+ Circ0, Circ, !VarSet, !Info)
+ ;
+ Type0 = builtin(_),
+ Type = Type0,
+ Changed = no,
+ Circ = no
+ ;
+ Type0 = higher_order(Args0, MaybeRet0, Purity, EvalMethod),
+ equiv_type__replace_in_type_list_2(EqvMap, TypeCtorsAlreadyExpanded,
+ Args0, Args, ArgsChanged, no, ArgsCirc, !VarSet, !Info),
+ (
+ MaybeRet0 = yes(Ret0),
+ equiv_type__replace_in_type_2(EqvMap, TypeCtorsAlreadyExpanded,
+ Ret0, Ret, RetChanged, RetCirc, !VarSet, !Info),
+ MaybeRet = yes(Ret),
+ Changed = bool__or(ArgsChanged, RetChanged),
+ Circ = bool__or(ArgsCirc, RetCirc)
;
- Circ1 = no
+ MaybeRet0 = no,
+ MaybeRet = no,
+ Changed = ArgsChanged,
+ Circ = ArgsCirc
),
(
- map__search(EqvMap, EqvTypeCtor,
- eqv_type_body(EqvVarSet, Args0, Body0)),
- %
- % Don't merge in the variable names from the type declaration
- % to avoid creating multiple variables with the same name so that
- % `varset__create_name_var_map' can be used on the resulting
- % tvarset. make_hlds uses `varset__create_name_var_map' to match up
- % type variables in `:- pragma type_spec' declarations and explicit
- % type qualifications with the type variables in the predicate's
- % declaration.
- %
- varset__merge_without_names(!.VarSet, EqvVarSet,
- [Body0 | Args0], !:VarSet, [Body | Args]),
- Circ0 = no,
- Circ1 = no
- ->
Changed = yes,
- equiv_type__record_expanded_item(item_id(type, EqvTypeCtor),
- !Info),
- term__term_list_to_var_list(Args, ArgVars),
- term__substitute_corresponding(ArgVars, TArgs1, Body, Type1),
- equiv_type__replace_in_type_2(EqvMap,
- [EqvTypeCtor | TypeCtorsAlreadyExpanded],
- Type1, Type, _, Circ, !VarSet, !Info)
+ Type = higher_order(Args, MaybeRet, Purity, EvalMethod)
;
- ArgsChanged = yes
- ->
+ Changed = no,
+ Type = Type0
+ )
+ ;
+ Type0 = tuple(Args0, Kind),
+ equiv_type__replace_in_type_list_2(EqvMap, TypeCtorsAlreadyExpanded,
+ Args0, Args, Changed, no, Circ, !VarSet, !Info),
+ (
Changed = yes,
- construct_type(EqvTypeCtor, TArgs1, Type),
- bool__or(Circ0, Circ1, Circ)
+ Type = tuple(Args, Kind)
;
Changed = no,
- Type = Type0,
- bool__or(Circ0, Circ1, Circ)
+ Type = Type0
)
;
- Changed = no,
- Type = Type0,
- Circ = no
+ Type0 = apply_n(Var, Args0, Kind),
+ equiv_type__replace_in_type_list_2(EqvMap, TypeCtorsAlreadyExpanded,
+ Args0, Args, Changed, no, Circ, !VarSet, !Info),
+ (
+ Changed = yes,
+ Type = apply_n(Var, Args, Kind)
+ ;
+ Changed = no,
+ Type = Type0
+ )
+ ;
+ Type0 = kinded(RawType0, Kind),
+ equiv_type__replace_in_type_2(EqvMap, TypeCtorsAlreadyExpanded,
+ RawType0, RawType, Changed, Circ, !VarSet, !Info),
+ (
+ Changed = yes,
+ Type = kinded(RawType, Kind)
+ ;
+ Changed = no,
+ Type = Type0
+ )
+ ).
+
+:- pred equiv_type__replace_type_ctor(eqv_map::in, list(type_ctor)::in,
+ (type)::in, type_ctor::in, list(type)::in, kind::in, (type)::out,
+ bool::in, bool::out, bool::in, bool::out, tvarset::in, tvarset::out,
+ equiv_type_info::in, equiv_type_info::out) is det.
+
+equiv_type__replace_type_ctor(EqvMap, TypeCtorsAlreadyExpanded, Type0,
+ TypeCtor, TArgs, Kind, Type, !Changed, !Circ, !VarSet, !Info) :-
+ ( list__member(TypeCtor, TypeCtorsAlreadyExpanded) ->
+ AlreadyExpanded = yes
+ ;
+ AlreadyExpanded = no
+ ),
+ (
+ map__search(EqvMap, TypeCtor, eqv_type_body(EqvVarSet, Args0, Body0)),
+ %
+ % Don't merge in the variable names from the type declaration to
+ % avoid creating multiple variables with the same name so that
+ % `varset__create_name_var_map' can be used on the resulting
+ % tvarset. make_hlds uses `varset__create_name_var_map' to match
+ % up type variables in `:- pragma type_spec' declarations and
+ % explicit type qualifications with the type variables in the
+ % predicate's declaration.
+ %
+ tvarset_merge_renaming_without_names(!.VarSet, EqvVarSet, !:VarSet,
+ Renaming),
+ !.Circ = no,
+ AlreadyExpanded = no
+ ->
+ !:Changed = yes,
+ map__apply_to_list(Args0, Renaming, Args),
+ apply_variable_renaming_to_type(Renaming, Body0, Body1),
+ equiv_type__record_expanded_item(item_id(type, TypeCtor), !Info),
+ map__from_corresponding_lists(Args, TArgs, Subst),
+ apply_subst_to_type(Subst, Body1, Body),
+ equiv_type__replace_in_type_2(EqvMap,
+ [TypeCtor | TypeCtorsAlreadyExpanded], Body, Type, _, !:Circ,
+ !VarSet, !Info)
+ ;
+ (
+ !.Changed = yes,
+ TypeCtor = SymName - _Arity,
+ Type = defined(SymName, TArgs, Kind)
+ ;
+ !.Changed = no,
+ Type = Type0
+ ),
+ bool__or(AlreadyExpanded, !Circ)
).
:- pred equiv_type__replace_in_inst((inst)::in, eqv_inst_map::in, (inst)::out,
Index: compiler/export.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/export.m,v
retrieving revision 1.87
diff -u -r1.87 export.m
--- compiler/export.m 29 Aug 2005 03:22:18 -0000 1.87
+++ compiler/export.m 2 Sep 2005 15:54:26 -0000
@@ -592,32 +592,36 @@
convert_type_to_mercury(Rval, Type, ConvertedRval) :-
(
- Type = term__functor(term__atom("string"), [], _)
+ Type = builtin(BuiltinType)
->
- string__append("(MR_Word) ", Rval, ConvertedRval)
- ;
- Type = term__functor(term__atom("float"), [], _)
- ->
- string__append_list(["MR_float_to_word(", Rval, ")" ],
- ConvertedRval)
- ;
- Type = term__functor(term__atom("character"), [], _)
- ->
- % We need to explicitly cast to UnsignedChar
- % to avoid problems with C compilers for which `char'
- % is signed.
- string__append("(UnsignedChar) ", Rval, ConvertedRval)
+ (
+ BuiltinType = string,
+ string__append("(MR_Word) ", Rval, ConvertedRval)
+ ;
+ BuiltinType = float,
+ string__append_list(["MR_float_to_word(", Rval, ")" ],
+ ConvertedRval)
+ ;
+ BuiltinType = character,
+ % We need to explicitly cast to UnsignedChar
+ % to avoid problems with C compilers for which `char'
+ % is signed.
+ string__append("(UnsignedChar) ", Rval, ConvertedRval)
+ ;
+ BuiltinType = int,
+ ConvertedRval = Rval
+ )
;
ConvertedRval = Rval
).
convert_type_from_mercury(Rval, Type, ConvertedRval) :-
(
- Type = term__functor(term__atom("string"), [], _)
+ Type = builtin(string)
->
string__append("(MR_String) ", Rval, ConvertedRval)
;
- Type = term__functor(term__atom("float"), [], _)
+ Type = builtin(float)
->
string__append_list(["MR_word_to_float(", Rval, ")" ],
ConvertedRval)
Index: compiler/fact_table.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/fact_table.m,v
retrieving revision 1.61
diff -u -r1.61 fact_table.m
--- compiler/fact_table.m 24 Mar 2005 02:00:25 -0000 1.61
+++ compiler/fact_table.m 6 Sep 2005 14:19:37 -0000
@@ -503,18 +503,19 @@
% the right type for this argument.
(
Functor = term__string(_),
- RequiredType = "string"
+ RequiredType = yes(string)
;
Functor = term__integer(_),
- RequiredType = "int"
+ RequiredType = yes(int)
;
Functor = term__float(_),
- RequiredType = "float"
+ RequiredType = yes(float)
;
Functor = term__atom(_),
- RequiredType = ""
+ RequiredType = no
),
- ( RequiredType = "" ->
+ (
+ RequiredType = no,
(
Items = [_ | _],
Msg = "Error: compound types are not " ++
@@ -527,11 +528,10 @@
add_error_report(Context, [words(Msg)], !Errors),
Result = error
;
+ RequiredType = yes(BuiltinType),
(
Types0 = [Type | Types],
- Type = term__functor(term__atom(TypeName),
- [], _),
- TypeName = RequiredType
+ Type = builtin(BuiltinType)
->
check_fact_type_and_mode(Types, Terms, ArgNum,
PredOrFunc, Context0, Result, !Errors)
@@ -694,13 +694,13 @@
Info = fact_arg_info(Type, _IsInput, IsOutput),
(
(
- Type = term__functor(term__atom("string"), [], _),
+ Type = builtin(string),
TypeStr = "MR_ConstString"
;
- Type = term__functor(term__atom("int"), [], _),
+ Type = builtin(int),
TypeStr = "MR_Integer"
;
- Type = term__functor(term__atom("float"), [], _),
+ Type = builtin(float),
TypeStr = "MR_Float"
)
->
@@ -1881,20 +1881,20 @@
is det.
convert_key_string_to_arg(ArgString, Type, Arg) :-
- ( Type = term__functor(term__atom("int"), [], _) ->
+ ( Type = builtin(int) ->
( string__base_string_to_int(36, ArgString, I) ->
Arg = term__integer(I)
;
error("convert_key_string_to_arg: " ++
"could not convert string to int")
)
- ; Type = term__functor(term__atom("string"), [], _) ->
+ ; Type = builtin(string) ->
string__to_char_list(ArgString, Cs0),
remove_sort_file_escapes(Cs0, [], Cs1),
list__reverse(Cs1, Cs),
string__from_char_list(Cs, S),
Arg = term__string(S)
- ; Type = term__functor(term__atom("float"), [], _) ->
+ ; Type = builtin(float) ->
( string__to_float(ArgString, F) ->
Arg = term__float(F)
;
@@ -2603,15 +2603,15 @@
FactTableSize, C_Code) :-
NextArgNum = ArgNum + 1,
( mode_is_fully_input(ModuleInfo, Mode) ->
- ( Type = term__functor(term__atom("int"), [], _) ->
+ ( Type = builtin(int) ->
generate_hash_int_code(Name, LabelName, LabelNum,
PredName, PragmaVars, Types, ModuleInfo,
NextArgNum, FactTableSize, C_Code0)
- ; Type = term__functor(term__atom("float"), [], _) ->
+ ; Type = builtin(float) ->
generate_hash_float_code(Name, LabelName, LabelNum,
PredName, PragmaVars, Types, ModuleInfo,
NextArgNum, FactTableSize, C_Code0)
- ; Type = term__functor(term__atom("string"), [], _) ->
+ ; Type = builtin(string) ->
generate_hash_string_code(Name, LabelName, LabelNum,
PredName, PragmaVars, Types, ModuleInfo,
NextArgNum, FactTableSize, C_Code0)
@@ -2804,7 +2804,7 @@
string__format(TableEntryTemplate, [s(PredName),
i(FactTableSize), i(FactTableSize), i(ArgNum)],
TableEntry),
- ( Type = term__functor(term__atom("string"), [], _) ->
+ ( Type = builtin(string) ->
mode_get_insts(ModuleInfo, Mode, _, FinalInst),
( inst_is_not_partly_unique(ModuleInfo, FinalInst) ->
% Cast MR_ConstString -> MR_Word -> MR_String
@@ -3114,7 +3114,7 @@
FactTableSize, CondCode) :-
PragmaVar = pragma_var(_, Name, Mode),
( mode_is_fully_input(ModuleInfo, Mode) ->
- ( Type = term__functor(term__atom("string"), [], _) ->
+ ( Type = builtin(string) ->
Template =
"strcmp(%s[ind/%d][ind%%%d].V_%d, %s) != 0\n"
;
Index: compiler/foreign.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/foreign.m,v
retrieving revision 1.48
diff -u -r1.48 foreign.m
--- compiler/foreign.m 24 Mar 2005 13:33:32 -0000 1.48
+++ compiler/foreign.m 11 Sep 2005 11:06:31 -0000
@@ -645,14 +645,20 @@
% XXX does this do the right thing for high level data?
to_type_string(c, mercury(Type)) = Result :-
- ( Type = term__functor(term__atom("int"), [], _) ->
- Result = "MR_Integer"
- ; Type = term__functor(term__atom("float"), [], _) ->
- Result = "MR_Float"
- ; Type = term__functor(term__atom("string"), [], _) ->
- Result = "MR_String"
- ; Type = term__functor(term__atom("character"), [], _) ->
- Result = "MR_Char"
+ ( Type = builtin(BuiltinType) ->
+ (
+ BuiltinType = int,
+ Result = "MR_Integer"
+ ;
+ BuiltinType = float,
+ Result = "MR_Float"
+ ;
+ BuiltinType = string,
+ Result = "MR_String"
+ ;
+ BuiltinType = character,
+ Result = "MR_Char"
+ )
;
Result = "MR_Word"
).
@@ -660,7 +666,7 @@
sorry(this_file, "to_type_string for csharp").
to_type_string(managed_cplusplus, mercury(Type)) = TypeString :-
(
- prog_type__var(Type, _)
+ Type = variable(_, _)
->
TypeString = "MR_Box"
;
@@ -669,14 +675,20 @@
to_type_string(il, mercury(_Type)) = _ :-
sorry(this_file, "to_type_string for il").
to_type_string(java, mercury(Type)) = Result :-
- ( Type = term__functor(term__atom("int"), [], _) ->
- Result = "int"
- ; Type = term__functor(term__atom("float"), [], _) ->
- Result = "double"
- ; Type = term__functor(term__atom("string"), [], _) ->
- Result = "java.lang.String"
- ; Type = term__functor(term__atom("character"), [], _) ->
- Result = "char"
+ ( Type = builtin(BuiltinType) ->
+ (
+ BuiltinType = int,
+ Result = "int"
+ ;
+ BuiltinType = float,
+ Result = "double"
+ ;
+ BuiltinType = string,
+ Result = "java.lang.String"
+ ;
+ BuiltinType = character,
+ Result = "char"
+ )
;
Result = "java.lang.Object"
).
Index: compiler/goal_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/goal_util.m,v
retrieving revision 1.112
diff -u -r1.112 goal_util.m
--- compiler/goal_util.m 30 Aug 2005 04:11:50 -0000 1.112
+++ compiler/goal_util.m 6 Sep 2005 07:40:59 -0000
@@ -308,6 +308,7 @@
:- import_module parse_tree__error_util.
:- import_module parse_tree__prog_data.
:- import_module parse_tree__prog_mode.
+:- import_module parse_tree__prog_type.
:- import_module parse_tree__prog_util.
:- import_module int.
@@ -914,7 +915,7 @@
%
set__to_sorted_list(NonLocals, NonLocalsList),
map__apply_to_list(NonLocalsList, VarTypes, NonLocalsTypes),
- term__vars_list(NonLocalsTypes, NonLocalTypeVarsList0),
+ prog_type__vars_list(NonLocalsTypes, NonLocalTypeVarsList0),
list__append(ExistQVars, NonLocalTypeVarsList0, NonLocalTypeVarsList),
set__list_to_set(NonLocalTypeVarsList, NonLocalTypeVars),
@@ -938,7 +939,7 @@
rtti_varmaps_reusable_constraints(RttiVarMaps, Constraints),
list__member(Constraint, Constraints),
Constraint = constraint(_Name, ArgTypes),
- term__contains_var_list(ArgTypes, TypeVar),
+ type_list_contains_var(ArgTypes, TypeVar),
set__member(TypeVar, NonLocalTypeVars),
% We found a constraint that is non-local. Include
Index: compiler/hhf.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hhf.m,v
retrieving revision 1.8
diff -u -r1.8 hhf.m
--- compiler/hhf.m 30 Aug 2005 04:11:51 -0000 1.8
+++ compiler/hhf.m 12 Sep 2005 02:42:59 -0000
@@ -423,14 +423,35 @@
:- pred same_type((type)::in, (type)::in) is semidet.
-same_type(term__variable(_), term__variable(_)).
-same_type(term__functor(Const, ArgsA, _), term__functor(Const, ArgsB, _)) :-
- list__same_length(ArgsA, ArgsB),
- all [A, B] (
- corresponding_members(ArgsA, ArgsB, A, B)
- =>
- same_type(A, B)
- ).
+same_type(A0, B0) :-
+ A = strip_kind_annotation(A0),
+ B = strip_kind_annotation(B0),
+ same_type_2(A, B).
+
+:- pred same_type_2((type)::in, (type)::in) is semidet.
+
+same_type_2(variable(_, _), variable(_, _)).
+same_type_2(defined(Name, ArgsA, _), defined(Name, ArgsB, _)) :-
+ same_type_list(ArgsA, ArgsB).
+same_type_2(builtin(BuiltinType), builtin(BuiltinType)).
+same_type_2(higher_order(ArgsA, no, Purity, EvalMethod),
+ higher_order(ArgsB, no, Purity, EvalMethod)) :-
+ same_type_list(ArgsA, ArgsB).
+same_type_2(higher_order(ArgsA, yes(RetA), Purity, EvalMethod),
+ higher_order(ArgsB, yes(RetB), Purity, EvalMethod)) :-
+ same_type_list(ArgsA, ArgsB),
+ same_type(RetA, RetB).
+same_type_2(tuple(ArgsA, _), tuple(ArgsB, _)) :-
+ same_type_list(ArgsA, ArgsB).
+same_type_2(apply_n(_, ArgsA, _), apply_n(_, ArgsB, _)) :-
+ same_type_list(ArgsA, ArgsB).
+
+:- pred same_type_list(list(type)::in, list(type)::in) is semidet.
+
+same_type_list([], []).
+same_type_list([A | As], [B | Bs]) :-
+ same_type(A, B),
+ same_type_list(As, Bs).
%------------------------------------------------------------------------%
Index: compiler/higher_order.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/higher_order.m,v
retrieving revision 1.134
diff -u -r1.134 higher_order.m
--- compiler/higher_order.m 30 Aug 2005 04:11:51 -0000 1.134
+++ compiler/higher_order.m 11 Sep 2005 11:28:10 -0000
@@ -843,7 +843,7 @@
InstanceDefn = hlds_instance_defn(_, _, _,
InstanceConstraints, InstanceTypes0, _,
yes(ClassInterface), _, _),
- term.vars_list(InstanceTypes0, InstanceTvars),
+ prog_type.vars_list(InstanceTypes0, InstanceTvars),
get_unconstrained_tvars(InstanceTvars,
InstanceConstraints, UnconstrainedTVars),
NumArgsToExtract = list.length(InstanceConstraints)
@@ -954,19 +954,21 @@
TVarSet0, TVarSet) :-
Instance = hlds_instance_defn(_, _, _, Constraints0,
InstanceTypes0, _, _, InstanceTVarSet, _),
- varset.merge_subst(TVarSet0, InstanceTVarSet, TVarSet, RenameSubst),
- term.apply_substitution_to_list(InstanceTypes0, RenameSubst,
+ tvarset_merge_renaming(TVarSet0, InstanceTVarSet, TVarSet, Renaming),
+ apply_variable_renaming_to_type_list(Renaming, InstanceTypes0,
InstanceTypes),
- apply_subst_to_prog_constraint_list(RenameSubst,
- Constraints0, Constraints1),
- term.vars_list(InstanceTypes, InstanceTVars),
+ apply_variable_renaming_to_prog_constraint_list(Renaming, Constraints0,
+ Constraints1),
+ prog_type.vars_list(InstanceTypes, InstanceTVars),
get_unconstrained_tvars(InstanceTVars, Constraints1, UnconstrainedTVars0),
type_list_subsumes(InstanceTypes, ClassTypes, Subst),
apply_rec_subst_to_prog_constraint_list(Subst, Constraints1, Constraints),
- term.var_list_to_term_list(UnconstrainedTVars0, UnconstrainedTVarTypes0),
- term.apply_rec_substitution_to_list(UnconstrainedTVarTypes0, Subst,
+ % XXX kind inference:
+ % we assume all tvars have kind `star'.
+ map__init(KindMap),
+ apply_rec_subst_to_tvar_list(KindMap, Subst, UnconstrainedTVars0,
UnconstrainedTVarTypes).
% Build calls to
@@ -1430,15 +1432,15 @@
CallerHeadTypeParams, ArgTypes, CalleeTVarSet,
CalleeExistQVars, CalleeArgTypes0) :-
CalleeUnivConstraints0 = [_ | _],
- varset.merge_subst(TVarSet0, CalleeTVarSet, TVarSet, TypeRenaming),
- term.apply_substitution_to_list(CalleeArgTypes0, TypeRenaming,
+ tvarset_merge_renaming(TVarSet0, CalleeTVarSet, TVarSet, TypeRenaming),
+ apply_variable_renaming_to_type_list(TypeRenaming, CalleeArgTypes0,
CalleeArgTypes1),
%
% Substitute the types in the callee's class constraints.
%
inlining.get_type_substitution(CalleeArgTypes1, ArgTypes,
CallerHeadTypeParams, CalleeExistQVars, TypeSubn),
- apply_subst_to_prog_constraint_list(TypeRenaming,
+ apply_variable_renaming_to_prog_constraint_list(TypeRenaming,
CalleeUnivConstraints0, CalleeUnivConstraints1),
apply_rec_subst_to_prog_constraint_list(TypeSubn,
CalleeUnivConstraints1, CalleeUnivConstraints),
@@ -1588,7 +1590,7 @@
ProcInfo = Info ^ proc_info,
proc_info_vartypes(ProcInfo, VarTypes),
map.apply_to_list(Args, VarTypes, ArgTypes),
- term.vars_list(ArgTypes, AllTVars),
+ prog_type.vars_list(ArgTypes, AllTVars),
(
AllTVars = [],
ExtraTypeInfoTVars = []
@@ -1608,7 +1610,7 @@
rtti_varmaps_var_info(RttiVarMaps, Var, VarInfo),
(
VarInfo = type_info_var(Type),
- ( prog_type.var(Type, TVar) ->
+ ( Type = variable(TVar, _) ->
!:TVars = [TVar | !.TVars]
;
true
@@ -1620,7 +1622,7 @@
% for.
list.filter_map(
(pred(ClassArgType::in, ClassTVar::out) is semidet :-
- prog_type.var(ClassArgType, ClassTVar)
+ ClassArgType = variable(ClassTVar, _)
), ClassArgTypes, ClassTVars),
list.append(ClassTVars, !TVars)
;
@@ -1723,19 +1725,22 @@
),
% Rename apart type variables.
- varset.merge_subst(RequestTVarSet, VersionTVarSet, _, TVarSubn),
- term.apply_substitution_to_list(VersionArgTypes0, TVarSubn,
+ tvarset_merge_renaming(RequestTVarSet, VersionTVarSet, _, TVarRenaming),
+ apply_variable_renaming_to_type_list(TVarRenaming, VersionArgTypes0,
VersionArgTypes),
type_list_subsumes(VersionArgTypes, CallArgTypes, TypeSubn),
%
% Work out the types of the extra type-info variables that
% need to be passed to the specialized version.
%
- term.var_list_to_term_list(VersionExtraTypeInfoTVars,
- VersionExtraTypeInfoTypes),
- term.apply_substitution_to_list(VersionExtraTypeInfoTypes,
- TVarSubn, ExtraTypeInfoTypes0),
- term.apply_rec_substitution_to_list(ExtraTypeInfoTypes0, TypeSubn,
+ % XXX kind inference:
+ % we assume all tvars have kind `star'
+ map__init(KindMap),
+ apply_variable_renaming_to_tvar_kind_map(TVarRenaming, KindMap,
+ RenamedKindMap),
+ apply_variable_renaming_to_tvar_list(TVarRenaming,
+ VersionExtraTypeInfoTVars, ExtraTypeInfoTVars0),
+ apply_rec_subst_to_tvar_list(RenamedKindMap, TypeSubn, ExtraTypeInfoTVars0,
ExtraTypeInfoTypes),
get_extra_arguments(HigherOrderArgs, Args0, Args).
@@ -1922,7 +1927,7 @@
special_pred_name_arity(SpecialId, PredName, PredArity),
special_pred_get_type(SpecialId, Args, Var),
map.lookup(VarTypes, Var, SpecialPredType),
- SpecialPredType \= term.variable(_),
+ SpecialPredType \= variable(_, _),
%
% Don't specialize tuple types -- the code to unify them only exists
% in the generic unification routine in the runtime.
@@ -1931,7 +1936,7 @@
% be worth inlining complicated unifications of small tuples (or any
% other small type).
%
- \+ type_is_tuple(SpecialPredType, _),
+ SpecialPredType \= tuple(_, _),
Args = [TypeInfoVar | SpecialPredArgs],
map.search(PredVars, TypeInfoVar,
@@ -2697,6 +2702,7 @@
proc_info_argmodes(!.NewProcInfo, ArgModes0),
pred_info_get_exist_quant_tvars(!.NewPredInfo, ExistQVars0),
pred_info_typevarset(!.NewPredInfo, TypeVarSet0),
+ pred_info_tvar_kinds(!.NewPredInfo, KindMap0),
pred_info_arg_types(!.NewPredInfo, OriginalArgTypes0),
CallerPredProcId = proc(CallerPredId, _),
@@ -2707,34 +2713,36 @@
% Specialize the types of the called procedure as for inlining.
%
proc_info_vartypes(!.NewProcInfo, VarTypes0),
- varset.merge_subst(CallerTypeVarSet, TypeVarSet0,
- TypeVarSet, TypeRenaming),
- apply_substitution_to_type_map(VarTypes0, TypeRenaming, VarTypes1),
- term.apply_substitution_to_list(OriginalArgTypes0,
- TypeRenaming, OriginalArgTypes1),
+ tvarset_merge_renaming(CallerTypeVarSet, TypeVarSet0, TypeVarSet,
+ TypeRenaming),
+ apply_variable_renaming_to_tvar_kind_map(TypeRenaming, KindMap0, KindMap),
+ apply_variable_renaming_to_type_map(TypeRenaming, VarTypes0, VarTypes1),
+ apply_variable_renaming_to_type_list(TypeRenaming, OriginalArgTypes0,
+ OriginalArgTypes1),
% The real set of existentially quantified variables may be
% smaller, but this is OK.
%
- term.var_list_to_term_list(ExistQVars0, ExistQTypes0),
- term.apply_substitution_to_list(ExistQTypes0, TypeRenaming, ExistQTypes1),
- term.term_list_to_var_list(ExistQTypes1, ExistQVars1),
+ apply_variable_renaming_to_tvar_list(TypeRenaming, ExistQVars0,
+ ExistQVars1),
inlining.get_type_substitution(OriginalArgTypes1, CallerArgTypes0,
CallerHeadParams, ExistQVars1, TypeSubn),
- term.apply_rec_substitution_to_list(ExistQTypes1, TypeSubn, ExistQTypes),
+ apply_rec_subst_to_tvar_list(KindMap, TypeSubn, ExistQVars1, ExistQTypes),
ExistQVars = list.filter_map(
(func(ExistQType) = ExistQVar is semidet :-
- ExistQType = term.variable(ExistQVar)
+ ExistQType = variable(ExistQVar, _)
), ExistQTypes),
- apply_rec_substitution_to_type_map(VarTypes1, TypeSubn, VarTypes2),
- term.apply_rec_substitution_to_list(OriginalArgTypes1, TypeSubn,
+ apply_rec_subst_to_type_map(TypeSubn, VarTypes1, VarTypes2),
+ apply_rec_subst_to_type_list(TypeSubn, OriginalArgTypes1,
OriginalArgTypes),
proc_info_set_vartypes(VarTypes2, !NewProcInfo),
- term.var_list_to_term_list(ExtraTypeInfoTVars0,
+ % XXX kind inference:
+ % we assume vars have kind `star'.
+ prog_type.var_list_to_type_list(map.init, ExtraTypeInfoTVars0,
ExtraTypeInfoTVarTypes0),
(
( map.is_empty(TypeSubn)
@@ -2749,12 +2757,19 @@
% callee we may need to bind type variables in the caller.
list.map(substitute_higher_order_arg(TypeSubn), HOArgs0, HOArgs),
- term.apply_rec_substitution_to_list(ExtraTypeInfoTVarTypes0,
- TypeSubn, ExtraTypeInfoTVarTypes),
+ apply_rec_subst_to_type_list(TypeSubn, ExtraTypeInfoTVarTypes0,
+ ExtraTypeInfoTVarTypes),
% The substitution should never bind any of the type variables
% for which extra type-infos are needed, otherwise it
% wouldn't be necessary to add them.
- term.term_list_to_var_list(ExtraTypeInfoTVarTypes, ExtraTypeInfoTVars)
+ (
+ prog_type.type_list_to_var_list(ExtraTypeInfoTVarTypes,
+ ExtraTypeInfoTVars1)
+ ->
+ ExtraTypeInfoTVars = ExtraTypeInfoTVars1
+ ;
+ unexpected(this_file, "create_new_proc: type var got bound")
+ )
),
% Add in the extra typeinfo vars.
@@ -2880,8 +2895,8 @@
type_list_subsumes(OriginalArgTypes,
OriginalHeadTypes, ExistentialSubn)
->
- term.apply_rec_substitution_to_list(ExtraHeadVarTypes0,
- ExistentialSubn, ExtraHeadVarTypes),
+ apply_rec_subst_to_type_list(ExistentialSubn, ExtraHeadVarTypes0,
+ ExtraHeadVarTypes),
assoc_list.from_corresponding_lists(ExtraHeadVars,
ExtraHeadVarTypes, ExtraHeadVarsAndTypes),
list.foldl(update_var_types, ExtraHeadVarsAndTypes,
@@ -3064,7 +3079,7 @@
(
VarInfo = type_info_var(TypeInfoType),
rtti_det_insert_type_info_type(Var, TypeInfoType, !RttiVarMaps),
- ( prog_type.var(TypeInfoType, TVar) ->
+ ( TypeInfoType = variable(TVar, _) ->
maybe_set_typeinfo_locn(TVar, type_info(Var), !RttiVarMaps)
;
true
@@ -3087,7 +3102,7 @@
rtti_varmaps::in, rtti_varmaps::out) is det.
update_type_info_locn(Var, ConstraintType, Index, Index + 1, !RttiVarMaps) :-
- ( prog_type.var(ConstraintType, ConstraintTVar) ->
+ ( ConstraintType = variable(ConstraintTVar, _) ->
maybe_set_typeinfo_locn(ConstraintTVar,
typeclass_info(Var, Index), !RttiVarMaps)
;
@@ -3145,8 +3160,7 @@
CurriedArgTypes0 = !.HOArg ^ hoa_curry_type_in_caller,
CurriedRttiTypes0 = !.HOArg ^ hoa_curry_rtti_type,
CurriedHOArgs0 = !.HOArg ^ hoa_known_curry_args,
- term.apply_rec_substitution_to_list(CurriedArgTypes0, Subn,
- CurriedArgTypes),
+ apply_rec_subst_to_type_list(Subn, CurriedArgTypes0, CurriedArgTypes),
list.map(substitute_rtti_var_info(Subn), CurriedRttiTypes0,
CurriedRttiTypes),
list.map(substitute_higher_order_arg(Subn), CurriedHOArgs0, CurriedHOArgs),
@@ -3158,7 +3172,7 @@
rtti_var_info::out) is det.
substitute_rtti_var_info(Subn, type_info_var(Type0), type_info_var(Type)) :-
- term.apply_rec_substitution(Type0, Subn, Type).
+ apply_rec_subst_to_type(Subn, Type0, Type).
substitute_rtti_var_info(Subn, typeclass_info_var(Constraint0),
typeclass_info_var(Constraint)) :-
apply_rec_subst_to_prog_constraint(Subn, Constraint0, Constraint).
Index: compiler/hlds_code_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_code_util.m,v
retrieving revision 1.17
diff -u -r1.17 hlds_code_util.m
--- compiler/hlds_code_util.m 26 Jul 2005 01:56:22 -0000 1.17
+++ compiler/hlds_code_util.m 6 Sep 2005 08:05:06 -0000
@@ -91,7 +91,7 @@
cons_id_to_tag(cons(Name, Arity), Type, ModuleInfo) = Tag :-
(
% handle the `character' type specially
- Type = term__functor(term__atom("character"), [], _),
+ Type = builtin(character),
Name = unqualified(ConsName),
string__char_to_string(Char, ConsName)
->
@@ -142,10 +142,10 @@
:- pred type_to_string((type)::in, string::out) is det.
type_to_string(Type, String) :-
- ( sym_name_and_args(Type, TypeName, TypeArgs) ->
+ ( type_to_ctor_and_args(Type, TypeCtor, _) ->
+ TypeCtor = TypeName - TypeArity,
mdbcomp__prim_data__sym_name_to_string(TypeName, "__",
TypeNameString),
- list__length(TypeArgs, TypeArity),
string__int_to_string(TypeArity, TypeArityString),
string__append_list(
[TypeNameString, "__arity", TypeArityString, "__"],
Index: compiler/hlds_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_data.m,v
retrieving revision 1.95
diff -u -r1.95 hlds_data.m
--- compiler/hlds_data.m 12 Sep 2005 03:05:42 -0000 1.95
+++ compiler/hlds_data.m 12 Sep 2005 04:07:41 -0000
@@ -27,6 +27,7 @@
:- implementation.
:- import_module check_hlds__type_util.
+:- import_module parse_tree__prog_type.
:- import_module int.
:- import_module svmulti_map.
@@ -121,12 +122,13 @@
:- type hlds_type_defn.
:- pred hlds_data__set_type_defn(tvarset::in, list(type_param)::in,
- hlds_type_body::in, import_status::in, bool::in, need_qualifier::in,
- prog_context::in, hlds_type_defn::out) is det.
+ tvar_kind_map::in, hlds_type_body::in, import_status::in, bool::in,
+ need_qualifier::in, prog_context::in, hlds_type_defn::out) is det.
:- pred get_type_defn_tvarset(hlds_type_defn::in, tvarset::out) is det.
:- pred get_type_defn_tparams(hlds_type_defn::in, list(type_param)::out)
is det.
+:- pred get_type_defn_kind_map(hlds_type_defn::in, tvar_kind_map::out) is det.
:- pred get_type_defn_body(hlds_type_defn::in, hlds_type_body::out) is det.
:- pred get_type_defn_status(hlds_type_defn::in, import_status::out) is det.
:- pred get_type_defn_in_exported_eqv(hlds_type_defn::in, bool::out) is det.
@@ -397,6 +399,8 @@
% Names of the type variables, if any.
type_defn_params :: list(type_param),
% Formal type parameters.
+ type_defn_kinds :: tvar_kind_map,
+ % Kinds of the formal parameters.
type_defn_body :: hlds_type_body,
% The definition of the type.
@@ -439,13 +443,14 @@
% source code
).
-hlds_data__set_type_defn(Tvarset, Params, Body, Status,
- InExportedEqv, NeedQual, Context, Defn) :-
- Defn = hlds_type_defn(Tvarset, Params, Body, Status, InExportedEqv,
- NeedQual, Context).
+hlds_data__set_type_defn(Tvarset, Params, Kinds, Body, Status, InExportedEqv,
+ NeedQual, Context, Defn) :-
+ Defn = hlds_type_defn(Tvarset, Params, Kinds, Body, Status,
+ InExportedEqv, NeedQual, Context).
get_type_defn_tvarset(Defn, Defn ^ type_defn_tvarset).
get_type_defn_tparams(Defn, Defn ^ type_defn_params).
+get_type_defn_kind_map(Defn, Defn ^ type_defn_kinds).
get_type_defn_body(Defn, Defn ^ type_defn_body).
get_type_defn_status(Defn, Defn ^ type_defn_import_status).
get_type_defn_in_exported_eqv(Defn, Defn ^ type_defn_in_exported_eqv).
@@ -809,6 +814,8 @@
% on them.
class_vars :: list(tvar),
% ClassVars
+ class_kinds :: tvar_kind_map,
+ % Kinds of class_vars.
class_interface :: class_interface,
% The interface from the
% original declaration,
@@ -1210,13 +1217,11 @@
% on class declarations can only use variables that
% appear in the head of the declaration.)
%
- varset.merge_subst(TVarSet, ClassTVarSet, _, RenameSubst),
- apply_subst_to_constraint_list(RenameSubst, ClassAncestors,
- RenamedAncestors),
- term.var_list_to_term_list(ClassParams, ClassParamTerms),
- term.apply_substitution_to_list(ClassParamTerms, RenameSubst,
- RenamedParamTerms),
- term.term_list_to_var_list(RenamedParamTerms, RenamedParams),
+ tvarset_merge_renaming(TVarSet, ClassTVarSet, _, Renaming),
+ apply_variable_renaming_to_constraint_list(Renaming,
+ ClassAncestors, RenamedAncestors),
+ apply_variable_renaming_to_tvar_list(Renaming, ClassParams,
+ RenamedParams),
map.from_corresponding_lists(RenamedParams, Args, Subst),
apply_subst_to_constraint_list(Subst, RenamedAncestors,
Ancestors),
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.365
diff -u -r1.365 hlds_out.m
--- compiler/hlds_out.m 22 Aug 2005 03:55:10 -0000 1.365
+++ compiler/hlds_out.m 11 Sep 2005 15:39:07 -0000
@@ -269,6 +269,7 @@
% Parse tree modules.
:- import_module parse_tree__mercury_to_mercury.
+:- import_module parse_tree__prog_io_util.
:- import_module parse_tree__prog_mode.
:- import_module parse_tree__prog_out.
:- import_module parse_tree__prog_util.
@@ -2028,7 +2029,7 @@
MaybeNameMode = no
),
io__write_string("@", !IO),
- mercury_output_term(Type, TVarSet, AppendVarNums, !IO),
+ mercury_output_type(TVarSet, AppendVarNums, Type, !IO),
(
Args = []
;
@@ -2497,7 +2498,7 @@
TypeQual = yes(TVarSet, _)
->
io__write_string(" `with_type` ", !IO),
- mercury_output_term(Type, TVarSet, no, next_to_graphic_token, !IO)
+ mercury_output_type(TVarSet, AppendVarNums, Type, !IO)
;
true
).
@@ -2567,8 +2568,7 @@
TypeQual = yes(TVarSet, _)
->
io__write_string(" `with_type` ", !IO),
- mercury_output_term(Type, TVarSet, AppendVarNums,
- next_to_graphic_token, !IO)
+ mercury_output_type(TVarSet, AppendVarNums, Type, !IO)
;
true
),
@@ -2955,13 +2955,13 @@
io::di, io::uo) is det.
hlds_out__write_type_list(Types, TypeVarSet, AppendVarNums, !IO) :-
- list__foldl(output_term_and_comma(TypeVarSet, AppendVarNums), Types, !IO).
+ list__foldl(output_type_and_comma(TypeVarSet, AppendVarNums), Types, !IO).
-:- pred output_term_and_comma(tvarset::in, bool::in, (type)::in,
+:- pred output_type_and_comma(tvarset::in, bool::in, (type)::in,
io::di, io::uo) is det.
-output_term_and_comma(TypeVarSet, AppendVarNums, Type, !IO) :-
- mercury_output_term(Type, TypeVarSet, AppendVarNums, !IO),
+output_type_and_comma(TypeVarSet, AppendVarNums, Type, !IO) :-
+ mercury_output_type(TypeVarSet, AppendVarNums, Type, !IO),
io__write_string(", ", !IO).
:- pred hlds_out__write_var_types(int::in, prog_varset::in, bool::in,
@@ -2991,7 +2991,7 @@
io__write_int(VarNum, !IO),
io__write_string(")", !IO),
io__write_string(": ", !IO),
- mercury_output_term(Type, TypeVarSet, AppendVarNums, !IO),
+ mercury_output_type(TypeVarSet, AppendVarNums, Type, !IO),
io__write_string("\n", !IO),
hlds_out__write_var_types_2(Vars, Indent, VarSet, AppendVarNums,
VarTypes, TypeVarSet, !IO).
@@ -3082,7 +3082,7 @@
(
VarInfo = type_info_var(Type),
io__write_string("type_info for ", !IO),
- mercury_output_term(Type, TVarSet, AppendVarNums, !IO)
+ mercury_output_type(TVarSet, AppendVarNums, Type, !IO)
;
VarInfo = typeclass_info_var(Constraint),
io__write_string("typeclass_info for", !IO),
@@ -3217,12 +3217,12 @@
hlds_out__write_type_params(_TVarSet, [], !IO).
hlds_out__write_type_params(TVarSet, [P], !IO) :-
io__write_string("(", !IO),
- term_io__write_term(TVarSet, P, !IO),
+ mercury_output_var(P, TVarSet, no, !IO),
io__write_string(")", !IO).
hlds_out__write_type_params(TVarSet, [P | Ps], !IO) :-
Ps = [_ | _],
io__write_string("(", !IO),
- term_io__write_term(TVarSet, P, !IO),
+ mercury_output_var(P, TVarSet, no, !IO),
hlds_out__write_type_params_2(TVarSet, Ps, !IO).
:- pred hlds_out__write_type_params_2(tvarset::in, list(type_param)::in,
@@ -3232,7 +3232,7 @@
io__write_string(")", !IO).
hlds_out__write_type_params_2(TVarSet, [P | Ps], !IO) :-
io__write_string(", ", !IO),
- term_io__write_term(TVarSet, P, !IO),
+ mercury_output_var(P, TVarSet, no, !IO),
hlds_out__write_type_params_2(TVarSet, Ps, !IO).
:- pred hlds_out__write_type_body(int::in, tvarset::in, hlds_type_body::in,
@@ -3268,7 +3268,7 @@
hlds_out__write_type_body(_Indent, TVarSet, eqv_type(Type), !IO) :-
io__write_string(" == ", !IO),
- term_io__write_term(TVarSet, Type, !IO),
+ mercury_output_type(TVarSet, no, Type, !IO),
io__write_string(".\n", !IO).
hlds_out__write_type_body(_Indent, _TVarSet, abstract_type(_IsSolverType),
@@ -3355,7 +3355,7 @@
hlds_out__write_class_id(ClassId, !IO),
io__write_string(":\n", !IO),
- ClassDefn = hlds_class_defn(_, Constraints, FunDeps, _, Vars, _,
+ ClassDefn = hlds_class_defn(_, Constraints, FunDeps, _, Vars, _, _,
Interface, VarSet, Context),
term__context_file(Context, FileName),
@@ -3472,7 +3472,7 @@
SuperClassId = class_id(SuperSymName, _SuperArity),
prog_out__write_sym_name(SuperSymName, !IO),
io__write_char('(', !IO),
- io__write_list(SuperClassVars, ", ", term_io__write_term(VarSet), !IO),
+ io__write_list(SuperClassVars, ", ", mercury_output_type(VarSet, no), !IO),
io__write_char(')', !IO).
%-----------------------------------------------------------------------------%
@@ -3528,8 +3528,7 @@
% curry the varset for term_io__write_variable/4
PrintTerm = (pred(TypeName::in, IO0::di, IO::uo) is det :-
- mercury_output_term(TypeName, VarSet,
- AppendVarNums, IO0, IO)
+ mercury_output_type(VarSet, AppendVarNums, TypeName, IO0, IO)
),
hlds_out__write_indent(Indent, !IO),
io__write_string("% Types: ", !IO),
@@ -3997,8 +3996,10 @@
make_atom(any_inst_uniqueness(Uniq), Context).
inst_to_term(free, Context) =
make_atom("free", Context).
-inst_to_term(free(Type), Context) =
- term__functor(term__atom("free"), [term__coerce(Type)], Context).
+inst_to_term(free(Type), Context) = Term :-
+ unparse_type(Type, Term0),
+ Term1 = term__coerce(Term0),
+ Term = term__functor(term__atom("free"), [Term1], Context).
inst_to_term(bound(Uniq, BoundInsts), Context) = Term :-
construct_qualified_term(unqualified(inst_uniqueness(Uniq, "bound")),
[bound_insts_to_term(BoundInsts, Context)], Context, Term).
@@ -4081,13 +4082,15 @@
make_atom((Real = real_unify -> "real" ; "fake"), Context)],
Context, Term).
inst_name_to_term(typed_ground(Uniq, Type), Context) = Term :-
+ unparse_type(Type, Term0),
construct_qualified_term(unqualified("$typed_ground"),
[make_atom(inst_uniqueness(Uniq, "shared"), Context),
- term__coerce(Type)],
+ term__coerce(Term0)],
Context, Term).
inst_name_to_term(typed_inst(Type, InstName), Context) = Term :-
+ unparse_type(Type, Term0),
construct_qualified_term(unqualified("$typed_inst"),
- [term__coerce(Type),
+ [term__coerce(Term0),
inst_name_to_term(InstName, Context)],
Context, Term).
Index: compiler/hlds_pred.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_pred.m,v
retrieving revision 1.175
diff -u -r1.175 hlds_pred.m
--- compiler/hlds_pred.m 27 Aug 2005 09:41:55 -0000 1.175
+++ compiler/hlds_pred.m 11 Sep 2005 15:01:03 -0000
@@ -380,7 +380,7 @@
% to all types first, then TSubst is applied to all types. Subst
% is applied to all prog_vars.
%
-:- pred apply_substitutions_to_rtti_varmaps(tsubst::in, tsubst::in,
+:- pred apply_substitutions_to_rtti_varmaps(tvar_renaming::in, tsubst::in,
map(prog_var, prog_var)::in, rtti_varmaps::in, rtti_varmaps::out)
is det.
@@ -499,7 +499,7 @@
maybe_check_type_info_var(type_info(Var), TVar, !VarMaps) :-
( map__search(!.VarMaps ^ ti_type_map, Var, Type) ->
- ( Type = term__variable(TVar) ->
+ ( Type = variable(TVar, _) ->
true
;
unexpected(this_file, "inconsistent info in rtti_varmaps")
@@ -607,12 +607,13 @@
Var = Var0
).
-:- pred apply_substs_to_tci_map(tsubst::in, tsubst::in,
+:- pred apply_substs_to_tci_map(tvar_renaming::in, tsubst::in,
map(prog_var, prog_var)::in, prog_constraint::in, prog_var::in,
typeclass_info_varmap::in, typeclass_info_varmap::out) is det.
apply_substs_to_tci_map(TRenaming, TSubst, Subst, Constraint0, Var0, !Map) :-
- apply_subst_to_prog_constraint(TRenaming, Constraint0, Constraint1),
+ apply_variable_renaming_to_prog_constraint(TRenaming, Constraint0,
+ Constraint1),
apply_rec_subst_to_prog_constraint(TSubst, Constraint1, Constraint),
apply_subst_to_prog_var(Subst, Var0, Var),
svmap__set(Constraint, Var, !Map).
@@ -624,7 +625,7 @@
% If tvar maps to a another type variable, we keep the new variable, if
% it maps to a type, we remove it from the map.
%
-:- pred apply_substs_to_ti_map(tsubst::in, tsubst::in,
+:- pred apply_substs_to_ti_map(tvar_renaming::in, tsubst::in,
map(prog_var, prog_var)::in, tvar::in, type_info_locn::in,
type_info_varmap::in, type_info_varmap::out) is det.
@@ -632,21 +633,14 @@
type_info_locn_var(Locn, Var),
apply_subst_to_prog_var(Subst, Var, NewVar),
type_info_locn_set_var(NewVar, Locn, NewLocn),
- (
- % Find the new tvar, if there is one.
- map__search(TRenaming, TVar, NewTVarType0)
- ->
- NewTVarType1 = NewTVarType0
- ;
- % The variable wasn't renamed.
- NewTVarType1 = term__variable(TVar)
- ),
- term__apply_rec_substitution(NewTVarType1, TSubst, NewTVarType),
-
+ apply_variable_renaming_to_tvar(TRenaming, TVar, NewTVar1),
+ % We don't use the correct kinds here, but that doesn't matter because
+ % the resulting kind will be thrown away anyway.
+ apply_rec_subst_to_tvar(map__init, TSubst, NewTVar1, NewType),
(
% If the tvar is still a variable, insert it into the map with the
% new var.
- prog_type__var(NewTVarType, NewTVar)
+ NewType = variable(NewTVar, _)
->
% Don't abort if two old type variables map to the same new type
% variable.
@@ -655,13 +649,13 @@
true
).
-:- pred apply_substs_to_type_map(tsubst::in, tsubst::in,
+:- pred apply_substs_to_type_map(tvar_renaming::in, tsubst::in,
map(prog_var, prog_var)::in, prog_var::in, (type)::in,
type_info_type_map::in, type_info_type_map::out) is det.
apply_substs_to_type_map(TRenaming, TSubst, Subst, Var0, Type0, !Map) :-
- term__apply_substitution(Type0, TRenaming, Type1),
- term__apply_rec_substitution(Type1, TSubst, Type),
+ apply_variable_renaming_to_type(TRenaming, Type0, Type1),
+ apply_rec_subst_to_type(TSubst, Type1, Type),
apply_subst_to_prog_var(Subst, Var0, Var),
( map__search(!.Map, Var, ExistingType) ->
( Type = ExistingType ->
@@ -673,14 +667,15 @@
svmap__det_insert(Var, Type, !Map)
).
-:- pred apply_substs_to_constraint_map(tsubst::in, tsubst::in,
+:- pred apply_substs_to_constraint_map(tvar_renaming::in, tsubst::in,
map(prog_var, prog_var)::in, prog_var::in, prog_constraint::in,
typeclass_info_constraint_map::in, typeclass_info_constraint_map::out)
is det.
apply_substs_to_constraint_map(TRenaming, TSubst, Subst, Var0, Constraint0,
!Map) :-
- apply_subst_to_prog_constraint(TRenaming, Constraint0, Constraint1),
+ apply_variable_renaming_to_prog_constraint(TRenaming, Constraint0,
+ Constraint1),
apply_rec_subst_to_prog_constraint(TSubst, Constraint1, Constraint),
apply_subst_to_prog_var(Subst, Var0, Var),
( map__search(!.Map, Var, ExistingConstraint) ->
@@ -1439,6 +1434,7 @@
:- pred pred_info_get_attributes(pred_info::in, pred_attributes::out) is det.
:- pred pred_info_arg_types(pred_info::in, list(type)::out) is det.
:- pred pred_info_typevarset(pred_info::in, tvarset::out) is det.
+:- pred pred_info_tvar_kinds(pred_info::in, tvar_kind_map::out) is det.
:- pred pred_info_get_exist_quant_tvars(pred_info::in, existq_tvars::out)
is det.
:- pred pred_info_get_existq_tvar_binding(pred_info::in, tsubst::out) is det.
@@ -1470,6 +1466,8 @@
pred_info::in, pred_info::out) is det.
:- pred pred_info_set_typevarset(tvarset::in,
pred_info::in, pred_info::out) is det.
+:- pred pred_info_set_tvar_kinds(tvar_kind_map::in,
+ pred_info::in, pred_info::out) is det.
:- pred pred_info_set_existq_tvar_binding(tsubst::in,
pred_info::in, pred_info::out) is det.
:- pred pred_info_set_head_type_params(head_type_params::in,
@@ -1799,6 +1797,9 @@
% Names of type vars in the predicate's type decl
% or in the variable type assignments.
+ tvar_kinds :: tvar_kind_map,
+ % Kinds of the type vars.
+
exist_quant_tvars :: existq_tvars,
% The set of existentially quantified type
% variables in the predicate's type decl.
@@ -1870,9 +1871,12 @@
ClausesInfo, PredInfo) :-
unqualify_name(SymName, PredName),
sym_name_get_module_name(SymName, ModuleName, PredModuleName),
- term__vars_list(ArgTypes, TVars),
+ prog_type__vars_list(ArgTypes, TVars),
list__delete_elems(TVars, ExistQVars, HeadTypeParams),
Attributes = [],
+ % XXX kind inference:
+ % we assume all tvars have kind `star'.
+ map__init(Kinds),
map__init(ExistQVarBindings),
UnprovenBodyConstraints = [],
set__init(Assertions),
@@ -1880,7 +1884,7 @@
map__init(Procs),
PredInfo = pred_info(PredModuleName, PredName, Arity, PredOrFunc,
Context, Origin, Status, GoalType, Markers, Attributes,
- ArgTypes, TypeVarSet, TypeVarSet, ExistQVars, ExistQVarBindings,
+ ArgTypes, TypeVarSet, TypeVarSet, Kinds, ExistQVars, ExistQVarBindings,
HeadTypeParams, ClassContext, ClassProofs, ClassConstraintMap,
UnprovenBodyConstraints, inst_graph_info_init, [],
Assertions, User, Indexes, ClausesInfo, Procs).
@@ -1896,8 +1900,11 @@
Attributes = [],
map__init(ClassProofs),
map__init(ClassConstraintMap),
- term__vars_list(ArgTypes, TVars),
+ prog_type__vars_list(ArgTypes, TVars),
list__delete_elems(TVars, ExistQVars, HeadTypeParams),
+ % XXX kind inference:
+ % we assume all tvars have kind `star'.
+ map__init(Kinds),
map__init(ExistQVarBindings),
UnprovenBodyConstraints = [],
Indexes = [],
@@ -1916,7 +1923,7 @@
PredInfo = pred_info(ModuleName, PredName, Arity, PredOrFunc,
Context, Origin, Status, clauses, Markers, Attributes,
- ArgTypes, TypeVarSet, TypeVarSet, ExistQVars, ExistQVarBindings,
+ ArgTypes, TypeVarSet, TypeVarSet, Kinds, ExistQVars, ExistQVarBindings,
HeadTypeParams, ClassContext, ClassProofs, ClassConstraintMap,
UnprovenBodyConstraints, inst_graph_info_init, [], Assertions,
User, Indexes, ClausesInfo, Procs).
@@ -2026,6 +2033,7 @@
pred_info_get_attributes(PI, PI ^ attributes).
pred_info_arg_types(PI, PI ^ arg_types).
pred_info_typevarset(PI, PI ^ typevarset).
+pred_info_tvar_kinds(PI, PI ^ tvar_kinds).
pred_info_get_exist_quant_tvars(PI, PI ^ exist_quant_tvars).
pred_info_get_existq_tvar_binding(PI, PI ^ existq_tvar_binding).
pred_info_get_head_type_params(PI, PI ^ head_type_params).
@@ -2045,6 +2053,7 @@
pred_info_set_markers(X, PI, PI ^ markers := X).
pred_info_set_attributes(X, PI, PI ^ attributes := X).
pred_info_set_typevarset(X, PI, PI ^ typevarset := X).
+pred_info_set_tvar_kinds(X, PI, PI ^ tvar_kinds := X).
pred_info_set_existq_tvar_binding(X, PI, PI ^ existq_tvar_binding := X).
pred_info_set_head_type_params(X, PI, PI ^ head_type_params := X).
pred_info_set_class_context(X, PI, PI ^ class_context := X).
@@ -2293,7 +2302,7 @@
pred_info_get_univ_quant_tvars(PredInfo, UnivQVars) :-
pred_info_arg_types(PredInfo, ArgTypes),
- term__vars_list(ArgTypes, ArgTypeVars0),
+ prog_type__vars_list(ArgTypes, ArgTypeVars0),
list__sort_and_remove_dups(ArgTypeVars0, ArgTypeVars),
pred_info_get_exist_quant_tvars(PredInfo, ExistQVars),
list__delete_elems(ArgTypeVars, ExistQVars, UnivQVars).
@@ -3185,7 +3194,7 @@
proc_info_get_typeinfo_vars_2([], _, _, []).
proc_info_get_typeinfo_vars_2([Var | Vars], VarTypes, TVarMap, TypeInfoVars) :-
( map__search(VarTypes, Var, Type) ->
- type_util__real_vars(Type, TypeVars),
+ prog_type__vars(Type, TypeVars),
(
% Optimize common case
TypeVars = []
Index: compiler/inlining.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/inlining.m,v
retrieving revision 1.125
diff -u -r1.125 inlining.m
--- compiler/inlining.m 9 Sep 2005 02:31:03 -0000 1.125
+++ compiler/inlining.m 11 Sep 2005 01:24:22 -0000
@@ -692,9 +692,9 @@
% any new type variables, but any unbound type variables in the callee
% will not be substituted away)
- varset__merge_subst(TypeVarSet0, CalleeTypeVarSet,
- TypeVarSet, TypeRenaming),
- apply_substitution_to_type_map(CalleeVarTypes0, TypeRenaming,
+ tvarset_merge_renaming(TypeVarSet0, CalleeTypeVarSet, TypeVarSet,
+ TypeRenaming),
+ apply_variable_renaming_to_type_map(TypeRenaming, CalleeVarTypes0,
CalleeVarTypes1),
% next, compute the type substitution and then apply it
@@ -719,16 +719,13 @@
% since we can do things more efficiently in that case
( CalleeExistQVars = [] ->
% update types in callee only
- apply_rec_substitution_to_type_map(CalleeVarTypes1,
- TypeSubn, CalleeVarTypes),
+ apply_rec_subst_to_type_map(TypeSubn, CalleeVarTypes1, CalleeVarTypes),
VarTypes1 = VarTypes0
;
% update types in callee
- apply_rec_substitution_to_type_map(CalleeVarTypes1,
- TypeSubn, CalleeVarTypes),
+ apply_rec_subst_to_type_map(TypeSubn, CalleeVarTypes1, CalleeVarTypes),
% update types in caller
- apply_rec_substitution_to_type_map(VarTypes0,
- TypeSubn, VarTypes1)
+ apply_rec_subst_to_type_map(TypeSubn, VarTypes0, VarTypes1)
),
% Now rename apart the variables in the called goal.
Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.175
diff -u -r1.175 intermod.m
--- compiler/intermod.m 5 Sep 2005 03:45:55 -0000 1.175
+++ compiler/intermod.m 8 Sep 2005 06:35:46 -0000
@@ -1391,7 +1391,8 @@
intermod__write_class(ModuleName, ClassId, ClassDefn, !IO) :-
ClassDefn = hlds_class_defn(ImportStatus, Constraints, HLDSFunDeps,
- _Ancestors, TVars, Interface, _HLDSClassInterface, TVarSet, Context),
+ _Ancestors, TVars, _Kinds, Interface, _HLDSClassInterface, TVarSet,
+ Context),
ClassId = class_id(QualifiedClassName, _),
(
QualifiedClassName = qualified(ModuleName, _),
Index: compiler/ite_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ite_gen.m,v
retrieving revision 1.80
diff -u -r1.80 ite_gen.m
--- compiler/ite_gen.m 7 Sep 2005 06:51:52 -0000 1.80
+++ compiler/ite_gen.m 7 Sep 2005 07:30:03 -0000
@@ -254,9 +254,9 @@
code_info__produce_variable(L, CodeL, ValL, !CI),
code_info__produce_variable(R, CodeR, ValR, !CI),
Type = code_info__variable_type(!.CI, L),
- ( Type = term__functor(term__atom("string"), [], _) ->
+ ( Type = builtin(string) ->
Op = str_eq
- ; Type = term__functor(term__atom("float"), [], _) ->
+ ; Type = builtin(float) ->
Op = float_eq
;
Op = eq
Index: compiler/layout_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/layout_out.m,v
retrieving revision 1.50
diff -u -r1.50 layout_out.m
--- compiler/layout_out.m 14 Aug 2005 03:20:39 -0000 1.50
+++ compiler/layout_out.m 7 Sep 2005 06:37:54 -0000
@@ -1234,7 +1234,7 @@
subst_to_name(TVar - Type) =
string__format("%d/%s",
- [i(TVar), s(mercury_term_to_string(Type, varset__init, no))]).
+ [i(TVar), s(mercury_type_to_string(varset__init, no, Type))]).
%-----------------------------------------------------------------------------%
Index: compiler/llds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/llds_out.m,v
retrieving revision 1.254
diff -u -r1.254 llds_out.m
--- compiler/llds_out.m 7 Sep 2005 06:51:54 -0000 1.254
+++ compiler/llds_out.m 7 Sep 2005 07:30:03 -0000
@@ -2434,10 +2434,10 @@
MaybeForeignTypeInfo = no,
io__write_string(VarName, !IO),
io__write_string(" = ", !IO),
- ( OrigType = term__functor(term__atom("string"), [], _) ->
+ ( OrigType = builtin(string) ->
output_llds_type_cast(string, !IO),
output_rval_as_type(Rval, word, !IO)
- ; OrigType = term__functor(term__atom("float"), [], _) ->
+ ; OrigType = builtin(float) ->
output_rval_as_type(Rval, float, !IO)
;
output_rval_as_type(Rval, word, !IO)
@@ -2504,12 +2504,12 @@
output_lval_as_word(Lval, !IO),
io__write_string(" = ", !IO),
(
- OrigType = term__functor(term__atom("string"), [], _)
+ OrigType = builtin(string)
->
output_llds_type_cast(word, !IO),
io__write_string(VarName, !IO)
;
- OrigType = term__functor(term__atom("float"), [], _)
+ OrigType = builtin(float)
->
io__write_string("MR_float_to_word(", !IO),
io__write_string(VarName, !IO),
@@ -2643,7 +2643,7 @@
io__write_string(", ", !IO),
% XXX Fake type varset
varset__init(NewTVarset),
- mercury_output_term(Type, NewTVarset, no, !IO),
+ mercury_output_type(NewTVarset, no, Type, !IO),
io__write_string(", ", !IO),
(
LldsInst = ground,
Index: compiler/magic_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/magic_util.m,v
retrieving revision 1.50
diff -u -r1.50 magic_util.m
--- compiler/magic_util.m 30 Aug 2005 04:11:54 -0000 1.50
+++ compiler/magic_util.m 2 Sep 2005 15:15:02 -0000
@@ -1315,9 +1315,8 @@
{ MaybeRtti = yes(typeclass_info) }
;
{ MaybeRtti = no },
- { map__init(Subn) },
{ set__init(Errors0) },
- { term__is_ground(ArgType, Subn) ->
+ { type_is_ground(ArgType) ->
Errors1 = Errors0
;
set__insert(Errors0, polymorphic, Errors1)
Index: compiler/make_hlds_passes.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds_passes.m,v
retrieving revision 1.8
diff -u -r1.8 make_hlds_passes.m
--- compiler/make_hlds_passes.m 12 Sep 2005 04:37:14 -0000 1.8
+++ compiler/make_hlds_passes.m 12 Sep 2005 04:41:11 -0000
@@ -455,9 +455,7 @@
InstVarSet = varset__init,
ExistQVars = [],
Constraints = constraints([], []),
- IOType = term__functor(term__atom("."), [
- term__functor(term__atom("io"), [], Context),
- term__functor(term__atom("state"), [], Context)], Context),
+ IOType = defined(qualified(unqualified("io"), "state"),[], star),
GetPredDecl = pred_or_func(VarSet, InstVarSet, ExistQVars, predicate,
mutable_get_pred_sym_name(ModuleName, Name),
[type_and_mode(Type, out_mode(Inst))],
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.267
diff -u -r1.267 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m 12 Sep 2005 03:05:43 -0000 1.267
+++ compiler/mercury_to_mercury.m 12 Sep 2005 04:07:41 -0000
@@ -262,11 +262,12 @@
:- func mercury_term_to_string(term(T), varset(T), bool, needs_quotes)
= string.
- % XXX Even though types are defined to be terms, these two functions
- % format types not as mercury_term_to_string does but in a simplified
- % manner.
- %
-:- func mercury_type_to_string(tvarset, type) = string.
+:- pred mercury_output_type(tvarset::in, bool::in, (type)::in, io::di, io::uo)
+ is det.
+:- func mercury_type_to_string(tvarset, bool, type) = string.
+:- pred mercury_format_type(tvarset::in, bool::in, (type)::in, U::di, U::uo)
+ is det <= output(U).
+
:- func mercury_type_list_to_string(tvarset, list(type)) = string.
:- pred mercury_output_newline(int::in, io::di, io::uo) is det.
@@ -745,7 +746,7 @@
io__write_char('(', !IO),
mercury_output_sym_name(ClassName, !IO),
io__write_char('(', !IO),
- io__write_list(Types, ", ", term_io__write_term(VarSet), !IO),
+ io__write_list(Types, ", ", mercury_output_type(VarSet, no), !IO),
io__write_char(')', !IO),
io__write_char(')', !IO),
AppendVarnums = no,
@@ -768,7 +769,7 @@
io__write_string(":- mutable(", !IO),
io__write_string(Name, !IO),
io__write_string(", ", !IO),
- mercury_output_term(Type, varset__init, no, !IO),
+ mercury_output_type(varset__init, no, Type, !IO),
io__write_string(", ", !IO),
mercury_output_term(InitTerm, varset__init, no, !IO),
io__write_string(", ", !IO),
@@ -1084,7 +1085,7 @@
).
mercury_format_structured_inst(inst_var(Var), Indent, VarSet, !U) :-
mercury_format_tabs(Indent, !U),
- mercury_format_var(Var, VarSet, no, !U),
+ mercury_format_var(VarSet, no, Var, !U),
add_string("\n", !U).
mercury_format_structured_inst(constrained_inst_vars(Vars, Inst), Indent,
VarSet, !U) :-
@@ -1172,7 +1173,7 @@
mercury_format_uniqueness(Uniq, "ground", !U)
).
mercury_format_inst(inst_var(Var), InstInfo, !U) :-
- mercury_format_var(Var, InstInfo ^ instvarset, no, !U).
+ mercury_format_var(InstInfo ^ instvarset, no, Var, !U).
mercury_format_inst(constrained_inst_vars(Vars, Inst), InstInfo, !U) :-
mercury_format_constrained_inst_vars(Vars, Inst, InstInfo, !U).
mercury_format_inst(abstract_inst(Name, Args), InstInfo, !U) :-
@@ -1297,14 +1298,14 @@
mercury_format_uniqueness(Uniqueness, "shared", !U),
add_string(", ", !U),
varset__init(TypeVarSet),
- mercury_format_term(Type, TypeVarSet, no, !U),
+ mercury_format_type(TypeVarSet, no, Type, !U),
add_string(")\n", !U).
mercury_format_structured_inst_name(typed_inst(Type, InstName),
Indent, VarSet, !U) :-
mercury_format_tabs(Indent, !U),
add_string("$typed_inst(", !U),
varset__init(TypeVarSet),
- mercury_format_term(Type, TypeVarSet, no, !U),
+ mercury_format_type(TypeVarSet, no, Type, !U),
add_string(",\n", !U),
mercury_format_structured_inst_name(InstName, Indent + 1, VarSet, !U),
mercury_format_tabs(Indent, !U),
@@ -1363,12 +1364,12 @@
mercury_format_uniqueness(Uniqueness, "shared", !U),
add_string(", ", !U),
varset__init(TypeVarSet),
- mercury_format_term(Type, TypeVarSet, no, !U),
+ mercury_format_type(TypeVarSet, no, Type, !U),
add_string(")", !U).
mercury_format_inst_name(typed_inst(Type, InstName), InstInfo, !U) :-
add_string("$typed_inst(", !U),
varset__init(TypeVarSet),
- mercury_format_term(Type, TypeVarSet, no, !U),
+ mercury_format_type(TypeVarSet, no, Type, !U),
add_string(", ", !U),
mercury_format_inst_name(InstName, InstInfo, !U),
add_string(")", !U).
@@ -1526,7 +1527,7 @@
mercury_format_constrained_inst_vars(Vars0, Inst, InstInfo, !U) :-
( set__remove_least(Vars0, Var, Vars1) ->
add_string("(", !U),
- mercury_format_var(Var, InstInfo ^ instvarset, no, !U),
+ mercury_format_var(InstInfo ^ instvarset, no, Var, !U),
add_string(" =< ", !U),
mercury_format_constrained_inst_vars(Vars1, Inst, InstInfo, !U),
add_string(")", !U)
@@ -1609,24 +1610,28 @@
list(type_param)::in, type_defn::in, prog_context::in, io::di, io::uo)
is det.
-mercury_output_type_defn(TVarSet, Name, Args,
+mercury_output_type_defn(TVarSet, Name, TParams,
abstract_type(IsSolverType), Context, !IO) :-
mercury_output_begin_type_decl(IsSolverType, !IO),
+ Args = list__map((func(V) = term__variable(V)), TParams),
construct_qualified_term(Name, Args, Context, TypeTerm),
mercury_output_term(TypeTerm, TVarSet, no, next_to_graphic_token, !IO),
io__write_string(".\n", !IO).
-mercury_output_type_defn(TVarSet, Name, Args, eqv_type(Body), Context, !IO) :-
+mercury_output_type_defn(TVarSet, Name, TParams, eqv_type(Body), Context,
+ !IO) :-
mercury_output_begin_type_decl(non_solver_type, !IO),
+ Args = list__map((func(V) = term__variable(V)), TParams),
construct_qualified_term(Name, Args, Context, TypeTerm),
mercury_output_term(TypeTerm, TVarSet, no, !IO),
io__write_string(" == ", !IO),
- mercury_output_term(Body, TVarSet, no, next_to_graphic_token, !IO),
+ mercury_output_type(TVarSet, no, Body, !IO),
io__write_string(".\n", !IO).
-mercury_output_type_defn(TVarSet, Name, Args,
+mercury_output_type_defn(TVarSet, Name, TParams,
du_type(Ctors, MaybeUserEqComp), Context, !IO) :-
mercury_output_begin_type_decl(non_solver_type, !IO),
+ Args = list__map((func(V) = term__variable(V)), TParams),
construct_qualified_term(Name, Args, Context, TypeTerm),
mercury_output_term(TypeTerm, TVarSet, no, !IO),
io__write_string("\n\t--->\t", !IO),
@@ -1634,16 +1639,17 @@
mercury_output_where_attributes(TVarSet, no, MaybeUserEqComp, !IO),
io__write_string(".\n", !IO).
-mercury_output_type_defn(TVarSet, Name, Args,
+mercury_output_type_defn(TVarSet, Name, TParams,
solver_type(SolverTypeDetails, MaybeUserEqComp), Context, !IO) :-
mercury_output_begin_type_decl(solver_type, !IO),
+ Args = list__map((func(V) = term__variable(V)), TParams),
construct_qualified_term(Name, Args, Context, TypeTerm),
mercury_output_term(TypeTerm, TVarSet, no, !IO),
mercury_output_where_attributes(TVarSet, yes(SolverTypeDetails),
MaybeUserEqComp, !IO),
io__write_string(".\n", !IO).
-mercury_output_type_defn(TVarSet, Name, Args,
+mercury_output_type_defn(TVarSet, Name, TParams,
foreign_type(ForeignType, MaybeUserEqComp, Assertions), _Context,
!IO) :-
io__write_string(":- pragma foreign_type(", !IO),
@@ -1657,6 +1663,7 @@
ForeignType = java(_),
io__write_string("java, ", !IO)
),
+ Args = list__map((func(V) = term__variable(V)), TParams),
construct_qualified_term(Name, Args, MercuryType),
mercury_output_term(MercuryType, TVarSet, no, !IO),
io__write_string(", \"", !IO),
@@ -1775,7 +1782,7 @@
solver_type_details(RepresentationType, InitPred, GroundInst, AnyInst),
!IO) :-
io__write_string("representation is ", !IO),
- mercury_output_term(RepresentationType, TVarSet, no, !IO),
+ mercury_output_type(TVarSet, no, RepresentationType, !IO),
io__write_string(",\n\t\tinitialisation is ", !IO),
mercury_output_bracketed_sym_name(InitPred, !IO),
varset__init(EmptyInstVarSet),
@@ -1865,13 +1872,13 @@
mercury_output_ctor_arg(Varset, N - T, !IO) :-
mercury_output_ctor_arg_name_prefix(N, !IO),
- mercury_output_term(T, Varset, no, !IO).
+ mercury_output_type(Varset, no, T, !IO).
mercury_output_remaining_ctor_args(_Varset, [], !IO).
mercury_output_remaining_ctor_args(Varset, [N - T | As], !IO) :-
io__write_string(", ", !IO),
mercury_output_ctor_arg_name_prefix(N, !IO),
- mercury_output_term(T, Varset, no, !IO),
+ mercury_output_type(Varset, no, T, !IO),
mercury_output_remaining_ctor_args(Varset, As, !IO).
:- pred mercury_output_ctor_arg_name_prefix(maybe(ctor_field_name)::in,
@@ -1961,11 +1968,10 @@
add_string(PredOrFuncStr, !U),
add_string(" ", !U),
(
- Types = [Type | Rest],
+ Types = [_ | _],
mercury_format_sym_name(PredName, !U),
add_string("(", !U),
- mercury_format_term(Type, VarSet, AppendVarnums, !U),
- mercury_format_remaining_terms(Rest, VarSet, AppendVarnums, !U),
+ add_list(Types, ", ", mercury_format_type(VarSet, AppendVarnums), !U),
add_string(")", !U)
;
Types = [],
@@ -1974,7 +1980,7 @@
(
MaybeWithType = yes(WithType),
add_string(" `with_type` (", !U),
- mercury_format_term(WithType, VarSet, AppendVarnums, !U),
+ mercury_format_type(VarSet, AppendVarnums, WithType, !U),
add_string(")", !U)
;
MaybeWithType = no
@@ -2081,19 +2087,17 @@
add_purity_prefix(Purity, !U),
add_string("func ", !U),
(
- Types = [Type | Rest],
+ Types = [_ | _],
mercury_format_sym_name(FuncName, !U),
add_string("(", !U),
- mercury_format_term(Type, VarSet, AppendVarnums, !U),
- mercury_format_remaining_terms(Rest, VarSet, AppendVarnums, !U),
+ add_list(Types, ", ", mercury_format_type(VarSet, AppendVarnums), !U),
add_string(")", !U)
;
Types = [],
mercury_format_bracketed_sym_name(FuncName, !U)
),
add_string(" = ", !U),
- mercury_format_term(RetType, VarSet, AppendVarnums, next_to_graphic_token,
- !U),
+ mercury_format_type(VarSet, AppendVarnums, RetType, !U),
mercury_format_class_context(ClassContext, ExistQVars, VarSet,
AppendVarnums, !U),
mercury_format_det_annotation(MaybeDet, !U),
@@ -2155,32 +2159,42 @@
<= output(U).
mercury_format_fundeps_and_prog_constraint_list(FunDeps, Constraints, VarSet,
- AppendVarnums, !U) :-
- list.map(make_fundep_constraint, FunDeps, FunDepConstraints),
- AllConstraints = FunDepConstraints ++ Constraints,
- mercury_format_prog_constraint_list(AllConstraints, VarSet, "<=",
- AppendVarnums, !U).
-
-:- pred make_fundep_constraint(prog_fundep::in, prog_constraint::out) is det.
-
-make_fundep_constraint(fundep(Domain, Range), Constraint) :-
- make_fundep_constraint_arg(Domain, DomainArg),
- make_fundep_constraint_arg(Range, RangeArg),
- Constraint = constraint(unqualified("->"), [DomainArg, RangeArg]).
-
-:- pred make_fundep_constraint_arg(list(tvar)::in, (type)::out) is det.
-
-make_fundep_constraint_arg(TVars, Arg) :-
- var_list_to_term_list(TVars, TVarTerms),
+ AppendVarNums, !U) :-
(
- TVarTerms = [],
- unexpected(this_file, "make_fundep_constraint_arg: empty list")
+ FunDeps = [],
+ Constraints = []
+ ->
+ true
;
- TVarTerms = [First | Rest],
- term.context_init(Context),
- list_to_conjunction(Context, First, Rest, Arg)
+ add_string(" <= (", !U),
+ add_list(FunDeps, ", ", mercury_format_fundep(VarSet, AppendVarNums),
+ !U),
+ (
+ Constraints = []
+ ;
+ Constraints = [_ | _],
+ (
+ FunDeps = []
+ ;
+ FunDeps = [_ | _],
+ add_string(", ", !U)
+ ),
+ add_list(Constraints, ", ",
+ mercury_format_constraint(VarSet, AppendVarNums), !U)
+ ),
+ add_string(")", !U)
).
+:- pred mercury_format_fundep(tvarset::in, bool::in, prog_fundep::in,
+ U::di, U::uo) is det <= output(U).
+
+mercury_format_fundep(VarSet, AppendVarNums, fundep(Domain, Range), !U) :-
+ add_string("(", !U),
+ add_list(Domain, ", ", mercury_format_var(VarSet, AppendVarNums), !U),
+ add_string(" -> ", !U),
+ add_list(Range, ", ", mercury_format_var(VarSet, AppendVarNums), !U),
+ add_string(")", !U).
+
:- pred mercury_format_prog_constraint_list(list(prog_constraint)::in,
tvarset::in, string::in, bool::in, U::di, U::uo) is det <= output(U).
@@ -2208,18 +2222,12 @@
mercury_format_constraint(VarSet, AppendVarnums, constraint(Name, Types), !U) :-
mercury_format_sym_name(Name, !U),
add_string("(", !U),
- add_list(Types, ", ", format_type(VarSet, AppendVarnums), !U),
+ add_list(Types, ", ", mercury_format_type(VarSet, AppendVarnums), !U),
add_string(")", !U).
-:- pred format_type(tvarset::in, bool::in, (type)::in, U::di, U::uo) is det
- <= output(U).
-
-format_type(VarSet, AppendVarnums, Type, !U) :-
- mercury_format_term(Type, VarSet, AppendVarnums, !U).
-
mercury_type_list_to_string(_, []) = "".
mercury_type_list_to_string(VarSet, [T | Ts]) = String :-
- String0 = mercury_type_to_string(VarSet, T),
+ String0 = mercury_type_to_string(VarSet, no, T),
String1 = mercury_type_list_to_string_2(VarSet, Ts),
string__append(String0, String1, String).
@@ -2227,47 +2235,25 @@
mercury_type_list_to_string_2(_, []) = "".
mercury_type_list_to_string_2(VarSet, [T | Ts]) = String :-
- String0 = mercury_type_to_string(VarSet, T),
+ String0 = mercury_type_to_string(VarSet, no, T),
String1 = mercury_type_list_to_string_2(VarSet, Ts),
string__append_list([", ", String0, String1], String).
- % XXX this should probably be a little cleverer, like
- % mercury_output_term.
-mercury_type_to_string(VarSet, term__variable(Var)) = String :-
- varset__lookup_name(VarSet, Var, String).
-mercury_type_to_string(VarSet, term__functor(Functor, Args, _)) = String :-
- (
- Functor = term__atom(FunctorName),
- ( FunctorName = "."
- ; FunctorName = ":"
- ),
- Args = [Arg1, Arg2]
- ->
- String1 = mercury_type_to_string(VarSet, Arg1),
- String2 = mercury_type_to_string(VarSet, Arg2),
- string__append_list([String1, ".", String2], String)
- ;
- (
- Functor = term__atom(String0)
- ;
- Functor = term__string(String0)
- ;
- Functor = term__integer(Int),
- string__int_to_string(Int, String0)
- ;
- Functor = term__float(Float),
- string__float_to_string(Float, String0)
- ),
- (
- Args = []
- ->
- String = String0
- ;
- ArgsString = mercury_type_list_to_string(VarSet, Args),
- string__append_list([String0, "(", ArgsString, ")"],
- String)
- )
- ).
+mercury_output_type(VarSet, AppendVarNums, Type, !IO) :-
+ mercury_format_type(VarSet, AppendVarNums, Type, !IO).
+
+mercury_type_to_string(VarSet, AppendVarNums, Type) = String :-
+ mercury_format_type(VarSet, AppendVarNums, Type, "", String).
+
+ % We convert to a term and then use mercury_format_term. The reason
+ % for this is that we have to be very careful about handling operators
+ % and precedence properly, and it is better to have the code to manage
+ % that in one place, rather than duplicated here.
+ %
+mercury_format_type(TVarSet, AppendVarNums, Type, !U) :-
+ unparse_type(Type, Term),
+ VarSet = varset__coerce(TVarSet),
+ mercury_format_term(Term, VarSet, AppendVarNums, !U).
%-----------------------------------------------------------------------------%
@@ -2751,7 +2737,7 @@
mercury_output_state_vars_using_prefix([SVar | SVars], BangPrefix, VarSet,
AppendVarnums, !IO) :-
io__write_string(BangPrefix, !IO),
- mercury_format_var(SVar, VarSet, AppendVarnums, !IO),
+ mercury_format_var(VarSet, AppendVarnums, SVar, !IO),
(
SVars \= []
->
@@ -3215,7 +3201,7 @@
mercury_output_type_subst(VarSet, AppendVarnums, Var - Type, !IO) :-
mercury_output_var(Var, VarSet, AppendVarnums, !IO),
io__write_string(" = ", !IO),
- mercury_output_term(Type, VarSet, AppendVarnums, !IO).
+ mercury_output_type(VarSet, AppendVarnums, Type, !IO).
%-----------------------------------------------------------------------------%
@@ -3491,7 +3477,7 @@
needs_quotes::in, U::di, U::uo) is det <= output(U).
mercury_format_term(term__variable(Var), VarSet, AppendVarnums, _, !U) :-
- mercury_format_var(Var, VarSet, AppendVarnums, !U).
+ mercury_format_var(VarSet, AppendVarnums, Var, !U).
mercury_format_term(term__functor(Functor, Args, _), VarSet, AppendVarnums,
NextToGraphicToken, !U) :-
(
@@ -3655,19 +3641,8 @@
:- pred mercury_format_vars(list(var(T))::in, varset(T)::in,
bool::in, U::di, U::uo) is det <= output(U).
-mercury_format_vars([], _VarSet, _AppendVarnum, !U).
-mercury_format_vars([Var | Vars], VarSet, AppendVarnum, !U) :-
- mercury_format_var(Var, VarSet, AppendVarnum, !U),
- mercury_format_vars_2(Vars, VarSet, AppendVarnum, !U).
-
-:- pred mercury_format_vars_2(list(var(T))::in, varset(T)::in,
- bool::in, U::di, U::uo) is det <= output(U).
-
-mercury_format_vars_2([], _VarSet, _AppendVarnum, !U).
-mercury_format_vars_2([Var | Vars], VarSet, AppendVarnum, !U) :-
- add_string(", ", !U),
- mercury_format_var(Var, VarSet, AppendVarnum, !U),
- mercury_format_vars_2(Vars, VarSet, AppendVarnum, !U).
+mercury_format_vars(Vars, VarSet, AppendVarnum, !U) :-
+ add_list(Vars, ", ", mercury_format_var(VarSet, AppendVarnum), !U).
% Output a single variable.
% Variables that didn't have names are given the name "V_<n>"
@@ -3676,15 +3651,15 @@
% name changed to start with `V__' to avoid name clashes.
mercury_output_var(Var, VarSet, AppendVarnum, !IO) :-
- mercury_format_var(Var, VarSet, AppendVarnum, !IO).
+ mercury_format_var(VarSet, AppendVarnum, Var, !IO).
mercury_var_to_string(Var, VarSet, AppendVarnum) = String :-
- mercury_format_var(Var, VarSet, AppendVarnum, "", String).
+ mercury_format_var(VarSet, AppendVarnum, Var, "", String).
-:- pred mercury_format_var(var(T)::in, varset(T)::in,
- bool::in, U::di, U::uo) is det <= output(U).
+:- pred mercury_format_var(varset(T)::in, bool::in, var(T)::in, U::di, U::uo)
+ is det <= output(U).
-mercury_format_var(Var, VarSet, AppendVarnum, !U) :-
+mercury_format_var(VarSet, AppendVarnum, Var, !U) :-
(
varset__search_name(VarSet, Var, Name)
->
Index: compiler/ml_call_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_call_gen.m,v
retrieving revision 1.52
diff -u -r1.52 ml_call_gen.m
--- compiler/ml_call_gen.m 12 Aug 2005 05:14:13 -0000 1.52
+++ compiler/ml_call_gen.m 11 Sep 2005 12:11:58 -0000
@@ -811,41 +811,41 @@
ml_gen_box_or_unbox_rval(SourceType, DestType, VarRval, ArgRval, !Info) :-
(
%
- % if converting from polymorphic type to concrete type,
- % then unbox
+ % If converting from polymorphic type to concrete type,
+ % then unbox.
%
- SourceType = term__variable(_),
- DestType = term__functor(_, _, _)
+ SourceType = variable(_, _),
+ DestType \= variable(_, _)
->
ml_gen_type(!.Info, DestType, MLDS_DestType),
ArgRval = unop(unbox(MLDS_DestType), VarRval)
;
%
- % if converting from concrete type to polymorphic type,
- % then box
+ % If converting from concrete type to polymorphic type,
+ % then box.
%
- SourceType = term__functor(_, _, _),
- DestType = term__variable(_)
+ SourceType \= variable(_, _),
+ DestType = variable(_, _)
->
ml_gen_type(!.Info, SourceType, MLDS_SourceType),
ArgRval = unop(box(MLDS_SourceType), VarRval)
;
%
- % if converting to float, cast to mlds__generic_type
- % and then unbox
+ % If converting to float, cast to mlds__generic_type
+ % and then unbox.
%
- DestType = term__functor(term__atom("float"), [], _),
- SourceType \= term__functor(term__atom("float"), [], _)
+ DestType = builtin(float),
+ SourceType \= builtin(float)
->
ml_gen_type(!.Info, DestType, MLDS_DestType),
ArgRval = unop(unbox(MLDS_DestType),
unop(cast(mlds__generic_type), VarRval))
;
%
- % if converting from float, box and then cast the result
+ % If converting from float, box and then cast the result.
%
- SourceType = term__functor(term__atom("float"), [], _),
- DestType \= term__functor(term__atom("float"), [], _)
+ SourceType = builtin(float),
+ DestType \= builtin(float)
->
ml_gen_type(!.Info, SourceType, MLDS_SourceType),
ml_gen_type(!.Info, DestType, MLDS_DestType),
@@ -853,7 +853,7 @@
unop(box(MLDS_SourceType), VarRval))
;
%
- % if converting from an array(T) to array(X) where
+ % If converting from an array(T) to array(X) where
% X is a concrete instance, we should insert a cast
% to the concrete instance. Also when converting to
% array(T) from array(X) we should cast to array(T).
@@ -863,20 +863,18 @@
type_to_ctor_and_args(DestType, DestTypeCtor, DestTypeArgs),
(
type_ctor_is_array(SourceTypeCtor),
- SourceTypeArgs = [term__variable(_)]
+ SourceTypeArgs = [variable(_, _)]
;
type_ctor_is_array(DestTypeCtor),
- DestTypeArgs = [term__variable(_)]
+ DestTypeArgs = [variable(_, _)]
)
->
ml_gen_type(!.Info, DestType, MLDS_DestType),
ArgRval = unop(cast(MLDS_DestType), VarRval)
;
%
- % if converting from one concrete type to a different
- % one, then cast
- %
- % This is needed to handle construction/deconstruction
+ % If converting from one concrete type to a different one, then
+ % cast. This is needed to handle construction/deconstruction
% unifications for no_tag types.
%
\+ type_util__type_unify(SourceType, DestType,
@@ -886,7 +884,7 @@
ArgRval = unop(cast(MLDS_DestType), VarRval)
;
%
- % otherwise leave unchanged
+ % Otherwise leave unchanged.
%
ArgRval = VarRval
).
@@ -936,7 +934,7 @@
% For closure wrappers, the argument type_infos are
% stored in the `type_params' local, so we need to
% handle the GC tracing code specially
- ( prog_type__var(CallerType, _TypeVar) ->
+ ( CallerType = variable(_, _) ->
ml_gen_local_for_output_arg(ArgVarName,
CalleeType, ArgNum, Context,
ArgVarDecl, !Info)
@@ -964,7 +962,7 @@
ConvOutputStatements = []
;
%
- % generate statements to box/unbox the fresh variable
+ % Generate statements to box/unbox the fresh variable
% and assign it to/from the output argument whose
% address we were passed.
%
Index: compiler/ml_code_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.154
diff -u -r1.154 ml_code_gen.m
--- compiler/ml_code_gen.m 1 Sep 2005 09:06:32 -0000 1.154
+++ compiler/ml_code_gen.m 11 Sep 2005 12:13:21 -0000
@@ -3130,7 +3130,7 @@
% Except for MC++, where polymorphic types are MR_Box,
% but we get here only if Lang is c or java.
(
- prog_type__var(OrigType, _)
+ OrigType = variable(_, _)
->
Cast = "(MR_Word) "
;
@@ -3338,7 +3338,7 @@
% `Word' in the C interface but `MR_Box' in the
% MLDS back-end.
(
- ( prog_type__var(OrigType, _)
+ ( OrigType = variable(_, _)
; Cast = yes
)
->
Index: compiler/ml_code_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_util.m,v
retrieving revision 1.91
diff -u -r1.91 ml_code_util.m
--- compiler/ml_code_util.m 22 Mar 2005 06:40:09 -0000 1.91
+++ compiler/ml_code_util.m 11 Sep 2005 12:14:30 -0000
@@ -142,10 +142,11 @@
%
:- func ml_string_type = mlds__type.
- % Allocate some fresh type variables to use as the Mercury types
- % of boxed objects (e.g. to get the argument types for tuple
- % constructors or closure constructors). Note that this should
- % only be used in cases where the tvarset doesn't matter.
+ % Allocate some fresh type variables, with kind `star', to use as
+ % the Mercury types of boxed objects (e.g. to get the argument types
+ % for tuple constructors or closure constructors). Note that this
+ % should only be used in cases where the tvarset doesn't matter.
+ %
:- func ml_make_boxed_types(arity) = list(prog_type).
%-----------------------------------------------------------------------------%
@@ -1049,7 +1050,7 @@
ml_make_boxed_types(Arity) = BoxedTypes :-
varset__init(TypeVarSet0),
varset__new_vars(TypeVarSet0, Arity, BoxedTypeVars, _TypeVarSet),
- term__var_list_to_term_list(BoxedTypeVars, BoxedTypes).
+ prog_type.var_list_to_type_list(map__init, BoxedTypeVars, BoxedTypes).
%-----------------------------------------------------------------------------%
%
@@ -2175,7 +2176,7 @@
:- pred trace_type_info_type(prog_type::in, prog_type::out) is semidet.
trace_type_info_type(Type, RealType) :-
- sym_name_and_args(Type, TypeName, _),
+ Type = defined(TypeName, _, _),
TypeName = qualified(PrivateBuiltin, Name),
mercury_private_builtin_module(PrivateBuiltin),
( Name = "type_info", RealType = sample_type_info_type
Index: compiler/ml_type_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_type_gen.m,v
retrieving revision 1.42
diff -u -r1.42 ml_type_gen.m
--- compiler/ml_type_gen.m 1 Apr 2005 14:28:59 -0000 1.42
+++ compiler/ml_type_gen.m 12 Sep 2005 01:56:43 -0000
@@ -909,7 +909,11 @@
ml_gen_type_info_member(ModuleInfo, Context, TypeVar, MLDS_Defn,
ArgNum0, ArgNum) :-
- polymorphism__build_type_info_type(term__variable(TypeVar), Type),
+ % We don't have access to the correct kind here. This won't
+ % matter though, since the type will only be checked to see that it
+ % is a variable, and won't be used in any other way.
+ Kind = star,
+ polymorphism__build_type_info_type(variable(TypeVar, Kind), Type),
ml_gen_field(ModuleInfo, Context, no, Type, MLDS_Defn, ArgNum0, ArgNum).
:- pred ml_gen_du_ctor_field(module_info::in, prog_context::in,
Index: compiler/ml_unify_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_unify_gen.m,v
retrieving revision 1.82
diff -u -r1.82 ml_unify_gen.m
--- compiler/ml_unify_gen.m 16 Aug 2005 10:42:37 -0000 1.82
+++ compiler/ml_unify_gen.m 11 Sep 2005 12:17:34 -0000
@@ -141,9 +141,9 @@
require(unify(CodeModel, model_semi),
"ml_code_gen: simple_test not semidet"),
ml_variable_type(!.Info, Var1, Type),
- ( Type = term__functor(term__atom("string"), [], _) ->
+ ( Type = builtin(string) ->
EqualityOp = str_eq
- ; Type = term__functor(term__atom("float"), [], _) ->
+ ; Type = builtin(float) ->
EqualityOp = float_eq
;
EqualityOp = eq
@@ -944,7 +944,8 @@
->
varset__init(TypeVarSet0),
varset__new_var(TypeVarSet0, TypeVar, _TypeVarSet),
- prog_type__var(BoxedFieldType, TypeVar)
+ % The kind is `star' since there are values with this type.
+ BoxedFieldType = variable(TypeVar, star)
;
BoxedFieldType = FieldType
).
@@ -1051,7 +1052,7 @@
% Handle the case where the field type is a boxed
% type -- in that case, we can just box the argument
% type.
- FieldType = term__variable(_)
+ FieldType = variable(_, _)
->
ml_gen_type(!.Info, ArgType, MLDS_ArgType),
ml_gen_box_const_rval(MLDS_ArgType, ArgRval, Context,
@@ -1097,7 +1098,7 @@
ml_gen_box_const_rval(Type, Rval, Context, ConstDefns, BoxedRval, !Info) :-
(
- ( Type = mercury_type(term__variable(_), _, _)
+ ( Type = mercury_type(variable(_, _), _, _)
; Type = mlds__generic_type
)
->
@@ -1117,8 +1118,7 @@
% since currently we don't support static
% ground term optimization for those back-ends.]
%
- ( Type = mercury_type(term__functor(term__atom("float"),
- [], _), _, _)
+ ( Type = mercury_type(builtin(float), _, _)
; Type = mlds__native_float_type
)
->
Index: compiler/mlds_to_c.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_c.m,v
retrieving revision 1.172
diff -u -r1.172 mlds_to_c.m
--- compiler/mlds_to_c.m 1 Sep 2005 09:06:34 -0000 1.172
+++ compiler/mlds_to_c.m 6 Sep 2005 14:54:41 -0000
@@ -3159,7 +3159,7 @@
FieldType, _ClassType), !IO) :-
(
( FieldType = mlds__generic_type
- ; FieldType = mlds__mercury_type(term__variable(_), _, _)
+ ; FieldType = mlds__mercury_type(variable(_, _), _, _)
)
->
io__write_string("(", !IO)
@@ -3379,8 +3379,7 @@
% casts from pointers to integers in static initializers.
mlds_output_boxed_rval(Type, InnerExprn, !IO)
;
- ( Type = mlds__mercury_type(
- term__functor(term__atom("float"), [], _), _, _)
+ ( Type = mlds__mercury_type(builtin(float), _, _)
; Type = mlds__native_float_type
)
->
@@ -3388,8 +3387,7 @@
mlds_output_rval(Exprn, !IO),
io__write_string(")", !IO)
;
- ( Type = mlds__mercury_type(term__functor(
- term__atom("character"), [], _), _, _)
+ ( Type = mlds__mercury_type(builtin(character), _, _)
; Type = mlds__native_char_type
; Type = mlds__native_bool_type
; Type = mlds__native_int_type
@@ -3425,8 +3423,7 @@
mlds_output_unboxed_rval(Type, Exprn, !IO) :-
(
- ( Type = mlds__mercury_type(term__functor(term__atom("float"),
- [], _), _, _)
+ ( Type = mlds__mercury_type(builtin(float), _, _)
; Type = mlds__native_float_type
)
->
@@ -3434,8 +3431,7 @@
mlds_output_rval(Exprn, !IO),
io__write_string(")", !IO)
;
- ( Type = mlds__mercury_type(term__functor(
- term__atom("character"), [], _), _, _)
+ ( Type = mlds__mercury_type(builtin(character), _, _)
; Type = mlds__native_char_type
; Type = mlds__native_bool_type
; Type = mlds__native_int_type
Index: compiler/mlds_to_gcc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_gcc.m,v
retrieving revision 1.105
diff -u -r1.105 mlds_to_gcc.m
--- compiler/mlds_to_gcc.m 1 Sep 2005 09:06:34 -0000 1.105
+++ compiler/mlds_to_gcc.m 6 Sep 2005 14:04:39 -0000
@@ -3223,7 +3223,7 @@
% sanity check (copied from mlds_to_c.m)
(
{ FieldType = mlds__generic_type
- ; FieldType = mlds__mercury_type(term__variable(_), _, _)
+ ; FieldType = mlds__mercury_type(variable(_, _), _, _)
}
->
[]
@@ -3443,8 +3443,7 @@
:- pred type_is_float(mlds__type::in) is semidet.
type_is_float(Type) :-
- ( Type = mlds__mercury_type(term__functor(term__atom("float"),
- [], _), _, _)
+ ( Type = mlds__mercury_type(builtin(float), _, _)
; Type = mlds__native_float_type
).
Index: compiler/mlds_to_il.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_il.m,v
retrieving revision 1.149
diff -u -r1.149 mlds_to_il.m
--- compiler/mlds_to_il.m 1 Sep 2005 09:06:34 -0000 1.149
+++ compiler/mlds_to_il.m 6 Sep 2005 14:57:26 -0000
@@ -1165,9 +1165,8 @@
)
),
- construct_qualified_term(
- qualified(unqualified("std_util"), "univ"),
- [], UnivMercuryType),
+ UnivSymName = qualified(unqualified("std_util"), "univ"),
+ UnivMercuryType = defined(UnivSymName, [], star),
UnivMLDSType = mercury_type(UnivMercuryType,
user_ctor_type, non_foreign_type(UnivMercuryType)),
UnivType = mlds_type_to_ilds_type(DataRep, UnivMLDSType),
@@ -3662,18 +3661,18 @@
mlds__func_params([], [])).
rval_const_to_type(int_const(_))
= mercury_type(IntType, int_type, non_foreign_type(IntType)) :-
- IntType = term__functor(term__atom("int"), [], context("", 0)).
+ IntType = builtin(int).
rval_const_to_type(float_const(_))
= mercury_type(FloatType, float_type, non_foreign_type(FloatType)) :-
- FloatType = term__functor(term__atom("float"), [], context("", 0)).
+ FloatType = builtin(float).
rval_const_to_type(false) = mlds__native_bool_type.
rval_const_to_type(true) = mlds__native_bool_type.
rval_const_to_type(string_const(_))
= mercury_type(StrType, str_type, non_foreign_type(StrType)) :-
- StrType = term__functor(term__atom("string"), [], context("", 0)).
+ StrType = builtin(string).
rval_const_to_type(multi_string_const(_, _))
= mercury_type(StrType, str_type, non_foreign_type(StrType)) :-
- StrType = term__functor(term__atom("string"), [], context("", 0)).
+ StrType = builtin(string).
rval_const_to_type(null(MldsType)) = MldsType.
%-----------------------------------------------------------------------------%
Index: compiler/mlds_to_java.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_java.m,v
retrieving revision 1.67
diff -u -r1.67 mlds_to_java.m
--- compiler/mlds_to_java.m 1 Sep 2005 09:06:35 -0000 1.67
+++ compiler/mlds_to_java.m 6 Sep 2005 15:07:24 -0000
@@ -2832,7 +2832,7 @@
ModuleName, !IO) :-
(
( FieldType = mlds__generic_type
- ; FieldType = mlds__mercury_type(term__variable(_), _, _))
+ ; FieldType = mlds__mercury_type(variable(_, _), _, _))
->
true
;
@@ -3066,18 +3066,15 @@
java_builtin_type(Type, "int", "java.lang.Integer", "intValue") :-
Type = mlds__native_int_type.
java_builtin_type(Type, "int", "java.lang.Integer", "intValue") :-
- Type = mlds__mercury_type(term__functor(term__atom("int"),
- [], _), _, _).
+ Type = mlds__mercury_type(builtin(int), _, _).
java_builtin_type(Type, "double", "java.lang.Double", "doubleValue") :-
Type = mlds__native_float_type.
java_builtin_type(Type, "double", "java.lang.Double", "doubleValue") :-
- Type = mlds__mercury_type(term__functor(term__atom("float"),
- [], _), _, _).
+ Type = mlds__mercury_type(builtin(float), _, _).
java_builtin_type(Type, "char", "java.lang.Character", "charValue") :-
Type = mlds__native_char_type.
java_builtin_type(Type, "char", "java.lang.Character", "charValue") :-
- Type = mlds__mercury_type(term__functor(term__atom("character"),
- [], _), _, _).
+ Type = mlds__mercury_type(builtin(character), _, _).
java_builtin_type(Type, "boolean", "java.lang.Boolean", "booleanValue") :-
Type = mlds__native_bool_type.
@@ -3086,12 +3083,10 @@
% reason they should have the Java type `int'.
%
java_builtin_type(Type, "int", "java.lang.Integer", "intValue") :-
- Type = mlds__mercury_type(term__functor(term__atom(":"), _, _), _, _),
- Type = mlds__mercury_type(MercuryType, _, _),
- type_util__is_dummy_argument_type(MercuryType).
-java_builtin_type(Type, "int", "java.lang.Integer", "intValue") :-
- Type = mlds__mercury_type(term__functor(term__atom("."), _, _), _, _),
- Type = mlds__mercury_type(MercuryType, _, _),
+ % The test for defined/3 is logically redundant since all dummy
+ % types are defined types, but enables the compiler to infer that
+ % this disjunction is a switch.
+ Type = mlds__mercury_type(MercuryType @ defined(_, _, _), _, _),
type_util__is_dummy_argument_type(MercuryType).
:- pred output_std_unop(builtin_ops__unary_op::in, mlds__rval::in,
Index: compiler/mode_errors.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mode_errors.m,v
retrieving revision 1.89
diff -u -r1.89 mode_errors.m
--- compiler/mode_errors.m 27 Aug 2005 09:41:57 -0000 1.89
+++ compiler/mode_errors.m 7 Sep 2005 06:27:53 -0000
@@ -831,7 +831,7 @@
words("with"), words(add_quotes(RHSStr)), suffix(":"), nl,
words("mode error: attempt at higher-order unification."), nl,
words("Cannot unify two terms of type"),
- words(add_quotes(mercury_term_to_string(Type, TypeVarSet, no))),
+ words(add_quotes(mercury_type_to_string(TypeVarSet, no, Type))),
suffix("."), nl],
globals__lookup_bool_option(Globals, verbose_errors, VerboseErrors),
(
Index: compiler/mode_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mode_util.m,v
retrieving revision 1.170
diff -u -r1.170 mode_util.m
--- compiler/mode_util.m 30 Aug 2005 04:11:55 -0000 1.170
+++ compiler/mode_util.m 5 Sep 2005 15:25:16 -0000
@@ -792,11 +792,10 @@
TypeCtor = qualified(TypeModule, _) - _,
module_info_types(ModuleInfo, TypeTable),
map__search(TypeTable, TypeCtor, TypeDefn),
- hlds_data__get_type_defn_tparams(TypeDefn, TypeParams0),
+ hlds_data__get_type_defn_tparams(TypeDefn, TypeParams),
hlds_data__get_type_defn_body(TypeDefn, TypeBody),
Constructors = TypeBody ^ du_type_ctors
->
- term__term_list_to_var_list(TypeParams0, TypeParams),
map__from_corresponding_lists(TypeParams, TypeArgs, ArgSubst),
propagate_ctor_info_3(ModuleInfo, ArgSubst, TypeModule, Constructors,
BoundInsts0, BoundInsts1),
@@ -876,7 +875,7 @@
( map__is_empty(Subst) ->
Type = Type0
;
- term__apply_substitution(Type0, Subst, Type)
+ apply_subst_to_type(Subst, Type0, Type)
).
%-----------------------------------------------------------------------------%
Index: compiler/modecheck_unify.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modecheck_unify.m,v
retrieving revision 1.85
diff -u -r1.85 modecheck_unify.m
--- compiler/modecheck_unify.m 30 Aug 2005 04:11:55 -0000 1.85
+++ compiler/modecheck_unify.m 3 Sep 2005 06:20:55 -0000
@@ -990,14 +990,14 @@
% [Actually we also allow `any' insts, since the (in, in)
% mode of unification for types which have `any' insts must
% also be able to handle (in(any), in(any)) unifications.]
- Type = term__variable(_),
+ Type = variable(_, _),
\+ inst_is_ground_or_any(ModuleInfo3, InitialInstX)
->
set__singleton_set(WaitingVars, X),
mode_info_error(WaitingVars, mode_error_poly_unify(X, InitialInstX),
!ModeInfo)
;
- Type = term__variable(_),
+ Type = variable(_, _),
\+ inst_is_ground_or_any(ModuleInfo3, InitialInstY)
->
set__singleton_set(WaitingVars, Y),
Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.112
diff -u -r1.112 module_qual.m
--- compiler/module_qual.m 12 Sep 2005 03:05:44 -0000 1.112
+++ compiler/module_qual.m 12 Sep 2005 04:07:41 -0000
@@ -985,64 +985,60 @@
qualify_type(Type0, Type, !Info, !IO),
qualify_type_list(Types0, Types, !Info, !IO).
+:- pred qualify_maybe_type(maybe(type)::in, maybe(type)::out,
+ mq_info::in, mq_info::out, io::di, io::uo) is det.
+
+qualify_maybe_type(no, no, !Info, !IO).
+qualify_maybe_type(yes(Type0), yes(Type), !Info, !IO) :-
+ qualify_type(Type0, Type, !Info, !IO).
+
% Qualify a type and its argument types.
%
:- pred qualify_type((type)::in, (type)::out, mq_info::in, mq_info::out,
io::di, io::uo) is det.
-qualify_type(term.variable(Var), term.variable(Var), !Info, !IO).
-qualify_type(Type0, Type, !Info, !IO) :-
- Type0 = term.functor(_, _, _),
- ( type_to_ctor_and_args(Type0, TypeCtor0, Args0) ->
- ( is_builtin_atomic_type(TypeCtor0) ->
- TypeCtor = TypeCtor0
- ; type_ctor_is_higher_order(TypeCtor0, _, _, _) ->
- TypeCtor = TypeCtor0
- ; type_ctor_is_tuple(TypeCtor0) ->
- TypeCtor = TypeCtor0
- ; type_ctor_is_variable(TypeCtor0) ->
- TypeCtor = TypeCtor0,
- % This is an error until we support higher-kinded
- % types.
- mq_info_get_error_context(!.Info, ErrorContext),
- report_invalid_type(Type0, ErrorContext, !IO),
- mq_info_set_error_flag(type_id, !Info),
- mq_info_incr_errors(!Info)
- ;
- mq_info_get_types(!.Info, Types),
- find_unique_match(TypeCtor0, TypeCtor, Types,
- type_id, !Info, !IO)
- ),
- qualify_type_list(Args0, Args, !Info, !IO),
- construct_type(TypeCtor, Args, Type)
- ;
- mq_info_get_error_context(!.Info, ErrorContext),
- report_invalid_type(Type0, ErrorContext, !IO),
- mq_info_set_error_flag(type_id, !Info),
- mq_info_incr_errors(!Info),
- Type = Type0
- ),
- %
- % The types `int', `float', and `string' are builtin types,
- % defined by the compiler, but arguably they ought to be
- % defined in int.m, float.m, and string.m, and so if someone
- % uses the type `int' in the interface, then we don't want
- % to warn about `import_module int' in the interface.
- %
- (
- Type = term.functor(term.atom(Typename), [], _),
- ( Typename = "int"
- ; Typename = "string"
- ; Typename = "float"
- )
- ->
- % -- not yet:
- % StdLibraryModule = qualified(unqualified("std"), Typename),
- StdLibraryModule = unqualified(Typename),
- mq_info_set_module_used(StdLibraryModule, !Info)
- ;
- true
- ).
+qualify_type(variable(Var, Kind), variable(Var, Kind), !Info, !IO).
+qualify_type(defined(SymName0, Args0, Kind), defined(SymName, Args, Kind),
+ !Info, !IO) :-
+ Arity = list.length(Args0),
+ TypeCtor0 = SymName0 - Arity,
+ mq_info_get_types(!.Info, Types),
+ find_unique_match(TypeCtor0, TypeCtor, Types, type_id, !Info, !IO),
+ TypeCtor = SymName - _,
+ qualify_type_list(Args0, Args, !Info, !IO).
+qualify_type(builtin(BuiltinType), builtin(BuiltinType), !Info, !IO) :-
+ %
+ % The types `int', `float', and `string' are builtin types, defined by
+ % the compiler, but arguably they ought to be defined in int.m, float.m,
+ % and string.m, and so if someone uses the type `int' in the interface,
+ % then we don't want to warn about `import_module int' in the interface.
+ % We don't do the same for `character', since the corresponding library
+ % module `char' will be flagged as used in the interface if the type
+ % `char' is used.
+ %
+ (
+ BuiltinType = int,
+ mq_info_set_module_used(unqualified("int"), !Info)
+ ;
+ BuiltinType = float,
+ mq_info_set_module_used(unqualified("float"), !Info)
+ ;
+ BuiltinType = string,
+ mq_info_set_module_used(unqualified("string"), !Info)
+ ;
+ BuiltinType = character
+ ).
+qualify_type(higher_order(Args0, MaybeRet0, Purity, EvalMethod),
+ higher_order(Args, MaybeRet, Purity, EvalMethod), !Info, !IO) :-
+ qualify_type_list(Args0, Args, !Info, !IO),
+ qualify_maybe_type(MaybeRet0, MaybeRet, !Info, !IO).
+qualify_type(tuple(Args0, Kind), tuple(Args, Kind), !Info, !IO) :-
+ qualify_type_list(Args0, Args, !Info, !IO).
+qualify_type(apply_n(Var, Args0, Kind), apply_n(Var, Args, Kind), !Info,
+ !IO) :-
+ qualify_type_list(Args0, Args, !Info, !IO).
+qualify_type(kinded(Type0, Kind), kinded(Type, Kind), !Info, !IO) :-
+ qualify_type(Type0, Type, !Info, !IO).
% Qualify the modes in a pragma c_code(...) decl.
%
@@ -1545,21 +1541,6 @@
is_or_are([_], "is").
is_or_are([_, _ | _], "are").
- % Output an error message about an ill-formed type.
- %
-:- pred report_invalid_type((type)::in, error_context::in,
- io::di, io::uo) is det.
-
-report_invalid_type(Type, ErrorContext - Context, !IO) :-
- ContextPieces = mq_error_context_to_pieces(ErrorContext),
- varset.init(VarSet),
- Pieces = [words("In")] ++ ContextPieces ++
- [suffix(":"), nl, words("error: ill-formed type"),
- fixed("`" ++ mercury_term_to_string(Type, VarSet, no) ++
- "'.")],
- write_error_pieces(Context, 0, Pieces, !IO),
- io.set_exit_status(1, !IO).
-
% Output an error message about an ill-formed user_inst.
%
:- pred report_invalid_user_inst(sym_name::in, list(inst)::in,
Index: compiler/modules.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.340
diff -u -r1.340 modules.m
--- compiler/modules.m 12 Sep 2005 03:05:44 -0000 1.340
+++ compiler/modules.m 12 Sep 2005 04:07:41 -0000
@@ -7291,7 +7291,7 @@
list__member(Constraint, Item ^ tc_constraints),
Constraint = constraint(_, ConstraintArgs),
list__member(ConstraintArg, ConstraintArgs),
- ConstraintArg \= term__variable(_)
+ type_is_nonvar(ConstraintArg)
)
->
no
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.272
diff -u -r1.272 polymorphism.m
--- compiler/polymorphism.m 9 Sep 2005 07:00:51 -0000 1.272
+++ compiler/polymorphism.m 11 Sep 2005 12:53:38 -0000
@@ -244,21 +244,21 @@
term__context::in, prog_var::out, list(hlds_goal)::out,
poly_info::in, poly_info::out) is det.
- % polymorphism__gen_extract_type_info(TypeVar, TypeClassInfoVar, Index,
- % ModuleInfo, Goals, TypeInfoVar, ...):
+ % polymorphism__gen_extract_type_info(TypeVar, Kind, TypeClassInfoVar,
+ % Index, ModuleInfo, Goals, TypeInfoVar, ...):
%
% Generate code to extract a type_info variable from a
% given slot of a typeclass_info variable, by calling
- % private_builtin:type_info_from_typeclass_info.
- % TypeVar is the type variable to which this type_info
- % variable corresponds. TypeClassInfoVar is the variable
- % holding the type_class_info. Index specifies which
- % slot it is. The procedure returns TypeInfoVar, which
- % is a fresh variable holding the type_info, and Goals,
- % which is the code generated to initialize TypeInfoVar.
+ % private_builtin.type_info_from_typeclass_info. TypeVar is the
+ % type variable to which this type_info variable corresponds.
+ % Kind is the kind of the type variable. TypeClassInfoVar is
+ % the variable holding the type_class_info. Index specifies
+ % which slot it is. The procedure returns TypeInfoVar, which is
+ % a fresh variable holding the type_info, and Goals, which is
+ % the code generated to initialize TypeInfoVar.
%
-:- pred polymorphism__gen_extract_type_info(tvar::in, prog_var::in, int::in,
- module_info::in, list(hlds_goal)::out, prog_var::out,
+:- pred polymorphism__gen_extract_type_info(tvar::in, kind::in, prog_var::in,
+ int::in, module_info::in, list(hlds_goal)::out, prog_var::out,
prog_varset::in, prog_varset::out,
map(prog_var, type)::in, map(prog_var, type)::out,
rtti_varmaps::in, rtti_varmaps::out) is det.
@@ -543,8 +543,8 @@
list__foldl(
(pred(HeadVar::in, Types0::in, Types::out) is det :-
map__lookup(Types0, HeadVar, HeadVarType0),
- term__apply_rec_substitution(HeadVarType0,
- Subn, HeadVarType),
+ apply_rec_subst_to_type(Subn, HeadVarType0,
+ HeadVarType),
map__set(Types0, HeadVar, HeadVarType, Types)
), ExtraHeadVars, VarTypes0, VarTypes),
clauses_info_set_vartypes(VarTypes, ClausesInfo0, ClausesInfo),
@@ -773,7 +773,7 @@
InstanceMethodConstraints = instance_method_constraints(_,
InstanceTypes, InstanceConstraints, ClassContext),
- term__vars_list(InstanceTypes, InstanceTVars),
+ prog_type__vars_list(InstanceTypes, InstanceTVars),
get_unconstrained_tvars(InstanceTVars, InstanceConstraints,
UnconstrainedInstanceTVars),
pred_info_arg_types(PredInfo, ArgTypeVarSet, _, _),
@@ -838,7 +838,7 @@
list__append(UnivHeadTypeClassInfoVars, ExistHeadTypeClassInfoVars,
ExtraHeadTypeClassInfoVars),
- term__vars_list(ArgTypes, HeadTypeVars),
+ prog_type__vars_list(ArgTypes, HeadTypeVars),
list__delete_elems(HeadTypeVars, UnivConstrainedTVars,
UnconstrainedTVars0),
list__delete_elems(UnconstrainedTVars0, ExistConstrainedTVars,
@@ -864,8 +864,8 @@
ArgTypeVarSet, ExistHeadTypeInfoVars, !Info)
),
- polymorphism__make_head_vars(UnconstrainedUnivTVars,
- ArgTypeVarSet, UnivHeadTypeInfoVars, !Info),
+ polymorphism__make_head_vars(UnconstrainedUnivTVars, ArgTypeVarSet,
+ UnivHeadTypeInfoVars, !Info),
list__append(UnivHeadTypeInfoVars, ExistHeadTypeInfoVars,
ExtraHeadTypeInfoVars),
@@ -949,6 +949,7 @@
!Info) :-
poly_info_get_var_types(!.Info, VarTypes0),
pred_info_arg_types(PredInfo, ArgTypes),
+ pred_info_tvar_kinds(PredInfo, KindMap),
pred_info_get_class_context(PredInfo, PredClassContext),
%
@@ -995,10 +996,8 @@
% to give the actual types, and then generate code
% to initialize the type_infos for those types
%
- term__var_list_to_term_list(UnconstrainedTVars,
- UnconstrainedTVarTerms),
- term__apply_substitution_to_list(UnconstrainedTVarTerms,
- PredToActualTypeSubst, ActualTypes),
+ apply_subst_to_tvar_list(KindMap, PredToActualTypeSubst,
+ UnconstrainedTVars, ActualTypes),
polymorphism__make_type_info_vars(ActualTypes, Context,
TypeInfoVars, ExtraTypeInfoGoals, !Info),
polymorphism__assign_var_list(TypeInfoHeadVars, TypeInfoVars,
@@ -1498,23 +1497,24 @@
ActualArgTypes, ActualRetType, Context,
ExtraVars, ExtraGoals, !Info) :-
- CtorDefn = ctor_defn(CtorTypeVarSet, CtorExistQVars,
+ CtorDefn = ctor_defn(CtorTypeVarSet, CtorExistQVars, CtorKindMap,
CtorExistentialConstraints, CtorArgTypes, CtorRetType),
%
% rename apart the type variables in the constructor definition
%
poly_info_get_typevarset(!.Info, TypeVarSet0),
- varset__merge_subst(TypeVarSet0, CtorTypeVarSet, TypeVarSet,
- CtorToParentSubst),
- term__var_list_to_term_list(CtorExistQVars, CtorExistQVarTerms),
- term__apply_substitution_to_list(CtorExistQVarTerms, CtorToParentSubst,
- ParentExistQVarsTerms),
- apply_subst_to_prog_constraint_list(CtorToParentSubst,
+ tvarset_merge_renaming(TypeVarSet0, CtorTypeVarSet, TypeVarSet,
+ CtorToParentRenaming),
+ apply_variable_renaming_to_tvar_list(CtorToParentRenaming,
+ CtorExistQVars, ParentExistQVars),
+ apply_variable_renaming_to_tvar_kind_map(CtorToParentRenaming,
+ CtorKindMap, ParentKindMap),
+ apply_variable_renaming_to_prog_constraint_list(CtorToParentRenaming,
CtorExistentialConstraints, ParentExistentialConstraints),
- term__apply_substitution_to_list(CtorArgTypes, CtorToParentSubst,
- ParentArgTypes),
- term__apply_substitution(CtorRetType, CtorToParentSubst,
+ apply_variable_renaming_to_type_list(CtorToParentRenaming,
+ CtorArgTypes, ParentArgTypes),
+ apply_variable_renaming_to_type(CtorToParentRenaming, CtorRetType,
ParentRetType),
poly_info_set_typevarset(TypeVarSet, !Info),
@@ -1559,13 +1559,10 @@
%
constraint_list_get_tvars(ParentExistentialConstraints,
ParentExistConstrainedTVars),
- term__var_list_to_term_list(ParentExistConstrainedTVars,
- ParentExistConstrainedTVarTerms),
- list__delete_elems(ParentExistQVarsTerms,
- ParentExistConstrainedTVarTerms,
- ParentUnconstrainedExistQVarTerms),
- term__apply_rec_substitution_to_list(ParentUnconstrainedExistQVarTerms,
- ParentToActualTypeSubst, ActualExistentialTypes),
+ list__delete_elems(ParentExistQVars, ParentExistConstrainedTVars,
+ ParentUnconstrainedExistQVars),
+ apply_rec_subst_to_tvar_list(ParentKindMap, ParentToActualTypeSubst,
+ ParentUnconstrainedExistQVars, ActualExistentialTypes),
%
% create type_info variables for the _unconstrained_
@@ -1642,7 +1639,7 @@
ExistVars0 = list__map(get_constrained_vars, ExistCs),
list__condense(ExistVars0, ExistConstrainedVars),
- term__vars_list(PredArgTypes, PredTypeVars0),
+ prog_type__vars_list(PredArgTypes, PredTypeVars0),
list__remove_dups(PredTypeVars0, PredTypeVars1),
list__delete_elems(PredTypeVars1, UnivConstrainedVars, PredTypeVars2),
list__delete_elems(PredTypeVars2, ExistConstrainedVars, PredTypeVars),
@@ -1678,9 +1675,7 @@
% insert type_info/typeclass_info types for all the inserted
% type_info/typeclass_info vars into the arg-types list
%
- term__var_list_to_term_list(PredTypeVars, PredTypeVarTypes),
- list__map(polymorphism__build_type_info_type, PredTypeVarTypes,
- TypeInfoTypes),
+ TypeInfoTypes = list__map((func(_) = type_info_type), PredTypeVars),
list__map(polymorphism__build_typeclass_info_type, UnivCs, UnivTypes),
list__map(polymorphism__build_typeclass_info_type, ExistCs, ExistTypes),
OrigArgTypes = TypeInfoTypes ++ UnivTypes ++ ExistTypes,
@@ -1695,7 +1690,7 @@
Constraint, MaybeArgName) :-
Constraint = constraint(Name0, Types),
mdbcomp__prim_data__sym_name_to_string(Name0, "__", Name),
- term__vars_list(Types, TypeVars),
+ prog_type__vars_list(Types, TypeVars),
TypeVarNames =
list__map(underscore_and_tvar_name(TypeVarSet), TypeVars),
string__append_list(["TypeClassInfo_for_", Name | TypeVarNames],
@@ -1799,37 +1794,39 @@
module_info_pred_info(ModuleInfo, PredId, PredInfo),
pred_info_arg_types(PredInfo, PredTypeVarSet, PredExistQVars,
PredArgTypes),
+ pred_info_tvar_kinds(PredInfo, PredKindMap),
pred_info_get_class_context(PredInfo, PredClassContext),
% VarTypes, TypeVarSet* etc come from the caller.
- % PredTypeVarSet, PredArgTypes, PredExistQVarTerms, etc come
+ % PredTypeVarSet, PredArgTypes, PredExistQVars, etc come
% directly from the callee.
- % ParentArgTypes, ParentExistQVarTerms etc come from a version
+ % ParentArgTypes, ParentExistQVars etc come from a version
% of the callee that has been renamed apart from the caller.
%
% The difference between e.g. PredArgTypes and ParentArgTypes
- % is the application of PredToParentTypeSubst, which maps the
- % type variables in the callee to new type variables in the
- % caller. Adding the new type variables to TypeVarSet0 yields
- % TypeVarSet.
+ % is the application of PredToParentTypeRenaming, which maps
+ % the type variables in the callee to new type variables in
+ % the caller. Adding the new type variables to TypeVarSet0
+ % yields TypeVarSet.
( varset__is_empty(PredTypeVarSet) ->
% optimize a common case
- map__init(PredToParentTypeSubst),
+ map__init(PredToParentTypeRenaming),
TypeVarSet = TypeVarSet0,
ParentArgTypes = PredArgTypes,
+ ParentKindMap = PredKindMap,
ParentTVars = [],
- ParentExistQVarTerms = []
+ ParentExistQVars = []
;
% (this merge might be a performance bottleneck?)
- varset__merge_subst(TypeVarSet0, PredTypeVarSet, TypeVarSet,
- PredToParentTypeSubst),
- term__apply_substitution_to_list(PredArgTypes,
- PredToParentTypeSubst, ParentArgTypes),
- term__vars_list(ParentArgTypes, ParentTVars),
- term__var_list_to_term_list(PredExistQVars,
- PredExistQVarTerms),
- term__apply_substitution_to_list(PredExistQVarTerms,
- PredToParentTypeSubst, ParentExistQVarTerms)
+ tvarset_merge_renaming(TypeVarSet0, PredTypeVarSet, TypeVarSet,
+ PredToParentTypeRenaming),
+ apply_variable_renaming_to_type_list(PredToParentTypeRenaming,
+ PredArgTypes, ParentArgTypes),
+ prog_type__vars_list(ParentArgTypes, ParentTVars),
+ apply_variable_renaming_to_tvar_kind_map(
+ PredToParentTypeRenaming, PredKindMap, ParentKindMap),
+ apply_variable_renaming_to_tvar_list(PredToParentTypeRenaming,
+ PredExistQVars, ParentExistQVars)
),
PredModule = pred_info_module(PredInfo),
@@ -1860,8 +1857,9 @@
% Compute which "parent" type variables are constrained
% by the type class constraints.
- apply_subst_to_prog_constraints(PredToParentTypeSubst,
- PredClassContext, ParentClassContext),
+ apply_variable_renaming_to_prog_constraints(
+ PredToParentTypeRenaming, PredClassContext,
+ ParentClassContext),
ParentClassContext = constraints(ParentUnivConstraints,
ParentExistConstraints),
constraint_list_get_tvars(ParentUnivConstraints,
@@ -1880,17 +1878,11 @@
list__delete_elems(ParentUnconstrainedTVars1,
ParentExistConstrainedTVars,
ParentUnconstrainedTVars),
- term__term_list_to_var_list(ParentExistQVarTerms,
- ParentExistQVars),
list__delete_elems(ParentUnconstrainedTVars, ParentExistQVars,
ParentUnconstrainedUnivTVars),
list__delete_elems(ParentUnconstrainedTVars,
ParentUnconstrainedUnivTVars,
ParentUnconstrainedExistTVars),
- term__var_list_to_term_list(ParentUnconstrainedUnivTVars,
- ParentUnconstrainedUnivTypes),
- term__var_list_to_term_list(ParentUnconstrainedExistTVars,
- ParentUnconstrainedExistTypes),
% Calculate the "parent to actual" binding.
map__apply_to_list(ArgVars0, VarTypes, ActualArgTypes),
@@ -1904,10 +1896,17 @@
list__length(ParentUnivConstraints, NumUnivConstraints),
lookup_hlds_constraint_list(ConstraintMap, unproven, GoalPath,
NumUnivConstraints, ActualUnivConstraints),
- term__apply_rec_substitution_to_list(ParentExistQVarTerms,
- ParentToActualTypeSubst, ActualExistQVarTerms),
- term__term_list_to_var_list(ActualExistQVarTerms,
- ActualExistQVars),
+ apply_rec_subst_to_tvar_list(ParentKindMap,
+ ParentToActualTypeSubst, ParentExistQVars,
+ ActualExistQVarTypes),
+ (
+ prog_type__type_list_to_var_list(ActualExistQVarTypes,
+ ActualExistQVars0)
+ ->
+ ActualExistQVars = ActualExistQVars0
+ ;
+ unexpected(this_file, "existq_tvar bound")
+ ),
goal_info_get_context(GoalInfo0, Context),
polymorphism__make_typeclass_info_vars(
ActualUnivConstraints, ActualExistQVars, Context,
@@ -1925,8 +1924,8 @@
% Make variables to hold typeinfos for unconstrained
% universal type vars.
- term__apply_rec_substitution_to_list(
- ParentUnconstrainedUnivTypes, ParentToActualTypeSubst,
+ apply_rec_subst_to_tvar_list(ParentKindMap,
+ ParentToActualTypeSubst, ParentUnconstrainedUnivTVars,
ActualUnconstrainedUnivTypes),
polymorphism__make_type_info_vars(ActualUnconstrainedUnivTypes,
Context, ExtraUnivTypeInfoVars, ExtraUnivTypeInfoGoals,
@@ -1934,8 +1933,8 @@
% Make variables to hold typeinfos for unconstrained
% existential type vars.
- term__apply_rec_substitution_to_list(
- ParentUnconstrainedExistTypes, ParentToActualTypeSubst,
+ apply_rec_subst_to_tvar_list(ParentKindMap,
+ ParentToActualTypeSubst, ParentUnconstrainedExistTVars,
ActualUnconstrainedExistTypes),
polymorphism__make_type_info_vars(
ActualUnconstrainedExistTypes, Context,
@@ -1989,10 +1988,10 @@
% Work out the bindings of type variables in the call.
%
- varset__merge_subst(TVarSet0, PredTVarSet, TVarSet,
- PredToParentTSubst),
- term__apply_substitution_to_list(OrigPredArgTypes, PredToParentTSubst,
- OrigParentArgTypes),
+ tvarset_merge_renaming(TVarSet0, PredTVarSet, TVarSet,
+ PredToParentRenaming),
+ apply_variable_renaming_to_type_list(PredToParentRenaming,
+ OrigPredArgTypes, OrigParentArgTypes),
type_list_subsumes_det(OrigParentArgTypes, ActualArgTypes0,
ParentToActualTSubst),
poly_info_set_typevarset(TVarSet, !Info),
@@ -2017,10 +2016,10 @@
)
),
list__map(GetTypeInfoTypes, CalleeExtraHeadVars, PredTypeInfoTypes),
- term__apply_substitution_to_list(PredTypeInfoTypes, PredToParentTSubst,
- ParentTypeInfoTypes),
- term__apply_rec_substitution_to_list(ParentTypeInfoTypes,
- ParentToActualTSubst, ActualTypeInfoTypes),
+ apply_variable_renaming_to_type_list(PredToParentRenaming,
+ PredTypeInfoTypes, ParentTypeInfoTypes),
+ apply_rec_subst_to_type_list(ParentToActualTSubst, ParentTypeInfoTypes,
+ ActualTypeInfoTypes),
% Construct goals to make the required type_infos.
%
@@ -2037,26 +2036,6 @@
CallGoal = CallGoalExpr - GoalInfo,
conj_list_to_goal(ExtraGoals ++ [CallGoal], GoalInfo, Goal).
-:- pred unify_corresponding_types(list(type)::in, list(type)::in,
- tsubst::in, tsubst::out) is det.
-
-unify_corresponding_types([], [], !Subst).
-unify_corresponding_types([], [_ | _], !Subst) :-
- error("polymorphism__unify_corresponding_types: " ++
- "differing list lengths").
-unify_corresponding_types([_ | _], [], !Subst) :-
- error("polymorphism__unify_corresponding_types: " ++
- "differing list lengths").
-unify_corresponding_types([A | As], [B | Bs], !Subst) :-
- (
- term__unify(A, B, !Subst)
- ->
- unify_corresponding_types(As, Bs, !Subst)
- ;
- error("polymorphism__unify_corresponding_types: " ++
- "term__unify failed")
- ).
-
%-----------------------------------------------------------------------------%
:- pred polymorphism__fixup_quantification(list(prog_var)::in,
@@ -2261,8 +2240,9 @@
ClassId, InstanceNum, ExistQVars, Context, MaybeVar,
!ExtraGoals, !Info) :-
Constraint = constraint(_ClassName, ConstrainedTypes),
- !.Info = poly_info(_VarSet0, _VarTypes0, TypeVarSet, _RttiVarMaps0,
- Proofs, _ConstraintMap, _PredName, ModuleInfo),
+ TypeVarSet = !.Info ^ typevarset,
+ Proofs = !.Info ^ proof_map,
+ ModuleInfo = !.Info ^ module_info,
module_info_instances(ModuleInfo, InstanceTable),
map__lookup(InstanceTable, ClassId, InstanceList),
@@ -2270,8 +2250,12 @@
ProofInstanceDefn = hlds_instance_defn(_, _, _, InstanceConstraints0,
InstanceTypes0, _, _, InstanceTVarset, SuperClassProofs0),
+
+ % XXX kind inference:
+ % we assume all tvars have kind `star'.
+ map__init(KindMap),
- term__vars_list(InstanceTypes0, InstanceTvars),
+ prog_type__vars_list(InstanceTypes0, InstanceTvars),
get_unconstrained_tvars(InstanceTvars,
InstanceConstraints0, UnconstrainedTvars0),
@@ -2280,27 +2264,28 @@
% when we call type_list_subsumes then apply
% the resulting bindings.
% XXX expand comment
- varset__merge_subst(TypeVarSet, InstanceTVarset,
- _NewTVarset, RenameSubst),
- term__apply_substitution_to_list(InstanceTypes0,
- RenameSubst, InstanceTypes),
+ tvarset_merge_renaming(TypeVarSet, InstanceTVarset,
+ _NewTVarset, Renaming),
+ apply_variable_renaming_to_type_list(Renaming, InstanceTypes0,
+ InstanceTypes),
type_list_subsumes_det(InstanceTypes, ConstrainedTypes, InstanceSubst),
- apply_subst_to_prog_constraint_list(RenameSubst,
+ apply_variable_renaming_to_prog_constraint_list(Renaming,
InstanceConstraints0, InstanceConstraints1),
apply_rec_subst_to_prog_constraint_list(InstanceSubst,
InstanceConstraints1, InstanceConstraints2),
% XXX document diamond as guess
InstanceConstraints = InstanceConstraints2 `list__delete_elems` Seen,
- apply_subst_to_constraint_proofs(RenameSubst,
+ apply_variable_renaming_to_constraint_proofs(Renaming,
SuperClassProofs0, SuperClassProofs1),
apply_rec_subst_to_constraint_proofs(InstanceSubst,
SuperClassProofs1, SuperClassProofs2),
- term__var_list_to_term_list(UnconstrainedTvars0, UnconstrainedTypes0),
- term__apply_substitution_to_list(UnconstrainedTypes0, RenameSubst,
- UnconstrainedTypes1),
- term__apply_rec_substitution_to_list(UnconstrainedTypes1,
- InstanceSubst, UnconstrainedTypes),
+ apply_variable_renaming_to_tvar_list(Renaming, UnconstrainedTvars0,
+ UnconstrainedTvars1),
+ apply_variable_renaming_to_tvar_kind_map(Renaming, KindMap,
+ RenamedKindMap),
+ apply_rec_subst_to_tvar_list(RenamedKindMap, InstanceSubst,
+ UnconstrainedTvars1, UnconstrainedTypes),
% XXX why name of output?
map__overlay(Proofs, SuperClassProofs2, SuperClassProofs),
@@ -2533,15 +2518,14 @@
SuperClasses0 = ClassDefn ^ class_supers,
ClassVars0 = ClassDefn ^ class_vars,
ClassTVarSet = ClassDefn ^ class_tvarset,
- varset__merge_subst(TVarSet0, ClassTVarSet, TVarSet1, Subst),
+ tvarset_merge_renaming(TVarSet0, ClassTVarSet, TVarSet1, Renaming),
poly_info_set_typevarset(TVarSet1, !Info),
- map__apply_to_list(ClassVars0, Subst, ClassVars1),
- term__vars_list(ClassVars1, ClassVars),
+ apply_variable_renaming_to_tvar_list(Renaming, ClassVars0, ClassVars),
map__from_corresponding_lists(ClassVars, InstanceTypes, TypeSubst),
- apply_subst_to_prog_constraint_list(Subst, SuperClasses0,
- SuperClasses1),
+ apply_variable_renaming_to_prog_constraint_list(Renaming,
+ SuperClasses0, SuperClasses1),
apply_rec_subst_to_prog_constraint_list(TypeSubst, SuperClasses1,
SuperClasses),
@@ -2675,7 +2659,7 @@
% Now handle the cases of types which are not known statically
% (i.e. type variables)
%
- Type = term__variable(TypeVar)
+ Type = variable(TypeVar, _)
->
get_type_info_locn(TypeVar, TypeInfoLocn, !Info),
get_type_info(TypeInfoLocn, TypeVar, ExtraGoals, Var, !Info)
@@ -2683,8 +2667,8 @@
error("polymorphism__make_var: unknown type")
).
-:- pred get_type_info_locn(tvar::in, type_info_locn::out,
- poly_info::in, poly_info::out) is det.
+:- pred get_type_info_locn(tvar::in, type_info_locn::out, poly_info::in,
+ poly_info::out) is det.
get_type_info_locn(TypeVar, TypeInfoLocn, !Info) :-
%
@@ -2711,7 +2695,8 @@
% not in a type_info variable. maybe_extract_type_info
% will fix this up when the typeclass_info is created.
%
- prog_type__var(Type, TypeVar),
+ get_tvar_kind(!.Info ^ tvar_kinds, TypeVar, Kind),
+ Type = variable(TypeVar, Kind),
polymorphism__new_type_info_var(Type, type_info, Var, !Info),
TypeInfoLocn = type_info(Var),
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
@@ -2815,7 +2800,7 @@
% a type_info, we need to adjust its type.
% Since type_ctor_info_const cons_ids are handled
% specially, this should not cause problems.
- polymorphism__build_type_info_type(type_info, Type,
+ polymorphism__build_type_info_type_2(type_info,
TypeInfoType),
map__det_update(!.VarTypes, TypeCtorVar, TypeInfoType,
!:VarTypes),
@@ -2979,7 +2964,8 @@
polymorphism__make_head_vars([], _, [], !Info).
polymorphism__make_head_vars([TypeVar | TypeVars], TypeVarSet, TypeInfoVars,
!Info) :-
- Type = term__variable(TypeVar),
+ get_tvar_kind(!.Info ^ tvar_kinds, TypeVar, Kind),
+ Type = variable(TypeVar, Kind),
polymorphism__new_type_info_var(Type, type_info, Var, !Info),
( varset__search_name(TypeVarSet, TypeVar, TypeVarName) ->
poly_info_get_varset(!.Info, VarSet0),
@@ -3025,7 +3011,7 @@
),
string__append(Prefix, VarNumStr, Name),
varset__name_var(!.VarSet, Var, Name, !:VarSet),
- polymorphism__build_type_info_type(Kind, Type, TypeInfoType),
+ polymorphism__build_type_info_type_2(Kind, TypeInfoType),
map__set(!.VarTypes, Var, TypeInfoType, !:VarTypes).
:- func typeinfo_prefix = string.
@@ -3068,19 +3054,22 @@
poly_info_get_var_types(!.Info, VarTypes0),
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
poly_info_get_module_info(!.Info, ModuleInfo),
- polymorphism__gen_extract_type_info(TypeVar, TypeClassInfoVar, Index,
- ModuleInfo, Goals, TypeInfoVar, VarSet0, VarSet,
+ poly_info_get_tvar_kinds(!.Info, TVarKinds),
+ get_tvar_kind(TVarKinds, TypeVar, Kind),
+ polymorphism__gen_extract_type_info(TypeVar, Kind, TypeClassInfoVar,
+ Index, ModuleInfo, Goals, TypeInfoVar, VarSet0, VarSet,
VarTypes0, VarTypes, RttiVarMaps0, RttiVarMaps),
poly_info_set_varset_and_types(VarSet, VarTypes, !Info),
poly_info_set_rtti_varmaps(RttiVarMaps, !Info).
-polymorphism__gen_extract_type_info(TypeVar, TypeClassInfoVar, Index,
+polymorphism__gen_extract_type_info(TypeVar, Kind, TypeClassInfoVar, Index,
ModuleInfo, Goals, TypeInfoVar, !VarSet, !VarTypes,
!RttiVarMaps) :-
make_int_const_construction(Index, yes("TypeInfoIndex"),
IndexGoal, IndexVar, !VarTypes, !VarSet),
- polymorphism__new_type_info_var_raw(term__variable(TypeVar), type_info,
- TypeInfoVar, !VarSet, !VarTypes, !RttiVarMaps),
+ Type = variable(TypeVar, Kind),
+ polymorphism__new_type_info_var_raw(Type, type_info, TypeInfoVar,
+ !VarSet, !VarTypes, !RttiVarMaps),
goal_util__generate_simple_call(mercury_private_builtin_module,
"type_info_from_typeclass_info", predicate, only_mode, det,
[TypeClassInfoVar, IndexVar, TypeInfoVar], [],
@@ -3138,7 +3127,7 @@
% The first type_info will be just after the superclass
% infos.
First = NumSuperClasses + 1,
- term__vars_list(ClassTypes, ClassTypeVars0),
+ prog_type__vars_list(ClassTypes, ClassTypeVars0),
MakeIndex = (pred(Elem0::in, Elem::out,
Index0::in, Index::out) is det :-
Elem = Elem0 - Index0,
@@ -3210,18 +3199,12 @@
poly_info_set_varset_and_types(VarSet, VarTypes, !Info),
poly_info_set_rtti_varmaps(RttiVarMaps, !Info).
-polymorphism__build_typeclass_info_type(Constraint, DictionaryType) :-
- Constraint = constraint(SymName, ArgTypes),
-
- % `constraint/n' is not really a type - it is a representation of a
- % class constraint about which a typeclass_info holds information.
- % `type_util:type_to_ctor_and_args' treats it as a type variable.
- construct_qualified_term(SymName, [], ClassNameTerm),
+polymorphism__build_typeclass_info_type(_Constraint, DictionaryType) :-
+ % Note: we no longer store meaningful information in the argument
+ % of typeclass_info/1.
PrivateBuiltin = mercury_private_builtin_module,
- construct_qualified_term(qualified(PrivateBuiltin, "constraint"),
- [ClassNameTerm | ArgTypes], ConstraintTerm),
- construct_type(qualified(PrivateBuiltin, "typeclass_info") - 1,
- [ConstraintTerm], DictionaryType).
+ TypeclassInfoTypeName = qualified(PrivateBuiltin, "typeclass_info"),
+ DictionaryType = defined(TypeclassInfoTypeName, [void_type], star).
%---------------------------------------------------------------------------%
@@ -3256,18 +3239,18 @@
% of the current predicate won't treat it as such.
Kind = type_info
),
- polymorphism__build_type_info_type(Kind, Type, TypeInfoType).
+ polymorphism__build_type_info_type_2(Kind, TypeInfoType).
-:- pred polymorphism__build_type_info_type(type_info_kind::in,
- (type)::in, (type)::out) is det.
+:- pred polymorphism__build_type_info_type_2(type_info_kind::in, (type)::out)
+ is det.
-polymorphism__build_type_info_type(Kind, Type, TypeInfoType) :-
+polymorphism__build_type_info_type_2(Kind, TypeInfoType) :-
(
Kind = type_info,
- TypeInfoType = type_info_type(Type)
+ TypeInfoType = type_info_type
;
Kind = type_ctor_info,
- TypeInfoType = type_ctor_info_type(Type)
+ TypeInfoType = type_ctor_info_type
).
%---------------------------------------------------------------------------%
@@ -3437,17 +3420,21 @@
get_constrained_vars(Constraint) = CVars :-
Constraint = constraint(_, CTypes),
- term__vars_list(CTypes, CVars).
+ prog_type__vars_list(CTypes, CVars).
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
:- type poly_info --->
poly_info(
- % the first three fields are from the proc_info
+ % The first two fields are from the proc_info.
varset :: prog_varset,
vartypes :: vartypes,
+
+ % The next two fields from the pred_info.
typevarset :: tvarset,
+ tvar_kinds :: tvar_kind_map,
+
rtti_varmaps :: rtti_varmaps,
% Gives information about the locations
% of type_infos and typeclass_infos.
@@ -3485,39 +3472,44 @@
clauses_info_varset(ClausesInfo, VarSet),
clauses_info_vartypes(ClausesInfo, VarTypes),
pred_info_typevarset(PredInfo, TypeVarSet),
+ pred_info_tvar_kinds(PredInfo, TypeVarKinds),
pred_info_get_constraint_proofs(PredInfo, Proofs),
pred_info_get_constraint_map(PredInfo, ConstraintMap),
rtti_varmaps_init(RttiVarMaps),
- PolyInfo = poly_info(VarSet, VarTypes, TypeVarSet, RttiVarMaps,
- Proofs, ConstraintMap, PredInfo, ModuleInfo).
+ PolyInfo = poly_info(VarSet, VarTypes, TypeVarSet, TypeVarKinds,
+ RttiVarMaps, Proofs, ConstraintMap, PredInfo, ModuleInfo).
% create_poly_info creates a poly_info for an existing procedure.
% (See also init_poly_info.)
create_poly_info(ModuleInfo, PredInfo, ProcInfo, PolyInfo) :-
pred_info_typevarset(PredInfo, TypeVarSet),
+ pred_info_tvar_kinds(PredInfo, TypeVarKinds),
pred_info_get_constraint_proofs(PredInfo, Proofs),
pred_info_get_constraint_map(PredInfo, ConstraintMap),
proc_info_varset(ProcInfo, VarSet),
proc_info_vartypes(ProcInfo, VarTypes),
proc_info_rtti_varmaps(ProcInfo, RttiVarMaps),
- PolyInfo = poly_info(VarSet, VarTypes, TypeVarSet, RttiVarMaps,
- Proofs, ConstraintMap, PredInfo, ModuleInfo).
+ PolyInfo = poly_info(VarSet, VarTypes, TypeVarSet, TypeVarKinds,
+ RttiVarMaps, Proofs, ConstraintMap, PredInfo, ModuleInfo).
poly_info_extract(Info, !PredInfo, !ProcInfo, ModuleInfo) :-
- Info = poly_info(VarSet, VarTypes, TypeVarSet, RttiVarMaps, _Proofs,
- _ConstraintMap, _OldPredInfo, ModuleInfo),
+ Info = poly_info(VarSet, VarTypes, TypeVarSet, TypeVarKinds,
+ RttiVarMaps, _Proofs, _ConstraintMap, _OldPredInfo,
+ ModuleInfo),
% set the new values of the fields in proc_info and pred_info
proc_info_set_varset(VarSet, !ProcInfo),
proc_info_set_vartypes(VarTypes, !ProcInfo),
proc_info_set_rtti_varmaps(RttiVarMaps, !ProcInfo),
- pred_info_set_typevarset(TypeVarSet, !PredInfo).
+ pred_info_set_typevarset(TypeVarSet, !PredInfo),
+ pred_info_set_tvar_kinds(TypeVarKinds, !PredInfo).
%---------------------------------------------------------------------------%
:- pred poly_info_get_varset(poly_info::in, prog_varset::out) is det.
:- pred poly_info_get_var_types(poly_info::in, vartypes::out) is det.
:- pred poly_info_get_typevarset(poly_info::in, tvarset::out) is det.
+:- pred poly_info_get_tvar_kinds(poly_info::in, tvar_kind_map::out) is det.
:- pred poly_info_get_rtti_varmaps(poly_info::in, rtti_varmaps::out) is det.
:- pred poly_info_get_proofs(poly_info::in, constraint_proof_map::out) is det.
:- pred poly_info_get_constraint_map(poly_info::in, constraint_map::out)
@@ -3528,6 +3520,7 @@
poly_info_get_varset(PolyInfo, PolyInfo ^ varset).
poly_info_get_var_types(PolyInfo, PolyInfo ^ vartypes).
poly_info_get_typevarset(PolyInfo, PolyInfo ^ typevarset).
+poly_info_get_tvar_kinds(PolyInfo, PolyInfo ^ tvar_kinds).
poly_info_get_rtti_varmaps(PolyInfo, PolyInfo ^ rtti_varmaps).
poly_info_get_proofs(PolyInfo, PolyInfo ^ proof_map).
poly_info_get_constraint_map(PolyInfo, PolyInfo ^ constraint_map).
@@ -3540,6 +3533,8 @@
poly_info::in, poly_info::out) is det.
:- pred poly_info_set_typevarset(tvarset::in, poly_info::in,
poly_info::out) is det.
+:- pred poly_info_set_tvar_kinds(tvar_kind_map::in, poly_info::in,
+ poly_info::out) is det.
:- pred poly_info_set_rtti_varmaps(rtti_varmaps::in,
poly_info::in, poly_info::out) is det.
:- pred poly_info_set_proofs(constraint_proof_map::in,
@@ -3553,6 +3548,7 @@
poly_info_set_varset_and_types(VarSet, VarTypes, PI,
(PI ^ varset := VarSet) ^ vartypes := VarTypes).
poly_info_set_typevarset(TVarSet, PI, PI ^ typevarset := TVarSet).
+poly_info_set_tvar_kinds(TVarKinds, PI, PI ^ tvar_kinds := TVarKinds).
poly_info_set_rtti_varmaps(RttiVarMaps, PI, PI ^ rtti_varmaps := RttiVarMaps).
poly_info_set_proofs(Proofs, PI, PI ^ proof_map := Proofs).
poly_info_set_constraint_map(ConstraintMap, PI,
Index: compiler/post_typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/post_typecheck.m,v
retrieving revision 1.77
diff -u -r1.77 post_typecheck.m
--- compiler/post_typecheck.m 30 Aug 2005 04:11:57 -0000 1.77
+++ compiler/post_typecheck.m 11 Sep 2005 15:27:28 -0000
@@ -305,7 +305,7 @@
check_type_bindings_2([], _, !Errs, !Set).
check_type_bindings_2([Var - Type | VarTypes], HeadTypeParams, !Errs, !Set) :-
- term__vars(Type, TVars),
+ prog_type__vars(Type, TVars),
set__list_to_set(TVars, TVarsSet0),
set__delete_list(TVarsSet0, HeadTypeParams, TVarsSet1),
( \+ set__empty(TVarsSet1) ->
@@ -319,37 +319,25 @@
%
% bind all the type variables in `UnboundTypeVarsSet' to the type `void' ...
%
-:- pred bind_type_vars_to_void(set(tvar)::in,
- map(prog_var, type)::in, map(prog_var, type)::out,
+:- pred bind_type_vars_to_void(set(tvar)::in, vartypes::in, vartypes::out,
constraint_proof_map::in, constraint_proof_map::out,
constraint_map::in, constraint_map::out) is det.
bind_type_vars_to_void(UnboundTypeVarsSet, !VarTypesMap, !Proofs,
!ConstraintMap) :-
%
- % first create a pair of corresponding lists (UnboundTypeVars, Voids)
- % that map the unbound type variables to void
+ % Create a substitution that maps all of the unbound type variables
+ % to `void'.
%
- set__to_sorted_list(UnboundTypeVarsSet, UnboundTypeVars),
- list__length(UnboundTypeVars, Length),
- list__duplicate(Length, void_type, Voids),
-
- %
- % then create a *substitution* that maps the
- % unbound type variables to void.
- %
- map__from_corresponding_lists(UnboundTypeVars, Voids, VoidSubst),
+ MapToVoid = (pred(TVar::in, Subst0::in, Subst::out) is det :-
+ map__det_insert(Subst0, TVar, void_type, Subst)
+ ),
+ set__fold(MapToVoid, UnboundTypeVarsSet, map__init, VoidSubst),
%
- % then apply the substitutions we just created to the variable types
- % and constraint proofs
+ % Then apply the substitution we just created to the various maps.
%
- map__keys(!.VarTypesMap, Vars),
- map__values(!.VarTypesMap, Types0),
- term__substitute_corresponding_list(UnboundTypeVars, Voids,
- Types0, Types),
- map__from_corresponding_lists(Vars, Types, !:VarTypesMap),
-
+ apply_subst_to_type_map(VoidSubst, !VarTypesMap),
apply_subst_to_constraint_proofs(VoidSubst, !Proofs),
apply_subst_to_constraint_map(VoidSubst, !ConstraintMap).
@@ -436,15 +424,15 @@
:- pred write_type_var_list(assoc_list(prog_var, (type))::in, prog_context::in,
prog_varset::in, tvarset::in, io::di, io::uo) is det.
-write_type_var_list([], _, _, _) --> [].
-write_type_var_list([Var - Type | Rest], Context, VarSet, TVarSet) -->
- prog_out__write_context(Context),
- io__write_string(" "),
- mercury_output_var(Var, VarSet, no),
- io__write_string(": "),
- mercury_output_term(Type, TVarSet, no),
- io__write_string("\n"),
- write_type_var_list(Rest, Context, VarSet, TVarSet).
+write_type_var_list([], _, _, _, !IO).
+write_type_var_list([Var - Type | Rest], Context, VarSet, TVarSet, !IO) :-
+ prog_out__write_context(Context, !IO),
+ io__write_string(" ", !IO),
+ mercury_output_var(Var, VarSet, no, !IO),
+ io__write_string(": ", !IO),
+ mercury_output_type(TVarSet, no, Type, !IO),
+ io__nl(!IO),
+ write_type_var_list(Rest, Context, VarSet, TVarSet, !IO).
%-----------------------------------------------------------------------------%
% resolve predicate overloading
@@ -1333,10 +1321,11 @@
module_info_types(ModuleInfo, Types),
map__search(Types, TypeCtor, TypeDefn),
hlds_data__get_type_defn_tvarset(TypeDefn, TypeTVarSet),
+ hlds_data__get_type_defn_kind_map(TypeDefn, TypeKindMap),
assoc_list__values(ConsArgs, ConsArgTypes),
- arg_type_list_subsumes(TVarSet, ArgTypes,
- TypeTVarSet, ConsExistQVars, ConsArgTypes).
+ arg_type_list_subsumes(TVarSet, ArgTypes, TypeTVarSet, TypeKindMap,
+ ConsExistQVars, ConsArgTypes).
%-----------------------------------------------------------------------------%
@@ -1403,8 +1392,8 @@
type_list_subsumes([FieldArgType], [FieldType],
FieldSubst)
->
- term__apply_rec_substitution_to_list(ArgTypes0,
- FieldSubst, ArgTypes)
+ apply_rec_subst_to_type_list(FieldSubst, ArgTypes0,
+ ArgTypes)
;
error("post_typecheck__translate_get_function: " ++
"type_list_subsumes failed")
@@ -1529,19 +1518,18 @@
pred_info_set_typevarset(TVarSet, !PredInfo),
map__from_corresponding_lists(ExistQVars, NewExistQVars,
TVarSubst),
- term__apply_variable_renaming_to_list(ArgTypes0, TVarSubst,
+ apply_variable_renaming_to_type_list(TVarSubst, ArgTypes0,
ArgTypes1)
),
hlds_data__get_type_defn_tparams(TypeDefn, TypeParams),
- term__term_list_to_var_list(TypeParams, TypeDefnArgs),
( type_to_ctor_and_args(TermType, _, TypeArgs) ->
- map__from_corresponding_lists(TypeDefnArgs, TypeArgs, TSubst)
+ map__from_corresponding_lists(TypeParams, TypeArgs, TSubst)
;
error("get_cons_id_arg_types_adding_existq_tvars: " ++
"type_to_ctor_and_args failed")
),
- term__apply_substitution_to_list(ArgTypes1, TSubst, ArgTypes).
+ apply_subst_to_type_list(TSubst, ArgTypes1, ArgTypes).
:- pred split_list_at_index(int::in, list(T)::in, list(T)::out, T::out,
list(T)::out) is det.
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.136
diff -u -r1.136 prog_data.m
--- compiler/prog_data.m 12 Sep 2005 03:05:45 -0000 1.136
+++ compiler/prog_data.m 12 Sep 2005 04:07:42 -0000
@@ -1426,25 +1426,52 @@
% The name of a user-defined comparison predicate.
:- type comparison_pred == sym_name.
- % probably type parameters should be variables not terms.
-:- type type_param == term(tvar_type).
+ % Parameters of type definitions.
+:- type type_param == tvar.
- % Module qualified types are represented as ':'/2 terms.
- % Use type_util:type_to_ctor_and_args to convert a type to a qualified
- % type_ctor and a list of arguments.
- % type_util:construct_type to construct a type from a type_ctor
- % and a list of arguments.
+ % Use type_util.type_to_ctor_and_args to convert a type to a qualified
+ % type_ctor and a list of arguments. Use type_util.construct_type to
+ % construct a type from a type_ctor and a list of arguments.
%
- % The `term__context's of the type terms must be empty (as
- % returned by term__context_init). prog_io_util__convert_type
- % ensures this is the case. There are at least two reasons that this
- % is required:
- % - Various parts of the code to handle typeclasses create maps
- % indexed by `prog_constraint's, which contain types.
- % - Smart recompilation requires that the items which occur in
- % interface files can be unified using the builtin unification
- % operation.
-:- type (type) == term(tvar_type).
+:- type (type)
+ ---> variable(tvar, kind)
+ % A type variable.
+
+ ; defined(sym_name, list(type), kind)
+ % A user defined type constructor.
+
+ ; builtin(builtin_type)
+ % These are all known to have kind `star'.
+
+ % The above three functors should be kept as the first three, since
+ % they will be the most commonly used and therefore we want them to
+ % get the primary tags on a 32-bit machine.
+
+ ; higher_order(list(type), maybe(type), purity,
+ lambda_eval_method)
+ % A type for higher-order values. If the second
+ % argument is yes(T) then the values are functions
+ % returning T, otherwise they are predicates. The
+ % kind is always `star'.
+
+ ; tuple(list(type), kind)
+ % Tuple types.
+
+ ; apply_n(tvar, list(type), kind)
+ % An apply/N expression. `apply_n(V, [T1, ...], K)'
+ % would be the representation of type `V(T1, ...)'
+ % with kind K. The list must be non-empty.
+
+ ; kinded((type), kind).
+ % A type expression with an explicit kind annotation.
+ % (These are not yet used.)
+
+:- type builtin_type
+ ---> int
+ ; float
+ ; string
+ ; character.
+
:- type type_term == term(tvar_type).
:- type tvar_type ---> type_var.
@@ -1453,6 +1480,7 @@
:- type tvarset == varset(tvar_type).
% used for sets of type variables
:- type tsubst == map(tvar, type). % used for type substitutions
+:- type tvar_renaming == map(tvar, tvar). % type renaming
:- type type_ctor == pair(sym_name, arity).
@@ -1472,6 +1500,55 @@
---> true
; where(term).
+ % Similar to varset__merge_subst but produces a tvar_renaming
+ % instead of a substitution, which is more suitable for types.
+ %
+:- pred tvarset_merge_renaming(tvarset::in, tvarset::in, tvarset::out,
+ tvar_renaming::out) is det.
+
+ % As above, but behaves like varset__merge_subst_without_names.
+ %
+:- pred tvarset_merge_renaming_without_names(tvarset::in, tvarset::in,
+ tvarset::out, tvar_renaming::out) is det.
+
+%-----------------------------------------------------------------------------%
+%
+% Kinds.
+%
+
+ % Note that we don't support any kind other than `star' at the
+ % moment. The other kinds are intended for the implementation
+ % of constructor classes.
+ %
+:- type kind
+ ---> star
+ % An ordinary type.
+
+ ; arrow(kind, kind)
+ % A type with kind `A' applied to a type with kind
+ % `arrow(A, B)' will have kind `B'.
+
+ ; variable(kvar).
+ % A kind variable. These can be used during kind
+ % inference; after kind inference, all remaining
+ % kind variables will be bound to `star'.
+
+:- type kvar_type ---> kind_var.
+:- type kvar == var(kvar_type).
+
+ % The kinds of type variables. For efficiency, we only have entries
+ % for type variables that have a kind other than `star'. Any type
+ % variable not appearing in this map, which will usually be the
+ % majority of type variables, can be assumed to have kind `star'.
+ %
+:- type tvar_kind_map == map(tvar, kind).
+
+:- pred get_tvar_kind(tvar_kind_map::in, tvar::in, kind::out) is det.
+
+ % Return the kind of a type.
+ %
+:- func get_type_kind(type) = kind.
+
%-----------------------------------------------------------------------------%
%
% insts and modes
@@ -1802,6 +1879,8 @@
:- implementation.
+:- import_module parse_tree.error_util.
+
:- import_module string.
:- type pragma_foreign_proc_attributes
@@ -1936,5 +2015,45 @@
"max_stack_size(" ++ string__int_to_string(Size) ++ ")".
%-----------------------------------------------------------------------------%
+
+tvarset_merge_renaming(TVarSetA, TVarSetB, TVarSet, Renaming) :-
+ varset__merge_subst(TVarSetA, TVarSetB, TVarSet, Subst),
+ map__map_values(convert_subst_term_to_tvar, Subst, Renaming).
+
+tvarset_merge_renaming_without_names(TVarSetA, TVarSetB, TVarSet, Renaming) :-
+ varset__merge_subst_without_names(TVarSetA, TVarSetB, TVarSet, Subst),
+ map__map_values(convert_subst_term_to_tvar, Subst, Renaming).
+
+:- pred convert_subst_term_to_tvar(tvar::in, term(tvar_type)::in, tvar::out)
+ is det.
+
+convert_subst_term_to_tvar(_, variable(TVar), TVar).
+convert_subst_term_to_tvar(_, functor(_, _, _), _) :-
+ unexpected(this_file, "non-variable found in renaming").
+
+%-----------------------------------------------------------------------------%
+
+get_tvar_kind(Map, TVar, Kind) :-
+ ( map__search(Map, TVar, Kind0) ->
+ Kind = Kind0
+ ;
+ Kind = star
+ ).
+
+get_type_kind(variable(_, Kind)) = Kind.
+get_type_kind(defined(_, _, Kind)) = Kind.
+get_type_kind(builtin(_)) = star.
+get_type_kind(higher_order(_, _, _, _)) = star.
+get_type_kind(tuple(_, Kind)) = Kind.
+get_type_kind(apply_n(_, _, Kind)) = Kind.
+get_type_kind(kinded(_, Kind)) = Kind.
+
+%-----------------------------------------------------------------------------%
+
+:- func this_file = string.
+
+this_file = "prog_data.m".
+
+%-----------------------------------------------------------------------------%
:- end_module prog_data.
%-----------------------------------------------------------------------------%
Index: compiler/prog_io.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io.m,v
retrieving revision 1.247
diff -u -r1.247 prog_io.m
--- compiler/prog_io.m 12 Sep 2005 03:05:46 -0000 1.247
+++ compiler/prog_io.m 12 Sep 2005 04:07:42 -0000
@@ -180,7 +180,7 @@
%
% Check the head of a type definition for errors.
:- pred parse_type_defn_head(module_name::in, term::in, term::in,
- maybe_functor::out) is det.
+ maybe2(sym_name, list(type_param))::out) is det.
% parse_type_decl_where_part_if_present(TypeSymName, Arity,
% IsSolverType, Inst, ModuleName, Term0, Term, Result):
@@ -1669,10 +1669,16 @@
get_condition(Pred, Body, Condition),
get_determinism(Body, Body2, MaybeDeterminism),
get_with_inst(Body2, Body3, WithInst),
- get_with_type(Body3, Body4, WithType),
- process_type_decl_pred_or_func(predicate, ModuleName,
- WithType, WithInst, MaybeDeterminism, VarSet, Body4,
- Condition, Attributes, R).
+ get_with_type(Body3, Body4, WithTypeResult),
+ (
+ WithTypeResult = ok(WithType),
+ process_type_decl_pred_or_func(predicate, ModuleName,
+ WithType, WithInst, MaybeDeterminism, VarSet, Body4,
+ Condition, Attributes, R)
+ ;
+ WithTypeResult = error(Msg, ErrorTerm),
+ R = error(Msg, ErrorTerm)
+ ).
:- pred process_type_decl_pred_or_func(pred_or_func::in, module_name::in,
maybe(type)::in, maybe1(maybe(inst))::in,
@@ -1731,10 +1737,16 @@
get_condition(Func, Body, Condition),
get_determinism(Body, Body2, MaybeDeterminism),
get_with_inst(Body2, Body3, WithInst),
- get_with_type(Body3, Body4, WithType),
- process_type_decl_pred_or_func(function, ModuleName,
- WithType, WithInst, MaybeDeterminism, VarSet, Body4,
- Condition, Attributes, R).
+ get_with_type(Body3, Body4, WithTypeResult),
+ (
+ WithTypeResult = ok(WithType),
+ process_type_decl_pred_or_func(function, ModuleName,
+ WithType, WithInst, MaybeDeterminism, VarSet, Body4,
+ Condition, Attributes, R)
+ ;
+ WithTypeResult = error(Msg, ErrorTerm),
+ R = error(Msg, ErrorTerm)
+ ).
%-----------------------------------------------------------------------------%
@@ -2156,8 +2168,8 @@
:- func parse_where_type_is(module_name, term) = maybe1(type).
-parse_where_type_is(_ModuleName, Term) = ok(Type) :-
- prog_io_util__convert_type(Term, Type).
+parse_where_type_is(_ModuleName, Term) = Result :-
+ prog_io_util__parse_type(Term, Result).
:- pred parse_where_end(maybe(term)::in, maybe1(maybe(unit))::out) is det.
@@ -2361,19 +2373,25 @@
WithInst = ok(no)
).
-:- pred get_with_type(term::in, term::out, maybe(type)::out) is det.
+:- pred get_with_type(term::in, term::out, maybe1(maybe(type))::out) is det.
-get_with_type(Body0, Body, WithType) :-
+get_with_type(Body0, Body, Result) :-
(
Body0 = term__functor(term__atom("with_type"),
[Body1, Type1], _)
->
Body = Body1,
- convert_type(Type1, Type),
- WithType = yes(Type)
+ parse_type(Type1, Result0),
+ (
+ Result0 = ok(Type),
+ Result = ok(yes(Type))
+ ;
+ Result0 = error(Msg, ErrorTerm),
+ Result = error(Msg, ErrorTerm)
+ )
;
Body = Body0,
- WithType = no
+ Result = ok(no)
).
%-----------------------------------------------------------------------------%
@@ -2436,19 +2454,17 @@
Result0 = error(String, Term),
Result = error(String, Term)
;
- Result0 = ok(Name, Args0),
+ Result0 = ok(Name, Params),
(
RepnType = SolverTypeDetails ^
representation_type,
- term__contains_var(RepnType, Var),
- not term__contains_var_list(Args0,
- term__coerce_var(Var))
+ type_contains_var(RepnType, Var),
+ not list__member(Var, Params)
->
Result = error("free type variable in " ++
"representation type", Head)
;
- list__map(term__coerce, Args0, Args),
- Result = ok(processed_type_body(Name, Args,
+ Result = ok(processed_type_body(Name, Params,
solver_type(SolverTypeDetails,
MaybeUserEqComp)))
)
@@ -2468,24 +2484,31 @@
parse_type_defn_head(ModuleName, Head, Body, Result0),
process_eqv_type_2(Result0, Body, Result).
-:- pred process_eqv_type_2(maybe_functor::in, term::in,
+:- pred process_eqv_type_2(maybe2(sym_name, list(type_param))::in, term::in,
maybe1(processed_type_body)::out) is det.
process_eqv_type_2(error(Error, Term), _, error(Error, Term)).
-process_eqv_type_2(ok(Name, Args0), Body0, Result) :-
- % check that all the variables in the body occur in the head
+process_eqv_type_2(ok(Name, Params), Body0, Result) :-
+ % Check that all the variables in the body occur in the head.
(
(
- term__contains_var(Body0, Var2),
- \+ term__contains_var_list(Args0, Var2)
+ term__contains_var(Body0, Var),
+ term__coerce_var(Var, TVar),
+ \+ list__member(TVar, Params)
)
->
Result = error("free type parameter in RHS of " ++
"type definition", Body0)
;
- list__map(term__coerce, Args0, Args),
- convert_type(Body0, Body),
- Result = ok(processed_type_body(Name, Args, eqv_type(Body)))
+ parse_type(Body0, BodyResult),
+ (
+ BodyResult = ok(Body),
+ Result = ok(processed_type_body(Name, Params,
+ eqv_type(Body)))
+ ;
+ BodyResult = error(Msg, ErrorTerm),
+ Result = error(Msg, ErrorTerm)
+ )
).
%-----------------------------------------------------------------------------%
@@ -2507,56 +2530,52 @@
Result0 = error(String, Term),
Result = error(String, Term)
;
- Result0 = ok(Functor, Args),
- process_du_type_2(Functor, Args, Body, Ctors,
+ Result0 = ok(Functor, Params),
+ process_du_type_2(Functor, Params, Body, Ctors,
MaybeUserEqComp, Result)
).
-:- pred process_du_type_2(sym_name::in, list(term)::in, term::in,
+:- pred process_du_type_2(sym_name::in, list(type_param)::in, term::in,
list(constructor)::in, maybe(unify_compare)::in,
maybe1(processed_type_body)::out) is det.
-process_du_type_2(Functor, Args0, Body, Ctors, MaybeUserEqComp, Result) :-
+process_du_type_2(Functor, Params, Body, Ctors, MaybeUserEqComp, Result) :-
- % check that body is a disjunction of constructors
- list__map(term__coerce, Args0, Args),
-
- % check that all type variables in the body
- % are either explicitly existentially quantified
- % or occur in the head.
+ % Check that all type variables in the body are either explicitly
+ % existentially quantified or occur in the head.
(
list__member(Ctor, Ctors),
Ctor = ctor(ExistQVars, _Constraints, _CtorName, CtorArgs),
assoc_list__values(CtorArgs, CtorArgTypes),
- term__contains_var_list(CtorArgTypes, Var),
+ type_list_contains_var(CtorArgTypes, Var),
\+ list__member(Var, ExistQVars),
- \+ term__contains_var_list(Args, Var)
+ \+ list__member(Var, Params)
->
Result = error("free type parameter in RHS of " ++
"type definition", Body)
- % check that all type variables in existential quantifiers
- % do not occur in the head
- % (maybe this should just be a warning, not an error?
- % If we were to allow it, we would need to rename them apart.)
+ % Check that all type variables in existential quantifiers do not
+ % occur in the head (maybe this should just be a warning, not an
+ % error? If we were to allow it, we would need to rename them
+ % apart.)
;
list__member(Ctor, Ctors),
Ctor = ctor(ExistQVars, _Constraints, _CtorName, _CtorArgs),
list__member(Var, ExistQVars),
- term__contains_var_list(Args, Var)
+ list__member(Var, Params)
->
Result = error("type variable has overlapping " ++
"scopes (explicit type quantifier " ++
"shadows argument type)", Body)
- % check that all type variables in existential quantifiers
- % occur somewhere in the constructor argument types or constraints.
+ % Check that all type variables in existential quantifiers occur
+ % somewhere in the constructor argument types or constraints.
;
list__member(Ctor, Ctors),
Ctor = ctor(ExistQVars, Constraints, _CtorName, CtorArgs),
list__member(Var, ExistQVars),
assoc_list__values(CtorArgs, CtorArgTypes),
- \+ term__contains_var_list(CtorArgTypes, Var),
+ \+ type_list_contains_var(CtorArgTypes, Var),
constraint_list_get_tvars(Constraints, ConstraintTVars),
\+ list__member(Var, ConstraintTVars)
->
@@ -2564,14 +2583,14 @@
"quantifier does not occur in " ++
"arguments or constraints of constructor", Body)
- % check that all type variables in existential constraints
- % occur in the existential quantifiers
+ % Check that all type variables in existential constraints occur in
+ % the existential quantifiers.
;
list__member(Ctor, Ctors),
Ctor = ctor(ExistQVars, Constraints, _CtorName, _CtorArgs),
list__member(Constraint, Constraints),
Constraint = constraint(_Name, ConstraintArgs),
- term__contains_var_list(ConstraintArgs, Var),
+ type_list_contains_var(ConstraintArgs, Var),
\+ list__member(Var, ExistQVars)
->
Result = error("type variables in class " ++
@@ -2580,7 +2599,7 @@
"existentially quantified " ++
"using `some'", Body)
;
- Result = ok(processed_type_body(Functor, Args,
+ Result = ok(processed_type_body(Functor, Params,
du_type(Ctors, MaybeUserEqComp)))
).
@@ -2601,14 +2620,13 @@
process_abstract_type_2(Result0, IsSolverType, Result1),
check_no_attributes(Result1, Attributes, Result).
-:- pred process_abstract_type_2(maybe_functor::in, is_solver_type::in,
- maybe1(processed_type_body)::out) is det.
+:- pred process_abstract_type_2(maybe2(sym_name, list(type_param))::in,
+ is_solver_type::in, maybe1(processed_type_body)::out) is det.
process_abstract_type_2(error(Error, Term), _, error(Error, Term)).
-process_abstract_type_2(ok(Functor, Args0), IsSolverType,
- ok(processed_type_body(Functor, Args,
- abstract_type(IsSolverType)))) :-
- list__map(term__coerce, Args0, Args).
+process_abstract_type_2(ok(Functor, Params), IsSolverType, Result) :-
+ Result = ok(processed_type_body(Functor, Params,
+ abstract_type(IsSolverType))).
%-----------------------------------------------------------------------------%
@@ -2630,37 +2648,37 @@
parse_type_defn_head_2(R, Head, Result)
).
-:- pred parse_type_defn_head_2(maybe_functor::in, term::in, maybe_functor::out)
- is det.
+:- pred parse_type_defn_head_2(maybe_functor::in, term::in,
+ maybe2(sym_name, list(tvar))::out) is det.
parse_type_defn_head_2(error(Msg, Term), _, error(Msg, Term)).
parse_type_defn_head_2(ok(Name, Args), Head, Result) :-
parse_type_defn_head_3(Name, Args, Head, Result).
:- pred parse_type_defn_head_3(sym_name::in, list(term)::in, term::in,
- maybe_functor::out) is det.
+ maybe2(sym_name, list(tvar))::out) is det.
parse_type_defn_head_3(Name, Args, Head, Result) :-
- % check that all the head args are variables
- ( %%% some [Arg]
- (
- list__member(Arg, Args),
- Arg \= term__variable(_)
- )
+ % Check that all the head args are variables.
+ (
+ var_list_to_term_list(Params0, Args)
->
- Result = error("type parameters must be variables", Head)
- ;
- % check that all the head arg variables are distinct
- %%% some [Arg2, OtherArgs]
- (
- list__member(Arg2, Args, [Arg2|OtherArgs]),
- list__member(Arg2, OtherArgs)
+ % Check that all the head arg variables are distinct.
+ ( some [Param, OtherParams]
+ (
+ list__member(_, Params0,
+ [Param | OtherParams]),
+ list__member(Param, OtherParams)
+ )
+ ->
+ Result = error("repeated type parameters "
+ ++ "in LHS of type defn", Head)
+ ;
+ list__map(term__coerce_var, Params0, Params),
+ Result = ok(Name, Params)
)
- ->
- Result = error("repeated type parameters in LHS of type defn",
- Head)
;
- Result = ok(Name, Args)
+ Result = error("type parameters must be variables", Head)
).
%-----------------------------------------------------------------------------%
@@ -3720,12 +3738,12 @@
Term = term__functor(term__atom("::"), [TypeTerm, ModeTerm],
_Context)
->
- convert_type(TypeTerm, Type),
+ parse_type(TypeTerm, ok(Type)),
convert_mode(allow_constrained_inst_var, ModeTerm, Mode0),
constrain_inst_vars_in_mode(InstConstraints, Mode0, Mode),
Result = type_and_mode(Type, Mode)
;
- convert_type(Term, Type),
+ parse_type(Term, ok(Type)),
Result = type_only(Type)
).
@@ -4002,12 +4020,18 @@
:- pred process_typed_predicate_specifier(maybe_functor::in,
maybe1(pred_specifier)::out) is det.
-process_typed_predicate_specifier(ok(Name, Args0), ok(Result)) :-
+process_typed_predicate_specifier(ok(Name, Args0), Result) :-
( Args0 = [] ->
- Result = sym(name(Name))
+ Result = ok(sym(name(Name)))
;
- list__map(term__coerce, Args0, Args),
- Result = name_args(Name, Args)
+ parse_types(Args0, ArgsResult),
+ (
+ ArgsResult = ok(Args),
+ Result = ok(name_args(Name, Args))
+ ;
+ ArgsResult = error(Msg, ErrorTerm),
+ Result = error(Msg, ErrorTerm)
+ )
).
process_typed_predicate_specifier(error(Msg, Term), error(Msg, Term)).
@@ -4340,13 +4364,6 @@
%-----------------------------------------------------------------------------%
- % types are represented just as ordinary terms
-
-:- pred parse_type(term::in, maybe1(type)::out) is det.
-
-parse_type(T0, ok(T)) :-
- convert_type(T0, T).
-
:- func convert_constructor_arg_list(module_name, list(term)) =
maybe1(list(constructor_arg)).
@@ -4383,15 +4400,21 @@
convert_constructor_arg_list_2(ModuleName, MaybeFieldName, TypeTerm, Terms) =
Result :-
- convert_type(TypeTerm, Type),
- Arg = MaybeFieldName - Type,
- Result0 = convert_constructor_arg_list(ModuleName, Terms),
+ parse_type(TypeTerm, TypeResult),
(
- Result0 = error(String, Term),
- Result = error(String, Term)
+ TypeResult = ok(Type),
+ Arg = MaybeFieldName - Type,
+ Result0 = convert_constructor_arg_list(ModuleName, Terms),
+ (
+ Result0 = error(String, Term),
+ Result = error(String, Term)
+ ;
+ Result0 = ok(Args),
+ Result = ok([Arg | Args])
+ )
;
- Result0 = ok(Args),
- Result = ok([Arg | Args])
+ TypeResult = error(String, Term),
+ Result = error(String, Term)
).
%-----------------------------------------------------------------------------%
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.86
diff -u -r1.86 prog_io_pragma.m
--- compiler/prog_io_pragma.m 5 Sep 2005 03:45:57 -0000 1.86
+++ compiler/prog_io_pragma.m 11 Sep 2005 14:03:28 -0000
@@ -146,9 +146,8 @@
parse_type_defn_head(ModuleName, MercuryTypeTerm, ErrorTerm,
MaybeTypeDefnHead),
(
- MaybeTypeDefnHead = ok(MercuryTypeSymName, MercuryArgs0),
+ MaybeTypeDefnHead = ok(MercuryTypeSymName, MercuryParams),
varset__coerce(VarSet, TVarSet),
- MercuryArgs = list__map(term__coerce, MercuryArgs0),
(
parse_maybe_foreign_type_assertions(MaybeAssertionTerm,
Assertions)
@@ -156,7 +155,7 @@
% rafe: XXX I'm not sure that `no' here is right
% - we might need some more parsing...
Result = ok(type_defn(TVarSet, MercuryTypeSymName,
- MercuryArgs,
+ MercuryParams,
foreign_type( ForeignType, no, Assertions),
true))
;
@@ -1861,7 +1860,7 @@
Term = term__functor(term__atom("="), [TypeVarTerm, SpecTypeTerm0], _),
TypeVarTerm = term__variable(TypeVar0),
term__coerce_var(TypeVar0, TypeVar),
- convert_type(SpecTypeTerm0, SpecType),
+ parse_type(SpecTypeTerm0, ok(SpecType)),
TypeSpec = TypeVar - SpecType.
%------------------------------------------------------------------------------%%
Index: compiler/prog_io_typeclass.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_typeclass.m,v
retrieving revision 1.41
diff -u -r1.41 prog_io_typeclass.m
--- compiler/prog_io_typeclass.m 12 Sep 2005 03:05:47 -0000 1.41
+++ compiler/prog_io_typeclass.m 12 Sep 2005 04:07:42 -0000
@@ -456,17 +456,20 @@
parse_qualified_term(ConstraintTerm, ConstraintTerm,
"class constraint", ok(ClassName, Args0))
->
- % we need to enforce the invariant that types in type class
- % constraints do not contain any info in their prog_context
- % fields
- list__map(convert_type, Args0, Args),
- Constraint = constraint(ClassName, Args),
+ parse_types(Args0, ArgsResult),
(
- constraint_is_not_simple(Constraint)
- ->
- Result = ok(non_simple(Constraint))
+ ArgsResult = ok(Args),
+ Constraint = constraint(ClassName, Args),
+ (
+ constraint_is_not_simple(Constraint)
+ ->
+ Result = ok(non_simple(Constraint))
+ ;
+ Result = ok(simple(Constraint))
+ )
;
- Result = ok(simple(Constraint))
+ ArgsResult = error(Msg, ErrorTerm),
+ Result = error(Msg, ErrorTerm)
)
;
Result = error("expected atom as class name or inst constraint",
@@ -508,8 +511,8 @@
constraint_is_not_simple(constraint(_Name, Types)) :-
some [Type] (
list__member(Type, Types),
- \+ prog_type__var(Type, _),
- \+ term__is_ground(Type)
+ type_is_nonvar(Type),
+ type_is_nonground(Type)
).
%-----------------------------------------------------------------------------%
@@ -588,57 +591,70 @@
parse_underived_instance(ModuleName, Name, TVarSet, Result) :-
% We don't give a default module name here since the instance
% declaration could well be for a typeclass defined in another
- % module
+ % module.
parse_qualified_term(Name, Name, "instance declaration",
MaybeClassName),
(
- MaybeClassName = ok(ClassName, TermTypes0),
- list__map(convert_type, TermTypes0, TermTypes),
-
- % Check that each type in the arguments of the instance
- % decl is a functor with vars as args.
- %
- (
- some [Type] (
- list__member(Type, TermTypes),
- \+ type_is_functor_and_vars(Type)
- )
- ->
- % We report the error as being in the name
- % rather than the specific argument, since
- % the argument types have had their contexts
- % removed.
- %
- Result = error("types in instance declarations" ++
- " must be functors with distinct variables" ++
- " as arguments", Name)
- ;
- Result = ok(instance([], ClassName,
- TermTypes, abstract, TVarSet, ModuleName))
- )
+ MaybeClassName = ok(ClassName, TermTypes),
+ parse_types(TermTypes, TypesResult),
+ parse_underived_instance_2(Name, ClassName, TypesResult,
+ TVarSet, ModuleName, Result)
;
MaybeClassName = error(String, Term),
Result = error(String, Term)
).
-:- pred type_is_functor_and_vars((type)::in) is semidet.
+:- pred parse_underived_instance_2(term::in, class_name::in,
+ maybe1(list(type))::in, tvarset::in, module_name::in,
+ maybe1(item)::out) is det.
-type_is_functor_and_vars(Type) :-
- % Is the top level functor an atom?
- Type = term__functor(term__atom(Functor), Args, _),
+parse_underived_instance_2(_, _, error(Msg, Term), _, _, error(Msg, Term)).
+parse_underived_instance_2(ErrorTerm, ClassName, ok(Types), TVarSet,
+ ModuleName, Result) :-
(
- ( Functor = ":"
- ; Functor = "."
+ % Check that each type in the arguments of the instance decl
+ % is a functor with vars as args.
+ %
+ some [Type] (
+ list__member(Type, Types),
+ \+ type_is_functor_and_vars(Type)
)
->
- Args = [_Module, Type1],
- type_is_functor_and_vars(Type1)
+ Result = error("types in instance declarations must be" ++
+ " functors with distinct variables as arguments",
+ ErrorTerm)
;
- % Are all the args of the functor variables?
- all [Arg] (
- list__member(Arg, Args) =>
- prog_type__var(Arg, _)
- )
+ Result = ok(instance([], ClassName, Types, abstract, TVarSet,
+ ModuleName))
+ ).
+
+:- pred type_is_functor_and_vars((type)::in) is semidet.
+
+type_is_functor_and_vars(defined(_, Args, _)) :-
+ functor_args_are_variables(Args).
+type_is_functor_and_vars(builtin(_)).
+type_is_functor_and_vars(higher_order(Args, MaybeRet, Purity, EvalMethod)) :-
+ % XXX We currently allow pred types to be instance arguments, but not
+ % func types. Even then, the pred type must be pure and have a
+ % lambda_eval_method of normal. We keep this behaviour basically
+ % for backwards compatibility -- there is little point fixing this
+ % now without fixing the more general problem of having these
+ % restrictions in the first place.
+ MaybeRet = no,
+ Purity = (pure),
+ EvalMethod = normal,
+ functor_args_are_variables(Args).
+type_is_functor_and_vars(tuple(Args, _)) :-
+ functor_args_are_variables(Args).
+type_is_functor_and_vars(kinded(Type, _)) :-
+ type_is_functor_and_vars(Type).
+
+:- pred functor_args_are_variables(list(type)::in) is semidet.
+
+functor_args_are_variables(Args) :-
+ all [Arg] (
+ list__member(Arg, Args)
+ => type_is_var(Arg)
).
:- pred parse_non_empty_instance(module_name::in, term::in, term::in,
@@ -690,7 +706,7 @@
prog_type__constraint_list_get_tvars(Constraints,
TVars),
list__member(TVar, TVars),
- \+ term__contains_var_list(Types, TVar)
+ \+ type_list_contains_var(Types, TVar)
->
Result = error("unbound type variable(s) " ++
"in constraints on instance declaration",
Index: compiler/prog_io_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_util.m,v
retrieving revision 1.37
diff -u -r1.37 prog_io_util.m
--- compiler/prog_io_util.m 5 Sep 2005 02:29:55 -0000 1.37
+++ compiler/prog_io_util.m 11 Sep 2005 14:20:07 -0000
@@ -107,7 +107,13 @@
:- pred parse_pred_or_func_and_args(term(_T)::in, pred_or_func::out,
sym_name::out, list(term(_T))::out) is semidet.
-:- pred convert_type(term(T)::in, (type)::out) is det.
+:- pred parse_type(term::in, maybe1(type)::out) is det.
+
+:- pred parse_types(list(term)::in, maybe1(list(type))::out) is det.
+
+:- pred unparse_type((type)::in, term::out) is det.
+
+:- pred parse_purity_annotation(term(T)::in, purity::out, term(T)::out) is det.
:- type allow_constrained_inst_var
---> allow_constrained_inst_var
@@ -161,8 +167,10 @@
:- import_module libs__globals.
:- import_module libs__options.
+:- import_module parse_tree__error_util.
:- import_module parse_tree__prog_io.
:- import_module parse_tree__prog_io_goal.
+:- import_module parse_tree__prog_out.
:- import_module parse_tree__prog_util.
:- import_module bool.
@@ -247,24 +255,197 @@
Head = term__variable(V),
parse_list_of_vars(Tail, Vs).
-convert_type(T0, T) :-
- term__coerce(strip_prog_context(T0), T).
+ % XXX kind inference:
+ % We currently give all types kind `star'. This will be different
+ % when we have a kind system.
+ %
+parse_type(Term, Result) :-
+ (
+ Term = term__variable(Var0)
+ ->
+ term__coerce_var(Var0, Var),
+ Result = ok(variable(Var, star))
+ ;
+ parse_builtin_type(Term, BuiltinType)
+ ->
+ Result = ok(builtin(BuiltinType))
+ ;
+ parse_higher_order_type(Term, HOArgs, MaybeRet, Purity,
+ EvalMethod)
+ ->
+ Result = ok(higher_order(HOArgs, MaybeRet, Purity, EvalMethod))
+ ;
+ Term = term__functor(term__atom("{}"), Args, _)
+ ->
+ parse_types(Args, ArgsResult),
+ (
+ ArgsResult = ok(ArgTypes),
+ Result = ok(tuple(ArgTypes, star))
+ ;
+ ArgsResult = error(Msg, ErrorTerm),
+ Result = error(Msg, ErrorTerm)
+ )
+ ;
+ %
+ % We don't support apply/N types yet, so we just detect them
+ % and report an error message.
+ %
+ Term = term__functor(term__atom(""), _, _)
+ ->
+ Result = error("ill-formed type", Term)
+ ;
+ %
+ % We don't support kind annotations yet, and we don't report
+ % an error either. Perhaps we should?
+ %
+
+ parse_qualified_term(Term, Term, "type", NameResult),
+ (
+ NameResult = ok(SymName, ArgTerms),
+ parse_types(ArgTerms, ArgsResult),
+ (
+ ArgsResult = ok(ArgTypes),
+ Result = ok(defined(SymName, ArgTypes, star))
+ ;
+ ArgsResult = error(Msg, ErrorTerm),
+ Result = error(Msg, ErrorTerm)
+ )
+ ;
+ NameResult = error(Msg, ErrorTerm),
+ Result = error(Msg, ErrorTerm)
+ )
+ ).
+
+parse_types(Terms, Result) :-
+ parse_types_2(Terms, [], Result).
+
+:- pred parse_types_2(list(term)::in, list(type)::in, maybe1(list(type))::out)
+ is det.
+
+parse_types_2([], RevTypes, ok(Types)) :-
+ list__reverse(RevTypes, Types).
+parse_types_2([Term | Terms], RevTypes, Result) :-
+ parse_type(Term, Result0),
+ (
+ Result0 = ok(Type),
+ parse_types_2(Terms, [Type | RevTypes], Result)
+ ;
+ Result0 = error(Msg, ErrorTerm),
+ Result = error(Msg, ErrorTerm)
+ ).
+
+:- pred parse_builtin_type(term::in, builtin_type::out) is semidet.
- % Strip out the prog_context fields, replacing them with empty
- % prog_context (as obtained by term__context_init/1)
- % in a type or list of types.
+parse_builtin_type(Term, BuiltinType) :-
+ Term = term__functor(term__atom(Name), [], _),
+ builtin_type_to_string(BuiltinType, Name).
+
+ % If there are any ill-formed types in the argument then we just
+ % fail. The predicate parse_type will then try to parse the term
+ % as an ordinary defined type and will produce the required error
+ % message.
%
- % This is necessary to allow maps indexed by class constraints.
- % Also, the version number computation for smart recompilation
- % relies on being able to unify program items, which won't
- % work if the types in the items contain context information.
-:- func strip_prog_context(term(T)) = term(T).
-
-strip_prog_context(term__variable(V)) = term__variable(V).
-strip_prog_context(term__functor(F, As, _)) =
- term__functor(F,
- list__map(strip_prog_context, As),
- term__context_init).
+:- pred parse_higher_order_type(term::in, list(type)::out, maybe(type)::out,
+ purity::out, lambda_eval_method::out) is semidet.
+
+parse_higher_order_type(Term0, ArgTypes, MaybeRet, Purity, EvalMethod) :-
+ parse_purity_annotation(Term0, Purity, Term1),
+ ( Term1 = term__functor(term__atom("="), [FuncAndArgs0, Ret], _) ->
+ parse_lambda_eval_method(FuncAndArgs0, EvalMethod,
+ FuncAndArgs),
+ FuncAndArgs = term__functor(term__atom("func"), Args, _),
+ parse_type(Ret, ok(RetType)),
+ MaybeRet = yes(RetType)
+ ;
+ parse_lambda_eval_method(Term1, EvalMethod, PredTerm),
+ PredTerm = term__functor(term__atom("pred"), Args, _),
+ MaybeRet = no
+ ),
+ parse_types(Args, ok(ArgTypes)).
+
+parse_purity_annotation(Term0, Purity, Term) :-
+ (
+ Term0 = term__functor(term__atom(PurityName), [Term1], _),
+ purity_name(Purity0, PurityName)
+ ->
+ Purity = Purity0,
+ Term = Term1
+ ;
+ Purity = (pure),
+ Term = Term0
+ ).
+
+unparse_type(variable(TVar, _), term__variable(Var)) :-
+ Var = term__coerce_var(TVar).
+unparse_type(defined(SymName, Args, _), Term) :-
+ unparse_type_list(Args, ArgTerms),
+ unparse_qualified_term(SymName, ArgTerms, Term).
+unparse_type(builtin(BuiltinType), Term) :-
+ Context = term__context_init,
+ builtin_type_to_string(BuiltinType, Name),
+ Term = term__functor(term__atom(Name), [], Context).
+unparse_type(higher_order(Args, MaybeRet, Purity, EvalMethod), Term) :-
+ Context = term__context_init,
+ unparse_type_list(Args, ArgTerms),
+ (
+ MaybeRet = yes(Ret),
+ Term0 = term__functor(term__atom("func"), ArgTerms, Context),
+ maybe_add_lambda_eval_method(EvalMethod, Term0, Term1),
+ unparse_type(Ret, RetTerm),
+ Term2 = term__functor(term__atom("="), [Term1, RetTerm],
+ Context)
+ ;
+ MaybeRet = no,
+ Term0 = term__functor(term__atom("pred"), ArgTerms, Context),
+ maybe_add_lambda_eval_method(EvalMethod, Term0, Term2)
+ ),
+ maybe_add_purity_annotation(Purity, Term2, Term).
+unparse_type(tuple(Args, _), Term) :-
+ Context = term__context_init,
+ unparse_type_list(Args, ArgTerms),
+ Term = term__functor(term__atom("{}"), ArgTerms, Context).
+unparse_type(apply_n(TVar, Args, _), Term) :-
+ Context = term__context_init,
+ Var = term__coerce_var(TVar),
+ unparse_type_list(Args, ArgTerms),
+ Term = term__functor(term__atom(""), [term__variable(Var) | ArgTerms],
+ Context).
+unparse_type(kinded(_, _), _) :-
+ unexpected(this_file, "prog_io_util: kind annotation").
+
+:- pred unparse_type_list(list(type)::in, list(term)::out) is det.
+
+unparse_type_list(Types, Terms) :-
+ list__map(unparse_type, Types, Terms).
+
+:- pred unparse_qualified_term(sym_name::in, list(term)::in, term::out) is det.
+
+unparse_qualified_term(unqualified(Name), Args, Term) :-
+ Context = term__context_init,
+ Term = term__functor(term__atom(Name), Args, Context).
+unparse_qualified_term(qualified(Qualifier, Name), Args, Term) :-
+ Context = term__context_init,
+ unparse_qualified_term(Qualifier, [], QualTerm),
+ Term0 = term__functor(term__atom(Name), Args, Context),
+ Term = term__functor(term__atom("."), [QualTerm, Term0], Context).
+
+:- pred maybe_add_lambda_eval_method(lambda_eval_method::in, term::in,
+ term::out) is det.
+
+maybe_add_lambda_eval_method(normal, Term, Term).
+maybe_add_lambda_eval_method((aditi_bottom_up), Term0, Term) :-
+ Context = term__context_init,
+ Term = term__functor(term__atom("aditi_bottom_up"), [Term0], Context).
+
+:- pred maybe_add_purity_annotation(purity::in, term::in, term::out) is det.
+
+maybe_add_purity_annotation(pure, Term, Term).
+maybe_add_purity_annotation((semipure), Term0, Term) :-
+ Context = term__context_init,
+ Term = term__functor(term__atom("semipure"), [Term0], Context).
+maybe_add_purity_annotation((impure), Term0, Term) :-
+ Context = term__context_init,
+ Term = term__functor(term__atom("impure"), [Term0], Context).
convert_mode_list(_, [], []).
convert_mode_list(AllowConstrainedInstVar, [H0 | T0], [H | T]) :-
@@ -631,4 +812,11 @@
).
%-----------------------------------------------------------------------------%
+
+:- func this_file = string.
+
+this_file = "prog_io_util.m".
+
+%-----------------------------------------------------------------------------%
+:- end_module parse_tree__prog_io_util.
%-----------------------------------------------------------------------------%
Index: compiler/prog_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_out.m,v
retrieving revision 1.62
diff -u -r1.62 prog_out.m
--- compiler/prog_out.m 22 Aug 2005 03:55:11 -0000 1.62
+++ compiler/prog_out.m 8 Sep 2005 03:19:39 -0000
@@ -113,6 +113,10 @@
:- mode promise_to_string(out) = in is semidet.
:- mode promise_to_string(out) = out is multi.
+:- pred builtin_type_to_string(builtin_type, string).
+:- mode builtin_type_to_string(in, out) is det.
+:- mode builtin_type_to_string(out, in) is semidet.
+
% Print "predicate" or "function" depending on the given value.
%
:- pred write_pred_or_func(pred_or_func::in, io::di, io::uo) is det.
@@ -376,6 +380,11 @@
promise_to_string(exclusive_exhaustive) =
"promise_exclusive_exhaustive".
+builtin_type_to_string(int, "int").
+builtin_type_to_string(float, "float").
+builtin_type_to_string(string, "string").
+builtin_type_to_string(character, "character").
+
write_promise_type(PromiseType, !IO) :-
io__write_string(promise_to_string(PromiseType), !IO).
Index: compiler/prog_type.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_type.m,v
retrieving revision 1.7
diff -u -r1.7 prog_type.m
--- compiler/prog_type.m 17 Jun 2005 10:13:54 -0000 1.7
+++ compiler/prog_type.m 12 Sep 2005 04:42:22 -0000
@@ -19,9 +19,25 @@
:- import_module parse_tree.prog_data.
:- import_module list.
-:- import_module map.
%-----------------------------------------------------------------------------%
+%
+% Simple tests for certain properties of types. These tests work modulo any
+% kind annotations, so in the early stages of the compiler (i.e., before type
+% checking) these should be used rather than direct tests. Once we reach
+% type checking all kind annotations should have been removed, so it would
+% be preferable to switch on the top functor rather than use these predicates
+% in an if-then-else expression, since switches will give better error
+% detection.
+%
+
+ % Succeeds iff the given type is a variable.
+ %
+:- pred type_is_var((type)::in) is semidet.
+
+ % Succeeds iff the given type is not a variable.
+ %
+:- pred type_is_nonvar((type)::in) is semidet.
% Succeeds iff the given type is a higher-order predicate or function
% type.
@@ -41,7 +57,32 @@
% the argument types.
%
:- pred type_is_tuple((type)::in, list(type)::out) is semidet.
+
+ % Remove the kind annotation at the top-level if there is one,
+ % otherwise return the type unchanged.
+ %
+:- func strip_kind_annotation(type) = (type).
+%-----------------------------------------------------------------------------%
+
+ % Succeeds iff the given type is ground (that is, contains no type
+ % variables).
+ %
+:- pred type_is_ground((type)::in) is semidet.
+
+ % Succeeds iff the given type is not ground.
+ %
+:- pred type_is_nonground((type)::in) is semidet.
+
+ % Succeeds iff the given type with the substitution applied is ground.
+ %
+:- pred type_is_ground((type)::in, tsubst::in) is semidet.
+
+ % Succeeds iff the given type with the substitution applied is not
+ % ground.
+ %
+:- pred type_is_nonground((type)::in, tsubst::in) is semidet.
+
% type_has_variable_arity_ctor(Type, TypeCtor, TypeArgs)
% Check if the principal type constructor of Type is of variable arity.
% If yes, return the type constructor as TypeCtor and its args as
@@ -68,17 +109,36 @@
% type_ctor_is_variable(TypeCtor) succeeds iff TypeCtor is a variable.
%
:- pred type_ctor_is_variable(type_ctor::in) is semidet.
-
- % Given a variable type, return its type variable.
+
+ % Convert a list of types to a list of vars. Fail if any of them are
+ % not variables.
%
-:- pred prog_type.var(type, tvar).
-:- mode prog_type.var(in, out) is semidet.
-:- mode prog_type.var(out, in) is det.
-
- % Return a list of the type variables of a type.
+:- pred prog_type.type_list_to_var_list(list(type)::in, list(tvar)::out)
+ is semidet.
+
+ % Convert a list of vars into a list of variable types.
+ %
+:- pred prog_type.var_list_to_type_list(tvar_kind_map::in, list(tvar)::in,
+ list(type)::out) is det.
+
+ % Return a list of the type variables of a type, in order of their
+ % first occurrence in a depth-first, left-right traversal.
%
:- pred prog_type.vars((type)::in, list(tvar)::out) is det.
-
+
+ % Return a list of the type variables of a list of types, in order
+ % of their first occurrence in a depth-first, left-right traversal.
+ %
+:- pred prog_type.vars_list(list(type)::in, list(tvar)::out) is det.
+
+ % Nondeterministically return the variables in a type.
+ %
+:- pred type_contains_var((type)::in, tvar::out) is nondet.
+
+ % Nondeterministically return the variables in a list of types.
+ %
+:- pred type_list_contains_var(list(type)::in, tvar::out) is nondet.
+
% Given a type_ctor and a list of argument types,
% construct a type.
%
@@ -103,6 +163,48 @@
%-----------------------------------------------------------------------------%
%
+% Type substitutions.
+%
+
+:- pred apply_rec_subst_to_type(tsubst::in, (type)::in, (type)::out) is det.
+
+:- pred apply_rec_subst_to_type_list(tsubst::in, list(type)::in,
+ list(type)::out) is det.
+
+:- pred apply_rec_subst_to_tvar(tvar_kind_map::in, tsubst::in,
+ tvar::in, (type)::out) is det.
+
+:- pred apply_rec_subst_to_tvar_list(tvar_kind_map::in, tsubst::in,
+ list(tvar)::in, list(type)::out) is det.
+
+:- pred apply_subst_to_type(tsubst::in, (type)::in, (type)::out) is det.
+
+:- pred apply_subst_to_type_list(tsubst::in, list(type)::in, list(type)::out)
+ is det.
+
+:- pred apply_subst_to_tvar(tvar_kind_map::in, tsubst::in,
+ tvar::in, (type)::out) is det.
+
+:- pred apply_subst_to_tvar_list(tvar_kind_map::in, tsubst::in,
+ list(tvar)::in, list(type)::out) is det.
+
+:- pred apply_variable_renaming_to_type(tvar_renaming::in, (type)::in,
+ (type)::out) is det.
+
+:- pred apply_variable_renaming_to_type_list(tvar_renaming::in, list(type)::in,
+ list(type)::out) is det.
+
+:- pred apply_variable_renaming_to_tvar(tvar_renaming::in, tvar::in, tvar::out)
+ is det.
+
+:- pred apply_variable_renaming_to_tvar_list(tvar_renaming::in, list(tvar)::in,
+ list(tvar)::out) is det.
+
+:- pred apply_variable_renaming_to_tvar_kind_map(tvar_renaming::in,
+ tvar_kind_map::in, tvar_kind_map::out) is det.
+
+%-----------------------------------------------------------------------------%
+%
% Utility predicates dealing with typeclass constraints.
%
@@ -124,13 +226,13 @@
:- pred apply_subst_to_prog_constraint(tsubst::in, prog_constraint::in,
prog_constraint::out) is det.
-:- pred apply_variable_renaming_to_prog_constraints(map(tvar, tvar)::in,
+:- pred apply_variable_renaming_to_prog_constraints(tvar_renaming::in,
prog_constraints::in, prog_constraints::out) is det.
-:- pred apply_variable_renaming_to_prog_constraint_list(map(tvar, tvar)::in,
+:- pred apply_variable_renaming_to_prog_constraint_list(tvar_renaming::in,
list(prog_constraint)::in, list(prog_constraint)::out) is det.
-:- pred apply_variable_renaming_to_prog_constraint(map(tvar, tvar)::in,
+:- pred apply_variable_renaming_to_prog_constraint(tvar_renaming::in,
prog_constraint::in, prog_constraint::out) is det.
% constraint_list_get_tvars(Constraints, TVars):
@@ -153,68 +255,66 @@
:- implementation.
+:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_io.
:- import_module parse_tree.prog_out.
:- import_module parse_tree.prog_util.
+:- import_module map.
:- import_module std_util.
-:- import_module term.
+:- import_module svmap.
%-----------------------------------------------------------------------------%
-type_is_higher_order(Type) :- type_is_higher_order(Type, _, _, _, _).
+type_is_var(Type) :-
+ strip_kind_annotation(Type) = variable(_, _).
+
+type_is_nonvar(Type) :-
+ \+ type_is_var(Type).
+
+type_is_higher_order(Type) :-
+ strip_kind_annotation(Type) = higher_order(_, _, _, _).
-type_is_higher_order(Type, Purity, PredOrFunc, EvalMethod, PredArgTypes) :-
+type_is_higher_order(Type0, Purity, PredOrFunc, EvalMethod, PredArgTypes) :-
+ Type = strip_kind_annotation(Type0),
+ Type = higher_order(ArgTypes, MaybeRetType, Purity, EvalMethod),
(
- Type = term.functor(term.atom(PurityName), [BaseType], _),
- purity_name(Purity0, PurityName),
- type_is_higher_order_2(BaseType,
- PredOrFunc0, EvalMethod0, PredArgTypes0)
- ->
- Purity = Purity0,
- PredOrFunc = PredOrFunc0,
- EvalMethod = EvalMethod0,
- PredArgTypes = PredArgTypes0
+ MaybeRetType = yes(RetType),
+ PredOrFunc = function,
+ PredArgTypes = list.append(ArgTypes, [RetType])
;
- Purity = (pure),
- type_is_higher_order_2(Type,
- PredOrFunc, EvalMethod, PredArgTypes)
+ MaybeRetType = no,
+ PredOrFunc = predicate,
+ PredArgTypes = ArgTypes
).
-% This parses a higher-order type without any purity indicator.
-:- pred type_is_higher_order_2((type)::in, pred_or_func::out,
- lambda_eval_method::out, list(type)::out) is semidet.
+type_is_tuple(Type, ArgTypes) :-
+ strip_kind_annotation(Type) = tuple(ArgTypes, _).
-type_is_higher_order_2(Type, PredOrFunc, EvalMethod, PredArgTypes) :-
- (
- Type = term.functor(term.atom("="),
- [FuncEvalAndArgs, FuncRetType], _)
- ->
- get_lambda_eval_method_and_args("func", FuncEvalAndArgs,
- EvalMethod, FuncArgTypes),
- list.append(FuncArgTypes, [FuncRetType], PredArgTypes),
- PredOrFunc = function
+strip_kind_annotation(Type0) = Type :-
+ ( Type0 = kinded(Type1, _) ->
+ Type = strip_kind_annotation(Type1)
;
- get_lambda_eval_method_and_args("pred",
- Type, EvalMethod, PredArgTypes),
- PredOrFunc = predicate
+ Type = Type0
).
- % From the type of a lambda expression, work out how it should
- % be evaluated and extract the argument types.
-:- pred get_lambda_eval_method_and_args(string::in, (type)::in,
- lambda_eval_method::out, list(type)::out) is semidet.
-
-get_lambda_eval_method_and_args(PorFStr, Type0, EvalMethod, ArgTypes) :-
- Type0 = term.functor(term.atom(Functor), Args, _),
- ( Functor = PorFStr ->
- EvalMethod = normal,
- ArgTypes = Args
+%-----------------------------------------------------------------------------%
+
+type_is_ground(Type) :-
+ \+ type_contains_var(Type, _).
+
+type_is_nonground(Type) :-
+ type_contains_var(Type, _).
+
+type_is_ground(Type, TSubst) :-
+ \+ type_is_nonground(Type, TSubst).
+
+type_is_nonground(Type, TSubst) :-
+ type_contains_var(Type, TVar),
+ ( map.search(TSubst, TVar, Binding) ->
+ type_is_nonground(Binding, TSubst)
;
- Args = [Type1],
- Type1 = term.functor(term.atom(PorFStr), ArgTypes, _),
- Functor = "aditi_bottom_up",
- EvalMethod = (aditi_bottom_up)
+ true
).
type_has_variable_arity_ctor(Type, TypeCtor, TypeArgs) :-
@@ -229,67 +329,53 @@
type_is_tuple(Type, TypeArgs1)
->
TypeArgs = TypeArgs1,
+ % XXX why tuple/0 and not {}/N ?
TypeCtor = unqualified("tuple") - 0
;
fail
).
-type_to_ctor_and_args(Type, SymName - Arity, Args) :-
- Type \= term.variable(_),
-
- % higher order types may have representations where
- % their arguments don't directly correspond to the
- % arguments of the term.
+type_to_ctor_and_args(defined(SymName, Args, _), SymName - Arity, Args) :-
+ Arity = list.length(Args).
+type_to_ctor_and_args(builtin(BuiltinType), SymName - 0, []) :-
+ builtin_type_to_string(BuiltinType, Name),
+ SymName = unqualified(Name).
+type_to_ctor_and_args(higher_order(Args0, MaybeRet, Purity, EvalMethod),
+ SymName - Arity, Args) :-
+ Arity = list.length(Args0),
(
- type_is_higher_order(Type, Purity, PredOrFunc,
- EvalMethod, PredArgTypes)
- ->
- Args = PredArgTypes,
- list.length(Args, Arity0),
- adjust_func_arity(PredOrFunc, Arity, Arity0),
- (
- PredOrFunc = predicate,
- PorFStr = "pred"
- ;
- PredOrFunc = function,
- PorFStr = "func"
- ),
- SymName0 = unqualified(PorFStr),
- (
- EvalMethod = (aditi_bottom_up),
- insert_module_qualifier("aditi_bottom_up", SymName0,
- SymName1)
- ;
- EvalMethod = normal,
- SymName1 = SymName0
- ),
- (
- Purity = (pure),
- SymName = SymName1
- ;
- Purity = (semipure),
- insert_module_qualifier("semipure", SymName1, SymName)
- ;
- Purity = (impure),
- insert_module_qualifier("impure", SymName1, SymName)
- )
+ MaybeRet = yes(Ret),
+ PorFStr = "func",
+ Args = list.append(Args0, [Ret])
;
- sym_name_and_args(Type, SymName, Args),
-
- % `private_builtin:constraint' is introduced by polymorphism,
- % and should only appear as the argument of a
- % `typeclass:info/1' type.
- % It behaves sort of like a type variable, so according to the
- % specification of `type_to_ctor_and_args', it should
- % cause failure. There isn't a definition in the type table.
- \+ (
- SymName = qualified(ModuleName, UnqualName),
- UnqualName = "constraint",
- mercury_private_builtin_module(PrivateBuiltin),
- ModuleName = PrivateBuiltin
- ),
- list.length(Args, Arity)
+ MaybeRet = no,
+ PorFStr = "pred",
+ Args = Args0
+ ),
+ SymName0 = unqualified(PorFStr),
+ (
+ EvalMethod = (aditi_bottom_up),
+ insert_module_qualifier("aditi_bottom_up", SymName0, SymName1)
+ ;
+ EvalMethod = normal,
+ SymName1 = SymName0
+ ),
+ (
+ Purity = (pure),
+ SymName = SymName1
+ ;
+ Purity = (semipure),
+ insert_module_qualifier("semipure", SymName1, SymName)
+ ;
+ Purity = (impure),
+ insert_module_qualifier("impure", SymName1, SymName)
).
+type_to_ctor_and_args(tuple(Args, _), unqualified("{}") - Arity, Args) :-
+ Arity = list.length(Args).
+type_to_ctor_and_args(apply_n(_, _, _), _, _) :-
+ sorry(this_file, "apply/N types").
+type_to_ctor_and_args(kinded(Type, _), TypeCtor, Args) :-
+ type_to_ctor_and_args(Type, TypeCtor, Args).
type_ctor_is_higher_order(SymName - _Arity, Purity, PredOrFunc, EvalMethod) :-
get_purity_and_eval_method(SymName, Purity, EvalMethod, PorFStr),
@@ -326,30 +412,104 @@
Purity = (pure)
).
-
-type_is_tuple(Type, ArgTypes) :-
- type_to_ctor_and_args(Type, TypeCtor, ArgTypes),
- type_ctor_is_tuple(TypeCtor).
-
type_ctor_is_tuple(unqualified("{}") - _).
type_ctor_is_variable(unqualified("") - _).
-prog_type.var(term.variable(Var), Var).
+prog_type.type_list_to_var_list([], []).
+prog_type.type_list_to_var_list([Type | Types], [Var | Vars]) :-
+ Type = variable(Var, _),
+ prog_type.type_list_to_var_list(Types, Vars).
+
+prog_type.var_list_to_type_list(_, [], []).
+prog_type.var_list_to_type_list(KindMap, [Var | Vars], [Type | Types]) :-
+ get_tvar_kind(KindMap, Var, Kind),
+ Type = variable(Var, Kind),
+ prog_type.var_list_to_type_list(KindMap, Vars, Types).
+
+prog_type.vars(Type, TVars) :-
+ prog_type.vars_2(Type, [], RevTVars),
+ list.reverse(RevTVars, TVarsDups),
+ list.remove_dups(TVarsDups, TVars).
+
+:- pred prog_type.vars_2((type)::in, list(tvar)::in, list(tvar)::out) is det.
+
+prog_type.vars_2(variable(Var, _), Vs, [Var | Vs]).
+prog_type.vars_2(defined(_, Args, _), !V) :-
+ prog_type.vars_list_2(Args, !V).
+prog_type.vars_2(builtin(_), !V).
+prog_type.vars_2(higher_order(Args, MaybeRet, _, _), !V) :-
+ prog_type.vars_list_2(Args, !V),
+ (
+ MaybeRet = yes(Ret),
+ prog_type.vars_2(Ret, !V)
+ ;
+ MaybeRet = no
+ ).
+prog_type.vars_2(tuple(Args, _), !V) :-
+ prog_type.vars_list_2(Args, !V).
+prog_type.vars_2(apply_n(Var, Args, _), !V) :-
+ !:V = [Var | !.V],
+ prog_type.vars_list_2(Args, !V).
+prog_type.vars_2(kinded(Type, _), !V) :-
+ prog_type.vars_2(Type, !V).
+
+prog_type.vars_list(Types, TVars) :-
+ prog_type.vars_list_2(Types, [], RevTVars),
+ list.reverse(RevTVars, TVarsDups),
+ list.remove_dups(TVarsDups, TVars).
+
+:- pred prog_type.vars_list_2(list(type)::in, list(tvar)::in, list(tvar)::out)
+ is det.
-prog_type.vars(Type, Tvars) :-
- term.vars(Type, Tvars).
+prog_type.vars_list_2([], !V).
+prog_type.vars_list_2([Type | Types], !V) :-
+ prog_type.vars_2(Type, !V),
+ prog_type.vars_list_2(Types, !V).
+
+type_contains_var(variable(Var, _), Var).
+type_contains_var(defined(_, Args, _), Var) :-
+ type_list_contains_var(Args, Var).
+type_contains_var(higher_order(Args, _, _, _), Var) :-
+ type_list_contains_var(Args, Var).
+type_contains_var(higher_order(_, yes(Ret), _, _), Var) :-
+ type_contains_var(Ret, Var).
+type_contains_var(tuple(Args, _), Var) :-
+ type_list_contains_var(Args, Var).
+type_contains_var(apply_n(Var, _, _), Var).
+type_contains_var(apply_n(_, Args, _), Var) :-
+ type_list_contains_var(Args, Var).
+type_contains_var(kinded(Type, _), Var) :-
+ type_contains_var(Type, Var).
+
+type_list_contains_var([Type | _], Var) :-
+ type_contains_var(Type, Var).
+type_list_contains_var([_ | Types], Var) :-
+ type_list_contains_var(Types, Var).
construct_type(TypeCtor, Args, Type) :-
(
+ TypeCtor = unqualified(Name) - 0,
+ builtin_type_to_string(BuiltinType, Name)
+ ->
+ Type = builtin(BuiltinType)
+ ;
type_ctor_is_higher_order(TypeCtor, Purity, PredOrFunc,
EvalMethod)
->
construct_higher_order_type(Purity, PredOrFunc, EvalMethod,
Args, Type)
;
+ type_ctor_is_tuple(TypeCtor)
+ ->
+ % XXX kind inference:
+ % we assume the kind is star.
+ Type = tuple(Args, star)
+ ;
TypeCtor = SymName - _,
- construct_qualified_term(SymName, Args, Type)
+ % XXX kind inference:
+ % we assume the kind is star.
+ Type = defined(SymName, Args, star)
).
construct_higher_order_type(Purity, PredOrFunc, EvalMethod, ArgTypes, Type) :-
@@ -365,61 +525,247 @@
).
construct_higher_order_pred_type(Purity, EvalMethod, ArgTypes, Type) :-
- construct_qualified_term(unqualified("pred"),
- ArgTypes, Type0),
- qualify_higher_order_type(EvalMethod, Type0, Type1),
- Type = add_purity_annotation(Purity, Type1).
+ Type = higher_order(ArgTypes, no, Purity, EvalMethod).
construct_higher_order_func_type(Purity, EvalMethod, ArgTypes, RetType, Type) :-
- construct_qualified_term(unqualified("func"), ArgTypes, Type0),
- qualify_higher_order_type(EvalMethod, Type0, Type1),
- Type2 = term.functor(term.atom("="), [Type1, RetType],
- term.context_init),
- Type = add_purity_annotation(Purity, Type2).
+ Type = higher_order(ArgTypes, yes(RetType), Purity, EvalMethod).
-:- func add_purity_annotation(purity, (type)) = (type).
-
-add_purity_annotation(Purity, Type0) = Type :-
+strip_builtin_qualifiers_from_type(variable(Var, Kind), variable(Var, Kind)).
+strip_builtin_qualifiers_from_type(defined(Name0, Args0, Kind),
+ defined(Name, Args, Kind)) :-
(
- Purity = (pure),
+ Name0 = qualified(Module, Name1),
+ mercury_public_builtin_module(Module)
+ ->
+ Name = unqualified(Name1)
+ ;
+ Name = Name0
+ ),
+ strip_builtin_qualifiers_from_type_list(Args0, Args).
+strip_builtin_qualifiers_from_type(builtin(BuiltinType), builtin(BuiltinType)).
+strip_builtin_qualifiers_from_type(
+ higher_order(Args0, MaybeRet0, Purity, EvalMethod),
+ higher_order(Args, MaybeRet, Purity, EvalMethod)) :-
+ strip_builtin_qualifiers_from_type_list(Args0, Args),
+ (
+ MaybeRet0 = yes(Ret0),
+ strip_builtin_qualifiers_from_type(Ret0, Ret),
+ MaybeRet = yes(Ret)
+ ;
+ MaybeRet0 = no,
+ MaybeRet = no
+ ).
+strip_builtin_qualifiers_from_type(tuple(Args0, Kind), tuple(Args, Kind)) :-
+ strip_builtin_qualifiers_from_type_list(Args0, Args).
+strip_builtin_qualifiers_from_type(apply_n(Var, Args0, Kind),
+ apply_n(Var, Args, Kind)) :-
+ strip_builtin_qualifiers_from_type_list(Args0, Args).
+strip_builtin_qualifiers_from_type(kinded(Type0, Kind), kinded(Type, Kind)) :-
+ strip_builtin_qualifiers_from_type(Type0, Type).
+
+strip_builtin_qualifiers_from_type_list(Types0, Types) :-
+ list__map(strip_builtin_qualifiers_from_type, Types0, Types).
+
+%-----------------------------------------------------------------------------%
+
+apply_rec_subst_to_type(Subst, Type0 @ variable(TVar, Kind), Type) :-
+ ( map__search(Subst, TVar, Type1) ->
+ ensure_type_has_kind(Kind, Type1, Type2),
+ apply_rec_subst_to_type(Subst, Type2, Type)
+ ;
Type = Type0
+ ).
+apply_rec_subst_to_type(Subst, defined(Name, Args0, Kind),
+ defined(Name, Args, Kind)) :-
+ apply_rec_subst_to_type_list(Subst, Args0, Args).
+apply_rec_subst_to_type(_Subst, Type @ builtin(_), Type).
+apply_rec_subst_to_type(Subst,
+ higher_order(Args0, MaybeReturn0, Purity, EvalMethod),
+ higher_order(Args, MaybeReturn, Purity, EvalMethod)) :-
+ apply_rec_subst_to_type_list(Subst, Args0, Args),
+ (
+ MaybeReturn0 = yes(Return0),
+ apply_rec_subst_to_type(Subst, Return0, Return),
+ MaybeReturn = yes(Return)
;
- Purity = (semipure),
- Type = term.functor(term.atom("semipure"), [Type0],
- term.context_init)
+ MaybeReturn0 = no,
+ MaybeReturn = no
+ ).
+apply_rec_subst_to_type(Subst, tuple(Args0, Kind), tuple(Args, Kind)) :-
+ apply_rec_subst_to_type_list(Subst, Args0, Args).
+apply_rec_subst_to_type(Subst, apply_n(TVar, Args0, Kind), Type) :-
+ apply_rec_subst_to_type_list(Subst, Args0, Args),
+ ( map__search(Subst, TVar, AppliedType0) ->
+ apply_rec_subst_to_type(Subst, AppliedType0, AppliedType),
+ apply_type_args(AppliedType, Args, Type)
;
- Purity = (impure),
- Type = term.functor(term.atom("impure"), [Type0],
- term.context_init)
+ Type = apply_n(TVar, Args, Kind)
).
+apply_rec_subst_to_type(Subst, kinded(Type0, Kind), kinded(Type, Kind)) :-
+ apply_rec_subst_to_type(Subst, Type0, Type).
-:- pred qualify_higher_order_type(lambda_eval_method::in, (type)::in,
- (type)::out) is det.
+apply_rec_subst_to_type_list(Subst, Types0, Types) :-
+ list__map(apply_rec_subst_to_type(Subst), Types0, Types).
-qualify_higher_order_type(normal, Type, Type).
-qualify_higher_order_type((aditi_bottom_up), Type0,
- term.functor(term.atom("aditi_bottom_up"), [Type0], Context)) :-
- term.context_init(Context).
-
-strip_builtin_qualifiers_from_type(Type0, Type) :-
- ( type_to_ctor_and_args(Type0, TypeCtor0, Args0) ->
- strip_builtin_qualifiers_from_type_list(Args0, Args),
- TypeCtor0 = SymName0 - Arity,
- (
- SymName0 = qualified(Module, Name),
- mercury_public_builtin_module(Module)
- ->
- SymName = unqualified(Name)
- ;
- SymName = SymName0
- ),
- construct_type(SymName - Arity, Args, Type)
+apply_rec_subst_to_tvar(KindMap, Subst, TVar, Type) :-
+ ( map__search(Subst, TVar, Type0) ->
+ apply_rec_subst_to_type(Subst, Type0, Type)
+ ;
+ get_tvar_kind(KindMap, TVar, Kind),
+ Type = variable(TVar, Kind)
+ ).
+
+apply_rec_subst_to_tvar_list(KindMap, Subst, TVars, Types) :-
+ list__map(apply_rec_subst_to_tvar(KindMap, Subst), TVars, Types).
+
+apply_subst_to_type(Subst, Type0 @ variable(TVar, Kind), Type) :-
+ ( map__search(Subst, TVar, Type1) ->
+ ensure_type_has_kind(Kind, Type1, Type)
;
Type = Type0
).
+apply_subst_to_type(Subst, defined(Name, Args0, Kind),
+ defined(Name, Args, Kind)) :-
+ apply_subst_to_type_list(Subst, Args0, Args).
+apply_subst_to_type(_Subst, Type @ builtin(_), Type).
+apply_subst_to_type(Subst,
+ higher_order(Args0, MaybeReturn0, Purity, EvalMethod),
+ higher_order(Args, MaybeReturn, Purity, EvalMethod)) :-
+ apply_subst_to_type_list(Subst, Args0, Args),
+ (
+ MaybeReturn0 = yes(Return0),
+ apply_subst_to_type(Subst, Return0, Return),
+ MaybeReturn = yes(Return)
+ ;
+ MaybeReturn0 = no,
+ MaybeReturn = no
+ ).
+apply_subst_to_type(Subst, tuple(Args0, Kind), tuple(Args, Kind)) :-
+ apply_subst_to_type_list(Subst, Args0, Args).
+apply_subst_to_type(Subst, apply_n(TVar, Args0, Kind), Type) :-
+ apply_subst_to_type_list(Subst, Args0, Args),
+ ( map__search(Subst, TVar, AppliedType) ->
+ apply_type_args(AppliedType, Args, Type)
+ ;
+ Type = apply_n(TVar, Args, Kind)
+ ).
+apply_subst_to_type(Subst, kinded(Type0, Kind), kinded(Type, Kind)) :-
+ apply_subst_to_type(Subst, Type0, Type).
+
+apply_subst_to_type_list(Subst, Types0, Types) :-
+ list__map(apply_subst_to_type(Subst), Types0, Types).
+
+apply_subst_to_tvar(KindMap, Subst, TVar, Type) :-
+ ( map__search(Subst, TVar, Type0) ->
+ apply_subst_to_type(Subst, Type0, Type)
+ ;
+ get_tvar_kind(KindMap, TVar, Kind),
+ Type = variable(TVar, Kind)
+ ).
+
+apply_subst_to_tvar_list(KindMap, Subst, TVars, Types) :-
+ list__map(apply_subst_to_tvar(KindMap, Subst), TVars, Types).
+
+apply_variable_renaming_to_type(Renaming, variable(TVar0, Kind),
+ variable(TVar, Kind)) :-
+ apply_variable_renaming_to_tvar(Renaming, TVar0, TVar).
+apply_variable_renaming_to_type(Renaming, defined(Name, Args0, Kind),
+ defined(Name, Args, Kind)) :-
+ apply_variable_renaming_to_type_list(Renaming, Args0, Args).
+apply_variable_renaming_to_type(_Renaming, Type @ builtin(_), Type).
+apply_variable_renaming_to_type(Renaming,
+ higher_order(Args0, MaybeReturn0, Purity, EvalMethod),
+ higher_order(Args, MaybeReturn, Purity, EvalMethod)) :-
+ apply_variable_renaming_to_type_list(Renaming, Args0, Args),
+ (
+ MaybeReturn0 = yes(Return0),
+ apply_variable_renaming_to_type(Renaming, Return0, Return),
+ MaybeReturn = yes(Return)
+ ;
+ MaybeReturn0 = no,
+ MaybeReturn = no
+ ).
+apply_variable_renaming_to_type(Renaming, tuple(Args0, Kind),
+ tuple(Args, Kind)) :-
+ apply_variable_renaming_to_type_list(Renaming, Args0, Args).
+apply_variable_renaming_to_type(Renaming, apply_n(TVar0, Args0, Kind),
+ apply_n(TVar, Args, Kind)) :-
+ apply_variable_renaming_to_type_list(Renaming, Args0, Args),
+ apply_variable_renaming_to_tvar(Renaming, TVar0, TVar).
+apply_variable_renaming_to_type(Renaming, kinded(Type0, Kind),
+ kinded(Type, Kind)) :-
+ apply_variable_renaming_to_type(Renaming, Type0, Type).
+
+apply_variable_renaming_to_type_list(Renaming, Types0, Types) :-
+ list__map(apply_variable_renaming_to_type(Renaming), Types0, Types).
+
+apply_variable_renaming_to_tvar(Renaming, TVar0, TVar) :-
+ ( map__search(Renaming, TVar0, TVar1) ->
+ TVar = TVar1
+ ;
+ TVar = TVar0
+ ).
+
+apply_variable_renaming_to_tvar_list(Renaming, TVars0, TVars) :-
+ list__map(apply_variable_renaming_to_tvar(Renaming), TVars0, TVars).
+
+apply_variable_renaming_to_tvar_kind_map(Renaming, KindMap0, KindMap) :-
+ map__foldl(apply_variable_renaming_to_tvar_kind_map_2(Renaming),
+ KindMap0, map__init, KindMap).
+
+:- pred apply_variable_renaming_to_tvar_kind_map_2(tvar_renaming::in, tvar::in,
+ kind::in, tvar_kind_map::in, tvar_kind_map::out) is det.
+
+apply_variable_renaming_to_tvar_kind_map_2(Renaming, TVar0, Kind, !KindMap) :-
+ apply_variable_renaming_to_tvar(Renaming, TVar0, TVar),
+ svmap__det_insert(TVar, Kind, !KindMap).
+
+:- pred apply_type_args((type)::in, list(type)::in, (type)::out) is det.
+
+apply_type_args(variable(TVar, Kind0), Args, apply_n(TVar, Args, Kind)) :-
+ apply_type_args_to_kind(Kind0, Args, Kind).
+apply_type_args(defined(Name, Args0, Kind0), Args,
+ defined(Name, Args0 ++ Args, Kind)) :-
+ apply_type_args_to_kind(Kind0, Args, Kind).
+apply_type_args(Type @ builtin(_), [], Type).
+apply_type_args(builtin(_), [_ | _], _) :-
+ unexpected(this_file, "applied type args to builtin").
+apply_type_args(Type @ higher_order(_, _, _, _), [], Type).
+apply_type_args(higher_order(_, _, _, _), [_ | _], _) :-
+ unexpected(this_file, "applied type args to higher_order").
+apply_type_args(tuple(Args0, Kind0), Args, tuple(Args0 ++ Args, Kind)) :-
+ apply_type_args_to_kind(Kind0, Args, Kind).
+apply_type_args(apply_n(TVar, Args0, Kind0), Args,
+ apply_n(TVar, Args0 ++ Args, Kind)) :-
+ apply_type_args_to_kind(Kind0, Args, Kind).
+apply_type_args(kinded(Type0, _), Args, Type) :-
+ % We drop the explicit kind annotation, since:
+ % - it will already have been used by kind inference, and
+ % - it no longer corresponds to any explicit annotation given.
+ apply_type_args(Type0, Args, Type).
+
+:- pred apply_type_args_to_kind(kind::in, list(type)::in, kind::out) is det.
+
+apply_type_args_to_kind(Kind, [], Kind).
+apply_type_args_to_kind(star, [_ | _], _) :-
+ unexpected(this_file, "too many args in apply_n").
+apply_type_args_to_kind(arrow(Kind0, Kind1), [ArgType | ArgTypes], Kind) :-
+ ( get_type_kind(ArgType) = Kind0 ->
+ apply_type_args_to_kind(Kind1, ArgTypes, Kind)
+ ;
+ unexpected(this_file, "kind error in apply_n")
+ ).
+apply_type_args_to_kind(variable(_), [_ | _], _) :-
+ unexpected(this_file, "unbound kind variable").
-strip_builtin_qualifiers_from_type_list(Types0, Types) :-
- list__map(strip_builtin_qualifiers_from_type, Types0, Types).
+:- pred ensure_type_has_kind(kind::in, (type)::in, (type)::out) is det.
+
+ensure_type_has_kind(Kind, Type0, Type) :-
+ ( get_type_kind(Type0) = Kind ->
+ Type = Type0
+ ;
+ unexpected(this_file, "substitution not kind preserving")
+ ).
%-----------------------------------------------------------------------------%
@@ -434,7 +780,7 @@
apply_rec_subst_to_prog_constraint(Subst, Constraint0, Constraint) :-
Constraint0 = constraint(ClassName, Types0),
- term__apply_rec_substitution_to_list(Types0, Subst, Types),
+ apply_rec_subst_to_type_list(Subst, Types0, Types),
Constraint = constraint(ClassName, Types).
apply_subst_to_prog_constraints(Subst,
@@ -449,7 +795,7 @@
apply_subst_to_prog_constraint(Subst, Constraint0, Constraint) :-
Constraint0 = constraint(ClassName, Types0),
- term__apply_substitution_to_list(Types0, Subst, Types),
+ apply_subst_to_type_list(Subst, Types0, Types),
Constraint = constraint(ClassName, Types).
apply_variable_renaming_to_prog_constraints(Renaming, Constraints0,
@@ -467,7 +813,7 @@
apply_variable_renaming_to_prog_constraint(Renaming, !Constraint) :-
!.Constraint = constraint(ClassName, ClassArgTypes0),
- term.apply_variable_renaming_to_list(ClassArgTypes0, Renaming,
+ apply_variable_renaming_to_type_list(Renaming, ClassArgTypes0,
ClassArgTypes),
!:Constraint = constraint(ClassName, ClassArgTypes).
@@ -476,7 +822,7 @@
list.condense(TVarsList, TVars).
constraint_get_tvars(constraint(_Name, Args), TVars) :-
- term.vars_list(Args, TVars).
+ prog_type.vars_list(Args, TVars).
get_unconstrained_tvars(Tvars, Constraints, Unconstrained) :-
constraint_list_get_tvars(Constraints, ConstrainedTvars),
@@ -484,5 +830,11 @@
list.remove_dups(Unconstrained0, Unconstrained).
%-----------------------------------------------------------------------------%
+
+:- func this_file = string.
+
+this_file = "prog_type.m".
+
+%-----------------------------------------------------------------------------%
:- end_module prog_type.
%-----------------------------------------------------------------------------%
Index: compiler/prog_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_util.m,v
retrieving revision 1.78
diff -u -r1.78 prog_util.m
--- compiler/prog_util.m 26 Jul 2005 01:56:25 -0000 1.78
+++ compiler/prog_util.m 8 Sep 2005 04:24:30 -0000
@@ -19,7 +19,6 @@
:- import_module parse_tree__prog_data.
:- import_module list.
-:- import_module map.
:- import_module std_util.
:- import_module term.
:- import_module varset.
@@ -247,7 +246,7 @@
%
:- pred get_new_tvars(list(tvar)::in, tvarset::in, tvarset::in, tvarset::out,
tvar_name_map::in, tvar_name_map::out,
- map(tvar, tvar)::in, map(tvar, tvar)::out) is det.
+ tvar_renaming::in, tvar_renaming::out) is det.
% substitute_vars(Vars0, Subst, Vars):
%
@@ -275,9 +274,10 @@
:- import_module bool.
:- import_module int.
-:- import_module svmap.
+:- import_module map.
:- import_module require.
:- import_module string.
+:- import_module svmap.
:- import_module varset.
%-----------------------------------------------------------------------------%
@@ -508,7 +508,7 @@
SubstToString = (pred(SubstElem::in, SubstStr::out) is det :-
SubstElem = Var - Type,
varset__lookup_name(VarSet, Var, VarName),
- TypeString = mercury_type_to_string(VarSet, Type),
+ TypeString = mercury_type_to_string(VarSet, no, Type),
string__append_list([VarName, " = ", TypeString], SubstStr)
),
list_to_string(SubstToString, TypeSubst, PredIdStr)
Index: compiler/pseudo_type_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/pseudo_type_info.m,v
retrieving revision 1.16
diff -u -r1.16 pseudo_type_info.m
--- compiler/pseudo_type_info.m 22 Mar 2005 06:40:21 -0000 1.16
+++ compiler/pseudo_type_info.m 11 Sep 2005 14:41:19 -0000
@@ -75,7 +75,7 @@
pseudo_type_info__construct_maybe_pseudo_type_info(Type, NumUnivQTvars,
ExistQTvars, MaybePseudoTypeInfo) :-
- ( term__is_ground(Type) ->
+ ( type_is_ground(Type) ->
pseudo_type_info__construct_type_info(Type, TypeInfo),
MaybePseudoTypeInfo = plain(TypeInfo)
;
@@ -118,7 +118,7 @@
PseudoArgs)
)
)
- ; prog_type__var(Type, Var) ->
+ ; Type = variable(Var, _) ->
% In the case of a type variable, we need to assign a
% variable number *for this constructor*, i.e. taking
% only the existentially quantified variables of
@@ -224,7 +224,7 @@
pseudo_type_info__generate_pseudo_arg(NumUnivQTvars, ExistQTvars,
TypeArg, MaybePseudoArg) :-
- ( term__is_ground(TypeArg) ->
+ ( type_is_ground(TypeArg) ->
pseudo_type_info__construct_type_info(TypeArg, PseudoArg),
MaybePseudoArg = plain(PseudoArg)
;
Index: compiler/qual_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/qual_info.m,v
retrieving revision 1.1
diff -u -r1.1 qual_info.m
--- compiler/qual_info.m 26 Jul 2005 01:56:25 -0000 1.1
+++ compiler/qual_info.m 6 Sep 2005 14:06:59 -0000
@@ -85,6 +85,7 @@
:- import_module hlds__hlds_data.
:- import_module parse_tree__prog_out.
+:- import_module parse_tree__prog_type.
:- import_module parse_tree__prog_util.
:- import_module std_util.
@@ -100,7 +101,7 @@
tvarset :: tvarset,
% All type variables for predicate.
- tvar_renaming :: map(tvar, tvar),
+ tvar_renaming :: tvar_renaming,
% Map from clause type variable to
% actual type variable in tvarset.
@@ -183,13 +184,13 @@
% Find any new type variables introduced by this type, and
% add them to the var-name index and the variable renaming.
- term__vars(Type1, TVars),
+ prog_type__vars(Type1, TVars),
get_new_tvars(TVars, VarSet, TVarSet0, TVarSet1,
TVarNameMap0, TVarNameMap, TVarRenaming0, TVarRenaming),
% Apply the updated renaming to convert type variables in
% the clause to type variables in the tvarset.
- term__apply_variable_renaming(Type1, TVarRenaming, Type2),
+ apply_variable_renaming_to_type(TVarRenaming, Type1, Type2),
% Expand equivalence types.
% We don't need to record the expanded types for smart recompilation
Index: compiler/recompilation.version.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/recompilation.version.m,v
retrieving revision 1.24
diff -u -r1.24 recompilation.version.m
--- compiler/recompilation.version.m 12 Sep 2005 03:05:47 -0000 1.24
+++ compiler/recompilation.version.m 12 Sep 2005 04:07:42 -0000
@@ -42,6 +42,7 @@
:- import_module check_hlds__mode_util.
:- import_module check_hlds__type_util.
:- import_module hlds__hlds_out.
+:- import_module parse_tree__error_util.
:- import_module parse_tree__mercury_to_mercury.
:- import_module parse_tree__prog_io.
:- import_module parse_tree__prog_type.
@@ -715,9 +716,14 @@
TVarSet2, _)
->
assoc_list__keys_and_values(TypeSubst1, TVars1, Types1),
- var_list_to_term_list(TVars1, TVarTypes1),
assoc_list__keys_and_values(TypeSubst2, TVars2, Types2),
- var_list_to_term_list(TVars2, TVarTypes2),
+ % XXX kind inference:
+ % we assume vars have kind `star'.
+ KindMap = map__init,
+ prog_type__var_list_to_type_list(KindMap, TVars1,
+ TVarTypes1),
+ prog_type__var_list_to_type_list(KindMap, TVars2,
+ TVarTypes2),
(
type_list_is_unchanged(
TVarSet1, TVarTypes1 ++ Types1,
@@ -850,24 +856,34 @@
),
type_list_is_unchanged(TVarSet1, AllTypes1, TVarSet2, AllTypes2,
- _TVarSet, RenameSubst, Types2ToTypes1Subst),
+ _TVarSet, Renaming, Types2ToTypes1Subst),
%
% Check that the existentially quantified variables are equivalent.
%
- SubstExistQVars2 =
- term_list_to_var_list(
- term__apply_rec_substitution_to_list(
- apply_substitution_to_list(
- var_list_to_term_list(ExistQVars2),
- RenameSubst),
- Types2ToTypes1Subst)),
- ExistQVars1 = SubstExistQVars2,
+ % XXX kind inference:
+ % we assume all tvars have kind `star'.
+ map__init(KindMap2),
+ apply_variable_renaming_to_tvar_kind_map(Renaming, KindMap2,
+ RenamedKindMap2),
+ apply_variable_renaming_to_tvar_list(Renaming, ExistQVars2,
+ RenamedExistQVars2),
+ apply_rec_subst_to_tvar_list(RenamedKindMap2, Types2ToTypes1Subst,
+ RenamedExistQVars2, SubstExistQTypes2),
+ (
+ prog_type__type_list_to_var_list(SubstExistQTypes2,
+ SubstExistQVars2)
+ ->
+ ExistQVars1 = SubstExistQVars2
+ ;
+ unexpected(this_file,
+ "pred_or_func_type_is_unchanged: non-var")
+ ),
%
% Check that the class constraints are identical.
%
- apply_subst_to_prog_constraints(RenameSubst,
+ apply_variable_renaming_to_prog_constraints(Renaming,
Constraints2, RenamedConstraints2),
apply_rec_subst_to_prog_constraints(Types2ToTypes1Subst,
RenamedConstraints2, SubstConstraints2),
@@ -875,15 +891,15 @@
:- pred type_list_is_unchanged(tvarset::in, list(type)::in,
tvarset::in, list(type)::in, tvarset::out,
- tsubst::out, tsubst::out) is semidet.
+ tvar_renaming::out, tsubst::out) is semidet.
type_list_is_unchanged(TVarSet1, Types1, TVarSet2, Types2,
- TVarSet, RenameSubst, Types2ToTypes1Subst) :-
- varset__merge_subst(TVarSet1, TVarSet2, TVarSet, RenameSubst),
- term__apply_substitution_to_list(Types2, RenameSubst, SubstTypes2),
+ TVarSet, Renaming, Types2ToTypes1Subst) :-
+ tvarset_merge_renaming(TVarSet1, TVarSet2, TVarSet, Renaming),
+ apply_variable_renaming_to_type_list(Renaming, Types2, SubstTypes2),
%
- % Check that the types are equivalent
+ % Check that the types are equivalent.
%
type_list_subsumes(SubstTypes2, Types1, Types2ToTypes1Subst),
type_list_subsumes(Types1, SubstTypes2, _),
@@ -899,16 +915,9 @@
( all [VarInItem1, VarInItem2]
(
map__member(Types2ToTypes1Subst, VarInItem2, SubstTerm),
- (
- SubstTerm = term__variable(VarInItem1)
- ;
- % The reverse subsumption test above should
- % ensure that the substitutions are all
- % var->var.
- SubstTerm = term__functor(_, _, _),
- error("pred_or_func_type_matches: " ++
- "invalid subst")
- )
+ % Note that since the type comes from a substitution,
+ % it will not contain a kind annotation.
+ SubstTerm = variable(VarInItem1, _)
)
=>
(
@@ -953,18 +962,16 @@
varset__merge_subst(VarSet1, VarSet2, _, InstSubst),
%
- % Treat modes as types here to use type_list_subsumes, which
- % does just what we want here. (XXX shouldn't type_list_subsumes
- % be in term.m and apply to generic terms anyway?).
- %
- ModeToTerm = (func(Mode) = term__coerce(mode_to_term(Mode))),
- ModeTerms1 = list__map(ModeToTerm, Modes1),
- ModeTerms2 = list__map(ModeToTerm, Modes2),
+ % Treat modes as terms here to use term__list_subsumes, which
+ % does just what we want here.
+ %
+ ModeTerms1 = list__map(mode_to_term, Modes1),
+ ModeTerms2 = list__map(mode_to_term, Modes2),
(
MaybeWithInst1 = yes(Inst1),
MaybeWithInst2 = yes(Inst2),
- WithInstTerm1 = term__coerce(mode_to_term(free -> Inst1)),
- WithInstTerm2 = term__coerce(mode_to_term(free -> Inst2)),
+ WithInstTerm1 = mode_to_term(free -> Inst1),
+ WithInstTerm2 = mode_to_term(free -> Inst2),
AllModeTerms1 = [WithInstTerm1 | ModeTerms1],
AllModeTerms2 = [WithInstTerm2 | ModeTerms2]
;
@@ -976,8 +983,8 @@
term__apply_substitution_to_list(AllModeTerms2,
InstSubst, SubstAllModeTerms2),
- type_list_subsumes(AllModeTerms1, SubstAllModeTerms2, _),
- type_list_subsumes(SubstAllModeTerms2, AllModeTerms1, _).
+ term__list_subsumes(AllModeTerms1, SubstAllModeTerms2, _),
+ term__list_subsumes(SubstAllModeTerms2, AllModeTerms1, _).
%
% Combined typeclass method type and mode declarations are split
@@ -1195,3 +1202,11 @@
).
%-----------------------------------------------------------------------------%
+
+:- func this_file = string.
+
+this_file = "recompilation.version.m".
+
+%-----------------------------------------------------------------------------%
+:- end_module recompilation__version.
+%-----------------------------------------------------------------------------%
Index: compiler/rl_dump.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rl_dump.m,v
retrieving revision 1.14
diff -u -r1.14 rl_dump.m
--- compiler/rl_dump.m 22 Mar 2005 06:40:22 -0000 1.14
+++ compiler/rl_dump.m 2 Sep 2005 16:04:52 -0000
@@ -105,9 +105,8 @@
io__write_string(")")
),
{ varset__init(TVarSet) },
- io__write_string(" "),
- rl_dump__write_list(term_io__write_term(TVarSet), Types),
- io__write_string(" : "),
+ { TypesStr = mercury_type_list_to_string(TVarSet, Types) },
+ io__write_strings([" [", TypesStr, "] : "]),
io__write_list(Index, " ", mercury_output_index_spec),
io__write_string(".\n").
Index: compiler/rtti_to_mlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rtti_to_mlds.m,v
retrieving revision 1.59
diff -u -r1.59 rtti_to_mlds.m
--- compiler/rtti_to_mlds.m 22 Mar 2005 06:40:24 -0000 1.59
+++ compiler/rtti_to_mlds.m 6 Sep 2005 15:08:32 -0000
@@ -892,7 +892,7 @@
= mlds__defn.
gen_field_names(_ModuleInfo, RttiTypeCtor, Ordinal, MaybeNames) = MLDS_Defn :-
- StrType = term__functor(term__atom("string"), [], context("", 0)),
+ StrType = builtin(string),
Init = gen_init_array(gen_init_maybe(
mercury_type(StrType, str_type,
non_foreign_type(StrType)),
Index: compiler/simplify.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/simplify.m,v
retrieving revision 1.152
diff -u -r1.152 simplify.m
--- compiler/simplify.m 2 Sep 2005 13:57:27 -0000 1.152
+++ compiler/simplify.m 5 Sep 2005 14:53:17 -0000
@@ -1377,7 +1377,7 @@
simplify_info_get_module_info(!.Info, ModuleInfo),
simplify_info_get_var_types(!.Info, VarTypes),
map__lookup(VarTypes, XVar, Type),
- ( Type = term__variable(TypeVar) ->
+ ( Type = variable(TypeVar, Kind) ->
%
% Convert polymorphic unifications into calls to `unify/2',
% the general unification predicate, passing the appropriate type_info:
@@ -1385,7 +1385,8 @@
% where TypeInfoVar is the type_info variable associated with
% the type of the variables that are being unified.
%
- simplify__type_info_locn(TypeVar, TypeInfoVar, ExtraGoals, !Info),
+ simplify__type_info_locn(TypeVar, Kind, TypeInfoVar, ExtraGoals,
+ !Info),
simplify__call_generic_unify(TypeInfoVar, XVar, YVar, ModuleInfo,
!.Info, Context, GoalInfo0, Call)
@@ -1540,10 +1541,10 @@
),
simplify_info_set_module_info(ModuleInfo, !Info).
-:- pred simplify__type_info_locn(tvar::in, prog_var::out, list(hlds_goal)::out,
- simplify_info::in, simplify_info::out) is det.
+:- pred simplify__type_info_locn(tvar::in, kind::in, prog_var::out,
+ list(hlds_goal)::out, simplify_info::in, simplify_info::out) is det.
-simplify__type_info_locn(TypeVar, TypeInfoVar, Goals, !Info) :-
+simplify__type_info_locn(TypeVar, Kind, TypeInfoVar, Goals, !Info) :-
simplify_info_get_rtti_varmaps(!.Info, RttiVarMaps),
rtti_lookup_type_info_locn(RttiVarMaps, TypeVar, TypeInfoLocn),
(
@@ -1553,22 +1554,22 @@
;
% If the typeinfo is in a typeclass_info then we need to extract it.
TypeInfoLocn = typeclass_info(TypeClassInfoVar, Index),
- simplify__extract_type_info(TypeVar, TypeClassInfoVar, Index,
+ simplify__extract_type_info(TypeVar, Kind, TypeClassInfoVar, Index,
Goals, TypeInfoVar, !Info)
).
-:- pred simplify__extract_type_info(tvar::in, prog_var::in, int::in,
+:- pred simplify__extract_type_info(tvar::in, kind::in, prog_var::in, int::in,
list(hlds_goal)::out, prog_var::out,
simplify_info::in, simplify_info::out) is det.
-simplify__extract_type_info(TypeVar, TypeClassInfoVar, Index,
+simplify__extract_type_info(TypeVar, Kind, TypeClassInfoVar, Index,
Goals, TypeInfoVar, !Info) :-
simplify_info_get_module_info(!.Info, ModuleInfo),
simplify_info_get_varset(!.Info, VarSet0),
simplify_info_get_var_types(!.Info, VarTypes0),
simplify_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
- polymorphism__gen_extract_type_info(TypeVar, TypeClassInfoVar, Index,
+ polymorphism__gen_extract_type_info(TypeVar, Kind, TypeClassInfoVar, Index,
ModuleInfo, Goals, TypeInfoVar, VarSet0, VarSet, VarTypes0, VarTypes,
RttiVarMaps0, RttiVarMaps),
@@ -2398,7 +2399,7 @@
simplify_info_get_var_types(!.Info, VarTypes0),
simplify_info_get_rtti_varmaps(!.Info, RttiVarMaps0),
ApplyTSubst = (pred(_::in, T0::in, T::out) is det :-
- T = term__apply_rec_substitution(T0, TSubst)
+ apply_rec_subst_to_type(TSubst, T0, T)
),
map__map_values(ApplyTSubst, VarTypes0, VarTypes),
apply_substitutions_to_rtti_varmaps(map__init, TSubst, map__init,
Index: compiler/size_prof.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/size_prof.m,v
retrieving revision 1.20
diff -u -r1.20 size_prof.m
--- compiler/size_prof.m 30 Aug 2005 04:11:59 -0000 1.20
+++ compiler/size_prof.m 8 Sep 2005 06:38:12 -0000
@@ -856,7 +856,7 @@
construct_type_info(Context, Type, TypeCtor, ArgTypes,
no, TypeInfoVar, TypeInfoGoals, !Info)
)
- ; Type = term__variable(TVar) ->
+ ; Type = variable(TVar, _) ->
rtti_lookup_type_info_locn(!.Info ^ rtti_varmaps, TVar, TVarLocn),
(
TVarLocn = type_info(TypeInfoVar),
@@ -1126,7 +1126,9 @@
record_typeinfo_in_type_info_varmap(RttiVarMaps, TVar, !Info) :-
rtti_lookup_type_info_locn(RttiVarMaps, TVar, TypeInfoLocn),
- Type = term__variable(TVar),
+ % XXX kind inference:
+ % we assume the kind is `star'.
+ Type = variable(TVar, star),
(
TypeInfoLocn = type_info(TypeInfoVar),
record_type_info_var(Type, TypeInfoVar, !Info)
Index: compiler/superhomogeneous.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/superhomogeneous.m,v
retrieving revision 1.3
diff -u -r1.3 superhomogeneous.m
--- compiler/superhomogeneous.m 30 Aug 2005 04:12:00 -0000 1.3
+++ compiler/superhomogeneous.m 8 Sep 2005 02:19:01 -0000
@@ -116,6 +116,7 @@
:- import_module hlds__make_hlds__field_access.
:- import_module hlds__make_hlds__qual_info.
:- import_module parse_tree__error_util.
+:- import_module parse_tree__mercury_to_mercury.
:- import_module parse_tree__module_qual.
:- import_module parse_tree__prog_io.
:- import_module parse_tree__prog_io_goal.
@@ -400,13 +401,31 @@
F = term__atom("with_type"),
Args = [RVal, DeclType0]
->
- convert_type(DeclType0, DeclType),
- varset__coerce(!.VarSet, DeclVarSet),
- process_type_qualification(X, DeclType, DeclVarSet,
- Context, !ModuleInfo, !QualInfo, !IO),
- unravel_unification(term__variable(X), RVal, Context,
- MainContext, SubContext, Purity, Goal,
- !VarSet, !ModuleInfo, !QualInfo, !SInfo, !IO)
+ % DeclType0 is a prog_term, but it is really a type so we coerce it
+ % to a generic term before parsing it.
+ term__coerce(DeclType0, DeclType1),
+ parse_type(DeclType1, DeclTypeResult),
+ (
+ DeclTypeResult = ok(DeclType),
+ varset__coerce(!.VarSet, DeclVarSet),
+ process_type_qualification(X, DeclType, DeclVarSet,
+ Context, !ModuleInfo, !QualInfo, !IO)
+ ;
+ DeclTypeResult = error(Msg, ErrorTerm),
+ % The varset is a prog_varset even though it contains the names
+ % of type variables in ErrorTerm, which is a generic term.
+ GenericVarSet = varset__coerce(!.VarSet),
+ TermStr = mercury_term_to_string(ErrorTerm, GenericVarSet, no),
+ Pieces = [words("In explicit type qualification:"),
+ words(Msg),
+ suffix(":"),
+ fixed("`" ++ TermStr ++ "'.")],
+ write_error_pieces(Context, 0, Pieces, !IO),
+ io.set_exit_status(1, !IO)
+ ),
+ unravel_unification(term__variable(X), RVal, Context, MainContext,
+ SubContext, Purity, Goal, !VarSet, !ModuleInfo, !QualInfo,
+ !SInfo, !IO)
;
% Handle unification expressions.
F = term__atom("@"),
Index: compiler/table_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/table_gen.m,v
retrieving revision 1.89
diff -u -r1.89 table_gen.m
--- compiler/table_gen.m 30 Aug 2005 04:12:00 -0000 1.89
+++ compiler/table_gen.m 8 Sep 2005 06:39:44 -0000
@@ -3435,7 +3435,7 @@
dummy_type_var = Type :-
varset__init(DummyTVarSet0),
varset__new_var(DummyTVarSet0, DummyTVar, _),
- Type = term__variable(DummyTVar).
+ Type = variable(DummyTVar, star).
%-----------------------------------------------------------------------------%
Index: compiler/term_norm.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/term_norm.m,v
retrieving revision 1.9
diff -u -r1.9 term_norm.m
--- compiler/term_norm.m 8 Apr 2005 06:50:49 -0000 1.9
+++ compiler/term_norm.m 11 Sep 2005 14:29:11 -0000
@@ -227,8 +227,9 @@
is_arg_recursive(Arg, TypeCtor, Params) :-
Arg = _Name - ArgType,
- type_to_ctor_and_args(ArgType, ArgTypeCtor, ArgTypeParams),
+ type_to_ctor_and_args(ArgType, ArgTypeCtor, ArgTypeArgs),
TypeCtor = ArgTypeCtor,
+ prog_type.type_list_to_var_list(ArgTypeArgs, ArgTypeParams),
list__perm(Params, ArgTypeParams).
:- pred search_weight_table(weight_table::in, type_ctor::in, cons_id::in,
Index: compiler/trace.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/trace.m,v
retrieving revision 1.73
diff -u -r1.73 trace.m
--- compiler/trace.m 7 Sep 2005 06:51:57 -0000 1.73
+++ compiler/trace.m 11 Sep 2005 15:32:12 -0000
@@ -240,6 +240,7 @@
:- import_module ll_backend__llds_out.
:- import_module mdbcomp__prim_data.
:- import_module parse_tree__error_util.
+:- import_module parse_tree__prog_type.
:- import_module bool.
:- import_module int.
@@ -965,7 +966,7 @@
),
LiveType = var(Var, Name, Type, LldsInst),
VarInfo = layout_var_info(direct(Lval), LiveType, "trace"),
- type_util__real_vars(Type, TypeVars),
+ prog_type__vars(Type, TypeVars),
set__insert_list(!.Tvars, TypeVars, !:Tvars).
%-----------------------------------------------------------------------------%
Index: compiler/type_ctor_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_ctor_info.m,v
retrieving revision 1.65
diff -u -r1.65 type_ctor_info.m
--- compiler/type_ctor_info.m 15 Aug 2005 07:18:31 -0000 1.65
+++ compiler/type_ctor_info.m 8 Sep 2005 10:02:01 -0000
@@ -78,6 +78,7 @@
:- import_module parse_tree__error_util.
:- import_module parse_tree__prog_data.
:- import_module parse_tree__prog_out.
+:- import_module parse_tree__prog_type.
:- import_module parse_tree__prog_util.
:- import_module assoc_list.
@@ -207,11 +208,12 @@
builtin_type_defn = TypeDefn :-
varset__init(TVarSet),
Params = [],
+ map__init(Kinds),
Body = abstract_type(non_solver_type),
ImportStatus = local,
NeedQualifier = may_be_unqualified,
term__context_init(Context),
- hlds_data__set_type_defn(TVarSet, Params, Body, ImportStatus, no,
+ hlds_data__set_type_defn(TVarSet, Params, Kinds, Body, ImportStatus, no,
NeedQualifier, Context, TypeDefn).
:- pred type_ctor_info__gen_type_ctor_gen_info(type_ctor::in, string::in,
@@ -809,7 +811,7 @@
list__map((pred(C::in, Ts::out) is det :- C = constraint(_, Ts)),
Constraints, ConstrainedTvars0),
list__condense(ConstrainedTvars0, ConstrainedTvars1),
- term__vars_list(ConstrainedTvars1, ConstrainedTvars2),
+ prog_type__vars_list(ConstrainedTvars1, ConstrainedTvars2),
list__delete_elems(ExistTvars, ConstrainedTvars2, UnconstrainedTvars),
% We do this to maintain the ordering of the type variables.
list__delete_elems(ExistTvars, UnconstrainedTvars, ConstrainedTvars),
@@ -852,7 +854,7 @@
first_matching_type_class_info([C | Cs], Tvar, MatchingConstraint, !N,
TypeInfoIndex) :-
C = constraint(_, Ts),
- term__vars_list(Ts, TVs),
+ prog_type__vars_list(Ts, TVs),
( list__nth_member_search(TVs, Tvar, Index) ->
MatchingConstraint = C,
TypeInfoIndex = Index
Index: compiler/type_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.152
diff -u -r1.152 type_util.m
--- compiler/type_util.m 26 Jul 2005 01:56:26 -0000 1.152
+++ compiler/type_util.m 12 Sep 2005 02:13:37 -0000
@@ -199,10 +199,10 @@
:- func comparison_result_type = (type).
:- func aditi_state_type = (type).
- % Construct type_infos and type_ctor_infos for the given types.
+ % Construct the types of type_infos and type_ctor_infos.
%
-:- func type_info_type(type) = (type).
-:- func type_ctor_info_type(type) = (type).
+:- func type_info_type = (type).
+:- func type_ctor_info_type = (type).
% Given a constant and an arity, return a type_ctor.
% Fails if the constant is not an atom.
@@ -310,6 +310,7 @@
---> ctor_defn(
tvarset,
existq_tvars,
+ tvar_kind_map, % kinds of existq_tvars
list(prog_constraint), % existential constraints
list(type), % functor argument types
(type) % functor result type
@@ -358,18 +359,15 @@
% The third argument is a list of type variables which cannot
% be bound (i.e. head type variables).
%
+ % No kind checking is done, since it is assumed that kind errors
+ % will be picked up elsewhere.
+ %
:- pred type_unify((type)::in, (type)::in, list(tvar)::in, tsubst::in,
tsubst::out) is semidet.
:- pred type_unify_list(list(type)::in, list(type)::in, list(tvar)::in,
tsubst::in, tsubst::out) is semidet.
- % Return a list of the type variables of a type,
- % ignoring any type variables if the variable in
- % question is a type-info
- %
-:- pred type_util__real_vars((type)::in, list(tvar)::out) is det.
-
% type_list_subsumes(TypesA, TypesB, Subst) succeeds iff the list
% TypesA subsumes (is more general than) TypesB, producing a
% type substitution which when applied to TypesA will give TypesB.
@@ -392,20 +390,24 @@
% the callee are bound.
%
:- pred arg_type_list_subsumes(tvarset::in, list(type)::in,
- tvarset::in, existq_tvars::in, list(type)::in) is semidet.
+ tvarset::in, tvar_kind_map::in, existq_tvars::in,
+ list(type)::in) is semidet.
% apply a type substitution (i.e. map from tvar -> type)
% to all the types in a variable typing (i.e. map from var -> type).
%
-:- pred apply_substitution_to_type_map(map(prog_var, type)::in, tsubst::in,
- map(prog_var, type)::out) is det.
+:- pred apply_subst_to_type_map(tsubst::in, vartypes::in, vartypes::out)
+ is det.
% same thing as above, except for a recursive substitution
% (i.e. we keep applying the substitution recursively until
% there are no more changes).
%
-:- pred apply_rec_substitution_to_type_map(map(prog_var, type)::in, tsubst::in,
- map(prog_var, type)::out) is det.
+:- pred apply_rec_subst_to_type_map(tsubst::in, vartypes::in, vartypes::out)
+ is det.
+
+:- pred apply_variable_renaming_to_type_map(tvar_renaming::in,
+ vartypes::in, vartypes::out) is det.
:- pred apply_rec_subst_to_constraints(tsubst::in, hlds_constraints::in,
hlds_constraints::out) is det.
@@ -437,22 +439,19 @@
:- pred apply_rec_subst_to_constraint_map(tsubst::in,
constraint_map::in, constraint_map::out) is det.
-:- pred apply_variable_renaming_to_type_map(map(tvar, tvar)::in,
- vartypes::in, vartypes::out) is det.
-
-:- pred apply_variable_renaming_to_constraints(map(tvar, tvar)::in,
+:- pred apply_variable_renaming_to_constraints(tvar_renaming::in,
hlds_constraints::in, hlds_constraints::out) is det.
-:- pred apply_variable_renaming_to_constraint_list(map(tvar, tvar)::in,
+:- pred apply_variable_renaming_to_constraint_list(tvar_renaming::in,
list(hlds_constraint)::in, list(hlds_constraint)::out) is det.
-:- pred apply_variable_renaming_to_constraint(map(tvar, tvar)::in,
+:- pred apply_variable_renaming_to_constraint(tvar_renaming::in,
hlds_constraint::in, hlds_constraint::out) is det.
-:- pred apply_variable_renaming_to_constraint_proofs(map(tvar, tvar)::in,
+:- pred apply_variable_renaming_to_constraint_proofs(tvar_renaming::in,
constraint_proof_map::in, constraint_proof_map::out) is det.
-:- pred apply_variable_renaming_to_constraint_map(map(tvar, tvar)::in,
+:- pred apply_variable_renaming_to_constraint_map(tvar_renaming::in,
constraint_map::in, constraint_map::out) is det.
% Apply a renaming (partial map) to a list.
@@ -517,6 +516,7 @@
:- import_module int.
:- import_module require.
:- import_module string.
+:- import_module svmap.
:- import_module varset.
type_util__type_ctor_module(_ModuleInfo, TypeName - _Arity, ModuleName) :-
@@ -813,63 +813,6 @@
hlds_data__get_type_defn_body(TypeDefn, TypeBody),
TypeBody ^ du_type_is_enum = yes.
-% type_to_ctor_and_args(Type, SymName - Arity, Args) :-
-% Type \= term__variable(_),
-%
-% % higher order types may have representations where
-% % their arguments don't directly correspond to the
-% % arguments of the term.
-% (
-% type_is_higher_order(Type, Purity, PredOrFunc,
-% EvalMethod, PredArgTypes)
-% ->
-% Args = PredArgTypes,
-% list__length(Args, Arity0),
-% adjust_func_arity(PredOrFunc, Arity, Arity0),
-% (
-% PredOrFunc = predicate,
-% PorFStr = "pred"
-% ;
-% PredOrFunc = function,
-% PorFStr = "func"
-% ),
-% SymName0 = unqualified(PorFStr),
-% (
-% EvalMethod = (aditi_bottom_up),
-% insert_module_qualifier("aditi_bottom_up", SymName0,
-% SymName1)
-% ;
-% EvalMethod = normal,
-% SymName1 = SymName0
-% ),
-% (
-% Purity = (pure),
-% SymName = SymName1
-% ;
-% Purity = (semipure),
-% insert_module_qualifier("semipure", SymName1, SymName)
-% ;
-% Purity = (impure),
-% insert_module_qualifier("impure", SymName1, SymName)
-% )
-% ;
-% sym_name_and_args(Type, SymName, Args),
-%
-% % `private_builtin:constraint' is introduced by polymorphism,
-% % and should only appear as the argument of a
-% % `typeclass:info/1' type.
-% % It behaves sort of like a type variable, so according to the
-% % specification of `type_to_ctor_and_args', it should
-% % cause failure. There isn't a definition in the type table.
-% \+ (
-% SymName = qualified(ModuleName, UnqualName),
-% UnqualName = "constraint",
-% mercury_private_builtin_module(PrivateBuiltin),
-% ModuleName = PrivateBuiltin
-% ),
-% list__length(Args, Arity)
-% ).
-
canonicalize_type_args(TypeCtor, TypeArgs0, TypeArgs) :-
(
% The arguments of typeclass_info/base_typeclass_info types
@@ -886,57 +829,47 @@
TypeArgs = TypeArgs0
).
-int_type = Type :-
- construct_type(unqualified("int") - 0, [], Type).
+int_type = builtin(int).
-string_type = Type :-
- construct_type(unqualified("string") - 0, [], Type).
+string_type = builtin(string).
-float_type = Type :-
- construct_type(unqualified("float") - 0, [], Type).
+float_type = builtin(float).
-char_type = Type :-
- construct_type(unqualified("character") - 0, [], Type).
+char_type = builtin(character).
-void_type = Type :-
- construct_type(unqualified("void") - 0, [], Type).
+void_type = defined(unqualified("void"), [], star).
-c_pointer_type = Type :-
+c_pointer_type = defined(Name, [], star) :-
mercury_public_builtin_module(BuiltinModule),
- construct_type(qualified(BuiltinModule, "c_pointer") - 0, [], Type).
+ Name = qualified(BuiltinModule, "c_pointer").
-heap_pointer_type = Type :-
+heap_pointer_type = defined(Name, [], star) :-
mercury_private_builtin_module(BuiltinModule),
- construct_type(qualified(BuiltinModule, "heap_pointer") - 0, [], Type).
+ Name = qualified(BuiltinModule, "heap_pointer").
-sample_type_info_type = Type :-
+sample_type_info_type = defined(Name, [], star) :-
mercury_private_builtin_module(BuiltinModule),
- construct_type(qualified(BuiltinModule,
- "sample_type_info") - 0, [], Type).
+ Name = qualified(BuiltinModule, "sample_type_info").
-sample_typeclass_info_type = Type :-
+sample_typeclass_info_type = defined(Name, [], star) :-
mercury_private_builtin_module(BuiltinModule),
- construct_type(qualified(BuiltinModule,
- "sample_typeclass_info") - 0, [], Type).
+ Name = qualified(BuiltinModule, "sample_typeclass_info").
-comparison_result_type = Type :-
+comparison_result_type = defined(Name, [], star) :-
mercury_public_builtin_module(BuiltinModule),
- construct_type(qualified(BuiltinModule,
- "comparison_result") - 0, [], Type).
+ Name = qualified(BuiltinModule, "comparison_result").
-type_info_type(ForType) = Type :-
+type_info_type = defined(Name, [void_type], star) :-
mercury_private_builtin_module(BuiltinModule),
- construct_type(qualified(BuiltinModule, "type_info") - 1,
- [ForType], Type).
+ Name = qualified(BuiltinModule, "type_info").
-type_ctor_info_type(ForType) = Type :-
+type_ctor_info_type = defined(Name, [void_type], star) :-
mercury_private_builtin_module(BuiltinModule),
- construct_type(qualified(BuiltinModule, "type_ctor_info") - 1,
- [ForType], Type).
+ Name = qualified(BuiltinModule, "type_ctor_info").
-aditi_state_type = Type :-
+aditi_state_type = defined(Name, [], star) :-
aditi_public_builtin_module(BuiltinModule),
- construct_type(qualified(BuiltinModule, "state") - 0, [], Type).
+ Name = qualified(BuiltinModule, "state").
%-----------------------------------------------------------------------------%
@@ -1029,10 +962,7 @@
Args, _, _),
Args \= []
->
- hlds_data__get_type_defn_tparams(TypeDefn,
- TypeDefnParams),
- term__term_list_to_var_list(TypeDefnParams,
- TypeDefnVars),
+ hlds_data__get_type_defn_tparams(TypeDefn, TypeParams),
% XXX handle ExistQVars
( ExistQVars0 = [] ->
@@ -1048,11 +978,10 @@
)
),
- map__from_corresponding_lists(TypeDefnVars, TypeArgs,
+ map__from_corresponding_lists(TypeParams, TypeArgs,
TSubst),
assoc_list__values(Args, ArgTypes0),
- term__apply_substitution_to_list(ArgTypes0, TSubst,
- ArgTypes)
+ apply_subst_to_type_list(TSubst, ArgTypes0, ArgTypes)
;
ArgTypes = []
)
@@ -1076,12 +1005,11 @@
% XXX handle ExistQVars
ExistQVars0 = [],
- hlds_data__get_type_defn_tparams(TypeDefn, TypeDefnParams),
- term__term_list_to_var_list(TypeDefnParams, TypeDefnVars),
+ hlds_data__get_type_defn_tparams(TypeDefn, TypeParams),
- map__from_corresponding_lists(TypeDefnVars, TypeArgs, TSubst),
+ map__from_corresponding_lists(TypeParams, TypeArgs, TSubst),
assoc_list__values(Args, ArgTypes0),
- term__apply_substitution_to_list(ArgTypes0, TSubst, ArgTypes).
+ apply_subst_to_type_list(TSubst, ArgTypes0, ArgTypes).
type_util__is_existq_cons(ModuleInfo, VarType, ConsId) :-
type_util__is_existq_cons(ModuleInfo, VarType, ConsId, _).
@@ -1106,10 +1034,12 @@
type_to_ctor_and_args(VarType, TypeCtor, _),
map__lookup(Types, TypeCtor, TypeDefn),
hlds_data__get_type_defn_tvarset(TypeDefn, TypeVarSet),
- hlds_data__get_type_defn_tparams(TypeDefn, TypeDefnParams),
+ hlds_data__get_type_defn_tparams(TypeDefn, TypeParams),
+ hlds_data__get_type_defn_kind_map(TypeDefn, KindMap),
+ prog_type.var_list_to_type_list(KindMap, TypeParams, TypeCtorArgs),
type_to_ctor_and_args(VarType, TypeCtor, _),
- construct_type(TypeCtor, TypeDefnParams, RetType),
- CtorDefn = ctor_defn(TypeVarSet, ExistQVars, Constraints,
+ construct_type(TypeCtor, TypeCtorArgs, RetType),
+ CtorDefn = ctor_defn(TypeVarSet, ExistQVars, KindMap, Constraints,
ArgTypes, RetType).
type_util__get_type_and_cons_defn(ModuleInfo, Type, ConsId,
@@ -1179,13 +1109,12 @@
type_to_ctor_and_args(Type, TypeCtor, TypeArgs),
module_info_no_tag_types(ModuleInfo, NoTagTypes),
map__search(NoTagTypes, TypeCtor, NoTagType),
- NoTagType = no_tag_type(TypeParams0, Ctor, ArgType0),
- ( TypeParams0 = [] ->
+ NoTagType = no_tag_type(TypeParams, Ctor, ArgType0),
+ ( TypeParams = [] ->
ArgType = ArgType0
;
- term__term_list_to_var_list(TypeParams0, TypeParams),
map__from_corresponding_lists(TypeParams, TypeArgs, Subn),
- term__apply_substitution(ArgType0, Subn, ArgType)
+ apply_subst_to_type(Subn, ArgType0, ArgType)
).
type_constructors_are_no_tag_type(Ctors, Ctor, ArgType, MaybeArgName) :-
@@ -1268,11 +1197,10 @@
:- pred substitute_type_args(list(type_param)::in, list(type)::in,
list(constructor)::in, list(constructor)::out) is det.
-substitute_type_args(TypeParams0, TypeArgs, Constructors0, Constructors) :-
- ( TypeParams0 = [] ->
+substitute_type_args(TypeParams, TypeArgs, Constructors0, Constructors) :-
+ ( TypeParams = [] ->
Constructors = Constructors0
;
- term__term_list_to_var_list(TypeParams0, TypeParams),
map__from_corresponding_lists(TypeParams, TypeArgs, Subst),
substitute_type_args_2(Subst, Constructors0, Constructors)
).
@@ -1298,7 +1226,7 @@
substitute_type_args_3(_, [], []).
substitute_type_args_3(Subst, [Name - Arg0 | Args0], [Name - Arg | Args]) :-
- term__apply_substitution(Arg0, Subst, Arg),
+ apply_subst_to_type(Subst, Arg0, Arg),
substitute_type_args_3(Subst, Args0, Args).
%-----------------------------------------------------------------------------%
@@ -1312,7 +1240,7 @@
% TypesA subsumes TypesB iff TypesA can be unified with TypesB
% without binding any of the type variables in TypesB.
%
- term__vars_list(TypesB, TypesBVars),
+ prog_type__vars_list(TypesB, TypesBVars),
map__init(TypeSubst0),
type_unify_list(TypesA, TypesB, TypesBVars, TypeSubst0, TypeSubst).
@@ -1323,20 +1251,23 @@
error("type_list_subsumes_det: type_list_subsumes failed")
).
-arg_type_list_subsumes(TVarSet, ArgTypes, CalleeTVarSet,
- CalleeExistQVars0, CalleeArgTypes0) :-
+arg_type_list_subsumes(TVarSet, ActualArgTypes, CalleeTVarSet, PredKindMap,
+ PredExistQVars, PredArgTypes) :-
%
- % rename the type variables in the callee's argument types.
+ % Rename the type variables in the callee's argument types.
%
- varset__merge_subst(TVarSet, CalleeTVarSet, _TVarSet1, Subst),
- term__apply_substitution_to_list(CalleeArgTypes0, Subst,
- CalleeArgTypes),
- map__apply_to_list(CalleeExistQVars0, Subst, CalleeExistQTypes0),
+ tvarset_merge_renaming(TVarSet, CalleeTVarSet, _TVarSet1, Renaming),
+ apply_variable_renaming_to_tvar_kind_map(Renaming, PredKindMap,
+ ParentKindMap),
+ apply_variable_renaming_to_type_list(Renaming, PredArgTypes,
+ ParentArgTypes),
+ apply_variable_renaming_to_tvar_list(Renaming, PredExistQVars,
+ ParentExistQVars),
%
- % check that the types of the candidate predicate/function
- % subsume the actual argument types
+ % Check that the types of the candidate predicate/function
+ % subsume the actual argument types.
% [This is the right thing to do even for calls to
% existentially typed preds, because we're using the
% type variables from the callee's pred decl (obtained
@@ -1345,247 +1276,378 @@
% clauses_info and proc_info) -- the latter
% might not subsume the actual argument types.]
%
- type_list_subsumes(CalleeArgTypes, ArgTypes, TypeSubst),
+ type_list_subsumes(ParentArgTypes, ActualArgTypes,
+ ParentToActualSubst),
%
- % check that the type substitution did not bind any
- % existentially typed variables to non-ground types
+ % Check that the type substitution did not bind any existentially
+ % typed variables to non-ground types.
%
- ( CalleeExistQTypes0 = [] ->
- % optimize common case
+ ( ParentExistQVars = [] ->
+ % Optimize common case.
true
;
- term__apply_rec_substitution_to_list(CalleeExistQTypes0,
- TypeSubst, CalleeExistQTypes),
- all [T] (list__member(T, CalleeExistQTypes) =>
- prog_type__var(T, _))
-
- % it might make sense to also check that
- % the type substitution did not bind any
- % existentially typed variables to universally
- % quantified type variables in the caller's
- % argument types
+ apply_rec_subst_to_tvar_list(ParentKindMap,
+ ParentToActualSubst, ParentExistQVars,
+ ActualExistQTypes),
+ all [T] (list__member(T, ActualExistQTypes) =>
+ T = variable(_, _))
+
+ % It might make sense to also check that the type
+ % substitution did not bind any existentially typed
+ % variables to universally quantified type variables in
+ % the caller's argument types.
).
%-----------------------------------------------------------------------------%
+%
+% Type unification.
+%
+
+type_unify(X, Y, HeadTypeParams, !Bindings) :-
+ (
+ X = variable(VarX, _)
+ ->
+ type_unify_var(VarX, Y, HeadTypeParams, !Bindings)
+ ;
+ Y = variable(VarY, _)
+ ->
+ type_unify_var(VarY, X, HeadTypeParams, !Bindings)
+ ;
+ type_unify_nonvar(X, Y, HeadTypeParams, !Bindings)
+ ->
+ true
+ ;
+ % Some special cases are not handled above. We handle them
+ % separately here.
+ type_unify_special(X, Y, HeadTypeParams, !Bindings)
+ ).
+
+:- pred type_unify_var(tvar::in, (type)::in, list(tvar)::in,
+ tsubst::in, tsubst::out) is semidet.
- % Types are represented as terms, but we can't just use term__unify
- % because we need to avoid binding any of the "head type params"
- % (the type variables that occur in the head of the clause),
- % and because one day we might want to handle equivalent types.
-
-type_unify(term__variable(X), term__variable(Y), HeadTypeParams,
- Bindings0, Bindings) :-
- ( list__member(Y, HeadTypeParams) ->
- type_unify_head_type_param(X, Y, HeadTypeParams,
- Bindings0, Bindings)
- ; list__member(X, HeadTypeParams) ->
- type_unify_head_type_param(Y, X, HeadTypeParams,
- Bindings0, Bindings)
- ; map__search(Bindings0, X, BindingOfX) ->
- ( map__search(Bindings0, Y, BindingOfY) ->
- % both X and Y already have bindings - just
- % unify the types they are bound to
+type_unify_var(VarX, TypeY, HeadTypeParams, !Bindings) :-
+ (
+ TypeY = variable(VarY, KindY)
+ ->
+ type_unify_var_var(VarX, VarY, KindY, HeadTypeParams,
+ !Bindings)
+ ;
+ map.search(!.Bindings, VarX, BindingOfX)
+ ->
+ % VarX has a binding. Y is not a variable.
+ type_unify(BindingOfX, TypeY, HeadTypeParams, !Bindings)
+ ;
+ % VarX has no binding, so bind it to TypeY.
+ \+ type_occurs(TypeY, VarX, !.Bindings),
+ \+ list.member(VarX, HeadTypeParams),
+ svmap.det_insert(VarX, TypeY, !Bindings)
+ ).
+
+:- pred type_unify_var_var(tvar::in, tvar::in, kind::in, list(tvar)::in,
+ tsubst::in, tsubst::out) is semidet.
+
+type_unify_var_var(X, Y, Kind, HeadTypeParams, !Bindings) :-
+ (
+ list.member(Y, HeadTypeParams)
+ ->
+ type_unify_head_type_param(X, Y, Kind, HeadTypeParams,
+ !Bindings)
+ ;
+ list.member(X, HeadTypeParams)
+ ->
+ type_unify_head_type_param(Y, X, Kind, HeadTypeParams,
+ !Bindings)
+ ;
+ map.search(!.Bindings, X, BindingOfX)
+ ->
+ (
+ map.search(!.Bindings, Y, BindingOfY)
+ ->
+ % Both X and Y already have bindings - just unify the
+ % types they are bound to.
type_unify(BindingOfX, BindingOfY, HeadTypeParams,
- Bindings0, Bindings)
+ !Bindings)
;
- term__apply_rec_substitution(BindingOfX,
- Bindings0, SubstBindingOfX),
- % Y is a type variable which hasn't been bound yet
- ( SubstBindingOfX = term__variable(Y) ->
- Bindings = Bindings0
+ % Y hasn't been bound yet.
+ apply_rec_subst_to_type(!.Bindings, BindingOfX,
+ SubstBindingOfX),
+ (
+ SubstBindingOfX = variable(Y, _)
+ ->
+ true
;
- \+ term__occurs(SubstBindingOfX, Y,
- Bindings0),
- map__det_insert(Bindings0, Y, SubstBindingOfX,
- Bindings)
+ \+ type_occurs(SubstBindingOfX, Y, !.Bindings),
+ svmap.det_insert(Y, SubstBindingOfX, !Bindings)
)
)
;
- ( map__search(Bindings0, Y, BindingOfY) ->
- term__apply_rec_substitution(BindingOfY,
- Bindings0, SubstBindingOfY),
- % X is a type variable which hasn't been bound yet
- ( SubstBindingOfY = term__variable(X) ->
- Bindings = Bindings0
+ % Neither X nor Y is a head type param. X had not been
+ % bound yet.
+ (
+ map.search(!.Bindings, Y, BindingOfY)
+ ->
+ apply_rec_subst_to_type(!.Bindings, BindingOfY,
+ SubstBindingOfY),
+ (
+ SubstBindingOfY = variable(X, _)
+ ->
+ true
;
- \+ term__occurs(SubstBindingOfY, X,
- Bindings0),
- map__det_insert(Bindings0, X, SubstBindingOfY,
- Bindings)
+ \+ type_occurs(SubstBindingOfY, X, !.Bindings),
+ svmap.det_insert(X, SubstBindingOfY, !Bindings)
)
;
- % both X and Y are unbound type variables -
- % bind one to the other
- ( X = Y ->
- Bindings = Bindings0
+ % Both X and Y are unbound type variables - bind one
+ % to the other.
+ (
+ X = Y
+ ->
+ true
;
- map__det_insert(Bindings0, X,
- term__variable(Y), Bindings)
+ svmap.det_insert(X, variable(Y, Kind),
+ !Bindings)
)
)
).
-type_unify(term__variable(X), term__functor(F, As, C), HeadTypeParams,
- Bindings0, Bindings) :-
- (
- map__search(Bindings0, X, BindingOfX)
- ->
- type_unify(BindingOfX, term__functor(F, As, C),
- HeadTypeParams, Bindings0, Bindings)
+:- pred type_unify_head_type_param(tvar::in, tvar::in, kind::in,
+ list(tvar)::in, tsubst::in, tsubst::out) is semidet.
+
+type_unify_head_type_param(Var, HeadVar, Kind, HeadTypeParams, !Bindings) :-
+ ( map.search(!.Bindings, Var, BindingOfVar) ->
+ BindingOfVar = variable(Var2, _),
+ type_unify_head_type_param(Var2, HeadVar, Kind, HeadTypeParams,
+ !Bindings)
;
- \+ term__occurs_list(As, X, Bindings0),
- \+ list__member(X, HeadTypeParams),
- map__det_insert(Bindings0, X, term__functor(F, As, C),
- Bindings)
+ ( Var = HeadVar ->
+ true
+ ;
+ \+ list.member(Var, HeadTypeParams),
+ svmap.det_insert(Var, variable(HeadVar, Kind),
+ !Bindings)
+ )
).
-type_unify(term__functor(F, As, C), term__variable(X), HeadTypeParams,
- Bindings0, Bindings) :-
+ % Unify two types, neither of which are variables. Two special cases
+ % which are not handled here are apply_n types and kinded types.
+ % Those are handled below.
+ %
+:- pred type_unify_nonvar((type)::in, (type)::in, list(tvar)::in,
+ tsubst::in, tsubst::out) is semidet.
+
+type_unify_nonvar(defined(SymName, ArgsX, _), defined(SymName, ArgsY, _),
+ HeadTypeParams, !Bindings) :-
+ % Instead of insisting that the names are equal and the arg lists
+ % unify, we should consider attempting to expand equivalence types
+ % first. That would require the type table to be passed in to the
+ % unification algorithm, though.
+ type_unify_list(ArgsX, ArgsY, HeadTypeParams, !Bindings).
+type_unify_nonvar(builtin(BuiltinType), builtin(BuiltinType), _, !Bindings).
+type_unify_nonvar(higher_order(ArgsX, no, Purity, EvalMethod),
+ higher_order(ArgsY, no, Purity, EvalMethod),
+ HeadTypeParams, !Bindings) :-
+ type_unify_list(ArgsX, ArgsY, HeadTypeParams, !Bindings).
+type_unify_nonvar(higher_order(ArgsX, yes(RetX), Purity, EvalMethod),
+ higher_order(ArgsY, yes(RetY), Purity, EvalMethod),
+ HeadTypeParams, !Bindings) :-
+ type_unify_list(ArgsX, ArgsY, HeadTypeParams, !Bindings),
+ type_unify(RetX, RetY, HeadTypeParams, !Bindings).
+type_unify_nonvar(tuple(ArgsX, _), tuple(ArgsY, _), HeadTypeParams,
+ !Bindings) :-
+ type_unify_list(ArgsX, ArgsY, HeadTypeParams, !Bindings).
+
+ % Handle apply_n types and kinded types.
+ %
+:- pred type_unify_special((type)::in, (type)::in, list(tvar)::in,
+ tsubst::in, tsubst::out) is semidet.
+
+type_unify_special(X, Y, HeadTypeParams, !Bindings) :-
(
- map__search(Bindings0, X, BindingOfX)
+ X = apply_n(VarX, ArgsX, _)
->
- type_unify(term__functor(F, As, C), BindingOfX,
- HeadTypeParams, Bindings0, Bindings)
+ type_unify_apply(Y, VarX, ArgsX, HeadTypeParams, !Bindings)
;
- \+ term__occurs_list(As, X, Bindings0),
- \+ list__member(X, HeadTypeParams),
- map__det_insert(Bindings0, X, term__functor(F, As, C),
- Bindings)
- ).
-
-type_unify(term__functor(FX, AsX, _CX), term__functor(FY, AsY, _CY),
- HeadTypeParams, Bindings0, Bindings) :-
- list__length(AsX, ArityX),
- list__length(AsY, ArityY),
- (
- FX = FY,
- ArityX = ArityY
+ Y = apply_n(VarY, ArgsY, _)
->
- type_unify_list(AsX, AsY, HeadTypeParams, Bindings0, Bindings)
+ type_unify_apply(X, VarY, ArgsY, HeadTypeParams, !Bindings)
;
- fail
- ).
-
- % XXX Instead of just failing if the functors' name/arity is different,
- % we should check here if these types have been defined
- % to be equivalent using equivalence types. But this
- % is difficult because the relevant variable
- % TypeTable hasn't been passed in to here.
-
-/*******
- ...
- ;
- replace_eqv_type(FX, ArityX, AsX, EqvType)
+ X = kinded(RawX, _)
->
- type_unify(EqvType, term__functor(FY, AsY, CY),
- HeadTypeParams, Bindings0, Bindings)
+ (
+ Y = kinded(RawY, _)
+ ->
+ type_unify(RawX, RawY, HeadTypeParams, !Bindings)
+ ;
+ type_unify(RawX, Y, HeadTypeParams, !Bindings)
+ )
;
- replace_eqv_type(FY, ArityY, AsY, EqvType)
+ Y = kinded(RawY, _)
->
- type_unify(term__functor(FX, AsX, CX), EqvType,
- HeadTypeParams, Bindings0, Bindings)
+ type_unify(X, RawY, HeadTypeParams, !Bindings)
;
fail
).
-:- pred replace_eqv_type(const::in, int::in, list(type)::in, (type)::out)
- is semidet.
+ % The idea here is that we try to strip off arguments from Y starting
+ % from the end and unify each with the corresponding argument of X.
+ % If we reach an atomic type before the arguments run out then we
+ % fail. If we reach a variable before the arguments run out then we
+ % unify it with what remains of the apply_n expression. If we manage
+ % to unify all of the arguments then we unify the apply_n variable
+ % with what remains of the other expression.
+ %
+ % Note that Y is not a variable, since that case would have been
+ % caught by type_unify.
+ %
+:- pred type_unify_apply((type)::in, tvar::in, list(type)::in, list(tvar)::in,
+ tsubst::in, tsubst::out) is semidet.
+
+type_unify_apply(defined(NameY, ArgsY0, KindY0), VarX, ArgsX, HeadTypeParams,
+ !Bindings) :-
+ type_unify_args(ArgsX, ArgsY0, ArgsY, KindY0, KindY, HeadTypeParams,
+ !Bindings),
+ type_unify_var(VarX, defined(NameY, ArgsY, KindY), HeadTypeParams,
+ !Bindings).
+type_unify_apply(Type @ builtin(_), VarX, [], HeadTypeParams, !Bindings) :-
+ type_unify_var(VarX, Type, HeadTypeParams, !Bindings).
+type_unify_apply(Type @ higher_order(_, _, _, _), VarX, [], HeadTypeParams,
+ !Bindings) :-
+ type_unify_var(VarX, Type, HeadTypeParams, !Bindings).
+type_unify_apply(tuple(ArgsY0, KindY0), VarX, ArgsX, HeadTypeParams,
+ !Bindings) :-
+ type_unify_args(ArgsX, ArgsY0, ArgsY, KindY0, KindY, HeadTypeParams,
+ !Bindings),
+ type_unify_var(VarX, tuple(ArgsY, KindY), HeadTypeParams, !Bindings).
+type_unify_apply(apply_n(VarY, ArgsY0, Kind0), VarX, ArgsX0, HeadTypeParams,
+ !Bindings) :-
+ list.length(ArgsX0, NArgsX0),
+ list.length(ArgsY0, NArgsY0),
+ compare(Result, NArgsX0, NArgsY0),
+ (
+ Result = (<),
+ type_unify_args(ArgsX0, ArgsY0, ArgsY, Kind0, Kind,
+ HeadTypeParams, !Bindings),
+ type_unify_var(VarX, apply_n(VarY, ArgsY, Kind),
+ HeadTypeParams, !Bindings)
+ ;
+ Result = (=),
+ % We know here that the list of remaining args will be empty.
+ type_unify_args(ArgsX0, ArgsY0, _, Kind0, Kind, HeadTypeParams,
+ !Bindings),
+ type_unify_var_var(VarX, VarY, Kind, HeadTypeParams, !Bindings)
+ ;
+ Result = (>),
+ type_unify_args(ArgsY0, ArgsX0, ArgsX, Kind0, Kind,
+ HeadTypeParams, !Bindings),
+ type_unify_var(VarY, apply_n(VarX, ArgsX, Kind),
+ HeadTypeParams, !Bindings)
+ ).
+type_unify_apply(kinded(RawY, _), VarX, ArgsX, HeadTypeParams, !Bindings) :-
+ type_unify_apply(RawY, VarX, ArgsX, HeadTypeParams, !Bindings).
-replace_eqv_type(Functor, Arity, Args, EqvType) :-
+:- pred type_unify_args(list(type)::in, list(type)::in, list(type)::out,
+ kind::in, kind::out, list(tvar)::in, tsubst::in, tsubst::out)
+ is semidet.
- % XXX magically_obtain(TypeTable)
+type_unify_args(ArgsX, ArgsY0, ArgsY, KindY0, KindY, HeadTypeParams,
+ !Bindings) :-
+ list.reverse(ArgsX, RevArgsX),
+ list.reverse(ArgsY0, RevArgsY0),
+ type_unify_rev_args(RevArgsX, RevArgsY0, RevArgsY, KindY0, KindY,
+ HeadTypeParams, !Bindings),
+ list.reverse(RevArgsY, ArgsY).
- make_type_ctor(Functor, Arity, TypeCtor),
- map__search(TypeTable, TypeCtor, TypeDefn),
- get_type_defn_body(TypeDefn, TypeBody),
- TypeBody = eqv_type(EqvType0),
- get_type_defn_tparams(TypeDefn, TypeParams0),
- type_param_to_var_list(TypeParams0, TypeParams),
- term__substitute_corresponding(EqvType0, TypeParams, AsX,
- EqvType).
-
-******/
-
-type_unify_list([], [], _) --> [].
-type_unify_list([X | Xs], [Y | Ys], HeadTypeParams) -->
- type_unify(X, Y, HeadTypeParams),
- type_unify_list(Xs, Ys, HeadTypeParams).
+:- pred type_unify_rev_args(list(type)::in, list(type)::in, list(type)::out,
+ kind::in, kind::out, list(tvar)::in, tsubst::in, tsubst::out)
+ is semidet.
-:- pred type_unify_head_type_param(tvar::in, tvar::in, list(tvar)::in,
- tsubst::in, tsubst::out) is semidet.
+type_unify_rev_args([], ArgsY, ArgsY, KindY, KindY, _, !Bindings).
+type_unify_rev_args([ArgX | ArgsX], [ArgY0 | ArgsY0], ArgsY, KindY0, KindY,
+ HeadTypeParams, !Bindings) :-
+ type_unify(ArgX, ArgY0, HeadTypeParams, !Bindings),
+ KindY1 = arrow(get_type_kind(ArgY0), KindY0),
+ type_unify_rev_args(ArgsX, ArgsY0, ArgsY, KindY1, KindY,
+ HeadTypeParams, !Bindings).
+
+type_unify_list([], [], _HeadTypeParams, !Bindings).
+type_unify_list([X | Xs], [Y | Ys], HeadTypeParams, !Bindings) :-
+ type_unify(X, Y, HeadTypeParams, !Bindings),
+ type_unify_list(Xs, Ys, HeadTypeParams, !Bindings).
+
+ % type_occurs(Type, Var, Subst) succeeds iff Type contains Var,
+ % perhaps indirectly via the substitution. (The variable must not
+ % be mapped by the substitution.)
+ %
+:- pred type_occurs((type)::in, tvar::in, tsubst::in) is semidet.
-type_unify_head_type_param(Var, HeadVar, HeadTypeParams, Bindings0,
- Bindings) :-
- ( map__search(Bindings0, Var, BindingOfVar) ->
- BindingOfVar = term__variable(Var2),
- type_unify_head_type_param(Var2, HeadVar, HeadTypeParams,
- Bindings0, Bindings)
+type_occurs(variable(X, _), Y, Bindings) :-
+ ( X = Y ->
+ true
;
- ( Var = HeadVar ->
- Bindings = Bindings0
- ;
- \+ list__member(Var, HeadTypeParams),
- map__det_insert(Bindings0, Var,
- term__variable(HeadVar), Bindings)
- )
+ map.search(Bindings, X, BindingOfX),
+ type_occurs(BindingOfX, Y, Bindings)
+ ).
+type_occurs(defined(_, Args, _), Y, Bindings) :-
+ type_occurs_list(Args, Y, Bindings).
+type_occurs(higher_order(Args, MaybeRet, _, _), Y, Bindings) :-
+ (
+ type_occurs_list(Args, Y, Bindings)
+ ;
+ MaybeRet = yes(Ret),
+ type_occurs(Ret, Y, Bindings)
).
+type_occurs(tuple(Args, _), Y, Bindings) :-
+ type_occurs_list(Args, Y, Bindings).
+type_occurs(apply_n(X, Args, _), Y, Bindings) :-
+ (
+ X = Y
+ ;
+ type_occurs_list(Args, Y, Bindings)
+ ;
+ map.search(Bindings, X, BindingOfX),
+ type_occurs(BindingOfX, Y, Bindings)
+ ).
+type_occurs(kinded(X, _), Y, Bindings) :-
+ type_occurs(X, Y, Bindings).
-%-----------------------------------------------------------------------------%
+:- pred type_occurs_list(list(type)::in, tvar::in, tsubst::in) is semidet.
-type_util__real_vars(Type, Tvars) :-
- ( is_introduced_type_info_type(Type) ->
- % for these types, we don't add the type parameters
- Tvars = []
+type_occurs_list([X | Xs], Y, Bindings) :-
+ (
+ type_occurs(X, Y, Bindings)
;
- prog_type__vars(Type, Tvars)
+ type_occurs_list(Xs, Y, Bindings)
).
%-----------------------------------------------------------------------------%
-apply_substitution_to_type_map(VarTypes0, Subst, VarTypes) :-
- % optimize the common case of an empty type substitution
- ( map__is_empty(Subst) ->
- VarTypes = VarTypes0
- ;
- map__keys(VarTypes0, Vars),
- apply_substitution_to_type_map_2(Vars, VarTypes0, Subst,
- VarTypes)
- ).
+apply_subst_to_type_map(Subst, !VarTypes) :-
+ map__map_values(apply_subst_to_type_map_2(Subst), !VarTypes).
-:- pred apply_substitution_to_type_map_2(list(prog_var)::in,
- map(prog_var, type)::in, tsubst::in, map(prog_var, type)::out) is det.
+:- pred apply_subst_to_type_map_2(tsubst::in, prog_var::in,
+ (type)::in, (type)::out) is det.
-apply_substitution_to_type_map_2([], VarTypes, _Subst, VarTypes).
-apply_substitution_to_type_map_2([Var | Vars], VarTypes0, Subst,
- VarTypes) :-
- map__lookup(VarTypes0, Var, VarType0),
- term__apply_substitution(VarType0, Subst, VarType),
- map__det_update(VarTypes0, Var, VarType, VarTypes1),
- apply_substitution_to_type_map_2(Vars, VarTypes1, Subst, VarTypes).
+apply_subst_to_type_map_2(Subst, _, !Type) :-
+ apply_subst_to_type(Subst, !Type).
-%-----------------------------------------------------------------------------%
+apply_rec_subst_to_type_map(Subst, !VarTypes) :-
+ map__map_values(apply_rec_subst_to_type_map_2(Subst), !VarTypes).
-apply_rec_substitution_to_type_map(VarTypes0, Subst, VarTypes) :-
- % optimize the common case of an empty type substitution
- ( map__is_empty(Subst) ->
- VarTypes = VarTypes0
- ;
- map__keys(VarTypes0, Vars),
- apply_rec_substitution_to_type_map_2(Vars, VarTypes0, Subst,
- VarTypes)
- ).
+:- pred apply_rec_subst_to_type_map_2(tsubst::in, prog_var::in,
+ (type)::in, (type)::out) is det.
-:- pred apply_rec_substitution_to_type_map_2(list(prog_var)::in,
- map(prog_var, type)::in, tsubst::in, map(prog_var, type)::out) is det.
+apply_rec_subst_to_type_map_2(Subst, _, !Type) :-
+ apply_rec_subst_to_type(Subst, !Type).
-apply_rec_substitution_to_type_map_2([], VarTypes, _Subst, VarTypes).
-apply_rec_substitution_to_type_map_2([Var | Vars], VarTypes0, Subst,
- VarTypes) :-
- map__lookup(VarTypes0, Var, VarType0),
- term__apply_rec_substitution(VarType0, Subst, VarType),
- map__det_update(VarTypes0, Var, VarType, VarTypes1),
- apply_rec_substitution_to_type_map_2(Vars, VarTypes1, Subst, VarTypes).
+apply_variable_renaming_to_type_map(Renaming, !Map) :-
+ map__map_values(apply_variable_renaming_to_type_map_2(Renaming), !Map).
+
+:- pred apply_variable_renaming_to_type_map_2(tvar_renaming::in, prog_var::in,
+ (type)::in, (type)::out) is det.
+
+apply_variable_renaming_to_type_map_2(Renaming, _, !Type) :-
+ apply_variable_renaming_to_type(Renaming, !Type).
%-----------------------------------------------------------------------------%
@@ -1604,7 +1666,7 @@
apply_rec_subst_to_constraint(Subst, !Constraint) :-
!.Constraint = constraint(Ids, Name, Types0),
- term.apply_rec_substitution_to_list(Types0, Subst, Types),
+ apply_rec_subst_to_type_list(Subst, Types0, Types),
!:Constraint = constraint(Ids, Name, Types).
apply_subst_to_constraints(Subst, !Constraints) :-
@@ -1622,7 +1684,7 @@
apply_subst_to_constraint(Subst, Constraint0, Constraint) :-
Constraint0 = constraint(Ids, ClassName, Types0),
- term__apply_substitution_to_list(Types0, Subst, Types),
+ apply_subst_to_type_list(Subst, Types0, Types),
Constraint = constraint(Ids, ClassName, Types).
apply_subst_to_constraint_proofs(Subst, Proofs0, Proofs) :-
@@ -1685,12 +1747,6 @@
apply_rec_subst_to_constraint_map_2(Subst, _Key, !Value) :-
apply_rec_subst_to_prog_constraint(Subst, !Value).
-apply_variable_renaming_to_type_map(Renaming, Map0, Map) :-
- map__map_values(
- (pred(_::in, Type0::in, Type::out) is det :-
- term__apply_variable_renaming(Type0, Renaming, Type)
- ), Map0, Map).
-
apply_variable_renaming_to_constraints(Renaming, !Constraints) :-
!.Constraints = constraints(Unproven0, Assumed0, Redundant0),
apply_variable_renaming_to_constraint_list(Renaming, Unproven0,
@@ -1709,8 +1765,8 @@
apply_variable_renaming_to_constraint(Renaming, Constraint0, Constraint) :-
Constraint0 = constraint(Ids, ClassName, ClassArgTypes0),
- term__apply_variable_renaming_to_list(ClassArgTypes0,
- Renaming, ClassArgTypes),
+ apply_variable_renaming_to_type_list(Renaming, ClassArgTypes0,
+ ClassArgTypes),
Constraint = constraint(Ids, ClassName, ClassArgTypes).
apply_variable_renaming_to_constraint_proofs(Renaming, Proofs0, Proofs) :-
@@ -1728,7 +1784,7 @@
% Apply a type variable renaming to a class constraint proof.
%
-:- pred rename_constraint_proof(map(tvar, tvar)::in, constraint_proof::in,
+:- pred rename_constraint_proof(tvar_renaming::in, constraint_proof::in,
constraint_proof::out) is det.
rename_constraint_proof(_TSubst, apply_instance(Num), apply_instance(Num)).
@@ -1741,7 +1797,7 @@
map__map_values(apply_variable_renaming_to_constraint_map_2(Renaming),
!ConstraintMap).
-:- pred apply_variable_renaming_to_constraint_map_2(map(tvar, tvar)::in,
+:- pred apply_variable_renaming_to_constraint_map_2(tvar_renaming::in,
constraint_id::in, prog_constraint::in, prog_constraint::out) is det.
apply_variable_renaming_to_constraint_map_2(Renaming, _Key, !Value) :-
@@ -1769,8 +1825,8 @@
type_util__get_existq_cons_defn(ModuleInfo, Type, ConsId,
ConsDefn)
->
- ConsDefn = ctor_defn(_TVarSet, ExistQTVars, Constraints,
- _ArgTypes, _ResultType),
+ ConsDefn = ctor_defn(_TVarSet, ExistQTVars, _KindMap,
+ Constraints, _ArgTypes, _ResultType),
list__length(Constraints, NumTypeClassInfos),
constraint_list_get_tvars(Constraints, ConstrainedTVars),
list__delete_elems(ExistQTVars, ConstrainedTVars,
Index: compiler/typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/typecheck.m,v
retrieving revision 1.375
diff -u -r1.375 typecheck.m
--- compiler/typecheck.m 30 Aug 2005 04:12:01 -0000 1.375
+++ compiler/typecheck.m 11 Sep 2005 15:12:11 -0000
@@ -398,7 +398,7 @@
% to indicate that all the existentially quantified tvars
% in the head of this pred are indeed bound by this
% predicate.
- term__vars_list(ArgTypes0, HeadVarsIncludingExistentials),
+ prog_type__vars_list(ArgTypes0, HeadVarsIncludingExistentials),
pred_info_set_head_type_params(HeadVarsIncludingExistentials,
!PredInfo),
Error = no,
@@ -433,7 +433,7 @@
Inferring = no,
write_pred_progress_message("% Type-checking ", PredId,
!.ModuleInfo, !IO),
- term__vars_list(ArgTypes0, !:HeadTypeParams),
+ prog_type__vars_list(ArgTypes0, !:HeadTypeParams),
pred_info_get_class_context(!.PredInfo, PredConstraints),
constraint_list_get_tvars(PredConstraints ^ univ_constraints,
UnivTVars),
@@ -498,7 +498,7 @@
% apply to type variables which occur only in the body.
%
map__apply_to_list(HeadVars, InferredVarTypes, ArgTypes),
- term__vars_list(ArgTypes, ArgTypeVars),
+ prog_type__vars_list(ArgTypes, ArgTypeVars),
restrict_to_head_vars(InferredTypeConstraints0, ArgTypeVars,
InferredTypeConstraints, UnprovenBodyConstraints),
@@ -536,11 +536,11 @@
% Check if anything changed
%
(
- % If the argument types and the type
- % constraints are identical up to renaming,
- % then nothing has changed.
- argtypes_identical_up_to_renaming(ExistQVars0, ArgTypes0,
- OldTypeConstraints, ExistQVars, ArgTypes,
+ % If the argument types and the type constraints are
+ % identical up to renaming, then nothing has changed.
+ pred_info_tvar_kinds(!.PredInfo, TVarKinds),
+ argtypes_identical_up_to_renaming(TVarKinds, ExistQVars0,
+ ArgTypes0, OldTypeConstraints, ExistQVars, ArgTypes,
InferredTypeConstraints)
->
Changed = no
@@ -575,8 +575,8 @@
ExistQVars0 = [_ | _],
apply_var_renaming_to_var_list(ExistQVars0,
ExistTypeRenaming, ExistQVars1),
- term__apply_variable_renaming_to_list(
- ArgTypes0, ExistTypeRenaming, ArgTypes1),
+ apply_variable_renaming_to_type_list(ExistTypeRenaming,
+ ArgTypes0, ArgTypes1),
apply_variable_renaming_to_prog_constraints(
ExistTypeRenaming, PredConstraints, PredConstraints1),
rename_instance_method_constraints(ExistTypeRenaming,
@@ -586,8 +586,8 @@
% rename them all to match the new typevarset
apply_var_renaming_to_var_list(ExistQVars1,
TVarRenaming, ExistQVars),
- term__apply_variable_renaming_to_list(ArgTypes1,
- TVarRenaming, RenamedOldArgTypes),
+ apply_variable_renaming_to_type_list(TVarRenaming, ArgTypes1,
+ RenamedOldArgTypes),
apply_variable_renaming_to_prog_constraints(TVarRenaming,
PredConstraints1, RenamedOldConstraints),
rename_instance_method_constraints(TVarRenaming,
@@ -657,15 +657,15 @@
Body = conj([UnifyGoal, CallGoal]) - GoalInfo,
StubClause = clause([], Body, mercury, Context).
-:- pred rename_instance_method_constraints(map(tvar, tvar)::in,
+:- pred rename_instance_method_constraints(tvar_renaming::in,
pred_origin::in, pred_origin::out) is det.
rename_instance_method_constraints(Renaming, Origin0, Origin) :-
( Origin0 = instance_method(Constraints0) ->
Constraints0 = instance_method_constraints(ClassId, InstanceTypes0,
InstanceConstraints0, ClassMethodClassContext0),
- term__apply_variable_renaming_to_list(InstanceTypes0,
- Renaming, InstanceTypes),
+ apply_variable_renaming_to_type_list(Renaming, InstanceTypes0,
+ InstanceTypes),
apply_variable_renaming_to_prog_constraint_list(Renaming,
InstanceConstraints0, InstanceConstraints),
apply_variable_renaming_to_prog_constraints(Renaming,
@@ -745,7 +745,7 @@
is_head_class_constraint(HeadTypeVars, constraint(_Name, Types)) :-
all [TVar] (
- term__contains_var_list(Types, TVar)
+ prog_type__type_list_contains_var(Types, TVar)
=>
list__member(TVar, HeadTypeVars)
).
@@ -759,19 +759,19 @@
% to append all the relevant types into one big type list and
% then compare them in a single call to identical_up_to_renaming.
%
-:- pred argtypes_identical_up_to_renaming(
+:- pred argtypes_identical_up_to_renaming(tvar_kind_map::in,
existq_tvars::in, list(type)::in, prog_constraints::in,
existq_tvars::in, list(type)::in, prog_constraints::in) is semidet.
-argtypes_identical_up_to_renaming(ExistQVarsA, ArgTypesA, TypeConstraintsA,
- ExistQVarsB, ArgTypesB, TypeConstraintsB) :-
+argtypes_identical_up_to_renaming(KindMap, ExistQVarsA, ArgTypesA,
+ TypeConstraintsA, ExistQVarsB, ArgTypesB, TypeConstraintsB) :-
same_structure(TypeConstraintsA, TypeConstraintsB,
ConstrainedTypesA, ConstrainedTypesB),
- term__var_list_to_term_list(ExistQVarsA, ExistQVarTermsA),
- term__var_list_to_term_list(ExistQVarsB, ExistQVarTermsB),
- list__condense([ExistQVarTermsA, ArgTypesA, ConstrainedTypesA],
+ prog_type__var_list_to_type_list(KindMap, ExistQVarsA, ExistQVarTypesA),
+ prog_type__var_list_to_type_list(KindMap, ExistQVarsB, ExistQVarTypesB),
+ list__condense([ExistQVarTypesA, ArgTypesA, ConstrainedTypesA],
TypesListA),
- list__condense([ExistQVarTermsB, ArgTypesB, ConstrainedTypesB],
+ list__condense([ExistQVarTypesB, ArgTypesB, ConstrainedTypesB],
TypesListB),
identical_up_to_renaming(TypesListA, TypesListB).
@@ -1238,9 +1238,9 @@
type_assign_get_type_bindings(TypeAssign2, TypeBindings2),
map__apply_to_list(HeadVars, VarTypes1, HeadTypes1),
map__apply_to_list(HeadVars, VarTypes2, HeadTypes2),
- term__apply_rec_substitution_to_list(HeadTypes1, TypeBindings1,
+ apply_rec_subst_to_type_list(TypeBindings1, HeadTypes1,
FinalHeadTypes1),
- term__apply_rec_substitution_to_list(HeadTypes2, TypeBindings2,
+ apply_rec_subst_to_type_list(TypeBindings2, HeadTypes2,
FinalHeadTypes2),
identical_up_to_renaming(FinalHeadTypes1, FinalHeadTypes2)
)
@@ -1424,12 +1424,13 @@
Vars = []
;
Vars = [_ | _],
- % Invent some new type variables to use as
- % the types of these variables.
+ % Invent some new type variables to use as the types of these
+ % variables. Since each type is the type of a program variable,
+ % each must have kind `star'.
list__length(Vars, NumVars),
varset__init(TypeVarSet0),
varset__new_vars(TypeVarSet0, NumVars, TypeVars, TypeVarSet),
- term__var_list_to_term_list(TypeVars, Types),
+ prog_type__var_list_to_type_list(map__init, TypeVars, Types),
empty_hlds_constraints(EmptyConstraints),
typecheck_var_has_polymorphic_type_list(Vars, TypeVarSet, [],
Types, EmptyConstraints, !Info, !IO)
@@ -1465,7 +1466,8 @@
ArgTypes) :-
varset__init(TypeVarSet0),
varset__new_vars(TypeVarSet0, Arity, ArgTypeVars, TypeVarSet),
- term__var_list_to_term_list(ArgTypeVars, ArgTypes),
+ % Argument types always have kind `star'.
+ prog_type__var_list_to_type_list(map__init, ArgTypeVars, ArgTypes),
construct_higher_order_type(Purity, predicate, EvalMethod, ArgTypes,
PredType).
@@ -1484,10 +1486,11 @@
varset__init(TypeVarSet0),
varset__new_vars(TypeVarSet0, Arity, ArgTypeVars, TypeVarSet1),
varset__new_var(TypeVarSet1, RetTypeVar, TypeVarSet),
- term__var_list_to_term_list(ArgTypeVars, ArgTypes),
- RetType = term__variable(RetTypeVar),
- construct_higher_order_func_type(Purity, EvalMethod,
- ArgTypes, RetType, FuncType).
+ % Argument and return types always have kind `star'.
+ prog_type__var_list_to_type_list(map__init, ArgTypeVars, ArgTypes),
+ RetType = variable(RetTypeVar, star),
+ construct_higher_order_func_type(Purity, EvalMethod, ArgTypes, RetType,
+ FuncType).
%-----------------------------------------------------------------------------%
@@ -1824,9 +1827,10 @@
module_info_pred_info(ModuleInfo, PredId, PredInfo),
pred_info_arg_types(PredInfo, PredTVarSet, PredExistQVars0,
PredArgTypes0),
+ pred_info_tvar_kinds(PredInfo, PredKindMap),
- arg_type_list_subsumes(TVarSet, ArgTypes,
- PredTVarSet, PredExistQVars0, PredArgTypes0)
+ arg_type_list_subsumes(TVarSet, ArgTypes, PredTVarSet, PredKindMap,
+ PredExistQVars0, PredArgTypes0)
->
%
% We've found a matching predicate.
@@ -1886,9 +1890,11 @@
% rename everything apart
%
type_assign_rename_apart(TypeAssign0, PredTypeVarSet, PredArgTypes,
- TypeAssign1, ParentArgTypes, Subst),
- apply_substitution_to_var_list(PredExistQVars, Subst, ParentExistQVars),
- apply_subst_to_constraints(Subst, PredConstraints, ParentConstraints),
+ TypeAssign1, ParentArgTypes, Renaming),
+ apply_variable_renaming_to_tvar_list(Renaming, PredExistQVars,
+ ParentExistQVars),
+ apply_variable_renaming_to_constraints(Renaming, PredConstraints,
+ ParentConstraints),
%
% insert the existentially quantified type variables for the called
@@ -1897,8 +1903,7 @@
%
type_assign_get_head_type_params(TypeAssign1, HeadTypeParams0),
list__append(ParentExistQVars, HeadTypeParams0, HeadTypeParams),
- type_assign_set_head_type_params(HeadTypeParams,
- TypeAssign1, TypeAssign),
+ type_assign_set_head_type_params(HeadTypeParams, TypeAssign1, TypeAssign),
%
% save the results and recurse
%
@@ -1908,13 +1913,14 @@
PredArgTypes, PredConstraints, !ArgTypeAssigns).
:- pred type_assign_rename_apart(type_assign::in, tvarset::in, list(type)::in,
- type_assign::out, list(type)::out, tsubst::out) is det.
+ type_assign::out, list(type)::out, tvar_renaming::out) is det.
type_assign_rename_apart(TypeAssign0, PredTypeVarSet, PredArgTypes,
- TypeAssign, ParentArgTypes, Subst) :-
+ TypeAssign, ParentArgTypes, Renaming) :-
type_assign_get_typevarset(TypeAssign0, TypeVarSet0),
- varset__merge_subst(TypeVarSet0, PredTypeVarSet, TypeVarSet, Subst),
- term__apply_substitution_to_list(PredArgTypes, Subst, ParentArgTypes),
+ tvarset_merge_renaming(TypeVarSet0, PredTypeVarSet, TypeVarSet, Renaming),
+ apply_variable_renaming_to_type_list(Renaming, PredArgTypes,
+ ParentArgTypes),
type_assign_set_typevarset(TypeVarSet, TypeAssign0, TypeAssign).
%-----------------------------------------------------------------------------%
@@ -2383,8 +2389,7 @@
type_assign_get_var_types(TypeAssign0, VarTypes0),
( map__search(VarTypes0, X, TypeX) ->
( map__search(VarTypes0, Y, TypeY) ->
- % both X and Y already have types - just
- % unify their types
+ % Both X and Y already have types - just unify their types.
(
type_assign_unify_type(TypeAssign0, TypeX, TypeY, TypeAssign3)
->
@@ -2394,28 +2399,24 @@
!:TypeAssignSet = !.TypeAssignSet
)
;
- % Y is a fresh variable which hasn't been
- % assigned a type yet
+ % Y is a fresh variable which hasn't been assigned a type yet.
map__det_insert(VarTypes0, Y, TypeX, VarTypes),
type_assign_set_var_types(VarTypes, TypeAssign0, TypeAssign),
!:TypeAssignSet = [TypeAssign | !.TypeAssignSet]
)
;
( map__search(VarTypes0, Y, TypeY) ->
- % X is a fresh variable which hasn't been
- % assigned a type yet
+ % X is a fresh variable which hasn't been assigned a type yet.
map__det_insert(VarTypes0, X, TypeY, VarTypes),
type_assign_set_var_types(VarTypes, TypeAssign0, TypeAssign),
!:TypeAssignSet = [TypeAssign | !.TypeAssignSet]
;
- % both X and Y are fresh variables -
- % introduce a fresh type variable to represent
- % their type
+ % Both X and Y are fresh variables - introduce a fresh type
+ % variable with kind `star' to represent their type.
type_assign_get_typevarset(TypeAssign0, TypeVarSet0),
varset__new_var(TypeVarSet0, TypeVar, TypeVarSet),
- type_assign_set_typevarset(TypeVarSet,
- TypeAssign0, TypeAssign1),
- Type = term__variable(TypeVar),
+ type_assign_set_typevarset(TypeVarSet, TypeAssign0, TypeAssign1),
+ Type = variable(TypeVar, star),
map__det_insert(VarTypes0, X, Type, VarTypes1),
( X \= Y ->
map__det_insert(VarTypes1, Y, Type, VarTypes)
@@ -2492,12 +2493,12 @@
ConstraintsToAdd = ClassConstraints0
;
type_assign_rename_apart(TypeAssign0, ConsTypeVarSet,
- [ConsType0 | ArgTypes0],
- TypeAssign1, [ConsType1 | ArgTypes1], Subst)
+ [ConsType0 | ArgTypes0], TypeAssign1, [ConsType1 | ArgTypes1],
+ Renaming)
->
- apply_substitution_to_var_list(ConsExistQVars0, Subst,
+ apply_variable_renaming_to_tvar_list(Renaming, ConsExistQVars0,
ConsExistQVars),
- apply_subst_to_constraints(Subst, ClassConstraints0,
+ apply_variable_renaming_to_constraints(Renaming, ClassConstraints0,
ConstraintsToAdd),
type_assign_get_head_type_params(TypeAssign1, HeadTypeParams0),
list__append(ConsExistQVars, HeadTypeParams0, HeadTypeParams),
@@ -2593,22 +2594,22 @@
type_assign_get_types_of_vars([], [], !TypeAssign).
type_assign_get_types_of_vars([Var | Vars], [Type | Types], !TypeAssign) :-
- % check whether the variable already has a type
+ % Check whether the variable already has a type.
type_assign_get_var_types(!.TypeAssign, VarTypes0),
( map__search(VarTypes0, Var, VarType) ->
- % if so, use that type
+ % If so, use that type.
Type = VarType
;
- % otherwise, introduce a fresh type variable to
- % use as the type of that variable
+ % Otherwise, introduce a fresh type variable with kind `star' to use
+ % as the type of that variable.
type_assign_get_typevarset(!.TypeAssign, TypeVarSet0),
varset__new_var(TypeVarSet0, TypeVar, TypeVarSet),
type_assign_set_typevarset(TypeVarSet, !TypeAssign),
- Type = term__variable(TypeVar),
+ Type = variable(TypeVar, star),
map__det_insert(VarTypes0, Var, Type, VarTypes1),
type_assign_set_var_types(VarTypes1, !TypeAssign)
),
- % recursively process the rest of the variables.
+ % Recursively process the rest of the variables.
type_assign_get_types_of_vars(Vars, Types, !TypeAssign).
%-----------------------------------------------------------------------------%
@@ -2942,7 +2943,7 @@
% Pair0 = 1 - 'a',
% Pair = Pair0 ^ snd := 2.
%
- term__vars(FieldType, TVarsInField),
+ prog_type__vars(FieldType, TVarsInField),
(
TVarsInField = [],
TVarSet = TVarSet0,
@@ -2980,7 +2981,7 @@
%
list__replace_nth_det(ConsArgTypes, FieldNumber, int_type,
ArgTypesWithoutField),
- term__vars_list(ArgTypesWithoutField, TVarsInOtherArgs),
+ prog_type__vars_list(ArgTypesWithoutField, TVarsInOtherArgs),
set__intersect(
set__list_to_set(TVarsInField),
set__intersect(
@@ -3003,10 +3004,10 @@
varset__new_vars(TVarSet0, NumNewTVars, NewTVars, TVarSet),
map__from_corresponding_lists(TVarsOnlyInField,
NewTVars, TVarRenaming),
- term__apply_variable_renaming(FieldType,
- TVarRenaming, RenamedFieldType),
- term__apply_variable_renaming(FunctorType,
- TVarRenaming, OutputFunctorType),
+ apply_variable_renaming_to_type(TVarRenaming, FieldType,
+ RenamedFieldType),
+ apply_variable_renaming_to_type(TVarRenaming, FunctorType,
+ OutputFunctorType),
%
% Rename the class constraints, projecting
@@ -3015,7 +3016,7 @@
% the call to `'field :='/2'. Note that we
% have already flipped the constraints.
%
- term__vars_list([FunctorType, FieldType], CallTVars0),
+ prog_type__vars_list([FunctorType, FieldType], CallTVars0),
set__list_to_set(CallTVars0, CallTVars),
project_and_rename_constraints(ClassTable, TVarSet, CallTVars,
TVarRenaming, Constraints0, Constraints),
@@ -3046,7 +3047,7 @@
% of the type variables are supplied by the caller.
%
:- pred project_and_rename_constraints(class_table::in, tvarset::in,
- set(tvar)::in, map(tvar, tvar)::in,
+ set(tvar)::in, tvar_renaming::in,
hlds_constraints::in, hlds_constraints::out) is det.
project_and_rename_constraints(ClassTable, TVarSet, CallTVars, TVarRenaming,
@@ -3081,21 +3082,21 @@
project_constraint(CallTVars, Constraint) :-
Constraint = constraint(_, _, TypesToCheck),
- term__vars_list(TypesToCheck, TVarsToCheck0),
+ prog_type__vars_list(TypesToCheck, TVarsToCheck0),
set__list_to_set(TVarsToCheck0, TVarsToCheck),
set__intersect(TVarsToCheck, CallTVars, RelevantTVars),
\+ set__empty(RelevantTVars).
-:- pred rename_constraint(map(tvar, tvar)::in, hlds_constraint::in,
+:- pred rename_constraint(tvar_renaming::in, hlds_constraint::in,
hlds_constraint::out) is semidet.
rename_constraint(TVarRenaming, Constraint0, Constraint) :-
Constraint0 = constraint(Ids, Name, Types0),
some [Var] (
- term__contains_var_list(Types0, Var),
+ type_list_contains_var(Types0, Var),
map__contains(TVarRenaming, Var)
),
- term__apply_variable_renaming_to_list(Types0, TVarRenaming, Types),
+ apply_variable_renaming_to_type_list(TVarRenaming, Types0, Types),
Constraint = constraint(Ids, Name, Types).
%-----------------------------------------------------------------------------%
@@ -3235,12 +3236,15 @@
Functor = cons(unqualified("{}"), TupleArity)
->
%
- % Make some fresh type variables for the argument types.
+ % Make some fresh type variables for the argument types. These have
+ % kind `star' since there are values (namely the arguments of the
+ % tuplpe constructor) which have these types.
%
varset__init(TupleConsTypeVarSet0),
- varset__new_vars(TupleConsTypeVarSet0, TupleArity,
- TupleArgTVars, TupleConsTypeVarSet),
- term__var_list_to_term_list(TupleArgTVars, TupleArgTypes),
+ varset__new_vars(TupleConsTypeVarSet0, TupleArity, TupleArgTVars,
+ TupleConsTypeVarSet),
+ prog_type__var_list_to_type_list(map__init, TupleArgTVars,
+ TupleArgTypes),
construct_type(unqualified("{}") - TupleArity, TupleArgTypes,
TupleConsType),
@@ -3321,6 +3325,7 @@
map__lookup(Types, TypeCtor, TypeDefn),
hlds_data__get_type_defn_tvarset(TypeDefn, ConsTypeVarSet),
hlds_data__get_type_defn_tparams(TypeDefn, ConsTypeParams),
+ hlds_data__get_type_defn_kind_map(TypeDefn, ConsTypeKinds),
hlds_data__get_type_defn_body(TypeDefn, Body),
%
@@ -3371,7 +3376,9 @@
% Do not allow 'new' constructors except on existential types.
ConsTypeInfo = error(new_on_non_existential_type(TypeCtor))
;
- construct_type(TypeCtor, ConsTypeParams, ConsType),
+ prog_type.var_list_to_type_list(ConsTypeKinds, ConsTypeParams,
+ ConsTypeArgs),
+ construct_type(TypeCtor, ConsTypeArgs, ConsType),
UnivProgConstraints = [],
(
Action = do_not_flip_constraints
Index: compiler/typecheck_errors.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/typecheck_errors.m,v
retrieving revision 1.3
diff -u -r1.3 typecheck_errors.m
--- compiler/typecheck_errors.m 8 Aug 2005 02:33:11 -0000 1.3
+++ compiler/typecheck_errors.m 11 Sep 2005 05:57:27 -0000
@@ -105,6 +105,7 @@
:- import_module parse_tree.error_util.
:- import_module parse_tree.mercury_to_mercury.
:- import_module parse_tree.modules.
+:- import_module parse_tree.prog_io_util.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_out.
:- import_module parse_tree.prog_type.
@@ -647,17 +648,17 @@
substitute_types_check_match(ExpType, TypeStuff, TypeMismatch) :-
TypeStuff = type_stuff(ArgType, TVarSet, TypeBindings, HeadTypeParams),
- term__apply_rec_substitution(ArgType, TypeBindings, FullArgType),
- term__apply_rec_substitution(ExpType, TypeBindings, FullExpType),
+ apply_rec_subst_to_type(TypeBindings, ArgType, FullArgType),
+ apply_rec_subst_to_type(TypeBindings, ExpType, FullExpType),
(
(
- % there is no mismatch if the actual type of the
- % argument is the same as the expected type
+ % There is no mismatch if the actual type of the
+ % argument is the same as the expected type.
identical_types(FullArgType, FullExpType)
;
- % there is no mismatch if the actual type of the
- % argument has no constraints on it
- FullArgType = term__functor(term__atom("<any>"), [], _)
+ % There is no mismatch if the actual type of the
+ % argument has no constraints on it.
+ FullArgType = defined(unqualified("<any>"), [], _)
)
->
fail
@@ -1167,8 +1168,8 @@
(
map__search(VarTypes1, V, Type1),
map__search(VarTypes2, V, Type2),
- term__apply_rec_substitution(Type1, TypeBindings1, T1),
- term__apply_rec_substitution(Type2, TypeBindings2, T2),
+ apply_rec_subst_to_type(TypeBindings1, Type1, T1),
+ apply_rec_subst_to_type(TypeBindings2, Type2, T2),
\+ identical_types(T1, T2)
->
typecheck_info_get_context(Info, Context),
@@ -1331,8 +1332,11 @@
Functor, _, !IO) :-
(
ArgTypes = [_ | _],
- ( cons_id_and_args_to_term(Functor, ArgTypes, Term) ->
- output_type(Term, TVarSet, ExistQVars, !IO)
+ (
+ Functor = cons(SymName, _Arity)
+ ->
+ Type = defined(SymName, ArgTypes, star),
+ output_type(Type, TVarSet, ExistQVars, !IO)
;
error("typecheck.write_cons_type: invalid cons_id")
),
@@ -1404,9 +1408,12 @@
io::di, io::uo) is det.
output_type(Type0, TVarSet, HeadTypeParams, !IO) :-
- strip_builtin_qualifiers_from_type(Type0, Type1),
- Type = maybe_add_existential_quantifier(HeadTypeParams, Type1),
- mercury_output_term(Type, TVarSet, no, !IO).
+ strip_builtin_qualifiers_from_type(Type0, Type),
+ unparse_type(Type, Term0),
+ list__map(term__coerce_var, HeadTypeParams, ExistQVars),
+ maybe_add_existential_quantifier(ExistQVars, Term0, Term),
+ varset__coerce(TVarSet, VarSet),
+ mercury_output_term(Term, VarSet, no, !IO).
:- pred write_types_list(prog_context::in, list(string)::in,
io::di, io::uo) is det.
@@ -1456,8 +1463,8 @@
io::di, io::uo) is det.
write_type_b(Type0, TypeVarSet, TypeBindings, HeadTypeParams, !IO) :-
- Type = maybe_add_existential_quantifier(HeadTypeParams, Type0),
- write_type_with_bindings(Type, TypeVarSet, TypeBindings, !IO).
+ apply_rec_subst_to_type(TypeBindings, Type0, Type),
+ output_type(Type, TypeVarSet, HeadTypeParams, !IO).
:- pred write_arg_type_stuff_list(prog_context::in, list(arg_type_stuff)::in,
io::di, io::uo) is det.
@@ -1636,8 +1643,7 @@
% This shouldn't happen - how can a variable which has
% not yet been assigned a type variable fail to have
% the correct type?
- term__context_init(Context),
- Type = term__functor(term__atom("<any>"), [], Context)
+ Type = defined(unqualified("<any>"), [], star)
),
TypeStuff = type_stuff(Type, TVarSet, TypeBindings, HeadTypeParams),
( list__member(TypeStuff, TailTypeStuffs) ->
@@ -1651,10 +1657,13 @@
typestuff_to_typestr(TypeStuff) = TypeStr :-
TypeStuff = type_stuff(Type0, TypeVarSet, TypeBindings,
HeadTypeParams),
- term__apply_rec_substitution(Type0, TypeBindings, Type1),
- strip_builtin_qualifiers_from_type(Type1, Type2),
- Type = maybe_add_existential_quantifier(HeadTypeParams, Type2),
- TypeStr = mercury_term_to_string(Type, TypeVarSet, no).
+ apply_rec_subst_to_type(TypeBindings, Type0, Type1),
+ strip_builtin_qualifiers_from_type(Type1, Type),
+ unparse_type(Type, Term0),
+ list__map(term__coerce_var, HeadTypeParams, ExistQVars),
+ maybe_add_existential_quantifier(ExistQVars, Term0, Term),
+ varset__coerce(TypeVarSet, VarSet),
+ TypeStr = mercury_term_to_string(Term, VarSet, no).
% Given an arg type assignment set and a variable id,
% return the list of possible different types for the argument
@@ -1680,12 +1689,11 @@
% This shouldn't happen - how can a variable which has
% not yet been assigned a type variable fail to have
% the correct type?
- term__context_init(Context),
- VarType = term__functor(term__atom("<any>"), [], Context)
+ VarType = defined(unqualified("<any>"), [], star)
),
list__index0_det(ArgTypes, 0, ArgType),
- term__apply_rec_substitution(ArgType, TypeBindings, ArgType2),
- term__apply_rec_substitution(VarType, TypeBindings, VarType2),
+ apply_rec_subst_to_type(TypeBindings, ArgType, ArgType2),
+ apply_rec_subst_to_type(TypeBindings, VarType, VarType2),
ArgTypeStuff = arg_type_stuff(ArgType2, VarType2, TVarSet,
HeadTypeParams),
( list__member(ArgTypeStuff, TailArgTypeStuffs) ->
@@ -1694,27 +1702,28 @@
ArgTypeStuffs = [ArgTypeStuff | TailArgTypeStuffs]
).
- % Check if any of the type variables in the type are existentially
- % quantified (occur in HeadTypeParams), and if so, add an
- % appropriate existential quantifier at the front of the type.
+ % Check if any of the variables in the term are existentially
+ % quantified (occur in the first argument), and if so, add the
+ % appropriate quantification to the term. Otherwise return the term
+ % unchanged.
%
-:- func maybe_add_existential_quantifier(head_type_params, (type)) = (type).
+:- pred maybe_add_existential_quantifier(list(var)::in, term::in, term::out)
+ is det.
-maybe_add_existential_quantifier(HeadTypeParams, Type0) = Type :-
- prog_type__vars(Type0, TVars),
- ExistQuantTVars = set__to_sorted_list(set__intersect(
- set__list_to_set(HeadTypeParams), set__list_to_set(TVars))),
- (
- ExistQuantTVars = [],
- Type = Type0
- ;
- ExistQuantTVars = [_ | _],
- Type = term__functor(term__atom("some"),
- [make_list_term(ExistQuantTVars), Type0],
+maybe_add_existential_quantifier(HeadTypeParams, !Term) :-
+ term__vars(!.Term, Vars),
+ ExistQVars = set__to_sorted_list(set__intersect(
+ set__list_to_set(HeadTypeParams), set__list_to_set(Vars))),
+ (
+ ExistQVars = []
+ ;
+ ExistQVars = [_ | _],
+ QTerm = make_list_term(ExistQVars),
+ !:Term = term__functor(term__atom("some"), [QTerm, !.Term],
term__context_init)
).
-:- func make_list_term(list(tvar)) = (type).
+:- func make_list_term(list(var)) = term.
make_list_term([]) = term__functor(term__atom("[]"), [], term__context_init).
make_list_term([Var | Vars]) = term__functor(term__atom("[|]"),
Index: compiler/typecheck_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/typecheck_info.m,v
retrieving revision 1.1
diff -u -r1.1 typecheck_info.m
--- compiler/typecheck_info.m 23 Apr 2005 06:29:48 -0000 1.1
+++ compiler/typecheck_info.m 7 Sep 2005 06:40:06 -0000
@@ -122,7 +122,7 @@
existq_tvars::in, vartypes::in, tvarset::out, existq_tvars::out,
map(prog_var, type)::out, prog_constraints::out,
constraint_proof_map::out, constraint_map::out,
- map(tvar, tvar)::out, map(tvar, tvar)::out) is det.
+ tvar_renaming::out, tvar_renaming::out) is det.
%-----------------------------------------------------------------------------%
%
@@ -296,14 +296,6 @@
).
%-----------------------------------------------------------------------------%
-
- % write_type_with_bindings writes out a type after applying the
- % type bindings.
- %
-:- pred write_type_with_bindings((type)::in, tvarset::in, tsubst::in,
- io::di, io::uo) is det.
-
-%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
@@ -315,6 +307,7 @@
:- import_module parse_tree.prog_util.
:- import_module std_util.
+:- import_module svmap.
:- import_module term.
:- import_module varset.
@@ -416,9 +409,9 @@
% ConstraintProofs too?)
%
map__values(VarTypes, Types),
- term__vars_list(Types, TypeVars0),
+ prog_type__vars_list(Types, TypeVars0),
map__values(OldExplicitVarTypes, ExplicitTypes),
- term__vars_list(ExplicitTypes, ExplicitTypeVars0),
+ prog_type__vars_list(ExplicitTypes, ExplicitTypeVars0),
map__keys(ExistTypeRenaming, ExistQVarsToBeRenamed),
list__delete_elems(OldExistQVars, ExistQVarsToBeRenamed,
ExistQVarsToRemain),
@@ -429,14 +422,12 @@
% Next, create a new typevarset with the same number of
% variables.
%
- varset__squash(OldTypeVarSet, TypeVars, NewTypeVarSet,
- TSubst),
+ varset__squash(OldTypeVarSet, TypeVars, NewTypeVarSet, TSubst),
%
% Finally, rename the types and type class constraints
% to use the new typevarset type variables.
%
- term__apply_variable_renaming_to_list(Types, TSubst,
- NewTypes),
+ apply_variable_renaming_to_type_list(TSubst, Types, NewTypes),
map__from_corresponding_lists(Vars, NewTypes, NewVarTypes),
map__apply_to_list(HeadTypeParams, TSubst, NewHeadTypeParams),
retrieve_prog_constraints(HLDSTypeConstraints,
@@ -462,7 +453,7 @@
expand_types([], _, !VarTypes).
expand_types([Var | Vars], TypeSubst, !VarTypes) :-
map__lookup(!.VarTypes, Var, Type0),
- term__apply_rec_substitution(Type0, TypeSubst, Type),
+ apply_rec_subst_to_type(TypeSubst, Type0, Type),
map__det_update(!.VarTypes, Var, Type, !:VarTypes),
expand_types(Vars, TypeSubst, !VarTypes).
@@ -471,7 +462,7 @@
% universally quantified type variables from the head of the predicate.
%
:- pred get_existq_tvar_renaming(list(tvar)::in, existq_tvars::in, tsubst::in,
- map(tvar, tvar)::out) is det.
+ tvar_renaming::out) is det.
get_existq_tvar_renaming(OldHeadTypeParams, ExistQVars, TypeBindings,
ExistTypeRenaming) :-
@@ -480,21 +471,29 @@
ExistQVars, map__init, ExistTypeRenaming).
:- pred get_existq_tvar_renaming_2(existq_tvars::in, tsubst::in,
- tvar::in, map(tvar, tvar)::in, map(tvar, tvar)::out) is det.
+ tvar::in, tvar_renaming::in, tvar_renaming::out) is det.
get_existq_tvar_renaming_2(OldHeadTypeParams, TypeBindings, TVar, !Renaming) :-
- term__apply_rec_substitution(term__variable(TVar), TypeBindings,
- Result),
(
- Result = term__variable(NewTVar),
+ tvar_maps_to_tvar(TypeBindings, TVar, NewTVar),
NewTVar \= TVar,
\+ list__member(NewTVar, OldHeadTypeParams)
->
- map__det_insert(!.Renaming, TVar, NewTVar, !:Renaming)
+ svmap__det_insert(TVar, NewTVar, !Renaming)
;
true
).
+:- pred tvar_maps_to_tvar(tsubst::in, tvar::in, tvar::out) is semidet.
+
+tvar_maps_to_tvar(TypeBindings, TVar0, TVar) :-
+ ( map__search(TypeBindings, TVar0, Type) ->
+ Type = variable(TVar1, _),
+ tvar_maps_to_tvar(TypeBindings, TVar1, TVar)
+ ;
+ TVar = TVar0
+ ).
+
%-----------------------------------------------------------------------------%
typecheck_info_get_module_info(Info, Info ^ module_info).
@@ -659,10 +658,16 @@
write_type_assign_constraints(Operator, Constraints, TypeBindings,
TypeVarSet, yes, !IO).
-write_type_with_bindings(Type, TypeVarSet, TypeBindings, !IO) :-
- term__apply_rec_substitution(Type, TypeBindings, Type2),
- strip_builtin_qualifiers_from_type(Type2, Type3),
- mercury_output_term(Type3, TypeVarSet, varnums, !IO).
+ % write_type_with_bindings writes out a type after applying the
+ % type bindings.
+ %
+:- pred write_type_with_bindings((type)::in, tvarset::in, tsubst::in,
+ io::di, io::uo) is det.
+
+write_type_with_bindings(Type0, TypeVarSet, TypeBindings, !IO) :-
+ apply_rec_subst_to_type(TypeBindings, Type0, Type1),
+ strip_builtin_qualifiers_from_type(Type1, Type),
+ mercury_output_type(TypeVarSet, no, Type, !IO).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
Index: compiler/typeclasses.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/typeclasses.m,v
retrieving revision 1.2
diff -u -r1.2 typeclasses.m
--- compiler/typeclasses.m 28 Apr 2005 07:24:58 -0000 1.2
+++ compiler/typeclasses.m 8 Sep 2005 10:02:01 -0000
@@ -202,8 +202,11 @@
EliminatedAssumed),
apply_instance_rules(ClassTable, InstanceTable, !TVarSet, !Proofs,
!ConstraintMap, !Seen, !Constraints, AppliedInstanceRule),
- apply_class_rules(SuperClassTable, !.TVarSet, !Proofs, !ConstraintMap,
- !Constraints, AppliedClassRule),
+ % XXX kind inference:
+ % We assume that all tvars have kind `star'.
+ map__init(KindMap),
+ apply_class_rules(SuperClassTable, !.TVarSet, KindMap, !Proofs,
+ !ConstraintMap, !Constraints, AppliedClassRule),
(
AppliedImprovementRule = no,
EliminatedAssumed = no,
@@ -453,9 +456,9 @@
!TVarSet, !Bindings, !Changed) :-
InstanceTVarSet = InstanceDefn ^ instance_tvarset,
InstanceTypes0 = InstanceDefn ^ instance_types,
- varset__merge_subst(!.TVarSet, InstanceTVarSet, NewTVarSet,
- RenameSubst),
- term__apply_substitution_to_list(InstanceTypes0, RenameSubst,
+ tvarset_merge_renaming(!.TVarSet, InstanceTVarSet, NewTVarSet,
+ Renaming),
+ apply_variable_renaming_to_type_list(Renaming, InstanceTypes0,
InstanceTypes),
list__foldl2(
do_instance_improvement_4(FunDeps, InstanceTypes,
@@ -496,7 +499,7 @@
%
subsumes_on_elements(Domain, InstanceTypes0, ConstraintTypes,
Subst),
- term__apply_rec_substitution_to_list(InstanceTypes0, Subst,
+ apply_rec_subst_to_type_list(Subst, InstanceTypes0,
InstanceTypes),
\+ lists_match_on_elements(Range, InstanceTypes,
ConstraintTypes),
@@ -547,7 +550,7 @@
subsumes_on_elements(Elements, TypesA, TypesB, Subst) :-
RTypesA = restrict_list_elements(Elements, TypesA),
RTypesB = restrict_list_elements(Elements, TypesB),
- term__vars_list(RTypesB, RTypesBVars),
+ prog_type__vars_list(RTypesB, RTypesBVars),
map__init(Subst0),
type_unify_list(RTypesA, RTypesB, RTypesBVars, Subst0, Subst).
@@ -684,15 +687,15 @@
ProgConstraints0 = Instance ^ instance_constraints,
InstanceTypes0 = Instance ^ instance_types,
InstanceTVarSet = Instance ^ instance_tvarset,
- varset__merge_subst(!.TVarSet, InstanceTVarSet, NewTVarSet,
- RenameSubst),
- term__apply_substitution_to_list(InstanceTypes0, RenameSubst,
+ tvarset_merge_renaming(!.TVarSet, InstanceTVarSet, NewTVarSet,
+ Renaming),
+ apply_variable_renaming_to_type_list(Renaming, InstanceTypes0,
InstanceTypes),
(
type_list_subsumes(InstanceTypes, Types, Subst)
->
!:TVarSet = NewTVarSet,
- apply_subst_to_prog_constraint_list(RenameSubst,
+ apply_variable_renaming_to_prog_constraint_list(Renaming,
ProgConstraints0, ProgConstraints1),
apply_rec_subst_to_prog_constraint_list(Subst,
ProgConstraints1, ProgConstraints),
@@ -711,28 +714,28 @@
% superclass relation to find a path from the inferred constraint to
% another (declared or inferred) constraint.
%
-:- pred apply_class_rules(superclass_table::in, tvarset::in,
+:- pred apply_class_rules(superclass_table::in, tvarset::in, tvar_kind_map::in,
constraint_proof_map::in, constraint_proof_map::out,
constraint_map::in, constraint_map::out,
hlds_constraints::in, hlds_constraints::out, bool::out) is det.
-apply_class_rules(SuperClassTable, TVarSet, !Proofs, !ConstraintMap,
+apply_class_rules(SuperClassTable, TVarSet, KindMap, !Proofs, !ConstraintMap,
!Constraints, Changed) :-
!.Constraints = constraints(Unproven0, Assumed, _),
- apply_class_rules_2(Assumed, SuperClassTable, TVarSet, !Proofs,
- !ConstraintMap, Unproven0, Unproven, Changed),
+ apply_class_rules_2(Assumed, SuperClassTable, TVarSet, KindMap,
+ !Proofs, !ConstraintMap, Unproven0, Unproven, Changed),
!:Constraints = !.Constraints ^ unproven := Unproven.
:- pred apply_class_rules_2(list(hlds_constraint)::in, superclass_table::in,
- tvarset::in, constraint_proof_map::in, constraint_proof_map::out,
- constraint_map::in, constraint_map::out,
+ tvarset::in, tvar_kind_map::in, constraint_proof_map::in,
+ constraint_proof_map::out, constraint_map::in, constraint_map::out,
list(hlds_constraint)::in, list(hlds_constraint)::out,
bool::out) is det.
-apply_class_rules_2(_, _, _, !Proofs, !ConstraintMap, [], [], no).
-apply_class_rules_2(AssumedConstraints, SuperClassTable, TVarSet, !Proofs,
- !ConstraintMap, [Constraint0 | Constraints0], Constraints,
- Changed) :-
+apply_class_rules_2(_, _, _, _, !Proofs, !ConstraintMap, [], [], no).
+apply_class_rules_2(AssumedConstraints, SuperClassTable, TVarSet, KindMap,
+ !Proofs, !ConstraintMap, [Constraint0 | Constraints0],
+ Constraints, Changed) :-
Parents = [],
retrieve_prog_constraint(Constraint0, ProgConstraint0),
@@ -745,16 +748,16 @@
(
eliminate_constraint_by_class_rules(ProgConstraint0, _, _,
AssumedConstraints, SuperClassTable, HeadTypeParams,
- TVarSet, Parents, !Proofs)
+ TVarSet, KindMap, Parents, !Proofs)
->
update_constraint_map(Constraint0, !ConstraintMap),
apply_class_rules_2(AssumedConstraints, SuperClassTable,
- TVarSet, !Proofs, !ConstraintMap,
+ TVarSet, KindMap, !Proofs, !ConstraintMap,
Constraints0, Constraints, _),
Changed = yes
;
apply_class_rules_2(AssumedConstraints, SuperClassTable,
- TVarSet, !Proofs, !ConstraintMap,
+ TVarSet, KindMap, !Proofs, !ConstraintMap,
Constraints0, TailConstraints, Changed),
Constraints = [Constraint0 | TailConstraints]
).
@@ -768,12 +771,12 @@
:- pred eliminate_constraint_by_class_rules(prog_constraint::in,
prog_constraint::out, tsubst::out, list(hlds_constraint)::in,
superclass_table::in, head_type_params::in, tvarset::in,
- list(prog_constraint)::in,
+ tvar_kind_map::in, list(prog_constraint)::in,
constraint_proof_map::in, constraint_proof_map::out) is semidet.
eliminate_constraint_by_class_rules(C, SubstC, SubClassSubst,
AssumedConstraints, SuperClassTable, HeadTypeParams, TVarSet,
- ParentConstraints, Proofs0, Proofs) :-
+ KindMap, ParentConstraints, Proofs0, Proofs) :-
% Make sure we aren't in a cycle in the
% superclass relation
@@ -792,7 +795,8 @@
% cannot contribute to proving the constraint we are trying to
% prove.
list__filter_map(
- subclass_details_to_constraint(TVarSet, SuperClassTypes),
+ subclass_details_to_constraint(TVarSet, KindMap,
+ SuperClassTypes),
SubClasses, SubClassConstraints),
(
% Do the first level of search. We search for
@@ -817,8 +821,8 @@
eliminate_constraint_by_class_rules(Constraint,
SubstConstraint, SubClassSubst0,
AssumedConstraints, SuperClassTable,
- HeadTypeParams, TVarSet, NewParentConstraints,
- Proofs0, SubProofs),
+ HeadTypeParams, TVarSet, KindMap,
+ NewParentConstraints, Proofs0, SubProofs),
CnstrtAndProof = {SubstConstraint, SubClassSubst0,
SubProofs}
),
@@ -858,26 +862,27 @@
% subclass_details_to_constraint will fail iff the call to
% type_unify_list fails.
%
-:- pred subclass_details_to_constraint(tvarset::in, list(type)::in,
- subclass_details::in, prog_constraint::out) is semidet.
+:- pred subclass_details_to_constraint(tvarset::in, tvar_kind_map::in,
+ list(type)::in, subclass_details::in, prog_constraint::out) is semidet.
-subclass_details_to_constraint(TVarSet, SuperClassTypes, SubClassDetails,
- SubC) :-
+subclass_details_to_constraint(TVarSet, KindMap0, SuperClassTypes,
+ SubClassDetails, SubC) :-
SubClassDetails = subclass_details(SuperVars0, SubID, SubVars0,
SuperVarSet),
% Rename the variables from the typeclass
- % declaration into those of the current pred
- varset__merge_subst(TVarSet, SuperVarSet, _NewTVarSet, RenameSubst),
- term__var_list_to_term_list(SubVars0, SubVars1),
- term__apply_substitution_to_list(SubVars1, RenameSubst, SubVars),
- term__apply_substitution_to_list(SuperVars0, RenameSubst, SuperVars),
+ % declaration into those of the current pred.
+ tvarset_merge_renaming(TVarSet, SuperVarSet, _NewTVarSet, Renaming),
+ apply_variable_renaming_to_tvar_kind_map(Renaming, KindMap0, KindMap),
+ apply_variable_renaming_to_tvar_list(Renaming, SubVars0, SubVars),
+ apply_variable_renaming_to_type_list(Renaming, SuperVars0, SuperVars),
% Work out what the (renamed) vars from the
% typeclass declaration are bound to here.
type_unify_list(SuperVars, SuperClassTypes, [], map__init, Bindings),
SubID = class_id(SubName, _SubArity),
- term__apply_substitution_to_list(SubVars, Bindings, SubClassTypes),
+ apply_rec_subst_to_tvar_list(KindMap, Bindings, SubVars,
+ SubClassTypes),
SubC = constraint(SubName, SubClassTypes).
% check_satisfiability(Constraints, HeadTypeParams):
@@ -922,7 +927,7 @@
=>
(
Constraint = constraint(_Ids, _ClassName, Types),
- term__contains_var_list(Types, TVar),
+ type_list_contains_var(Types, TVar),
not list__member(TVar, HeadTypeParams)
)
).
Index: compiler/unify_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unify_gen.m,v
retrieving revision 1.150
diff -u -r1.150 unify_gen.m
--- compiler/unify_gen.m 26 May 2005 00:17:03 -0000 1.150
+++ compiler/unify_gen.m 6 Sep 2005 14:25:03 -0000
@@ -161,9 +161,9 @@
code_info__produce_variable(VarB, CodeB, ValB, !CI),
CodeAB = tree(CodeA, CodeB),
Type = code_info__variable_type(!.CI, VarA),
- ( Type = term__functor(term__atom("string"), [], _) ->
+ ( Type = builtin(string) ->
Op = str_eq
- ; Type = term__functor(term__atom("float"), [], _) ->
+ ; Type = builtin(float) ->
Op = float_eq
;
Op = eq
Index: compiler/unify_proc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unify_proc.m,v
retrieving revision 1.150
diff -u -r1.150 unify_proc.m
--- compiler/unify_proc.m 30 Aug 2005 04:12:01 -0000 1.150
+++ compiler/unify_proc.m 11 Sep 2005 15:18:03 -0000
@@ -502,7 +502,8 @@
% be used by unify_proc__generate_clause_info.
varset__init(TVarSet0),
varset__new_vars(TVarSet0, TupleArity, TupleArgTVars, TVarSet),
- term__var_list_to_term_list(TupleArgTVars, TupleArgTypes),
+ prog_type.var_list_to_type_list(map__init, TupleArgTVars,
+ TupleArgTypes),
% Tuple constructors can't be existentially quantified.
ExistQVars = [],
@@ -619,13 +620,15 @@
map__lookup(Types, TypeCtor, TypeDefn),
hlds_data__get_type_defn_tvarset(TypeDefn, TVarSet),
hlds_data__get_type_defn_tparams(TypeDefn, TypeParams),
+ hlds_data__get_type_defn_kind_map(TypeDefn, KindMap),
hlds_data__get_type_defn_body(TypeDefn, TypeBody),
hlds_data__get_type_defn_status(TypeDefn, TypeStatus),
hlds_data__get_type_defn_context(TypeDefn, Context),
require(special_pred_is_generated_lazily(ModuleInfo, TypeCtor, TypeBody,
TypeStatus), "unify_proc__add_lazily_generated_unify_pred"),
- construct_type(TypeCtor, TypeParams, Type).
+ prog_type.var_list_to_type_list(KindMap, TypeParams, TypeArgs),
+ construct_type(TypeCtor, TypeArgs, Type).
%-----------------------------------------------------------------------------%
@@ -1733,7 +1736,7 @@
%
(
list__member(ExistQTVar, ExistQTVars),
- term__contains_var(Type, ExistQTVar)
+ type_contains_var(Type, ExistQTVar)
->
ComparePred = "typed_compare"
;
@@ -1906,7 +1909,7 @@
%
(
list__member(ExistQTVar, ExistQTVars),
- term__contains_var(Type, ExistQTVar)
+ type_contains_var(Type, ExistQTVar)
->
unify_proc__build_call("typed_unify", [Var1, Var2], Context, Goal,
!Info)
Index: library/rtti_implementation.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/rtti_implementation.m,v
retrieving revision 1.56
diff -u -r1.56 rtti_implementation.m
--- library/rtti_implementation.m 16 Dec 2004 07:00:34 -0000 1.56
+++ library/rtti_implementation.m 8 Sep 2005 10:11:49 -0000
@@ -1053,7 +1053,7 @@
)
).
-:- func iterate(int, int, func(int, T)) = list(T).
+:- func iterate(int, int, (func(int) = T)) = list(T).
iterate(Start, Max, Func) = Results :-
( Start =< Max ->
Index: library/term.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/term.m,v
retrieving revision 1.112
diff -u -r1.112 term.m
--- library/term.m 16 Jun 2005 04:08:06 -0000 1.112
+++ library/term.m 8 Sep 2005 05:39:55 -0000
@@ -172,6 +172,34 @@
:- pred term__unify(term(T)::in, term(T)::in, substitution(T)::in,
substitution(T)::out) is semidet.
+ % As above, but unify the corresponding elements of two lists of
+ % terms. Fails if the lists are not of equal length.
+ %
+:- pred term__unify_list(list(term(T))::in, list(term(T))::in,
+ substitution(T)::in, substitution(T)::out) is semidet.
+
+ % term__unify(Term1, Term2, BoundVars, Bindings0, Bindings):
+ % Unify (with occur check) two terms with respect to a set of bindings
+ % and possibly update the set of bindings. Fails if any of the
+ % variables in BoundVars would become bound by the unification.
+ %
+:- pred term__unify(term(T)::in, term(T)::in, list(var(T))::in,
+ substitution(T)::in, substitution(T)::out) is semidet.
+
+ % As above, but unify the corresponding elements of two lists of
+ % terms. Fails if the lists are not of equal length.
+ %
+:- pred term__unify_list(list(term(T))::in, list(term(T))::in,
+ list(var(T))::in, substitution(T)::in, substitution(T)::out)
+ is semidet.
+
+ % term__list_subsumes(Terms1, Terms2, Subst) succeeds iff the list
+ % Terms1 subsumes (is more general than) Terms2, producing a
+ % substitution which when applied to Terms1 will give Terms2.
+ %
+:- pred term__list_subsumes(list(term(T))::in, list(term(T))::in,
+ substitution(T)::out) is semidet.
+
% term__substitute(Term0, Var, Replacement, Term):
% Replace all occurrences of Var in Term0 with Replacement,
% and return the result in Term.
@@ -439,6 +467,7 @@
:- import_module require.
:- import_module std_util.
:- import_module string.
+:- import_module svmap.
%-----------------------------------------------------------------------------%
@@ -911,14 +940,130 @@
term__unify(term__functor(F, AsX, _), term__functor(F, AsY, _), !Bindings) :-
term__unify_list(AsX, AsY, !Bindings).
-:- pred term__unify_list(list(term(T))::in, list(term(T))::in,
- substitution(T)::in, substitution(T)::out) is semidet.
-
term__unify_list([], [], !Bindings).
term__unify_list([X | Xs], [Y | Ys], !Bindings) :-
term__unify(X, Y, !Bindings),
term__unify_list(Xs, Ys, !Bindings).
+term__unify(term__variable(X), term__variable(Y), BoundVars, !Bindings) :-
+ ( list__member(Y, BoundVars) ->
+ unify_bound_var(X, Y, BoundVars, !Bindings)
+ ; list__member(X, BoundVars) ->
+ unify_bound_var(Y, X, BoundVars, !Bindings)
+ ; map__search(!.Bindings, X, BindingOfX) ->
+ ( map__search(!.Bindings, Y, BindingOfY) ->
+ % Both X and Y already have bindings - just unify the
+ % terms they are bound to.
+ term__unify(BindingOfX, BindingOfY, BoundVars,
+ !Bindings)
+ ;
+ term__apply_rec_substitution(BindingOfX, !.Bindings,
+ SubstBindingOfX),
+ % Y is a variable which hasn't been bound yet.
+ ( SubstBindingOfX = term__variable(Y) ->
+ true
+ ;
+ \+ term__occurs(SubstBindingOfX, Y,
+ !.Bindings),
+ svmap__det_insert(Y, SubstBindingOfX,
+ !Bindings)
+ )
+ )
+ ;
+ ( map__search(!.Bindings, Y, BindingOfY) ->
+ term__apply_rec_substitution(BindingOfY, !.Bindings,
+ SubstBindingOfY),
+ % X is a variable which hasn't been bound yet.
+ ( SubstBindingOfY = term__variable(X) ->
+ true
+ ;
+ \+ term__occurs(SubstBindingOfY, X,
+ !.Bindings),
+ svmap__det_insert(X, SubstBindingOfY,
+ !Bindings)
+ )
+ ;
+ % Both X and Y are unbound variables - bind one to the
+ % other.
+ ( X = Y ->
+ true
+ ;
+ svmap__det_insert(X, term__variable(Y),
+ !Bindings)
+ )
+ )
+ ).
+
+term__unify(term__variable(X), term__functor(F, As, C), BoundVars,
+ !Bindings) :-
+ (
+ map__search(!.Bindings, X, BindingOfX)
+ ->
+ term__unify(BindingOfX, term__functor(F, As, C), BoundVars,
+ !Bindings)
+ ;
+ \+ term__occurs_list(As, X, !.Bindings),
+ \+ list__member(X, BoundVars),
+ svmap__det_insert(X, term__functor(F, As, C), !Bindings)
+ ).
+
+term__unify(term__functor(F, As, C), term__variable(X), BoundVars,
+ !Bindings) :-
+ (
+ map__search(!.Bindings, X, BindingOfX)
+ ->
+ term__unify(term__functor(F, As, C), BindingOfX, BoundVars,
+ !Bindings)
+ ;
+ \+ term__occurs_list(As, X, !.Bindings),
+ \+ list__member(X, BoundVars),
+ svmap__det_insert(X, term__functor(F, As, C), !Bindings)
+ ).
+
+term__unify(term__functor(FX, AsX, _CX), term__functor(FY, AsY, _CY),
+ BoundVars, !Bindings) :-
+ list__length(AsX, ArityX),
+ list__length(AsY, ArityY),
+ (
+ FX = FY,
+ ArityX = ArityY
+ ->
+ term__unify_list(AsX, AsY, BoundVars, !Bindings)
+ ;
+ fail
+ ).
+
+term__unify_list([], [], _, !Bindings).
+term__unify_list([X | Xs], [Y | Ys], BoundVars, !Bindings) :-
+ term__unify(X, Y, BoundVars, !Bindings),
+ term__unify_list(Xs, Ys, BoundVars, !Bindings).
+
+:- pred unify_bound_var(var(T)::in, var(T)::in, list(var(T))::in,
+ substitution(T)::in, substitution(T)::out) is semidet.
+
+unify_bound_var(Var, BoundVar, BoundVars, !Bindings) :-
+ ( map__search(!.Bindings, Var, BindingOfVar) ->
+ BindingOfVar = term__variable(Var2),
+ unify_bound_var(Var2, BoundVar, BoundVars, !Bindings)
+ ;
+ ( Var = BoundVar ->
+ true
+ ;
+ \+ list__member(Var, BoundVars),
+ svmap__det_insert(Var, term__variable(BoundVar),
+ !Bindings)
+ )
+ ).
+
+term__list_subsumes(Terms1, Terms2, Subst) :-
+ %
+ % Terms1 subsumes Terms2 iff Terms1 can be unified with Terms2
+ % without binding any of the variables in Terms2.
+ %
+ term__vars_list(Terms2, Terms2Vars),
+ map__init(Subst0),
+ term__unify_list(Terms1, Terms2, Terms2Vars, Subst0, Subst).
+
%-----------------------------------------------------------------------------%
% term__occurs(Term, Var, Subst) succeeds if Term contains Var,
Index: tests/invalid/kind.err_exp
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/kind.err_exp,v
retrieving revision 1.1
diff -u -r1.1 kind.err_exp
--- tests/invalid/kind.err_exp 7 May 2005 15:49:32 -0000 1.1
+++ tests/invalid/kind.err_exp 11 Sep 2005 08:22:49 -0000
@@ -1,7 +1,5 @@
-kind.m:004: In definition of type `kind.t'/1:
-kind.m:004: error: ill-formed type `V_1(int)'.
-kind.m:006: In declaration of typeclass `kind.tc'/1:
-kind.m:006: error: ill-formed type `V_1(string)'.
+kind.m:004: Error: ill-formed type: _1(int).
+kind.m:007: Error: syntax error in arguments of `:- func' declaration: f(_1(string)).
kind.m:011: In definition of inst `kind.i'/1:
kind.m:011: error: variable used as inst constructor.
kind.m:012: In definition of mode `kind.m'/1:
Index: tests/invalid/tc_err1.err_exp
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/tc_err1.err_exp,v
retrieving revision 1.5
diff -u -r1.5 tc_err1.err_exp
--- tests/invalid/tc_err1.err_exp 12 Apr 2005 07:58:20 -0000 1.5
+++ tests/invalid/tc_err1.err_exp 11 Sep 2005 07:22:20 -0000
@@ -1,6 +1,6 @@
tc_err1.m:025: Error: no determinism declaration for type class method
tc_err1.m:025: predicate `tc_err1.handle_typedefs'/3.
-tc_err1.m:032: In instance declaration for `tc_err1.actions(tc_err1.pstate)':
+tc_err1.m:032: In instance declaration for `tc_err1.actions((tc_err1.pstate))':
tc_err1.m:032: no implementation for type class predicate method
tc_err1.m:032: `tc_err1.handle_typedefs'/3.
tc_err1.m:032: In instance declaration for `tc_err1.actions'/1: incorrect
Index: tests/invalid/tc_err2.err_exp
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/tc_err2.err_exp,v
retrieving revision 1.4
diff -u -r1.4 tc_err2.err_exp
--- tests/invalid/tc_err2.err_exp 12 Apr 2005 07:58:20 -0000 1.4
+++ tests/invalid/tc_err2.err_exp 11 Sep 2005 07:22:55 -0000
@@ -1,4 +1,4 @@
-tc_err2.m:044: In instance declaration for `tc_err2.actions(tc_err2.pstate)':
+tc_err2.m:044: In instance declaration for `tc_err2.actions((tc_err2.pstate))':
tc_err2.m:044: no implementation for type class predicate method
tc_err2.m:044: `tc_err2.handle_typedefs'/3.
tc_err2.m:044: In instance declaration for `tc_err2.actions'/1: incorrect
Index: tests/misc_tests/pretty_print_test.exp
===================================================================
RCS file: /home/mercury1/repository/tests/misc_tests/pretty_print_test.exp,v
retrieving revision 1.7
diff -u -r1.7 pretty_print_test.exp
--- tests/misc_tests/pretty_print_test.exp 13 Oct 2004 01:27:57 -0000 1.7
+++ tests/misc_tests/pretty_print_test.exp 11 Sep 2005 07:24:48 -0000
@@ -1,7 +1,7 @@
:- module pretty_print_test.
:- interface.
:- import_module io.
-:- pred main(io__state, io__state).
+:- pred main((io.state), (io.state)).
:- mode main(di, uo) is det.
:- implementation.
:- type foobar
--------------------------------------------------------------------------
mercury-reviews mailing list
post: mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------
More information about the reviews
mailing list