[m-rev.] for review: improvements for foreign_type
Simon Taylor
stayl at cs.mu.OZ.AU
Fri Jun 28 18:30:46 AEST 2002
For review by Pete or Tyson.
Simon.
Estimated hours taken: 10
Branches: main
Improvements for `:- pragma foreign_type'.
- Allow default Mercury definitions. The Mercury definition must define
a discriminated union type. The type is treated as abstract except
in predicates or functions which have implementations for all the
foreign languages the type has implementations for (the check for
this isn't quite right).
- Allow polymorphic foreign types.
- Don't require the `:- pragma foreign_type' for exported foreign types
to be in the interface. We now only require that all definitions
have the same visibility.
compiler/prog_data.m:
compiler/prog_io_pragma.m:
Allow polymorphic foreign types.
compiler/prog_io.m:
Export code to parse the type name in a type definition for
use by prog_io_pragma.m.
compiler/make_hlds.m:
Handle Mercury definitions for foreign types.
Separate out the code to add constructors and special predicates
to the HLDS into a separate pass. For foreign types, we don't know
what to add until all type definitions have been seen.
Use the C definition for foreign types with `--target asm'.
compiler/modules.m:
Distinguish properly between `exported' and `exported_to_submodules'.
Previously, if a module had sub-modules, all declarations,
including those in the interface, had import_status
`exported_to_submodules'. Now, the declarations in the
interface have status `exported' or `abstract_exported'.
This is needed to check that the visibility of all the
definitions of a type is the same.
compiler/hlds_pred.m:
Add a predicate status_is_exported_to_non_submodules, which
fails if an item is local to the module and its sub-modules.
compiler/hlds_data.m:
compiler/*.m:
Record whether a du type has foreign definitions as well.
compiler/typecheck.m:
Check that a predicate or function has foreign clauses before
allowing the use of a constructor of a type which also has
foreign definitions.
compiler/hlds_pred.m:
compiler/make_hlds.m:
Simplify the code to work out the goal_type for a predicate.
compiler/hlds_out.m:
Don't abort on foreign types.
Print the goal type for each predicate.
compiler/error_util.m:
Handle the case where the message being written is a
continuation of an existing message, so the first line
should be indented.
compiler/module_qual.m:
Remove unnecessary processing of foreign types.
doc/reference_manual.tex:
Document the change.
Update the documentation for mixing Mercury and foreign clauses.
The Mercury clauses no longer need to be mode-specific.
tests/hard_coded/Mmakefile:
tests/hard_coded/foreign_type2.{m,exp}:
tests/hard_coded/foreign_type.m:
tests/invalid/Mmakefile:
tests/invalid/foreign_type_2.{m,err_exp}:
tests/invalid/foreign_type_visibility.{m,err_exp}:
Test cases.
Test cases.
tests/invalid/record_syntax.err_exp:
Update expected output.
Index: compiler/code_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/code_util.m,v
retrieving revision 1.137
diff -u -u -r1.137 code_util.m
--- compiler/code_util.m 28 Mar 2002 03:42:48 -0000 1.137
+++ compiler/code_util.m 23 Jun 2002 19:26:32 -0000
@@ -735,7 +735,7 @@
map__lookup(TypeTable, TypeCtor, TypeDefn),
hlds_data__get_type_defn_body(TypeDefn, TypeBody),
(
- TypeBody = du_type(_, ConsTable0, _, _)
+ TypeBody = du_type(_, ConsTable0, _, _, _)
->
ConsTable = ConsTable0
;
Index: compiler/det_report.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/det_report.m,v
retrieving revision 1.72
diff -u -u -r1.72 det_report.m
--- compiler/det_report.m 28 Mar 2002 03:42:53 -0000 1.72
+++ compiler/det_report.m 23 Jun 2002 18:38:20 -0000
@@ -563,7 +563,7 @@
{ det_lookup_var_type(ModuleInfo, ProcInfo, Var,
TypeDefn) },
{ hlds_data__get_type_defn_body(TypeDefn, TypeBody) },
- { TypeBody = du_type(_, ConsTable, _, _) }
+ { TypeBody = du_type(_, ConsTable, _, _, _) }
->
{ map__keys(ConsTable, ConsIds) },
{ det_diagnose_missing_consids(ConsIds, Cases,
Index: compiler/error_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/error_util.m,v
retrieving revision 1.18
diff -u -u -r1.18 error_util.m
--- compiler/error_util.m 20 Mar 2002 12:36:08 -0000 1.18
+++ compiler/error_util.m 26 Jun 2002 09:40:46 -0000
@@ -67,6 +67,10 @@
:- pred write_error_pieces(prog_context::in, int::in,
list(format_component)::in, io__state::di, io__state::uo) is det.
+ % Display the given error message, but indent the first line.
+:- pred write_error_pieces_not_first_line(prog_context::in, int::in,
+ list(format_component)::in, io__state::di, io__state::uo) is det.
+
:- pred write_error_pieces_maybe_with_context(maybe(prog_context)::in, int::in,
list(format_component)::in, io__state::di, io__state::uo) is det.
@@ -167,10 +171,23 @@
write_error_pieces(Context, Indent, Components).
write_error_pieces(Context, Indent, Components) -->
- write_error_pieces_maybe_with_context(yes(Context),
+ write_error_pieces_maybe_with_context(yes, yes(Context),
+ Indent, Components).
+
+write_error_pieces_not_first_line(Context, Indent, Components) -->
+ write_error_pieces_maybe_with_context(no, yes(Context),
Indent, Components).
write_error_pieces_maybe_with_context(MaybeContext, Indent, Components) -->
+ write_error_pieces_maybe_with_context(yes, MaybeContext,
+ Indent, Components).
+
+:- pred write_error_pieces_maybe_with_context(bool::in,
+ maybe(prog_context)::in, int::in, list(format_component)::in,
+ io__state::di, io__state::uo) is det.
+
+write_error_pieces_maybe_with_context(IsFirst, MaybeContext,
+ Indent, Components) -->
{
% The fixed characters at the start of the line are:
% filename
@@ -197,11 +214,16 @@
MaybeContext = no,
ContextLength = 0
),
- Remain is 79 - (ContextLength + Indent),
+ NotFirstIndent = (IsFirst = yes -> 0 ; 2),
+ Remain = 79 - (ContextLength + Indent + NotFirstIndent),
convert_components_to_word_list(Components, [], [], Words),
- group_words(yes, Words, Remain, Lines)
+ group_words(IsFirst, Words, Remain, Lines)
},
- write_lines(Lines, MaybeContext, Indent).
+ ( { IsFirst = yes } ->
+ write_lines(Lines, MaybeContext, Indent)
+ ;
+ write_nonfirst_lines(Lines, MaybeContext, Indent + 2)
+ ).
:- pred write_lines(list(list(string))::in, maybe(prog_context)::in, int::in,
io__state::di, io__state::uo) is det.
Index: compiler/foreign.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/foreign.m,v
retrieving revision 1.16
diff -u -u -r1.16 foreign.m
--- compiler/foreign.m 30 May 2002 08:00:01 -0000 1.16
+++ compiler/foreign.m 24 Jun 2002 06:24:22 -0000
@@ -601,7 +601,7 @@
map__search(Types, TypeCtor, TypeDefn)
->
hlds_data__get_type_defn_body(TypeDefn, Body),
- ( Body = foreign_type(MaybeIL, MaybeC) ->
+ ( Body = foreign_type(foreign_type_body(MaybeIL, MaybeC)) ->
( Target = c,
( MaybeC = yes(c(NameStr)),
Name = unqualified(NameStr)
Index: compiler/hlds_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_data.m,v
retrieving revision 1.69
diff -u -u -r1.69 hlds_data.m
--- compiler/hlds_data.m 7 May 2002 11:02:44 -0000 1.69
+++ compiler/hlds_data.m 24 Jun 2002 06:05:39 -0000
@@ -259,9 +259,9 @@
:- type hlds_type_defn.
-:- pred hlds_data__set_type_defn(tvarset, list(type_param),
- hlds_type_body, import_status, prog_context, hlds_type_defn).
-:- mode hlds_data__set_type_defn(in, in, in, in, in, out) is det.
+:- pred hlds_data__set_type_defn(tvarset, list(type_param), hlds_type_body,
+ import_status, need_qualifier, prog_context, hlds_type_defn).
+:- mode hlds_data__set_type_defn(in, in, in, in, in, in, out) is det.
:- pred hlds_data__get_type_defn_tvarset(hlds_type_defn, tvarset).
:- mode hlds_data__get_type_defn_tvarset(in, out) is det.
@@ -275,6 +275,10 @@
:- pred hlds_data__get_type_defn_status(hlds_type_defn, import_status).
:- mode hlds_data__get_type_defn_status(in, out) is det.
+:- pred hlds_data__get_type_defn_need_qualifier(hlds_type_defn,
+ need_qualifier).
+:- mode hlds_data__get_type_defn_need_qualifier(in, out) is det.
+
:- pred hlds_data__get_type_defn_context(hlds_type_defn, prog_context).
:- mode hlds_data__get_type_defn_context(in, out) is det.
@@ -293,17 +297,27 @@
:- type hlds_type_body
---> du_type(
- list(constructor), % the ctors for this type
- cons_tag_values, % their tag values
- bool, % is this type an enumeration?
- maybe(sym_name) % user-defined equality pred
+ % the ctors for this type
+ du_type_ctors :: list(constructor),
+ % their tag values
+ du_type_cons_tag_values :: cons_tag_values,
+ % is this type an enumeration?
+ du_type_is_enum :: bool,
+ % user-defined equality pred
+ du_type_usereq :: maybe(sym_name),
+ % are there `:- pragma foreign' type
+ % declarations for this type.
+ du_type_is_foreign_type :: maybe(foreign_type_body)
)
; eqv_type(type)
- ; foreign_type(
+ ; foreign_type(foreign_type_body)
+ ; abstract_type.
+
+:- type foreign_type_body
+ ---> foreign_type_body(
il :: maybe(il_foreign_type),
c :: maybe(c_foreign_type)
- )
- ; abstract_type.
+ ).
% The `cons_tag_values' type stores the information on how
% a discriminated union type is represented.
@@ -510,15 +524,24 @@
:- type hlds_type_defn
---> hlds_type_defn(
- tvarset, % Names of type vars (empty
+ type_defn_tvarset :: tvarset,
+ % Names of type vars (empty
% except for polymorphic types)
- list(type_param), % Formal type parameters
- hlds_type_body, % The definition of the type
+ type_defn_params :: list(type_param),
+ % Formal type parameters
+ type_defn_body :: hlds_type_body,
+ % The definition of the type
- import_status, % Is the type defined in this
+ type_defn_import_status :: import_status,
+ % Is the type defined in this
% module, and if yes, is it
% exported
+ type_defn_need_qualifier :: need_qualifier,
+ % Do uses of the type and
+ % its constructors need
+ % to be qualified.
+
% condition, % UNUSED
% % Reserved for holding a user-defined invariant
% % for the type, as in the NU-Prolog's type
@@ -527,24 +550,27 @@
% % :- type sorted_list(T) == list(T)
% % where sorted.
- prog_context % The location of this type
+ type_defn_context :: prog_context
+ % The location of this type
% definition in the original
% source code
).
-hlds_data__set_type_defn(Tvarset, Params, Body, Status, Context, Defn) :-
- Defn = hlds_type_defn(Tvarset, Params, Body, Status, Context).
-
-hlds_data__get_type_defn_tvarset(hlds_type_defn(Tvarset, _, _, _, _), Tvarset).
-hlds_data__get_type_defn_tparams(hlds_type_defn(_, Params, _, _, _), Params).
-hlds_data__get_type_defn_body(hlds_type_defn(_, _, Body, _, _), Body).
-hlds_data__get_type_defn_status(hlds_type_defn(_, _, _, Status, _), Status).
-hlds_data__get_type_defn_context(hlds_type_defn(_, _, _, _, Context), Context).
-
-hlds_data__set_type_defn_body(hlds_type_defn(A, B, _, D, E), Body,
- hlds_type_defn(A, B, Body, D, E)).
-hlds_data__set_type_defn_status(hlds_type_defn(A, B, C, _, E), Status,
- hlds_type_defn(A, B, C, Status, E)).
+hlds_data__set_type_defn(Tvarset, Params, Body, Status,
+ NeedQual, Context, Defn) :-
+ Defn = hlds_type_defn(Tvarset, Params, Body,
+ Status, NeedQual, Context).
+
+hlds_data__get_type_defn_tvarset(Defn, Defn ^ type_defn_tvarset).
+hlds_data__get_type_defn_tparams(Defn, Defn ^ type_defn_params).
+hlds_data__get_type_defn_body(Defn, Defn ^ type_defn_body).
+hlds_data__get_type_defn_status(Defn, Defn ^ type_defn_import_status).
+hlds_data__get_type_defn_need_qualifier(Defn, Defn ^ type_defn_need_qualifier).
+hlds_data__get_type_defn_context(Defn, Defn ^ type_defn_context).
+
+hlds_data__set_type_defn_body(Defn, Body, Defn ^ type_defn_body := Body).
+hlds_data__set_type_defn_status(Defn, Status,
+ Defn ^ type_defn_import_status := Status).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.284
diff -u -u -r1.284 hlds_out.m
--- compiler/hlds_out.m 30 May 2002 12:54:57 -0000 1.284
+++ compiler/hlds_out.m 27 Jun 2002 17:35:01 -0000
@@ -865,6 +865,10 @@
io__write_string(", status: "),
hlds_out__write_import_status(ImportStatus),
io__write_string("\n"),
+ io__write_string("goal_type: "),
+ { pred_info_get_goal_type(PredInfo, GoalType) },
+ io__write(GoalType),
+ io__write_string("\n"),
{ markers_to_marker_list(Markers, MarkerList) },
( { MarkerList = [] } ->
[]
@@ -2869,7 +2873,7 @@
:- mode hlds_out__write_type_body(in, in, in, di, uo) is det.
hlds_out__write_type_body(Indent, Tvarset, du_type(Ctors, Tags, Enum,
- MaybeEqualityPred)) -->
+ MaybeEqualityPred, Foreign)) -->
io__write_string(" --->\n"),
( { Enum = yes } ->
hlds_out__write_indent(Indent),
@@ -2886,6 +2890,12 @@
;
[]
),
+ ( { Foreign = yes(_) } ->
+ hlds_out__write_indent(Indent),
+ io__write_string("/* has foreign_type */\n")
+ ;
+ []
+ ),
io__write_string(".\n").
@@ -2897,8 +2907,9 @@
hlds_out__write_type_body(_Indent, _Tvarset, abstract_type) -->
io__write_string(".\n").
-hlds_out__write_type_body(_Indent, _Tvarset, foreign_type(_, _)) -->
- { error("hlds_out__write_type_body: foreign type body found") }.
+hlds_out__write_type_body(_Indent, _Tvarset, foreign_type(_)) -->
+ % XXX
+ io__write_string(" == $foreign_type.\n").
:- pred hlds_out__write_constructors(int, tvarset, list(constructor),
cons_tag_values, io__state, io__state).
Index: compiler/hlds_pred.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_pred.m,v
retrieving revision 1.109
diff -u -u -r1.109 hlds_pred.m
--- compiler/hlds_pred.m 30 May 2002 12:54:59 -0000 1.109
+++ compiler/hlds_pred.m 26 Jun 2002 16:40:16 -0000
@@ -321,6 +321,11 @@
:- pred status_is_exported(import_status::in, bool::out) is det.
% returns yes if the status indicates that the item was
+ % exported to importing modules (not just to sub-modules).
+:- pred status_is_exported_to_non_submodules(import_status::in,
+ bool::out) is det.
+
+ % returns yes if the status indicates that the item was
% in any way imported -- that is, if it was defined in
% some other module, or in a sub-module of this module.
% This is the opposite of status_defined_in_this_module.
@@ -709,6 +714,9 @@
:- pred pred_info_pragma_goal_type(pred_info).
:- mode pred_info_pragma_goal_type(in) is semidet.
+:- pred pred_info_update_goal_type(pred_info, goal_type, pred_info).
+:- mode pred_info_update_goal_type(in, in, out) is det.
+
:- pred pred_info_set_goal_type(pred_info, goal_type, pred_info).
:- mode pred_info_set_goal_type(in, in, out) is det.
@@ -882,6 +890,16 @@
status_is_exported(exported_to_submodules, yes).
status_is_exported(local, no).
+status_is_exported_to_non_submodules(Status, Result) :-
+ (
+ status_is_exported(Status, yes),
+ Status \= exported_to_submodules
+ ->
+ Result = yes
+ ;
+ Result = no
+ ).
+
status_is_imported(Status, Imported) :-
status_defined_in_this_module(Status, InThisModule),
bool__not(InThisModule, Imported).
@@ -1214,14 +1232,47 @@
pred_info_get_goal_type(PredInfo, PredInfo^goal_type).
pred_info_clause_goal_type(PredInfo) :-
- ( PredInfo ^ goal_type = clauses
- ; PredInfo ^ goal_type = clauses_and_pragmas
- ).
+ clause_goal_type(PredInfo ^ goal_type).
pred_info_pragma_goal_type(PredInfo) :-
- ( PredInfo ^ goal_type = pragmas
- ; PredInfo ^ goal_type = clauses_and_pragmas
- ).
+ pragma_goal_type(PredInfo ^ goal_type).
+
+:- pred clause_goal_type(goal_type::in) is semidet.
+
+clause_goal_type(clauses).
+clause_goal_type(clauses_and_pragmas).
+
+:- pred pragma_goal_type(goal_type::in) is semidet.
+
+pragma_goal_type(pragmas).
+pragma_goal_type(clauses_and_pragmas).
+
+pred_info_update_goal_type(PredInfo0, GoalType1, PredInfo) :-
+ pred_info_get_goal_type(PredInfo0, GoalType0),
+ (
+ GoalType0 = none, GoalType = GoalType1
+ ;
+ GoalType0 = pragmas,
+ ( clause_goal_type(GoalType1) ->
+ GoalType = clauses_and_pragmas
+ ;
+ GoalType = pragmas
+ )
+ ;
+ GoalType0 = clauses,
+ ( pragma_goal_type(GoalType1) ->
+ GoalType = clauses_and_pragmas
+ ;
+ GoalType = clauses
+ )
+
+ ;
+ GoalType0 = clauses_and_pragmas,
+ GoalType = GoalType0
+ ;
+ GoalType0 = promise(_), error("pred_info_update_goal_type")
+ ),
+ pred_info_set_goal_type(PredInfo0, GoalType, PredInfo).
pred_info_set_goal_type(PredInfo, X, PredInfo^goal_type := X).
Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.121
diff -u -u -r1.121 intermod.m
--- compiler/intermod.m 10 May 2002 14:03:58 -0000 1.121
+++ compiler/intermod.m 27 Jun 2002 17:35:38 -0000
@@ -999,7 +999,7 @@
->
(
hlds_data__get_type_defn_body(TypeDefn0, TypeBody0),
- TypeBody0 = du_type(Ctors, Tags, Enum, MaybeUserEq0),
+ TypeBody0 = du_type(Ctors, Tags, Enum, MaybeUserEq0, Foreign),
MaybeUserEq0 = yes(UserEq0)
->
module_info_get_special_pred_map(ModuleInfo, SpecialPreds),
@@ -1008,7 +1008,7 @@
pred_info_arg_types(UnifyPredInfo, TVarSet, _, ArgTypes),
typecheck__resolve_pred_overloading(ModuleInfo, ArgTypes,
TVarSet, UserEq0, UserEq, UserEqPredId),
- TypeBody = du_type(Ctors, Tags, Enum, yes(UserEq)),
+ TypeBody = du_type(Ctors, Tags, Enum, yes(UserEq), Foreign),
hlds_data__set_type_defn_body(TypeDefn0, TypeBody, TypeDefn),
intermod__add_proc(UserEqPredId, _, Info1, Info2)
;
@@ -1185,7 +1185,7 @@
{ hlds_data__get_type_defn_context(TypeDefn, Context) },
{ TypeCtor = Name - _Arity },
(
- { Body = du_type(Ctors, _, _, MaybeEqualityPred) },
+ { Body = du_type(Ctors, _, _, MaybeEqualityPred, _) },
{ TypeBody = du_type(Ctors, MaybeEqualityPred) }
;
{ Body = eqv_type(EqvType) },
@@ -1194,24 +1194,30 @@
{ Body = abstract_type },
{ TypeBody = abstract_type }
;
- { Body = foreign_type(_, _) },
+ { Body = foreign_type(_) },
{ TypeBody = abstract_type }
),
mercury_output_item(type_defn(VarSet, Name, Args, TypeBody, true),
Context),
- ( { Body = foreign_type(MaybeIL, MaybeC) } ->
- { construct_type(TypeCtor, [], Type) },
+ (
+ { Body = foreign_type(ForeignTypeBody)
+ ; Body = du_type(_, _, _, _, yes(ForeignTypeBody))
+ },
+ { ForeignTypeBody = foreign_type_body(MaybeIL, MaybeC) }
+ ->
( { MaybeIL = yes(ILForeignType) },
mercury_output_item(pragma(
- foreign_type(il(ILForeignType), Type, Name)),
+ foreign_type(il(ILForeignType), VarSet,
+ Name, Args)),
Context)
; { MaybeIL = no },
[]
),
( { MaybeC = yes(CForeignType) },
mercury_output_item(pragma(
- foreign_type(c(CForeignType), Type, Name)),
+ foreign_type(c(CForeignType), VarSet,
+ Name, Args)),
Context)
; { MaybeC = no },
[]
Index: compiler/magic_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/magic_util.m,v
retrieving revision 1.21
diff -u -u -r1.21 magic_util.m
--- compiler/magic_util.m 7 May 2002 11:02:53 -0000 1.21
+++ compiler/magic_util.m 24 Jun 2002 06:18:14 -0000
@@ -1374,14 +1374,14 @@
set(argument_error)::in, set(argument_error)::out,
magic_info::in, magic_info::out) is det.
-magic_util__check_type_defn(du_type(Ctors, _, _, _),
+magic_util__check_type_defn(du_type(Ctors, _, _, _, _),
Parents, Errors0, Errors) -->
list__foldl2(magic_util__check_ctor(Parents), Ctors, Errors0, Errors).
magic_util__check_type_defn(eqv_type(_), _, _, _) -->
{ error("magic_util__check_type_defn: eqv_type") }.
magic_util__check_type_defn(abstract_type, _, Errors0, Errors) -->
{ set__insert(Errors0, abstract, Errors) }.
-magic_util__check_type_defn(foreign_type(_, _), _, _, _) -->
+magic_util__check_type_defn(foreign_type(_), _, _, _) -->
{ error("magic_util__check_type_defn: foreign_type") }.
:- pred magic_util__check_ctor(set(type_ctor)::in, constructor::in,
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.414
diff -u -u -r1.414 make_hlds.m
--- compiler/make_hlds.m 10 Jun 2002 15:58:05 -0000 1.414
+++ compiler/make_hlds.m 26 Jun 2002 18:22:31 -0000
@@ -131,12 +131,17 @@
add_item_list_decls_pass_2(Items,
item_status(local, may_be_unqualified), Module1, Module2),
+ % Add constructors and special preds. This must be done after
+ % adding all type and `:- pragma foreign_type' declarations.
+ { module_info_types(Module2, Types) },
+ map__foldl2(process_type_defn, Types, Module2, Module3),
+
maybe_report_stats(Statistics),
% balance the binary trees
- { module_info_optimize(Module2, Module3) },
+ { module_info_optimize(Module3, Module4) },
maybe_report_stats(Statistics),
{ init_qual_info(MQInfo0, EqvMap, QualInfo0) },
- add_item_list_clauses(Items, local, Module3, Module4,
+ add_item_list_clauses(Items, local, Module4, Module5,
QualInfo0, QualInfo),
{ qual_info_get_mq_info(QualInfo, MQInfo) },
{ mq_info_get_type_error_flag(MQInfo, UndefTypes) },
@@ -144,10 +149,10 @@
{ mq_info_get_num_errors(MQInfo, MQ_NumErrors) },
{ module_info_num_errors(Module4, NumErrors0) },
{ NumErrors is NumErrors0 + MQ_NumErrors },
- { module_info_set_num_errors(Module4, NumErrors, Module5) },
+ { module_info_set_num_errors(Module5, NumErrors, Module6) },
% the predid list is constructed in reverse order, for
% efficiency, so we return it to the correct order here.
- { module_info_reverse_predids(Module5, Module) }.
+ { module_info_reverse_predids(Module6, Module) }.
%-----------------------------------------------------------------------------%
@@ -412,49 +417,9 @@
% Note that we check during add_item_clause that we have
% defined a foreign_type which is usable by the back-end
% we are compiling on.
- { Pragma = foreign_type(ForeignType, _MercuryType, Name) },
-
- { varset__init(VarSet) },
- { Args = [] },
- { ForeignType = il(ILForeignType),
- Body = foreign_type(yes(ILForeignType), no)
- ; ForeignType = c(CForeignType),
- Body = foreign_type(no, yes(CForeignType))
- },
- { Cond = true },
-
- { TypeCtor = Name - 0 },
- { module_info_types(Module0, Types) },
- { TypeStr = error_util__describe_sym_name_and_arity(
- Name / 0) },
- (
- { map__search(Types, TypeCtor, OldDefn) }
- ->
- { hlds_data__get_type_defn_status(OldDefn, OldStatus) },
- { combine_status(OldStatus, ImportStatus, NewStatus) },
- ( { NewStatus = abstract_exported } ->
- { ErrorPieces = [
- words("Error: pragma foreign_type "),
- fixed(TypeStr),
- words("must have the same visibility as the type declaration.")
- ] },
- error_util__write_error_pieces(Context, 0, ErrorPieces),
- { module_info_incr_errors(Module0, Module) }
-
- ;
- module_add_type_defn_2(Module0, VarSet, Name,
- Args, Body, Cond, Context, Status,
- Module)
- )
- ;
- { ErrorPieces = [
- words("Error: type "),
- fixed(TypeStr),
- words("defined as foreign_type without being declared.")
- ] },
- error_util__write_error_pieces(Context, 0, ErrorPieces),
- { module_info_incr_errors(Module0, Module) }
- )
+ { Pragma = foreign_type(ForeignType, TVarSet, Name, Args) },
+ add_pragma_foreign_type(Context, Status, ForeignType,
+ TVarSet, Name, Args, Module0, Module)
;
% Handle pragma tabled decls later on (when we process
% clauses).
@@ -812,10 +777,11 @@
Module0, Module),
{ Info = Info0 }
;
- { Pragma = foreign_type(_, _, Name) }
+ { Pragma = foreign_type(_, _, Name, Args) }
->
- check_foreign_type(Name, Context, Module0, Module),
- { Info = Info0 }
+ check_foreign_type(Name, list__length(Args),
+ Context, Module0, Module),
+ { Info = Info0 }
;
% don't worry about any pragma declarations other than the
% clause-like pragmas (c_code, tabling and fact_table),
@@ -946,6 +912,63 @@
%-----------------------------------------------------------------------------%
+:- pred add_pragma_foreign_type(prog_context, item_status,
+ foreign_language_type, tvarset, sym_name, list(type_param),
+ module_info, module_info, io__state, io__state).
+:- mode add_pragma_foreign_type(in, in, in, in, in, in,
+ in, out, di, uo) is det.
+
+add_pragma_foreign_type(Context, item_status(ImportStatus, NeedQual),
+ ForeignType, TVarSet, Name, Args, Module0, Module) -->
+ { ForeignType = il(ILForeignType),
+ Body = foreign_type(foreign_type_body(yes(ILForeignType), no))
+ ; ForeignType = c(CForeignType),
+ Body = foreign_type(foreign_type_body(no, yes(CForeignType)))
+ },
+ { Cond = true },
+
+ { Arity = list__length(Args) },
+ { TypeCtor = Name - Arity },
+ { module_info_types(Module0, Types) },
+ { TypeStr = error_util__describe_sym_name_and_arity(Name / Arity) },
+ (
+ { map__search(Types, TypeCtor, OldDefn) }
+ ->
+ { hlds_data__get_type_defn_status(OldDefn, OldStatus) },
+ { hlds_data__get_type_defn_body(OldDefn, OldBody) },
+ (
+ { OldBody = abstract_type },
+ { status_is_exported_to_non_submodules(OldStatus,
+ no) },
+ { status_is_exported_to_non_submodules(ImportStatus,
+ yes) }
+ ->
+ { ErrorPieces = [
+ words("Error: pragma foreign_type "),
+ fixed(TypeStr),
+ words(
+ "must have the same visibility as the type declaration.")
+ ] },
+ error_util__write_error_pieces(Context, 0, ErrorPieces),
+ { module_info_incr_errors(Module0, Module) }
+ ;
+ module_add_type_defn_2(Module0, TVarSet, Name,
+ Args, Body, Cond, Context,
+ item_status(ImportStatus, NeedQual),
+ Module)
+ )
+ ;
+ { ErrorPieces = [
+ words("Error: type "),
+ fixed(TypeStr),
+ words("defined as foreign_type without being declared.")
+ ] },
+ error_util__write_error_pieces(Context, 0, ErrorPieces),
+ { module_info_incr_errors(Module0, Module) }
+ ).
+
+%-----------------------------------------------------------------------------%
+
:- pred add_pragma_unused_args(pred_or_func, sym_name, arity, mode_num,
list(int), prog_context, module_info, module_info,
io__state, io__state).
@@ -1886,7 +1909,6 @@
module_add_type_defn_2(Module0, TVarSet, Name, Args, Body, _Cond, Context,
item_status(Status0, NeedQual), Module) -->
{ module_info_types(Module0, Types0) },
- globals__io_get_globals(Globals),
{ list__length(Args, Arity) },
{ TypeCtor = Name - Arity },
{ Body = abstract_type ->
@@ -1906,7 +1928,8 @@
MaybeOldDefn = no,
Status = Status1
},
- { hlds_data__set_type_defn(TVarSet, Args, Body, Status, Context, T) },
+ { hlds_data__set_type_defn(TVarSet, Args, Body, Status,
+ NeedQual, Context, T) },
(
% if there was an existing non-abstract definition for the type
{ MaybeOldDefn = yes(T2) },
@@ -1915,8 +1938,11 @@
{ 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) },
+ { hlds_data__get_type_defn_need_qualifier(T2,
+ OrigNeedQual) },
{ Body_2 \= abstract_type }
->
+ globals__io_get_target(Target),
(
% then if this definition was abstract, ignore it
% (but update the status of the old defn if necessary)
@@ -1928,17 +1954,37 @@
Module = Module0
;
hlds_data__set_type_defn(TVarSet_2, Params_2,
- Body_2, Status, OrigContext, T3),
+ Body_2, Status, OrigNeedQual,
+ OrigContext, T3),
map__det_update(Types0, TypeCtor, T3, Types),
module_info_set_types(Module0, Types, Module)
}
;
- { merge_foreign_type_bodies(Body, Body_2, NewBody) }
+ { merge_foreign_type_bodies(Target, Body, Body_2,
+ NewBody) }
->
- { hlds_data__set_type_defn(TVarSet_2, Params_2,
- NewBody, Status, Context, T3) },
- { map__det_update(Types0, TypeCtor, T3, Types) },
- { module_info_set_types(Module0, Types, Module) }
+ (
+ { check_foreign_type_visibility(OrigStatus,
+ Status1) }
+ ->
+ { hlds_data__set_type_defn(TVarSet_2, Params_2,
+ NewBody, Status, OrigNeedQual,
+ Context, T3) },
+ { map__det_update(Types0,
+ TypeCtor, T3, Types) },
+ { module_info_set_types(Module0,
+ Types, Module) }
+ ;
+ { module_info_incr_errors(Module0, Module) },
+ { Pieces = [words("In definition of type"),
+ fixed(describe_sym_name_and_arity(
+ Name / Arity) ++ ":"), nl,
+ words("error: all definitions of a"),
+ words("type must have the same"),
+ words("visibility")] },
+ error_util__write_error_pieces(Context, 0,
+ Pieces)
+ )
;
% otherwise issue an error message if the second
% definition wasn't read while reading .opt files.
@@ -1952,42 +1998,7 @@
)
;
{ map__set(Types0, TypeCtor, T, Types) },
- { construct_type(TypeCtor, Args, Type) },
- (
- { Body = du_type(ConsList, _, _, _) }
- ->
- { module_info_ctors(Module0, Ctors0) },
- { module_info_get_partial_qualifier_info(Module0,
- PQInfo) },
- { module_info_ctor_field_table(Module0,
- CtorFields0) },
- ctors_add(ConsList, TypeCtor, TVarSet, NeedQual,
- PQInfo, Context, Status,
- CtorFields0, CtorFields, Ctors0, Ctors),
- { module_info_set_ctors(Module0, Ctors, Module1) },
- { module_info_set_ctor_field_table(Module1,
- CtorFields, Module1a) },
- {
- type_constructors_should_be_no_tag(ConsList,
- Globals, Name, CtorArgType, _)
- ->
- NoTagType = no_tag_type(Args,
- Name, CtorArgType),
- module_info_no_tag_types(Module1a,
- NoTagTypes0),
- map__set(NoTagTypes0, TypeCtor, NoTagType,
- NoTagTypes),
- module_info_set_no_tag_types(Module1a,
- NoTagTypes, Module2)
- ;
- Module2 = Module1a
- }
- ;
- { Module2 = Module0 }
- ),
- { add_special_preds(Module2, TVarSet, Type, TypeCtor,
- Body, Context, Status, Module3) },
- { module_info_set_types(Module3, Types, Module) },
+ { module_info_set_types(Module0, Types, Module) },
(
% XXX we can't handle abstract exported
% polymorphic equivalence types with monomorphic
@@ -2024,20 +2035,76 @@
)
).
+:- pred check_foreign_type_visibility(import_status::in,
+ import_status::in) is semidet.
+
+check_foreign_type_visibility(OldStatus, NewStatus) :-
+ ( OldStatus = abstract_exported ->
+ status_is_exported_to_non_submodules(NewStatus, no)
+ ; OldStatus = exported ->
+ NewStatus = exported
+ ;
+ status_is_exported_to_non_submodules(OldStatus, no),
+ status_is_exported_to_non_submodules(NewStatus, no)
+ ).
+
+ % Add the constructors and special preds for a type to the HLDS.
+:- pred process_type_defn(type_ctor::in, hlds_type_defn::in, module_info::in,
+ module_info::out, io__state::di, io__state::uo) is det.
+
+process_type_defn(TypeCtor, TypeDefn, Module0, Module) -->
+ { hlds_data__get_type_defn_context(TypeDefn, Context) },
+ { hlds_data__get_type_defn_tvarset(TypeDefn, TVarSet) },
+ { hlds_data__get_type_defn_tparams(TypeDefn, Args) },
+ { hlds_data__get_type_defn_body(TypeDefn, Body) },
+ { hlds_data__get_type_defn_status(TypeDefn, Status) },
+ { hlds_data__get_type_defn_need_qualifier(TypeDefn, NeedQual) },
+ (
+ { Body = du_type(ConsList, _, _, _, _) }
+ ->
+ { module_info_ctors(Module0, Ctors0) },
+ { module_info_get_partial_qualifier_info(Module0, PQInfo) },
+ { module_info_ctor_field_table(Module0, CtorFields0) },
+ ctors_add(ConsList, TypeCtor, TVarSet, NeedQual,
+ PQInfo, Context, Status,
+ CtorFields0, CtorFields, Ctors0, Ctors),
+ { module_info_set_ctors(Module0, Ctors, Module1) },
+ { module_info_set_ctor_field_table(Module1,
+ CtorFields, Module2) },
+ globals__io_get_globals(Globals),
+ {
+ type_constructors_should_be_no_tag(ConsList,
+ Globals, Name, CtorArgType, _)
+ ->
+ NoTagType = no_tag_type(Args, Name, CtorArgType),
+ module_info_no_tag_types(Module2, NoTagTypes0),
+ map__set(NoTagTypes0, TypeCtor, NoTagType, NoTagTypes),
+ module_info_set_no_tag_types(Module2,
+ NoTagTypes, Module3)
+ ;
+ Module3 = Module2
+ }
+ ;
+ { Module3 = Module0 }
+ ),
+ { construct_type(TypeCtor, Args, Type) },
+ { add_special_preds(Module3, TVarSet, Type, TypeCtor,
+ Body, Context, Status, Module) }.
+
% check_foreign_type ensures that if we are generating code for
% a specific backend that the foreign type has a representation
% on that backend.
-:- pred check_foreign_type(sym_name::in, prog_context::in,
+:- pred check_foreign_type(sym_name::in, arity::in, prog_context::in,
module_info::in, module_info::out, io::di, io::uo) is det.
-check_foreign_type(Name, Context, Module0, Module) -->
- { TypeCtor = Name - 0 },
+check_foreign_type(Name, Arity, Context, Module0, Module) -->
+ { TypeCtor = Name - Arity },
{ module_info_types(Module0, Types) },
- { TypeStr = error_util__describe_sym_name_and_arity(Name/0) },
+ { TypeStr = error_util__describe_sym_name_and_arity(Name/Arity) },
(
{ map__search(Types, TypeCtor, Defn) },
{ hlds_data__get_type_defn_body(Defn, Body) },
- { Body = foreign_type(MaybeIL, MaybeC) }
+ { Body = foreign_type(ForeignTypeBody) }
->
{ module_info_globals(Module0, Globals) },
generating_code(GeneratingCode),
@@ -2054,44 +2121,48 @@
VerboseErrorPieces = []
},
{ globals__get_target(Globals, Target) },
- ( { Target = c },
- ( { MaybeC = yes(_) },
+ (
+ { have_foreign_type_for_backend(Target,
+ ForeignTypeBody, yes) }
+ ->
{ Module = Module0 }
- ; { MaybeC = no },
+ ;
+
+ { Target = c, LangStr = "C"
+ ; Target = il, LangStr = "IL"
+ % Foreign types aren't yet supported for Java.
+ ; Target = java, LangStr = "Mercury"
+ ; Target = asm, LangStr = "C"
+ },
{ ErrorPieces = [
- words("Error: no C pragma"),
- words("foreign_type declaration for"),
+ words("Error: no"), words(LangStr),
+ words(
+ "`pragma foreign_type' declaration for"),
fixed(TypeStr) | VerboseErrorPieces
] },
error_util__write_error_pieces(Context,
0, ErrorPieces),
{ module_info_incr_errors(Module0, Module) }
- )
- ; { Target = il },
- ( { MaybeIL = yes(_) },
- { Module = Module0 }
- ; { MaybeIL = no },
- { ErrorPieces = [
- words("Error: no IL pragma"),
- words("foreign_type declaration for"),
- fixed(TypeStr) | VerboseErrorPieces
- ] },
- error_util__write_error_pieces(Context, 0,
- ErrorPieces),
- { module_info_incr_errors(Module0, Module) }
- )
- ; { Target = java },
- { Module = Module0 }
- ; { Target = asm },
- { Module = Module0 }
)
;
{ Module = Module0 }
)
;
- { error("check_foreign_type: unable to find foreign type") }
+ % We probably chose a Mercury implementation for this type.
+ { Module = Module0 }
).
+:- pred have_foreign_type_for_backend(compilation_target::in,
+ foreign_type_body::in, bool::out) is det.
+
+have_foreign_type_for_backend(c, ForeignTypeBody,
+ ( ForeignTypeBody ^ c = yes(_) -> yes ; no )).
+have_foreign_type_for_backend(il, ForeignTypeBody,
+ ( ForeignTypeBody ^ il = yes(_) -> yes ; no )).
+have_foreign_type_for_backend(java, _, no).
+have_foreign_type_for_backend(asm, ForeignTypeBody, Result) :-
+ have_foreign_type_for_backend(c, ForeignTypeBody, Result).
+
% Do the options imply that we will generate code for a specific
% back-end?
:- pred generating_code(bool::out, io::di, io::uo) is det.
@@ -2114,16 +2185,42 @@
TypeCheckOnly, ErrorCheckOnly, OutputGradeString],
NotGeneratingCode) }.
-:- pred merge_foreign_type_bodies(hlds_type_body::in,
+:- pred merge_foreign_type_bodies(compilation_target::in, hlds_type_body::in,
hlds_type_body::in, hlds_type_body::out) is semidet.
-merge_foreign_type_bodies(foreign_type(MaybeILA, MaybeCA),
- foreign_type(MaybeILB, MaybeCB),
- foreign_type(MaybeIL, MaybeC)) :-
+ % Ignore Mercury definitions if we've got a foreign type
+ % declaration suitable for this back-end.
+merge_foreign_type_bodies(Target, foreign_type(ForeignTypeBody0),
+ Body1 @ du_type(_, _, _, _, MaybeForeignTypeBody1), Body) :-
+ ( MaybeForeignTypeBody1 = yes(ForeignTypeBody1)
+ ; MaybeForeignTypeBody1 = no,
+ ForeignTypeBody1 = foreign_type_body(no, no)
+ ),
+ merge_foreign_type_bodies_2(ForeignTypeBody0,
+ ForeignTypeBody1, ForeignTypeBody),
+ ( have_foreign_type_for_backend(Target, ForeignTypeBody, yes) ->
+ Body = foreign_type(ForeignTypeBody)
+ ;
+ Body = Body1 ^ du_type_is_foreign_type := yes(ForeignTypeBody)
+ ).
+merge_foreign_type_bodies(Target, Body0 @ du_type(_, _, _, _, _),
+ Body1 @ foreign_type(_), Body) :-
+ merge_foreign_type_bodies(Target, Body1, Body0, Body).
+merge_foreign_type_bodies(_, foreign_type(Body0), foreign_type(Body1),
+ foreign_type(Body)) :-
+ merge_foreign_type_bodies_2(Body0, Body1, Body).
+
+:- pred merge_foreign_type_bodies_2(foreign_type_body::in,
+ foreign_type_body::in, foreign_type_body::out) is semidet.
+
+merge_foreign_type_bodies_2(foreign_type_body(MaybeILA, MaybeCA),
+ foreign_type_body(MaybeILB, MaybeCB),
+ foreign_type_body(MaybeIL, MaybeC)) :-
merge_maybe(MaybeILA, MaybeILB, MaybeIL),
merge_maybe(MaybeCA, MaybeCB, MaybeC).
:- pred merge_maybe(maybe(T)::in, maybe(T)::in, maybe(T)::out) is semidet.
+merge_maybe(no, no, no).
merge_maybe(yes(T), no, yes(T)).
merge_maybe(no, yes(T), yes(T)).
@@ -2157,7 +2254,13 @@
combine_status_2(local, Status2, Status) :-
combine_status_local(Status2, Status).
combine_status_2(exported, _Status2, exported).
-combine_status_2(exported_to_submodules, _Status2, exported_to_submodules).
+combine_status_2(exported_to_submodules, Status2, Status) :-
+ combine_status_local(Status2, Status3),
+ ( Status3 = local ->
+ Status = exported_to_submodules
+ ;
+ Status = Status3
+ ).
combine_status_2(opt_imported, _Status2, opt_imported).
combine_status_2(abstract_imported, Status2, Status) :-
combine_status_abstract_imported(Status2, Status).
@@ -2179,6 +2282,8 @@
combine_status_local(imported(_), local).
combine_status_local(local, local).
+combine_status_local(exported_to_submodules,
+ exported_to_submodules).
combine_status_local(exported, exported).
combine_status_local(opt_imported, local).
combine_status_local(abstract_imported, local).
@@ -2208,7 +2313,8 @@
:- mode convert_type_defn(in, in, in, out) is det.
convert_type_defn(du_type(Body, EqualityPred), TypeCtor, Globals,
- du_type(Body, CtorTags, IsEnum, EqualityPred)) :-
+ du_type(Body, CtorTags, IsEnum, EqualityPred, IsForeign)) :-
+ IsForeign = no,
assign_constructor_tags(Body, TypeCtor, Globals, CtorTags, IsEnum).
convert_type_defn(eqv_type(Body), _, _, eqv_type(Body)).
convert_type_defn(abstract_type, _, _, abstract_type).
@@ -3220,7 +3326,7 @@
->
(
Body = du_type(Ctors, _, IsEnum,
- UserDefinedEquality),
+ UserDefinedEquality, _),
IsEnum = no,
UserDefinedEquality = no,
module_info_globals(Module0, Globals),
@@ -3295,7 +3401,7 @@
Module = Module0
;
SpecialPredId = compare,
- ( TypeBody = du_type(_, _, _, yes(_)) ->
+ ( TypeBody = du_type(_, _, _, yes(_), _) ->
% The compiler generated comparison
% procedure prints an error message,
% since comparisons of types with
@@ -3338,7 +3444,7 @@
->
pred_info_set_import_status(PredInfo0, Status, PredInfo1)
;
- TypeBody = du_type(_, _, _, yes(_)),
+ TypeBody = du_type(_, _, _, yes(_), _),
pred_info_import_status(PredInfo0, OldStatus),
OldStatus = pseudo_imported,
status_is_imported(Status, no)
@@ -3438,7 +3544,7 @@
import_status::out) is det.
add_special_pred_unify_status(TypeBody, Status0, Status) :-
- ( TypeBody = du_type(_, _, _, yes(_)) ->
+ ( TypeBody = du_type(_, _, _, yes(_), _) ->
% If the type has user-defined equality,
% then we create a real __Unify__ predicate
% for it, whose body calls the user-specified
@@ -3861,14 +3967,8 @@
pred_info_set_goal_type(PredInfo3, promise(PromiseType),
PredInfo4)
;
- HaveForeignClauses = Clauses ^ have_foreign_clauses,
- ( HaveForeignClauses = yes,
- NewGoalType = clauses_and_pragmas
- ; HaveForeignClauses = no,
- NewGoalType = clauses
- ),
- pred_info_set_goal_type(PredInfo3,
- NewGoalType, PredInfo4)
+ pred_info_update_goal_type(PredInfo3,
+ clauses, PredInfo4)
),
pred_info_set_typevarset(PredInfo4, TVarSet, PredInfo5),
pred_info_arg_types(PredInfo5, _ArgTVarSet,
@@ -4246,7 +4346,7 @@
io__write_string(" with preceding clauses.\n"),
{ Info = Info0 }
;
- { pred_info_set_goal_type(PredInfo1, pragmas, PredInfo2) },
+ { pred_info_update_goal_type(PredInfo1, pragmas, PredInfo2) },
%
% add the pragma declaration to the proc_info for this procedure
%
@@ -4415,7 +4515,9 @@
% than the ones we can generate code for.
{ not list__member(PragmaForeignLanguage, BackendForeignLangs) }
->
- { ModuleInfo = ModuleInfo1 },
+ { pred_info_update_goal_type(PredInfo0, pragmas, PredInfo) },
+ { module_info_set_pred_info(ModuleInfo1,
+ PredId, PredInfo, ModuleInfo) },
{ Info = Info0 }
;
% add the pragma declaration to the proc_info for this procedure
@@ -4438,13 +4540,8 @@
ModuleInfo2, Info0, Info),
{ pred_info_set_clauses_info(PredInfo1, Clauses,
PredInfo2) },
- { pred_info_clause_goal_type(PredInfo2) ->
- pred_info_set_goal_type(PredInfo2,
- clauses_and_pragmas, PredInfo)
- ;
- pred_info_set_goal_type(PredInfo2, pragmas,
- PredInfo)
- },
+ { pred_info_update_goal_type(PredInfo2, pragmas,
+ PredInfo) },
{ map__det_update(Preds0, PredId, PredInfo, Preds) },
{ predicate_table_set_preds(PredicateTable1, Preds,
PredicateTable) },
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.216
diff -u -u -r1.216 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m 30 May 2002 11:03:54 -0000 1.216
+++ compiler/mercury_to_mercury.m 23 Jun 2002 17:00:56 -0000
@@ -508,8 +508,8 @@
mercury_output_pragma_foreign_code(Attributes, Pred,
PredOrFunc, Vars, VarSet, PragmaCode)
;
- { Pragma = foreign_type(ForeignType, _MercuryType,
- MercuryTypeSymName) },
+ { Pragma = foreign_type(ForeignType, TVarSet,
+ MercuryTypeSymName, MercuryTypeArgs) },
io__write_string(":- pragma foreign_type("),
( { ForeignType = il(_) },
@@ -517,7 +517,9 @@
; { ForeignType = c(_) },
io__write_string("c, ")
),
- mercury_output_sym_name(MercuryTypeSymName),
+ { construct_qualified_term(MercuryTypeSymName,
+ MercuryTypeArgs, MercuryType) },
+ mercury_output_term(MercuryType, TVarSet, no),
io__write_string(", \""),
{ ForeignType = il(il(RefOrVal,
ForeignLocStr, ForeignTypeName)),
Index: compiler/ml_code_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.119
diff -u -u -r1.119 ml_code_gen.m
--- compiler/ml_code_gen.m 21 Jun 2002 13:26:39 -0000 1.119
+++ compiler/ml_code_gen.m 24 Jun 2002 06:35:07 -0000
@@ -876,7 +876,7 @@
foreign_type_required_imports(c, _) = [].
foreign_type_required_imports(il, TypeDefn) = Imports :-
hlds_data__get_type_defn_body(TypeDefn, Body),
- ( Body = foreign_type(MaybeIL, _MaybeC) ->
+ ( Body = foreign_type(foreign_type_body(MaybeIL, _MaybeC)) ->
( MaybeIL = yes(il(_, Location, _)) ->
Name = il_assembly_name(mercury_module_name_to_mlds(
unqualified(Location))),
Index: compiler/ml_type_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_type_gen.m,v
retrieving revision 1.27
diff -u -u -r1.27 ml_type_gen.m
--- compiler/ml_type_gen.m 7 May 2002 11:03:04 -0000 1.27
+++ compiler/ml_type_gen.m 24 Jun 2002 06:36:04 -0000
@@ -116,7 +116,7 @@
ml_gen_type_2(eqv_type(_EqvType), _, _, _) --> []. % XXX Fixme!
% For a description of the problems with equivalence types,
% see our BABEL'01 paper "Compiling Mercury to the .NET CLR".
-ml_gen_type_2(du_type(Ctors, TagValues, IsEnum, MaybeEqualityPred),
+ml_gen_type_2(du_type(Ctors, TagValues, IsEnum, MaybeEqualityPred, _),
ModuleInfo, TypeCtor, TypeDefn) -->
{ ml_gen_equality_members(MaybeEqualityPred, MaybeEqualityMembers) },
( { IsEnum = yes } ->
@@ -127,7 +127,7 @@
Ctors, TagValues, MaybeEqualityMembers)
).
% XXX Fixme! Same issues here as for eqv_type/1.
-ml_gen_type_2(foreign_type(_, _), _, _, _) --> [].
+ml_gen_type_2(foreign_type(_), _, _, _) --> [].
%-----------------------------------------------------------------------------%
%
Index: compiler/ml_unify_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_unify_gen.m,v
retrieving revision 1.56
diff -u -u -r1.56 ml_unify_gen.m
--- compiler/ml_unify_gen.m 20 Mar 2002 12:36:48 -0000 1.56
+++ compiler/ml_unify_gen.m 23 Jun 2002 18:43:51 -0000
@@ -1876,7 +1876,7 @@
module_info_types(ModuleInfo, TypeTable),
TypeDefn = map__lookup(TypeTable, TypeCtor),
hlds_data__get_type_defn_body(TypeDefn, TypeDefnBody),
- ( TypeDefnBody = du_type(Ctors, TagValues, _, _) ->
+ ( TypeDefnBody = du_type(Ctors, TagValues, _, _, _) ->
(
(some [Ctor] (
list__member(Ctor, Ctors),
Index: compiler/mlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds.m,v
retrieving revision 1.93
diff -u -u -r1.93 mlds.m
--- compiler/mlds.m 21 Jun 2002 13:26:41 -0000 1.93
+++ compiler/mlds.m 24 Jun 2002 06:36:28 -0000
@@ -1690,7 +1690,7 @@
module_info_types(ModuleInfo, Types),
map__search(Types, TypeCtor, TypeDefn),
hlds_data__get_type_defn_body(TypeDefn, Body),
- Body = foreign_type(MaybeIL, MaybeC)
+ Body = foreign_type(foreign_type_body(MaybeIL, MaybeC))
->
module_info_globals(ModuleInfo, Globals),
globals__get_target(Globals, Target),
Index: compiler/mode_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mode_util.m,v
retrieving revision 1.144
diff -u -u -r1.144 mode_util.m
--- compiler/mode_util.m 28 Mar 2002 03:43:21 -0000 1.144
+++ compiler/mode_util.m 23 Jun 2002 18:39:21 -0000
@@ -896,7 +896,7 @@
map__search(TypeTable, TypeCtor, TypeDefn),
hlds_data__get_type_defn_tparams(TypeDefn, TypeParams0),
hlds_data__get_type_defn_body(TypeDefn, TypeBody),
- TypeBody = du_type(Constructors, _, _, _)
+ TypeBody = du_type(Constructors, _, _, _, _)
->
term__term_list_to_var_list(TypeParams0, TypeParams),
map__from_corresponding_lists(TypeParams, TypeArgs, ArgSubst),
Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.79
diff -u -u -r1.79 module_qual.m
--- compiler/module_qual.m 8 May 2002 11:45:38 -0000 1.79
+++ compiler/module_qual.m 28 Jun 2002 08:06:03 -0000
@@ -248,20 +248,7 @@
process_module_defn(ModuleDefn, Info0, Info).
collect_mq_info_2(pred_or_func(_,_,_,_,__,_,_,_,_,_,_,_), Info, Info).
collect_mq_info_2(pred_or_func_mode(_,_,_,_,_,_,_), Info, Info).
-collect_mq_info_2(pragma(Pragma), Info0, Info) :-
- ( Pragma = foreign_type(_, Type, SymName) ->
- ( type_to_ctor_and_args(Type, _ - Arity0, _) ->
- Arity = Arity0
- ;
- Arity = 0
- ),
- mq_info_get_types(Info0, Types0),
- mq_info_get_need_qual_flag(Info0, NeedQualifier),
- id_set_insert(NeedQualifier, SymName - Arity, Types0, Types),
- mq_info_set_types(Info0, Types, Info)
- ;
- Info = Info0
- ).
+collect_mq_info_2(pragma(_), Info, Info).
collect_mq_info_2(promise(_PromiseType, Goal, _ProgVarSet, _UnivVars), Info0,
Info) :-
process_assert(Goal, SymNames, Success),
@@ -896,9 +883,7 @@
qualify_pragma(X at source_file(_), X, Info, Info) --> [].
qualify_pragma(X at foreign_decl(_, _), X, Info, Info) --> [].
qualify_pragma(X at foreign_code(_, _), X, Info, Info) --> [].
-qualify_pragma(foreign_type(ForeignType, Type0, SymName),
- foreign_type(ForeignType, Type, SymName), Info0, Info) -->
- qualify_type(Type0, Type, Info0, Info).
+qualify_pragma(X at foreign_type(_, _, _, _), X, Info, Info) --> [].
qualify_pragma(X at foreign_import_module(_, _), X, Info, Info) --> [].
qualify_pragma(
foreign_proc(Rec, SymName, PredOrFunc, PragmaVars0, Varset, Code),
Index: compiler/modules.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.236
diff -u -u -r1.236 modules.m
--- compiler/modules.m 25 Jun 2002 14:24:04 -0000 1.236
+++ compiler/modules.m 25 Jun 2002 14:36:02 -0000
@@ -1215,7 +1215,7 @@
pragma_allowed_in_interface(foreign_import_module(_, _), no).
pragma_allowed_in_interface(foreign_code(_, _), no).
pragma_allowed_in_interface(foreign_proc(_, _, _, _, _, _), no).
-pragma_allowed_in_interface(foreign_type(_, _, _), yes).
+pragma_allowed_in_interface(foreign_type(_, _, _, _), yes).
pragma_allowed_in_interface(inline(_, _), no).
pragma_allowed_in_interface(no_inline(_, _), no).
pragma_allowed_in_interface(obsolete(_, _), yes).
@@ -1455,7 +1455,8 @@
ImpUsedModules0, ImpUsedModules),
{ get_fact_table_dependencies(Items0, FactDeps) },
- { get_interface(Items0, InterfaceItems) },
+ { get_interface_and_implementation(Items0,
+ InterfaceItems, ImplItems) },
{ get_children(InterfaceItems, PublicChildren) },
{ MaybeTimestamp = yes(Timestamp) ->
MaybeTimestamps = yes(map__det_insert(map__init, ModuleName,
@@ -1469,19 +1470,23 @@
MaybeTimestamps, Module0) },
% If this module has any seperately-compiled sub-modules,
- % then we need to make everything in this module
- % exported_to_submodules. We do that by splitting
- % out the declarations and putting them in a special
- % `:- private_interface' section.
+ % then we need to make everything in the implementation
+ % of this module exported_to_submodules. We do that by
+ % splitting out the implementation declarations and putting
+ % them in a special `:- private_interface' section.
{ get_children(Items0, Children) },
{ Children = [] ->
+ Items1 = Items0,
Module1 = Module0
;
- split_clauses_and_decls(Items0, Clauses, Decls),
+ split_clauses_and_decls(ImplItems, Clauses, ImplDecls),
+ make_pseudo_decl(interface, InterfaceDecl),
make_pseudo_decl(private_interface, PrivateInterfaceDecl),
make_pseudo_decl(implementation, ImplementationDecl),
- list__append([PrivateInterfaceDecl | Decls],
- [ImplementationDecl | Clauses], Items1),
+ list__condense(
+ [[InterfaceDecl | InterfaceItems],
+ [PrivateInterfaceDecl | ImplDecls],
+ [ImplementationDecl | Clauses]], Items1),
module_imports_set_items(Module0, Items1, Module1)
},
@@ -1493,7 +1498,7 @@
% Add `builtin' and `private_builtin' to the
% list of imported modules
globals__io_get_globals(Globals),
- { add_implicit_imports(Items0, Globals,
+ { add_implicit_imports(Items1, Globals,
IntImportedModules1, IntUsedModules1,
IntImportedModules2, IntUsedModules2) },
@@ -5800,17 +5805,35 @@
:- mode get_interface(in, out) is det.
get_interface(Items0, Items) :-
- get_interface_2(Items0, no, [], RevItems),
+ AddToImpl = (func(_, ImplItems) = ImplItems),
+ get_interface_and_implementation_2(Items0, no, [], RevItems,
+ AddToImpl, unit, _),
list__reverse(RevItems, Items).
-:- pred get_interface_2(item_list, bool, item_list, item_list).
-:- mode get_interface_2(in, in, in, out) is det.
+:- pred get_interface_and_implementation(item_list, item_list, item_list).
+:- mode get_interface_and_implementation(in, out, out) is det.
-get_interface_2([], _, Items, Items).
-get_interface_2([Item - Context | Rest], InInterface0,
- Items0, Items) :-
+get_interface_and_implementation(Items0, InterfaceItems,
+ ImplementationItems) :-
+ AddToImpl = (func(ImplItem, ImplItems) = [ImplItem | ImplItems]),
+ get_interface_and_implementation_2(Items0, no, [], RevIntItems,
+ AddToImpl, [], RevImplItems),
+ list__reverse(RevIntItems, InterfaceItems),
+ list__reverse(RevImplItems, ImplementationItems).
+
+:- pred get_interface_and_implementation_2(item_list, bool,
+ item_list, item_list, func(item_and_context, T) = T, T, T).
+:- mode get_interface_and_implementation_2(in, in, in, out,
+ in, in, out) is det.
+
+get_interface_and_implementation_2([], _, IntItems, IntItems, _,
+ ImplItems, ImplItems).
+get_interface_and_implementation_2([ItemAndContext | Rest], InInterface0,
+ IntItems0, IntItems, AddImplItem, ImplItems0, ImplItems) :-
+ ItemAndContext = Item - Context,
( Item = module_defn(_, interface) ->
- Items1 = Items0,
+ IntItems1 = IntItems0,
+ ImplItems1 = ImplItems0,
InInterface1 = yes,
Continue = yes
;
@@ -5820,33 +5843,42 @@
)
->
% Items after here are not part of this module.
- Items1 = Items0,
+ IntItems1 = IntItems0,
+ ImplItems1 = ImplItems0,
InInterface1 = no,
Continue = no
;
Item = module_defn(_, implementation)
->
- Items1 = Items0,
+ IntItems1 = IntItems0,
+ ImplItems1 = ImplItems0,
InInterface1 = no,
Continue = yes
;
( InInterface0 = yes ->
( make_abstract_instance(Item, Item1) ->
- ItemToWrite = Item1
+ ItemToWrite = Item1,
+ ImplItems1 = AddImplItem(ItemAndContext,
+ ImplItems0)
;
- ItemToWrite = Item
+ ItemToWrite = Item,
+ ImplItems1 = ImplItems0
),
- Items1 = [ItemToWrite - Context | Items0]
+ IntItems1 = [ItemToWrite - Context | IntItems0]
;
- Items1 = Items0
+ IntItems1 = IntItems0,
+ ImplItems1 = AddImplItem(ItemAndContext, ImplItems0)
),
InInterface1 = InInterface0,
Continue = yes
),
( Continue = yes ->
- get_interface_2(Rest, InInterface1, Items1, Items)
+ get_interface_and_implementation_2(Rest, InInterface1,
+ IntItems1, IntItems, AddImplItem,
+ ImplItems1, ImplItems)
;
- Items = Items1
+ ImplItems = ImplItems1,
+ IntItems = IntItems1
).
% Given a module interface (well, a list of items), extract the
Index: compiler/post_typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/post_typecheck.m,v
retrieving revision 1.38
diff -u -u -r1.38 post_typecheck.m
--- compiler/post_typecheck.m 7 Apr 2002 10:22:49 -0000 1.38
+++ compiler/post_typecheck.m 23 Jun 2002 18:45:18 -0000
@@ -1567,7 +1567,7 @@
module_info_types(ModuleInfo, Types),
map__lookup(Types, TermTypeCtor, TermTypeDefn),
hlds_data__get_type_defn_body(TermTypeDefn, TermTypeBody),
- ( TermTypeBody = du_type(Ctors, _, _, _) ->
+ ( TermTypeBody = du_type(Ctors, _, _, _, _) ->
get_constructor_containing_field_2(Ctors, FieldName, ConsId,
FieldNumber)
;
Index: compiler/pragma_c_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/pragma_c_gen.m,v
retrieving revision 1.52
diff -u -u -r1.52 pragma_c_gen.m
--- compiler/pragma_c_gen.m 30 May 2002 08:00:07 -0000 1.52
+++ compiler/pragma_c_gen.m 24 Jun 2002 06:33:08 -0000
@@ -1207,7 +1207,7 @@
type_to_ctor_and_args(Type, TypeId, _SubTypes),
map__search(Types, TypeId, Defn),
hlds_data__get_type_defn_body(Defn, Body),
- Body = foreign_type(_MaybeIL, MaybeC)
+ Body = foreign_type(foreign_type_body(_MaybeIL, MaybeC))
->
( MaybeC = yes(c(Name)),
MaybeForeignType = yes(Name)
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.83
diff -u -u -r1.83 prog_data.m
--- compiler/prog_data.m 7 May 2002 11:03:11 -0000 1.83
+++ compiler/prog_data.m 23 Jun 2002 16:13:12 -0000
@@ -172,8 +172,9 @@
% PredName, Predicate or Function, Vars/Mode,
% VarNames, Foreign Code Implementation Info
- ; foreign_type(foreign_language_type, (type), sym_name)
- % ForeignType, MercuryType, MercuryTypeName
+ ; foreign_type(foreign_language_type, tvarset,
+ sym_name, list(type_param))
+ % ForeignType, TVarSet, MercuryType, MercuryTypeName
; foreign_import_module(foreign_language, module_name)
% Equivalent to
Index: compiler/prog_io.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io.m,v
retrieving revision 1.208
diff -u -u -r1.208 prog_io.m
--- compiler/prog_io.m 15 Apr 2002 05:04:13 -0000 1.208
+++ compiler/prog_io.m 23 Jun 2002 16:04:24 -0000
@@ -177,6 +177,12 @@
:- pred parse_decl(module_name, varset, term, maybe_item_and_context).
:- mode parse_decl(in, in, in, out) is det.
+ % parse_type_defn_head(ModuleName, Head, Body, HeadResult).
+ %
+ % Check the head of a type definition for errors.
+:- pred parse_type_defn_head(module_name, term, term, maybe_functor).
+:- mode parse_type_defn_head(in, in, in, out) is det.
+
%-----------------------------------------------------------------------------%
% A QualifiedTerm is one of
@@ -1769,7 +1775,7 @@
:- pred process_eqv_type(module_name, term, term, maybe1(processed_type_body)).
:- mode process_eqv_type(in, in, in, out) is det.
process_eqv_type(ModuleName, Head, Body, Result) :-
- check_for_errors(ModuleName, Head, Body, Result0),
+ parse_type_defn_head(ModuleName, Head, Body, Result0),
process_eqv_type_2(Result0, Body, Result).
:- pred process_eqv_type_2(maybe_functor, term, maybe1(processed_type_body)).
@@ -1802,7 +1808,7 @@
maybe1(processed_type_body)).
:- mode process_du_type(in, in, in, in, out) is det.
process_du_type(ModuleName, Head, Body, EqualityPred, Result) :-
- check_for_errors(ModuleName, Head, Body, Result0),
+ parse_type_defn_head(ModuleName, Head, Body, Result0),
process_du_type_2(ModuleName, Result0, Body, EqualityPred, Result).
:- pred process_du_type_2(module_name, maybe_functor, term,
@@ -1902,7 +1908,7 @@
:- mode process_abstract_type(in, in, out) is det.
process_abstract_type(ModuleName, Head, Result) :-
dummy_term(Body),
- check_for_errors(ModuleName, Head, Body, Result0),
+ parse_type_defn_head(ModuleName, Head, Body, Result0),
process_abstract_type_2(Result0, Result).
:- pred process_abstract_type_2(maybe_functor, maybe1(processed_type_body)).
@@ -1914,11 +1920,7 @@
%-----------------------------------------------------------------------------%
- % check a type definition for errors
-
-:- pred check_for_errors(module_name, term, term, maybe_functor).
-:- mode check_for_errors(in, in, in, out) is det.
-check_for_errors(ModuleName, Head, Body, Result) :-
+parse_type_defn_head(ModuleName, Head, Body, Result) :-
( Head = term__variable(_) ->
%
% `Head' has no term__context, so we need to get the
@@ -1933,18 +1935,18 @@
;
parse_implicitly_qualified_term(ModuleName,
Head, Head, "type definition", R),
- check_for_errors_2(R, Body, Head, Result)
+ parse_type_defn_head_2(R, Body, Head, Result)
).
-:- pred check_for_errors_2(maybe_functor, term, term, maybe_functor).
-:- mode check_for_errors_2(in, in, in, out) is det.
-check_for_errors_2(error(Msg, Term), _, _, error(Msg, Term)).
-check_for_errors_2(ok(Name, Args), Body, Head, Result) :-
- check_for_errors_3(Name, Args, Body, Head, Result).
-
-:- pred check_for_errors_3(sym_name, list(term), term, term, maybe_functor).
-:- mode check_for_errors_3(in, in, in, in, out) is det.
-check_for_errors_3(Name, Args, _Body, Head, Result) :-
+:- pred parse_type_defn_head_2(maybe_functor, term, term, maybe_functor).
+:- mode parse_type_defn_head_2(in, in, in, out) is det.
+parse_type_defn_head_2(error(Msg, Term), _, _, error(Msg, Term)).
+parse_type_defn_head_2(ok(Name, Args), Body, Head, Result) :-
+ parse_type_defn_head_3(Name, Args, Body, Head, Result).
+
+:- pred parse_type_defn_head_3(sym_name, list(term), term, term, maybe_functor).
+:- mode parse_type_defn_head_3(in, in, in, in, out) is det.
+parse_type_defn_head_3(Name, Args, _Body, Head, Result) :-
% check that all the head args are variables
( %%% some [Arg]
(
@@ -1961,7 +1963,8 @@
list__member(Arg2, OtherArgs)
)
->
- Result = error("repeated type parameters in LHS of type defn", Head)
+ Result = error("repeated type parameters in LHS of type defn",
+ Head)
;
Result = ok(Name, Args)
).
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.50
diff -u -u -r1.50 prog_io_pragma.m
--- compiler/prog_io_pragma.m 7 May 2002 11:03:12 -0000 1.50
+++ compiler/prog_io_pragma.m 23 Jun 2002 16:13:14 -0000
@@ -72,27 +72,23 @@
).
parse_pragma_type(ModuleName, "foreign_type", PragmaTerms,
- ErrorTerm, _VarSet, Result) :-
- ( PragmaTerms = [LangTerm, MercuryName, ForeignTypeTerm] ->
+ ErrorTerm, VarSet, Result) :-
+ ( PragmaTerms = [LangTerm, MercuryTypeTerm, ForeignTypeTerm] ->
( parse_foreign_language(LangTerm, Language) ->
parse_foreign_language_type(ForeignTypeTerm, Language,
MaybeForeignType),
(
MaybeForeignType = ok(ForeignType),
- parse_implicitly_qualified_term(ModuleName, MercuryName,
- ErrorTerm, "`:- pragma foreign_type' declaration",
- MaybeMercuryType),
+ parse_type_defn_head(ModuleName, MercuryTypeTerm,
+ ErrorTerm, MaybeTypeDefnHead),
(
- MaybeMercuryType = ok(MercuryTypeSymName, MercuryArgs),
- ( MercuryArgs = [] ->
- term__coerce(MercuryName, MercuryType),
- Result = ok(pragma(foreign_type(ForeignType,
- MercuryType, MercuryTypeSymName)))
- ;
- Result = error("foreign type arity not 0", ErrorTerm)
- )
+ MaybeTypeDefnHead = ok(MercuryTypeSymName, MercuryArgs0),
+ varset__coerce(VarSet, TVarSet),
+ MercuryArgs = list__map(term__coerce, MercuryArgs0),
+ Result = ok(pragma(foreign_type(ForeignType,
+ TVarSet, MercuryTypeSymName, MercuryArgs)))
;
- MaybeMercuryType = error(String, Term),
+ MaybeTypeDefnHead = error(String, Term),
Result = error(String, Term)
)
;
Index: compiler/recompilation.usage.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/recompilation.usage.m,v
retrieving revision 1.2
diff -u -u -r1.2 recompilation.usage.m
--- compiler/recompilation.usage.m 7 May 2002 11:03:13 -0000 1.2
+++ compiler/recompilation.usage.m 24 Jun 2002 06:38:10 -0000
@@ -1030,7 +1030,8 @@
:- pred recompilation__usage__find_items_used_by_type_body(hlds_type_body::in,
recompilation_usage_info::in, recompilation_usage_info::out) is det.
-recompilation__usage__find_items_used_by_type_body(du_type(Ctors, _, _, _)) -->
+recompilation__usage__find_items_used_by_type_body(
+ du_type(Ctors, _, _, _, _)) -->
list__foldl(
(pred(Ctor::in, in, out) is det -->
{ Ctor = ctor(_, Constraints, _, CtorArgs) },
@@ -1045,7 +1046,7 @@
recompilation__usage__find_items_used_by_type_body(eqv_type(Type)) -->
recompilation__usage__find_items_used_by_type(Type).
recompilation__usage__find_items_used_by_type_body(abstract_type) --> [].
-recompilation__usage__find_items_used_by_type_body(foreign_type(_, _)) --> [].
+recompilation__usage__find_items_used_by_type_body(foreign_type(_)) --> [].
:- pred recompilation__usage__find_items_used_by_mode_defn(hlds_mode_defn::in,
recompilation_usage_info::in, recompilation_usage_info::out) is det.
Index: compiler/recompilation.version.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/recompilation.version.m,v
retrieving revision 1.1
diff -u -u -r1.1 recompilation.version.m
--- compiler/recompilation.version.m 20 Mar 2002 12:37:17 -0000 1.1
+++ compiler/recompilation.version.m 23 Jun 2002 17:35:57 -0000
@@ -538,7 +538,7 @@
is_pred_pragma(foreign_proc(_, Name, PredOrFunc, Args, _, _),
yes(yes(PredOrFunc) - Name / Arity)) :-
adjust_func_arity(PredOrFunc, Arity, list__length(Args)).
-is_pred_pragma(foreign_type(_, _, _), no).
+is_pred_pragma(foreign_type(_, _, _, _), no).
is_pred_pragma(type_spec(Name, _, Arity, MaybePredOrFunc, _, _, _, _),
yes(MaybePredOrFunc - Name / Arity)).
is_pred_pragma(inline(Name, Arity), yes(no - Name / Arity)).
Index: compiler/rl_key.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/rl_key.m,v
retrieving revision 1.11
diff -u -u -r1.11 rl_key.m
--- compiler/rl_key.m 28 Mar 2002 03:43:36 -0000 1.11
+++ compiler/rl_key.m 23 Jun 2002 18:44:49 -0000
@@ -132,8 +132,7 @@
type_to_ctor_and_args(Type, TypeCtor, _),
map__search(Types, TypeCtor, TypeDefn),
hlds_data__get_type_defn_body(TypeDefn, Body),
- Body = du_type(Ctors, _, _, _),
- Ctors = [_]
+ Body ^ du_type_ctors = []
->
Bound = var - Vars
;
@@ -1028,9 +1027,9 @@
map__search(Types, TypeCtor, TypeDefn),
hlds_data__get_type_defn_body(TypeDefn, Body),
% If there's a user defined equality pred we're in trouble.
- Body = du_type(Ctors, _, _, no),
- rl_key__choose_cons_id_2(Ctors, UpperLower, ConsId1,
- ConsId2, ConsId)
+ Body ^ du_type_usereq = no,
+ rl_key__choose_cons_id_2(Body ^ du_type_ctors,
+ UpperLower, ConsId1, ConsId2, ConsId)
;
% int_consts etc. can be directly compared.
compare(CompareRes, ConsId1, ConsId2),
Index: compiler/special_pred.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/special_pred.m,v
retrieving revision 1.32
diff -u -u -r1.32 special_pred.m
--- compiler/special_pred.m 7 May 2002 11:03:13 -0000 1.32
+++ compiler/special_pred.m 24 Jun 2002 06:30:13 -0000
@@ -202,7 +202,7 @@
% polymorphism__process_generated_pred can't handle calls to
% polymorphic procedures after the initial polymorphism pass.
%
- Body \= foreign_type(_, _),
+ Body \= foreign_type(_),
% The special predicates for types with user-defined
% equality or existentially typed constructors are always
@@ -210,7 +210,7 @@
\+ special_pred_for_type_needs_typecheck(Body).
special_pred_for_type_needs_typecheck(Body) :-
- Body = du_type(Ctors, _, _, MaybeEqualityPred),
+ Body = du_type(Ctors, _, _, MaybeEqualityPred, _),
(
MaybeEqualityPred = yes(_)
;
Index: compiler/stack_opt.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/stack_opt.m,v
retrieving revision 1.2
diff -u -u -r1.2 stack_opt.m
--- compiler/stack_opt.m 28 Mar 2002 11:49:13 -0000 1.2
+++ compiler/stack_opt.m 23 Jun 2002 19:28:41 -0000
@@ -1077,7 +1077,7 @@
{ module_info_types(ModuleInfo, TypeTable) },
{ map__lookup(TypeTable, TypeCtor, TypeDefn) },
{ hlds_data__get_type_defn_body(TypeDefn, TypeBody) },
- { TypeBody = du_type(_, ConsTable, _, _) }
+ { TypeBody = du_type(_, ConsTable, _, _, _) }
->
{ map__lookup(ConsTable, ConsId, ConsTag) },
{ ConsTag = no_tag ->
Index: compiler/switch_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/switch_util.m,v
retrieving revision 1.8
diff -u -u -r1.8 switch_util.m
--- compiler/switch_util.m 20 Mar 2002 12:37:25 -0000 1.8
+++ compiler/switch_util.m 23 Jun 2002 18:37:11 -0000
@@ -317,7 +317,7 @@
module_info_types(ModuleInfo, TypeTable),
map__lookup(TypeTable, TypeCtor, TypeDefn),
hlds_data__get_type_defn_body(TypeDefn, TypeBody),
- ( TypeBody = du_type(_, ConsTable, _, _) ->
+ ( TypeBody = du_type(_, ConsTable, _, _, _) ->
map__count(ConsTable, TypeRange),
MaxEnum = TypeRange - 1
;
@@ -338,7 +338,7 @@
module_info_types(ModuleInfo, TypeTable),
map__lookup(TypeTable, TypeCtor, TypeDefn),
hlds_data__get_type_defn_body(TypeDefn, Body),
- ( Body = du_type(_, ConsTable, _, _) ->
+ ( Body = du_type(_, ConsTable, _, _, _) ->
map__to_assoc_list(ConsTable, ConsList),
switch_util__cons_list_to_tag_list(ConsList, TagList)
;
Index: compiler/table_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/table_gen.m,v
retrieving revision 1.34
diff -u -u -r1.34 table_gen.m
--- compiler/table_gen.m 28 Mar 2002 03:43:39 -0000 1.34
+++ compiler/table_gen.m 23 Jun 2002 19:36:57 -0000
@@ -1132,7 +1132,7 @@
map__lookup(TypeDefnTable, TypeCtor, TypeDefn),
hlds_data__get_type_defn_body(TypeDefn, TypeBody),
(
- TypeBody = du_type(Ctors, _, yes, no)
+ TypeBody = du_type(Ctors, _, yes, no, _)
->
list__length(Ctors, EnumRange)
;
Index: compiler/term_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/term_util.m,v
retrieving revision 1.20
diff -u -u -r1.20 term_util.m
--- compiler/term_util.m 7 May 2002 11:03:13 -0000 1.20
+++ compiler/term_util.m 24 Jun 2002 06:40:12 -0000
@@ -255,7 +255,7 @@
find_weights_for_type(TypeCtor, TypeDefn, Weights0, Weights) :-
hlds_data__get_type_defn_body(TypeDefn, TypeBody),
(
- TypeBody = du_type(Constructors, _, _, _),
+ TypeBody = du_type(Constructors, _, _, _, _),
hlds_data__get_type_defn_tparams(TypeDefn, TypeParams),
find_weights_for_cons_list(Constructors, TypeCtor, TypeParams,
Weights0, Weights)
@@ -270,7 +270,7 @@
Weights = Weights0
;
% This type does not introduce any functors
- TypeBody = foreign_type(_, _),
+ TypeBody = foreign_type(_),
Weights = Weights0
).
Index: compiler/type_ctor_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_ctor_info.m,v
retrieving revision 1.28
diff -u -u -r1.28 type_ctor_info.m
--- compiler/type_ctor_info.m 16 May 2002 09:21:37 -0000 1.28
+++ compiler/type_ctor_info.m 24 Jun 2002 06:24:47 -0000
@@ -121,7 +121,7 @@
;
SpecialPreds = no,
hlds_data__get_type_defn_body(TypeDefn, Body),
- Body = du_type(_, _, _, yes(_UserDefinedEquality))
+ Body = du_type(_, _, _, yes(_UserDefinedEquality), _)
)
->
map__lookup(SpecMap, unify - TypeCtor, UnifyPredId),
@@ -256,7 +256,7 @@
;
% We treat foreign_types as equivalent to the
% type builtin__c_pointer.
- TypeBody = foreign_type(_, _),
+ TypeBody = foreign_type(_),
gen_layout_info_eqv_type(c_pointer_type, TypeArity,
TypeCtorRep, NumFunctors, FunctorsInfo,
LayoutInfo, NumPtags, TypeTables)
@@ -279,7 +279,7 @@
LayoutInfo = equiv_layout(PseudoTypeInfoRttiData),
NumPtags = -1
;
- TypeBody = du_type(Ctors, ConsTagMap, Enum, EqualityPred),
+ TypeBody = du_type(Ctors, ConsTagMap, Enum, EqualityPred, _),
(
EqualityPred = yes(_),
EqualityAxioms = user_defined
Index: compiler/type_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.107
diff -u -u -r1.107 type_util.m
--- compiler/type_util.m 20 Mar 2002 12:37:30 -0000 1.107
+++ compiler/type_util.m 23 Jun 2002 18:44:16 -0000
@@ -645,7 +645,7 @@
type_to_ctor_and_args(Type, TypeCtor, _TypeArgs),
map__search(TypeTable, TypeCtor, TypeDefn),
hlds_data__get_type_defn_body(TypeDefn, TypeBody),
- TypeBody = du_type(_, _, _, yes(SymName)).
+ TypeBody ^ du_type_usereq = yes(SymName).
% Certain types, e.g. io__state and store__store(S),
% are just dummy types used to ensure logical semantics;
@@ -700,8 +700,7 @@
module_info_types(ModuleInfo, TypeDefnTable),
map__search(TypeDefnTable, TypeCtor, TypeDefn),
hlds_data__get_type_defn_body(TypeDefn, TypeBody),
- TypeBody = du_type(_, _, IsEnum, _),
- IsEnum = yes.
+ TypeBody ^ du_type_is_enum = yes.
type_to_ctor_and_args(Type, SymName - Arity, Args) :-
Type \= term__variable(_),
@@ -851,9 +850,8 @@
map__search(TypeTable, TypeCtor, TypeDefn),
hlds_data__get_type_defn_tparams(TypeDefn, TypeParams),
hlds_data__get_type_defn_body(TypeDefn, TypeBody),
- TypeBody = du_type(Constructors0, _, _, _),
- substitute_type_args(TypeParams, TypeArgs, Constructors0,
- Constructors)
+ substitute_type_args(TypeParams, TypeArgs,
+ TypeBody ^ du_type_ctors, Constructors)
).
%-----------------------------------------------------------------------------%
@@ -873,8 +871,7 @@
module_info_types(ModuleInfo, TypeTable),
map__search(TypeTable, TypeCtor, TypeDefn),
hlds_data__get_type_defn_body(TypeDefn, TypeBody),
- TypeBody = du_type(_, ConsTable, _, _),
- map__count(ConsTable, NumFunctors)
+ map__count(TypeBody ^ du_type_cons_tag_values, NumFunctors)
).
%-----------------------------------------------------------------------------%
@@ -948,8 +945,7 @@
module_info_types(ModuleInfo, Types),
map__search(Types, TypeCtor, TypeDefn),
hlds_data__get_type_defn_body(TypeDefn, TypeDefnBody),
- TypeDefnBody = du_type(_, ConsTags, _, _),
- map__member(ConsTags, ConsId, _),
+ map__member(TypeDefnBody ^ du_type_cons_tag_values, ConsId, _),
module_info_ctors(ModuleInfo, Ctors),
map__lookup(Ctors, ConsId, ConsDefns),
Index: compiler/typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/typecheck.m,v
retrieving revision 1.319
diff -u -u -r1.319 typecheck.m
--- compiler/typecheck.m 21 Jun 2002 16:47:25 -0000 1.319
+++ compiler/typecheck.m 27 Jun 2002 15:48:09 -0000
@@ -261,16 +261,16 @@
{ pred_info_is_imported(PredInfo0) }
->
{ Error2 = Error0 },
- { ModuleInfo2 = ModuleInfo0 },
+ { ModuleInfo3 = ModuleInfo0 },
{ Changed2 = Changed0 }
;
- typecheck_pred_type(Iteration, PredId, PredInfo0, ModuleInfo0,
- PredInfo1, Error1, Changed1),
+ typecheck_pred_type(Iteration, PredId, PredInfo0, PredInfo1,
+ ModuleInfo0, ModuleInfo1, Error1, Changed1),
(
{ Error1 = no },
{ map__det_update(Preds0, PredId, PredInfo1, Preds) },
- { module_info_set_preds(ModuleInfo0, Preds,
- ModuleInfo2) }
+ { module_info_set_preds(ModuleInfo1, Preds,
+ ModuleInfo3) }
;
{ Error1 = yes },
/********************
@@ -296,23 +296,23 @@
{ map__det_update(Preds0, PredId, PredInfo, Preds) },
*******************/
{ map__det_update(Preds0, PredId, PredInfo1, Preds) },
- { module_info_set_preds(ModuleInfo0, Preds,
- ModuleInfo1) },
- { module_info_remove_predid(ModuleInfo1, PredId,
- ModuleInfo2) }
+ { module_info_set_preds(ModuleInfo1, Preds,
+ ModuleInfo2) },
+ { module_info_remove_predid(ModuleInfo2, PredId,
+ ModuleInfo3) }
),
{ bool__or(Error0, Error1, Error2) },
{ bool__or(Changed0, Changed1, Changed2) }
),
- typecheck_pred_types_2(Iteration, PredIds, ModuleInfo2, ModuleInfo,
+ typecheck_pred_types_2(Iteration, PredIds, ModuleInfo3, ModuleInfo,
Error2, Error, Changed2, Changed).
-:- pred typecheck_pred_type(int, pred_id, pred_info, module_info,
- pred_info, bool, bool, io__state, io__state).
-:- mode typecheck_pred_type(in, in, in, in, out, out, out, di, uo) is det.
+:- pred typecheck_pred_type(int, pred_id, pred_info, pred_info,
+ module_info, module_info, bool, bool, io__state, io__state).
+:- mode typecheck_pred_type(in, in, in, out, in, out, out, out, di, uo) is det.
-typecheck_pred_type(Iteration, PredId, PredInfo0, ModuleInfo, PredInfo,
- Error, Changed, IOState0, IOState) :-
+typecheck_pred_type(Iteration, PredId, PredInfo0, PredInfo,
+ ModuleInfo0, ModuleInfo, Error, Changed, IOState0, IOState) :-
(
% Compiler-generated predicates are created already type-correct,
% there's no need to typecheck them. Same for builtins.
@@ -320,7 +320,7 @@
% to be type-correct if they call a user-defined equality pred
% or if it is a special pred for an existentially typed data type.
( code_util__compiler_generated(PredInfo0),
- \+ special_pred_needs_typecheck(PredInfo0, ModuleInfo)
+ \+ special_pred_needs_typecheck(PredInfo0, ModuleInfo0)
; code_util__predinfo_is_builtin(PredInfo0)
)
->
@@ -333,15 +333,22 @@
),
Error = no,
Changed = no,
+ ModuleInfo = ModuleInfo0,
IOState = IOState0
;
globals__io_get_globals(Globals, IOState0, IOState1),
( Iteration = 1 ->
- maybe_add_field_access_function_clause(ModuleInfo,
+ maybe_add_field_access_function_clause(ModuleInfo0,
PredInfo0, PredInfo0a),
- maybe_improve_headvar_names(Globals, PredInfo0a, PredInfo1)
+ maybe_improve_headvar_names(Globals, PredInfo0a, PredInfo1),
+
+ % The goal_type of the pred_info may have been changed
+ % by maybe_add_field_access_function_clause.
+ module_info_set_pred_info(ModuleInfo0, PredId, PredInfo1,
+ ModuleInfo)
;
- PredInfo1 = PredInfo0
+ PredInfo1 = PredInfo0,
+ ModuleInfo = ModuleInfo0
),
pred_info_arg_types(PredInfo1, _ArgTypeVarSet, ExistQVars0,
ArgTypes0),
@@ -830,7 +837,8 @@
ProcIds = [], % the clause applies to all procedures.
Clause = clause(ProcIds, Goal, mercury, Context),
clauses_info_set_clauses(ClausesInfo0, [Clause], ClausesInfo),
- pred_info_set_clauses_info(PredInfo0, ClausesInfo, PredInfo)
+ pred_info_update_goal_type(PredInfo0, clauses, PredInfo1),
+ pred_info_set_clauses_info(PredInfo1, ClausesInfo, PredInfo)
;
PredInfo = PredInfo0
).
@@ -3096,12 +3104,12 @@
% Succeed if Functor is the name of one the automatically
% generated field access functions (fieldname, '<fieldname> :=').
:- pred builtin_field_access_function_type(typecheck_info, cons_id, arity,
- list(cons_type_info), list(invalid_field_update)).
+ list(maybe_cons_type_info)).
:- mode builtin_field_access_function_type(typecheck_info_ui, in, in,
- out, out) is semidet.
+ out) is semidet.
builtin_field_access_function_type(TypeCheckInfo, Functor, Arity,
- ConsTypeInfos, InvalidFieldUpdates) :-
+ MaybeConsTypeInfos) :-
%
% Taking the address of automatically generated field access
% functions is not allowed, so currying does have to be
@@ -3118,17 +3126,7 @@
list__filter_map(
make_field_access_function_cons_type_info(TypeCheckInfo, Name,
Arity, AccessType, FieldName),
- FieldDefns, MaybeConsTypeInfos),
-
- list__filter_map(
- (pred(MaybeConsTypeInfo::in, ConsTypeInfo::out) is semidet :-
- MaybeConsTypeInfo = cons_type_info(ConsTypeInfo)
- ), MaybeConsTypeInfos, ConsTypeInfos),
-
- list__filter_map(
- (pred(MaybeConsTypeInfo::in, InvalidCons::out) is semidet :-
- MaybeConsTypeInfo = invalid_field_update(InvalidCons)
- ), MaybeConsTypeInfos, InvalidFieldUpdates).
+ FieldDefns, MaybeConsTypeInfos).
:- pred make_field_access_function_cons_type_info(typecheck_info,
sym_name, arity, field_access_type,
@@ -3139,12 +3137,19 @@
make_field_access_function_cons_type_info(TypeCheckInfo, FuncName, Arity,
AccessType, FieldName, FieldDefn, ConsTypeInfo) :-
get_field_access_constructor(TypeCheckInfo, FuncName, Arity,
- AccessType, FieldDefn, FunctorConsTypeInfo),
- convert_field_access_cons_type_info(AccessType, FieldName, FieldDefn,
- FunctorConsTypeInfo, ConsTypeInfo).
+ AccessType, FieldDefn, MaybeFunctorConsTypeInfo),
+ (
+ MaybeFunctorConsTypeInfo = ok(FunctorConsTypeInfo),
+ convert_field_access_cons_type_info(AccessType,
+ FieldName, FieldDefn, FunctorConsTypeInfo,
+ ConsTypeInfo)
+ ;
+ MaybeFunctorConsTypeInfo = error(_),
+ ConsTypeInfo = MaybeFunctorConsTypeInfo
+ ).
:- pred get_field_access_constructor(typecheck_info, sym_name, arity,
- field_access_type, hlds_ctor_field_defn, cons_type_info).
+ field_access_type, hlds_ctor_field_defn, maybe_cons_type_info).
:- mode get_field_access_constructor(typecheck_info_ui,
in, in, in, in, out) is semidet.
@@ -3181,12 +3186,13 @@
convert_cons_defn(TypeCheckInfo, ConsDefn, FunctorConsTypeInfo).
:- type maybe_cons_type_info
- ---> cons_type_info(cons_type_info)
- ; invalid_field_update(invalid_field_update)
+ ---> ok(cons_type_info)
+ ; error(cons_error)
.
-:- type invalid_field_update
- ---> invalid_field_update(ctor_field_name, hlds_ctor_field_defn,
+:- type cons_error
+ ---> foreign_type_constructor(type_ctor, hlds_type_defn)
+ ; invalid_field_update(ctor_field_name, hlds_ctor_field_defn,
tvarset, list(tvar)).
:- pred convert_field_access_cons_type_info(field_access_type,
@@ -3208,7 +3214,7 @@
TVarSet = TVarSet0,
ExistQVars = ExistQVars0,
ClassConstraints = ClassConstraints0,
- ConsTypeInfo = cons_type_info(cons_type_info(TVarSet, ExistQVars,
+ ConsTypeInfo = ok(cons_type_info(TVarSet, ExistQVars,
RetType, ArgTypes, ClassConstraints))
;
AccessType = set,
@@ -3250,8 +3256,7 @@
%
ClassConstraints0 = constraints(UnivConstraints, _),
ClassConstraints = constraints(UnivConstraints, []),
- ConsTypeInfo = cons_type_info(
- cons_type_info(TVarSet, ExistQVars,
+ ConsTypeInfo = ok(cons_type_info(TVarSet, ExistQVars,
RetType, ArgTypes, ClassConstraints))
;
%
@@ -3320,8 +3325,7 @@
RetType = OutputFunctorType,
ArgTypes = [FunctorType, RenamedFieldType],
- ConsTypeInfo = cons_type_info(
- cons_type_info(TVarSet, ExistQVars,
+ ConsTypeInfo = ok(cons_type_info(TVarSet, ExistQVars,
RetType, ArgTypes, ClassConstraints))
;
%
@@ -3334,9 +3338,9 @@
set__to_sorted_list(ExistQVarsInFieldAndOthers,
ExistQVarsInFieldAndOthers1),
ConsTypeInfo =
- invalid_field_update(
- invalid_field_update(FieldName, FieldDefn,
- TVarSet0, ExistQVarsInFieldAndOthers1))
+ error(invalid_field_update(FieldName,
+ FieldDefn, TVarSet0,
+ ExistQVarsInFieldAndOthers1))
)
)
).
@@ -3937,12 +3941,12 @@
% recompilation__usage__find_matching_constructors
% and recompilation__check__check_functor_ambiguities.
:- pred typecheck_info_get_ctor_list(typecheck_info, cons_id, int,
- list(cons_type_info), list(invalid_field_update)).
+ list(cons_type_info), list(cons_error)).
:- mode typecheck_info_get_ctor_list(typecheck_info_ui,
in, in, out, out) is det.
typecheck_info_get_ctor_list(TypeCheckInfo, Functor, Arity,
- ConsInfoList, InvalidFieldUpdates) :-
+ ConsInfoList, ConsErrors) :-
(
%
% If we're typechecking the clause added for
@@ -3958,27 +3962,26 @@
->
(
builtin_field_access_function_type(TypeCheckInfo,
- Functor, Arity, FieldAccessConsInfoList,
- InvalidFieldUpdates0)
+ Functor, Arity, FieldAccessConsInfoList)
->
- ConsInfoList = FieldAccessConsInfoList,
- InvalidFieldUpdates = InvalidFieldUpdates0
+ split_cons_errors(FieldAccessConsInfoList,
+ ConsInfoList, ConsErrors)
;
ConsInfoList = [],
- InvalidFieldUpdates = []
+ ConsErrors = []
)
;
typecheck_info_get_ctor_list_2(TypeCheckInfo, Functor, Arity,
- ConsInfoList, InvalidFieldUpdates)
+ ConsInfoList, ConsErrors)
).
:- pred typecheck_info_get_ctor_list_2(typecheck_info, cons_id,
- int, list(cons_type_info), list(invalid_field_update)).
+ int, list(cons_type_info), list(cons_error)).
:- mode typecheck_info_get_ctor_list_2(typecheck_info_ui,
in, in, out, out) is det.
typecheck_info_get_ctor_list_2(TypeCheckInfo, Functor, Arity,
- ConsInfoList, InvalidFieldUpdates) :-
+ ConsInfoList, ConsErrors) :-
% Check if `Functor/Arity' has been defined as a constructor
% in some discriminated union type(s). This gives
% us a list of possible cons_type_infos.
@@ -3988,9 +3991,9 @@
map__search(Ctors, Functor, HLDS_ConsDefnList)
->
convert_cons_defn_list(TypeCheckInfo, HLDS_ConsDefnList,
- ConsInfoList0)
+ MaybeConsInfoList0)
;
- ConsInfoList0 = []
+ MaybeConsInfoList0 = []
),
% For "existentially typed" functors, whether the functor
@@ -4022,11 +4025,27 @@
list__filter_map(flip_quantifiers, ExistQuantifiedConsInfoList,
UnivQuantifiedConsInfoList),
list__append(UnivQuantifiedConsInfoList,
- ConsInfoList0, ConsInfoList1)
+ MaybeConsInfoList0, MaybeConsInfoList1)
+ ;
+ MaybeConsInfoList1 = MaybeConsInfoList0
+ ),
+
+ %
+ % Check if Functor is a field access function for which the
+ % user has not supplied a declaration.
+ %
+ (
+ builtin_field_access_function_type(TypeCheckInfo,
+ Functor, Arity, FieldAccessConsInfoList)
+ ->
+ MaybeConsInfoList = FieldAccessConsInfoList ++
+ MaybeConsInfoList1
;
- ConsInfoList1 = ConsInfoList0
+ MaybeConsInfoList = MaybeConsInfoList1
),
+ split_cons_errors(MaybeConsInfoList, ConsInfoList1, ConsErrors),
+
% Check if Functor is a constant of one of the builtin atomic
% types (string, float, int, character). If so, insert
% the resulting cons_type_info at the start of the list.
@@ -4082,23 +4101,6 @@
;
ConsInfoList4 = ConsInfoList3
),
-
- %
- % Check if Functor is a field access function for which the
- % user has not supplied a declaration.
- %
- (
- builtin_field_access_function_type(TypeCheckInfo,
- Functor, Arity, FieldAccessConsInfoList,
- InvalidFieldUpdates0)
- ->
- list__append(FieldAccessConsInfoList,
- ConsInfoList4, ConsInfoList5),
- InvalidFieldUpdates = InvalidFieldUpdates0
- ;
- InvalidFieldUpdates = [],
- ConsInfoList5 = ConsInfoList4
- ),
%
% Check for higher-order function calls
@@ -4107,16 +4109,17 @@
builtin_apply_type(TypeCheckInfo, Functor, Arity,
ApplyConsInfoList)
->
- ConsInfoList = list__append(ConsInfoList5, ApplyConsInfoList)
+ ConsInfoList = list__append(ConsInfoList4, ApplyConsInfoList)
;
- ConsInfoList = ConsInfoList5
+ ConsInfoList = ConsInfoList4
).
-:- pred flip_quantifiers(cons_type_info, cons_type_info).
+:- pred flip_quantifiers(maybe_cons_type_info, maybe_cons_type_info).
:- mode flip_quantifiers(in, out) is semidet.
-flip_quantifiers(cons_type_info(A, ExistQVars0, C, D, Constraints0),
- cons_type_info(A, ExistQVars, C, D, Constraints)) :-
+flip_quantifiers(Error @ error(_), Error).
+flip_quantifiers(ok(cons_type_info(A, ExistQVars0, C, D, Constraints0)),
+ ok(cons_type_info(A, ExistQVars, C, D, Constraints))) :-
% Fail if there are no existentially quantifier variables.
% We do this because we want to allow the 'new foo' syntax only
% for existentially typed functors, not for ordinary functors.
@@ -4132,6 +4135,28 @@
% convert the existential constraints into universal constraints
dual_constraints(Constraints0, Constraints).
+:- pred split_cons_errors(list(maybe_cons_type_info)::in,
+ list(cons_type_info)::out, list(cons_error)::out) is det.
+
+split_cons_errors(MaybeConsInfoList, ConsInfoList1, ConsErrors) :-
+ %
+ % Filter out the errors (they aren't actually reported as
+ % errors unless there was no other matching constructor).
+ %
+ list__filter_map(
+ (pred(ok(ConsInfo)::in, ConsInfo::out) is semidet),
+ MaybeConsInfoList, ConsInfoList1, ConsErrors0),
+ (
+ list__map(
+ (pred(error(ConsError)::in,
+ ConsError::out) is semidet),
+ ConsErrors0, ConsErrors1)
+ ->
+ ConsErrors = ConsErrors1
+ ;
+ error("typecheck_info_get_ctor_list")
+ ).
+
%-----------------------------------------------------------------------------%
:- pred report_unsatisfiable_constraints(type_assign_set, typecheck_info,
@@ -4635,15 +4660,16 @@
%-----------------------------------------------------------------------------%
:- pred convert_cons_defn_list(typecheck_info, list(hlds_cons_defn),
- list(cons_type_info)).
+ list(maybe_cons_type_info)).
:- mode convert_cons_defn_list(typecheck_info_ui, in, out) is det.
convert_cons_defn_list(_TypeCheckInfo, [], []).
-convert_cons_defn_list(TypeCheckInfo, [X|Xs], [Y|Ys]) :-
+convert_cons_defn_list(TypeCheckInfo, [X|Xs], [Y | Ys]) :-
convert_cons_defn(TypeCheckInfo, X, Y),
convert_cons_defn_list(TypeCheckInfo, Xs, Ys).
-:- pred convert_cons_defn(typecheck_info, hlds_cons_defn, cons_type_info).
+:- pred convert_cons_defn(typecheck_info, hlds_cons_defn,
+ maybe_cons_type_info).
:- mode convert_cons_defn(typecheck_info_ui, in, out) is det.
convert_cons_defn(TypeCheckInfo, HLDS_ConsDefn, ConsTypeInfo) :-
@@ -4654,11 +4680,42 @@
map__lookup(Types, TypeCtor, TypeDefn),
hlds_data__get_type_defn_tvarset(TypeDefn, ConsTypeVarSet),
hlds_data__get_type_defn_tparams(TypeDefn, ConsTypeParams),
- construct_type(TypeCtor, ConsTypeParams, ConsType),
- UnivConstraints = [],
- Constraints = constraints(UnivConstraints, ExistConstraints),
- ConsTypeInfo = cons_type_info(ConsTypeVarSet, ExistQVars,
- ConsType, ArgTypes, Constraints).
+ hlds_data__get_type_defn_body(TypeDefn, Body),
+
+ %
+ % If this type has `:- pragma foreign_type' declarations, we
+ % can only use its constructors in predicates which have foreign
+ % clauses and in the unification and comparison predicates for
+ % the type (otherwise the code wouldn't compile when using a
+ % back-end which caused another version of the type to be selected).
+ % The constructors may also appear in the automatically generated
+ % unification and comparison predicates.
+ %
+ % XXX This check isn't quite right -- we really need to check for
+ % each procedure that there is a foreign_proc declaration for all
+ % languages for which this type has a foreign_type declaration, but
+ % this will do for now. Such a check may be difficult because by
+ % this point we've thrown away the clauses which we aren't using
+ % in the current compilation.
+ %
+ (
+ Body ^ du_type_is_foreign_type = yes(_),
+ typecheck_info_get_predid(TypeCheckInfo, PredId),
+ typecheck_info_get_module_info(TypeCheckInfo, ModuleInfo),
+ module_info_pred_info(ModuleInfo, PredId, PredInfo),
+ \+ ( pred_info_get_goal_type(PredInfo, clauses_and_pragmas)
+ ; code_util__compiler_generated(PredInfo)
+ )
+ ->
+ ConsTypeInfo = error(foreign_type_constructor(TypeCtor,
+ TypeDefn))
+ ;
+ construct_type(TypeCtor, ConsTypeParams, ConsType),
+ UnivConstraints = [],
+ Constraints = constraints(UnivConstraints, ExistConstraints),
+ ConsTypeInfo = ok(cons_type_info(ConsTypeVarSet, ExistQVars,
+ ConsType, ArgTypes, Constraints))
+ ).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -5968,12 +6025,12 @@
prog_out__write_sym_name(SymName),
io__write_string("'.\n").
-:- pred report_error_undef_cons(typecheck_info, list(invalid_field_update),
+:- pred report_error_undef_cons(typecheck_info, list(cons_error),
cons_id, int, io__state, io__state).
:- mode report_error_undef_cons(typecheck_info_no_io, in,
in, in, di, uo) is det.
-report_error_undef_cons(TypeCheckInfo, InvalidFieldUpdates, Functor, Arity) -->
+report_error_undef_cons(TypeCheckInfo, ConsErrors, Functor, Arity) -->
{ typecheck_info_get_pred_markers(TypeCheckInfo, PredMarkers) },
{ typecheck_info_get_called_predid(TypeCheckInfo, CalledPredId) },
{ typecheck_info_get_arg_num(TypeCheckInfo, ArgNum) },
@@ -6108,21 +6165,17 @@
; { Functor = cons(unqualified("."), 2) } ->
io__write_string(
" error: the list constructor is now `[|]/2', not `./2'.\n")
- ; { InvalidFieldUpdates = [_ | _] } ->
- io__write_string(
- " error: invalid field update `"),
- hlds_out__write_cons_id(Functor),
- io__write_string("':\n"),
- report_invalid_field_updates(InvalidFieldUpdates)
;
(
{ Functor = cons(Constructor, Arity) },
{ typecheck_info_get_ctors(TypeCheckInfo, ConsTable) },
- { solutions(lambda([N::out] is nondet,
+ { solutions(
+ (pred(N::out) is nondet :-
map__member(ConsTable,
cons(Constructor, N),
- _)),
- ActualArities) },
+ _),
+ N \= Arity
+ ), ActualArities) },
{ ActualArities \= [] }
->
report_wrong_arity_constructor(Constructor, Arity,
@@ -6147,25 +6200,39 @@
;
io__write_string(".\n")
)
+ ),
+ ( { ConsErrors \= [] } ->
+ list__foldl(report_cons_error(Context), ConsErrors)
+ ;
+ []
)
).
-:- pred report_invalid_field_updates(list(invalid_field_update),
- io__state, io__state).
-:- mode report_invalid_field_updates(in, di, uo) is det.
-
-report_invalid_field_updates(Updates) -->
- io__write_list(Updates, ", ", report_invalid_field_update).
+:- pred report_cons_error(prog_context, cons_error,
+ io__state, io__state).
+:- mode report_cons_error(in, in, di, uo) is det.
-:- pred report_invalid_field_update(invalid_field_update,
- io__state, io__state).
-:- mode report_invalid_field_update(in, di, uo) is det.
+report_cons_error(Context,
+ foreign_type_constructor(TypeName - TypeArity, _)) -->
+ { ErrorPieces =
+ [words("There are"), fixed("`:- pragma foreign_type'"),
+ words("declarations for type"),
+ fixed(describe_sym_name_and_arity(TypeName / TypeArity) ++ ","),
+ words("so it is treated as an abstract type in all"),
+ words("predicates and functions which are not implemented"),
+ words("for those foreign types.")] },
+ error_util__write_error_pieces_not_first_line(Context,
+ 0, ErrorPieces).
-report_invalid_field_update(invalid_field_update(FieldName, FieldDefn,
- TVarSet, TVars)) -->
+report_cons_error(_,
+ invalid_field_update(FieldName, FieldDefn, TVarSet, TVars)) -->
{ FieldDefn = hlds_ctor_field_defn(Context, _, _, ConsId, _) },
prog_out__write_context(Context),
- io__write_string(" existentially quantified type "),
+ io__write_string(" Field `"),
+ prog_out__write_sym_name(FieldName),
+ io__write_string("' cannot be updated because\n"),
+ prog_out__write_context(Context),
+ io__write_string(" the existentially quantified type "),
(
{ TVars = [] },
{ error("report_invalid_field_update: no type variables") }
Index: compiler/unify_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unify_gen.m,v
retrieving revision 1.120
diff -u -u -r1.120 unify_gen.m
--- compiler/unify_gen.m 20 Mar 2002 12:37:34 -0000 1.120
+++ compiler/unify_gen.m 23 Jun 2002 18:45:50 -0000
@@ -164,7 +164,7 @@
code_info__lookup_type_defn(Type, TypeDefn),
{ hlds_data__get_type_defn_body(TypeDefn, TypeBody) },
{
- TypeBody = du_type(_, ConsTable, _, _)
+ TypeBody = du_type(_, ConsTable, _, _, _)
->
map__to_assoc_list(ConsTable, ConsList),
(
Index: compiler/unify_proc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unify_proc.m,v
retrieving revision 1.110
diff -u -u -r1.110 unify_proc.m
--- compiler/unify_proc.m 16 May 2002 09:21:37 -0000 1.110
+++ compiler/unify_proc.m 24 Jun 2002 06:28:12 -0000
@@ -546,7 +546,9 @@
ConsTagValues),
UnifyPred = no,
IsEnum = no,
- TypeBody = du_type([Ctor], ConsTagValues, IsEnum, UnifyPred),
+ IsForeign = no,
+ TypeBody = du_type([Ctor], ConsTagValues, IsEnum,
+ UnifyPred, IsForeign),
construct_type(TypeCtor, TupleArgTypes, Type),
term__context_init(Context)
@@ -703,7 +705,7 @@
unify_proc__generate_unify_clauses(TypeBody, H1, H2, Context, Clauses) -->
(
- { TypeBody = du_type(Ctors, _, IsEnum, MaybeEqPred) },
+ { TypeBody = du_type(Ctors, _, IsEnum, MaybeEqPred, _) },
( { MaybeEqPred = yes(PredName) } ->
%
% Just generate a call to the specified predicate,
@@ -743,7 +745,7 @@
;
% We treat foreign_type as if they were an equivalent to
% the builtin type c_pointer.
- { TypeBody = foreign_type(_, _) },
+ { TypeBody = foreign_type(_) },
generate_unify_clauses_eqv_type(c_pointer_type,
H1, H2, Context, Clauses)
;
@@ -793,7 +795,7 @@
unify_proc__generate_index_clauses(TypeBody, X, Index, Context, Clauses) -->
(
- { TypeBody = du_type(Ctors, _, IsEnum, MaybeEqPred) },
+ { TypeBody = du_type(Ctors, _, IsEnum, MaybeEqPred, _) },
( { MaybeEqPred = yes(_) } ->
%
% For non-canonical types, the generated comparison
@@ -826,7 +828,7 @@
% invoked.
{ error("trying to create index proc for eqv type") }
;
- { TypeBody = foreign_type(_, _) },
+ { TypeBody = foreign_type(_) },
{ error("trying to create index proc for a foreign type") }
;
{ TypeBody = abstract_type },
@@ -840,7 +842,7 @@
unify_proc__generate_compare_clauses(Type, TypeBody, Res, H1, H2, Context,
Clauses) -->
(
- { TypeBody = du_type(Ctors, _, IsEnum, MaybeEqPred) },
+ { TypeBody = du_type(Ctors, _, IsEnum, MaybeEqPred, _) },
( { MaybeEqPred = yes(_) } ->
%
% just generate code that will call error/1
@@ -881,7 +883,7 @@
generate_compare_clauses_eqv_type(EqvType,
Res, H1, H2, Context, Clauses)
;
- { TypeBody = foreign_type(_, _) },
+ { TypeBody = foreign_type(_) },
generate_compare_clauses_eqv_type(c_pointer_type,
Res, H1, H2, Context, Clauses)
;
Index: doc/reference_manual.texi
===================================================================
RCS file: /home/mercury1/repository/mercury/doc/reference_manual.texi,v
retrieving revision 1.249
diff -u -u -r1.249 reference_manual.texi
--- doc/reference_manual.texi 30 May 2002 08:00:15 -0000 1.249
+++ doc/reference_manual.texi 28 Jun 2002 08:10:52 -0000
@@ -5016,8 +5016,8 @@
Mercury User's Guide.
If there is a @code{pragma foreign_proc} declaration for any
-mode of a predicate or function, then there must be either a mode
-specific clause or a @code{pragma foreign_proc}
+mode of a predicate or function, then there must be either a
+clause or a @code{pragma foreign_proc}
@c or @code{pragma import}
declaration for every mode of that predicate or function.
@@ -5042,8 +5042,6 @@
If there are both Mercury definitions and foreign_proc definitions for
a procedure and/or foreign_proc definitions for different languages,
it is implementation defined which definition is used.
-All such Mercury definitions must use mode-specific clauses (even if
-there is only a single mode for the predicate).
For pure and semipure procedures, the declarative semantics of the
foreign_proc definitions must be the same as that of the Mercury code.
@@ -5193,8 +5191,6 @@
modifications to mutable state are done via side effects,
rather than argument passing.
- at c XXX foreign type should be documented here.
-
@c -----------------------------------------------------------------------
@node Using foreign types from Mercury
@@ -5209,10 +5205,11 @@
This defines @var{MercuryTypeName} as a synonym for type
@var{ForeignTypeDescriptor} defined in the foreign language @var{Lang}.
-You must declare @var{MercuryTypeName} using a @samp{:- type}
-declaration as usual, and the foreign_type pragma must have the same
-visibility as the type declaration (either both in the interface or both
-in the implementation).
+You must declare @var{MercuryTypeName} using a (posssibly abstract)
+ at samp{:- type} declaration as usual. The @samp{pragma foreign_type} must
+not have wider visibility than the type declaration (if the
+ at samp{pragma foreign_type} declaration is in the interface,
+the @samp{:- type} declaration must be also).
@var{ForeignTypeDescriptor} defines how the Mercury type is mapped for a
particular foreign language. Specific syntax is given in the language
@@ -5221,12 +5218,18 @@
@var{MercuryTypeName} is treated as an abstract type at all times in
Mercury code.
However, if @var{MercuryTypeName} is one of the parameters of a
-foreign_proc for @var{Lang}, it will be passed to that foreign_proc as
+foreign_proc for @var{Lang}, and the @samp{pragma foreign_type} declaration
+is visible to the foreign_proc, it will be passed to that foreign_proc as
specified by @var{ForeignTypeDescriptor}.
Multiple foreign language definitions may be given for the same type ---
the appropriate definition will be used for the appropriate language (see the
-language specific information below for details).
+language specific information below for details). All definitions
+must have the same visibility. A Mercury definition, which must define
+a discriminated union type, may also be given. The constructors for the
+type will only be visible in clauses for for predicates or functions with
+ at samp{pragma foreign_proc} clauses for all of the languages for which there
+are @samp{foreign_type} declarations for the type.
You can use Mercury foreign language interfacing declarations
which specify language @var{X} to interface to types that are actually
Index: tests/debugger/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/debugger/Mmakefile,v
retrieving revision 1.78
diff -u -u -r1.78 Mmakefile
--- tests/debugger/Mmakefile 12 Jun 2002 14:27:01 -0000 1.78
+++ tests/debugger/Mmakefile 27 Jun 2002 06:07:15 -0000
@@ -316,7 +316,8 @@
cp $(WORKSPACE)/tools/lmc lmc/mmc
endif
echo "echo on" > interactive.inp.tmp
- echo mmc_options $(ALL_MCFLAGS) --trace minimum >> interactive.inp.tmp
+ echo mmc_options $(ALL_GRADEFLAGS) $(ALL_MCFLAGS) \
+ --trace minimum >> interactive.inp.tmp
cat interactive.inp >> interactive.inp.tmp
PATH="`pwd`/lmc:$$PATH" $(MDB) ./interactive \
< interactive.inp.tmp > interactive.out.orig 2>&1
Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/Mmakefile,v
retrieving revision 1.155
diff -u -u -r1.155 Mmakefile
--- tests/hard_coded/Mmakefile 11 Jun 2002 16:29:57 -0000 1.155
+++ tests/hard_coded/Mmakefile 25 Jun 2002 18:28:22 -0000
@@ -59,6 +59,7 @@
foreign_and_mercury \
foreign_import_module \
foreign_type \
+ foreign_type2 \
frameopt_pragma_redirect \
free_free_mode \
func_and_pred \
Index: tests/hard_coded/foreign_type.m
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/foreign_type.m,v
retrieving revision 1.1
diff -u -u -r1.1 foreign_type.m
--- tests/hard_coded/foreign_type.m 7 May 2002 11:02:42 -0000 1.1
+++ tests/hard_coded/foreign_type.m 25 Jun 2002 15:02:46 -0000
@@ -91,4 +91,13 @@
").
%----------------------------------------------------------------------------%
+
+% Mercury implementation
+:- type coord ---> coord(x :: int, y :: int).
+
+new(X, Y) = coord(X, Y).
+x(C) = C ^ x.
+y(C) = C ^ y.
+
+%----------------------------------------------------------------------------%
%----------------------------------------------------------------------------%
Index: tests/hard_coded/foreign_type2.exp
===================================================================
RCS file: tests/hard_coded/foreign_type2.exp
diff -N tests/hard_coded/foreign_type2.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/foreign_type2.exp 28 Jun 2002 07:27:49 -0000
@@ -0,0 +1,3 @@
+X:4
+Y:5
+foreign_type2:coord(int)
Index: tests/hard_coded/foreign_type2.m
===================================================================
RCS file: tests/hard_coded/foreign_type2.m
diff -N tests/hard_coded/foreign_type2.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/foreign_type2.m 28 Jun 2002 07:27:26 -0000
@@ -0,0 +1,74 @@
+:- module foreign_type2.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(io__state::di, io__state::uo) is det.
+
+:- implementation.
+
+:- import_module std_util.
+
+:- type coord(T).
+
+:- func new(T, int, int) = coord(T).
+
+:- func x(coord(T)) = int.
+:- func y(coord(T)) = int.
+
+main -->
+ { C = new(1, 4, 5) },
+ io__write_string("X:"),
+ io__write_int(x(C)),
+ io__nl,
+ io__write_string("Y:"),
+ io__write_int(y(C)),
+ io__nl,
+ io__write_string(type_name(type_of(C))),
+ io__nl.
+
+%----------------------------------------------------------------------------%
+%----------------------------------------------------------------------------%
+
+% IL implementation
+:- pragma foreign_type(il, coord(T),
+ "class [foreign_type__csharp_code]coord").
+
+:- pragma foreign_decl("C#", "
+public class coord {
+ public int x;
+ public int y;
+}
+").
+
+:- pragma foreign_proc("C#", new(_T::in, X::in, Y::in) = (C::out),
+ [will_not_call_mercury, promise_pure],
+"
+ C = new coord();
+ C.x = X;
+ C.y = Y;
+").
+
+:- pragma foreign_proc("C#", x(C::in) = (X::out),
+ [will_not_call_mercury, promise_pure],
+"
+ X = C.x;
+").
+
+:- pragma foreign_proc("C#", y(C::in) = (Y::out),
+ [will_not_call_mercury, promise_pure],
+"
+ Y = C.y;
+").
+
+%----------------------------------------------------------------------------%
+%----------------------------------------------------------------------------%
+
+% Mercury implementation
+:- type coord(T) ---> coord(x :: int, y :: int).
+
+new(_, X, Y) = coord(X, Y).
+
+%----------------------------------------------------------------------------%
+%----------------------------------------------------------------------------%
Index: tests/invalid/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/Mmakefile,v
retrieving revision 1.113
diff -u -u -r1.113 Mmakefile
--- tests/invalid/Mmakefile 1 Jun 2002 13:34:42 -0000 1.113
+++ tests/invalid/Mmakefile 26 Jun 2002 18:27:17 -0000
@@ -53,6 +53,8 @@
exported_mode.m \
field_syntax_error.m \
foreign_singleton.m \
+ foreign_type_2.m \
+ foreign_type_visibility.m \
func_errors.m \
funcs_as_preds.m \
ho_default_func_1.m \
@@ -172,6 +174,8 @@
MCFLAGS-exported_mode = --infer-all --no-intermodule-optimization
MCFLAGS-foreign_type = --compile-only
MCFLAGS-foreign_singleton = --halt-at-warn
+MCFLAGS-foreign_type_2 = --no-intermodule-optimization
+MCFLAGS-foreign_type_visibility = --no-intermodule-optimization
MCFLAGS-imported_mode = --infer-all --no-intermodule-optimization
MCFLAGS-missing_det_decls = --no-infer-det
MCFLAGS-missing_interface_import = --make-interface
Index: tests/invalid/foreign_type_2.err_exp
===================================================================
RCS file: tests/invalid/foreign_type_2.err_exp
diff -N tests/invalid/foreign_type_2.err_exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/foreign_type_2.err_exp 27 Jun 2002 16:44:54 -0000
@@ -0,0 +1,8 @@
+foreign_type_2.m:018: In clause for function `foreign_type_2:unwrap_foreign/1':
+foreign_type_2.m:018: in argument 1 of clause head:
+foreign_type_2.m:018: error: undefined symbol `foreign/1'.
+foreign_type_2.m:018: There are `:- pragma foreign_type' declarations for
+foreign_type_2.m:018: type `foreign_type_2:foreign/0', so it is treated as an
+foreign_type_2.m:018: abstract type in all predicates and functions which are
+foreign_type_2.m:018: not implemented for those foreign types.
+For more information, try recompiling with `-E'.
Index: tests/invalid/foreign_type_2.m
===================================================================
RCS file: tests/invalid/foreign_type_2.m
diff -N tests/invalid/foreign_type_2.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/foreign_type_2.m 27 Jun 2002 06:13:17 -0000
@@ -0,0 +1,19 @@
+:- module foreign_type_2.
+
+:- interface.
+
+:- type foreign.
+
+:- func unwrap_foreign(foreign) = int is semidet.
+
+:- implementation.
+
+:- pragma foreign_type(il, foreign, "class [mscorlib]System.Object").
+
+:- type foreign
+ ---> foreign(int).
+
+% There are no foreign clauses for this function, so the use
+% of the foreign/1 constructor is an error.
+unwrap_foreign(foreign(Int)) = Int.
+
Index: tests/invalid/foreign_type_visibility.err_exp
===================================================================
RCS file: tests/invalid/foreign_type_visibility.err_exp
diff -N tests/invalid/foreign_type_visibility.err_exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/foreign_type_visibility.err_exp 27 Jun 2002 16:44:40 -0000
@@ -0,0 +1,12 @@
+foreign_type_visibility.m:009: Error: pragma foreign_type
+foreign_type_visibility.m:009: `foreign_type_visibility:foreign/0' must have
+foreign_type_visibility.m:009: the same visibility as the type declaration.
+foreign_type_visibility.m:020: In definition of type
+foreign_type_visibility.m:020: `foreign_type_visibility:foreign2/0':
+foreign_type_visibility.m:020: error: all definitions of a type must have the
+foreign_type_visibility.m:020: same visibility
+foreign_type_visibility.m:022: In definition of type
+foreign_type_visibility.m:022: `foreign_type_visibility:foreign3/0':
+foreign_type_visibility.m:022: error: all definitions of a type must have the
+foreign_type_visibility.m:022: same visibility
+For more information, try recompiling with `-E'.
Index: tests/invalid/foreign_type_visibility.m
===================================================================
RCS file: tests/invalid/foreign_type_visibility.m
diff -N tests/invalid/foreign_type_visibility.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/foreign_type_visibility.m 26 Jun 2002 18:26:20 -0000
@@ -0,0 +1,23 @@
+:- module foreign_type_visibility.
+
+:- implementation.
+
+:- type foreign.
+
+:- interface.
+
+:- pragma foreign_type(il, foreign, "class [mscorlib]System.Object").
+
+:- type foreign2.
+
+:- pragma foreign_type(il, foreign2, "class [mscorlib]System.Object").
+
+:- type foreign3
+ ---> foreign3(c_pointer).
+
+:- implementation.
+
+:- pragma foreign_type(c, foreign2, "void *").
+
+:- pragma foreign_type(c, foreign3, "void *").
+
Index: tests/invalid/record_syntax_errors.err_exp
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/record_syntax_errors.err_exp,v
retrieving revision 1.7
diff -u -u -r1.7 record_syntax_errors.err_exp
--- tests/invalid/record_syntax_errors.err_exp 10 Jun 2002 15:58:11 -0000 1.7
+++ tests/invalid/record_syntax_errors.err_exp 27 Jun 2002 15:50:30 -0000
@@ -24,8 +24,9 @@
record_syntax_errors.m:016: Error: no clauses for
record_syntax_errors.m:016: predicate `record_syntax_errors:dcg_syntax_2/2'.
record_syntax_errors.m:042: In clause for predicate `record_syntax_errors:construct_exist_cons/1':
-record_syntax_errors.m:042: error: invalid field update `field2 :=/2':
-record_syntax_errors.m:005: existentially quantified type variable `T' occurs
+record_syntax_errors.m:042: error: undefined symbol `field2 :=/2'.
+record_syntax_errors.m:005: Field `field2' cannot be updated because
+record_syntax_errors.m:005: the existentially quantified type variable `T' occurs
record_syntax_errors.m:005: in the types of field `field2' and some other field
record_syntax_errors.m:005: in definition of constructor `record_syntax_errors:exist_cons/3 '.
record_syntax_errors.m:046: In clause for predicate `record_syntax_errors:arg_type_error/1':
--------------------------------------------------------------------------
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