[m-rev.] [dotnet-foreign] diff: add pragma attribute

Tyson Dowd trd at cs.mu.OZ.AU
Fri May 18 23:07:55 AEST 2001


Hi,

Here's the patch (against dotnet-foreign) for adding attributes.

Syntax is liable to change before it moves onto the main branch.
If you have ideas I'm interested in them.

===================================================================


Estimated hours taken: 24
Branches: dotnet-foreign

Add support for custom attributes to the .NET backend.

You can now write 

:- pragma foreign_type(web_method_attribute,
        'System__Web__Services__WebMethodAttribute',
        "System.Web.Services").

:- pragma attribute(foo/1, web_method_attribute).

which will do the same as the C# declaration
[WebMethod()]

Parameters to the attribute initializer are not yet handled.
Web methods don't necessarily work, because they have an added constraint
that the web method has to be an instance method.

compiler/hlds_pred.m:
compiler/make_hlds.m:
compiler/module_qual.m:
compiler/modules.m:
compiler/prog_data.m:
	Add attributes to the pred_info (they are a bit like markers, but
	are more than just boolean flags).

compiler/mercury_to_mercury.m:
	Add :- pragma attribute support.

compiler/ml_code_gen.m:
compiler/ml_code_util.m:
compiler/ml_elim_nested.m:
compiler/ml_optimize.m:
compiler/ml_tailcall.m:
compiler/ml_util.m:
compiler/mlds.m:
compiler/mlds_to_c.m:
compiler/mlds_to_csharp.m:
compiler/mlds_to_gcc.m:
compiler/mlds_to_java.m:
compiler/mlds_to_mcpp.m:
	Add mlds__attributes, which are the MLDS version of custom attributes.
	Convert hlds_pred__attributes into mlds__attributes.
	Add a list of mlds__attributes to the mlds__function defn.
	
compiler/il_peephole.m:
	Rename classdecl as class_member (and ClassDecls as ClassMembers) 

compiler/ilasm.m:
compiler/mlds_to_il.m:
	Add custom attributes to appropriate positions (on assemblies,
	IL types and methods). 
	Rename classdecl as class_member (and ClassDecls as ClassMembers) 

compiler/prog_io_pragma.m:
	Parse the new pragma.


Index: compiler/hlds_pred.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_pred.m,v
retrieving revision 1.94
diff -u -r1.94 hlds_pred.m
--- compiler/hlds_pred.m	2001/03/27 05:23:06	1.94
+++ compiler/hlds_pred.m	2001/05/18 12:50:11
@@ -446,6 +446,17 @@
 				% then it must give an error message.
 	.
 
+
+	% An abstract set of attributes.
+:- type pred_attributes.
+
+:- type attribute
+	--->	custom(type)
+				% A custom attribute, indended to be associated
+				% with this predicate in the underlying
+				% implementation.
+	.
+
 	% Aditi predicates are identified by their owner as well as
 	% module, name and arity.
 :- type aditi_owner == string.
@@ -751,6 +762,12 @@
 :- pred pred_info_set_markers(pred_info, pred_markers, pred_info).
 :- mode pred_info_set_markers(in, in, out) is det.
 
+:- pred pred_info_get_attributes(pred_info, pred_attributes).
+:- mode pred_info_get_attributes(in, out) is det.
+
+:- pred pred_info_set_attributes(pred_info, pred_attributes, pred_info).
+:- mode pred_info_set_attributes(in, in, out) is det.
+
 :- pred pred_info_get_call_id(pred_info, simple_call_id).
 :- mode pred_info_get_call_id(in, out) is det.
 
@@ -777,6 +794,29 @@
 :- pred marker_list_to_markers(list(marker), pred_markers).
 :- mode marker_list_to_markers(in, out) is det.
 
+	% create an empty set of attributes
+:- pred init_attributes(pred_attributes).
+:- mode init_attributes(out) is det.
+
+	% check if a particular is in the set
+:- pred check_attribute(pred_attributes, attribute).
+:- mode check_attribute(in, in) is semidet.
+
+	% add a attribute to the set
+:- pred add_attribute(pred_attributes, attribute, pred_attributes).
+:- mode add_attribute(in, in, out) is det.
+
+	% remove a attribute from the set
+:- pred remove_attribute(pred_attributes, attribute, pred_attributes).
+:- mode remove_attribute(in, in, out) is det.
+
+	% convert the set to a list
+:- pred attributes_to_attribute_list(pred_attributes, list(attribute)).
+:- mode attributes_to_attribute_list(in, out) is det.
+
+:- pred attribute_list_to_attributes(list(attribute), pred_attributes).
+:- mode attribute_list_to_attributes(in, out) is det.
+
 %-----------------------------------------------------------------------------%
 
 :- implementation.
@@ -873,6 +913,8 @@
 					% pragma foreign_code(...) decs, or none
 			markers		:: pred_markers,
 					% various boolean flags
+			attributes	:: pred_attributes,
+					% various attributes 
 			is_pred_or_func	:: pred_or_func,
 					% whether this "predicate" was really
 					% a predicate or a function
@@ -941,15 +983,17 @@
 	sym_name_get_module_name(SymName, ModuleName, PredModuleName),
 	term__vars_list(Types, TVars),
 	list__delete_elems(TVars, ExistQVars, HeadTypeParams),
+	Attributes = [],
 	UnprovenBodyConstraints = [],
 	Indexes = [],
 	set__init(Assertions),
 	MaybeInstanceConstraints = no,
 	PredInfo = predicate(TypeVarSet, Types, Cond, ClausesInfo, Procs,
 		Context, PredModuleName, PredName, Arity, Status, TypeVarSet,
-		GoalType, Markers, PredOrFunc, ClassContext, ClassProofs,
-		ExistQVars, HeadTypeParams, UnprovenBodyConstraints, User,
-		Indexes, Assertions, MaybeInstanceConstraints).
+		GoalType, Markers, Attributes, PredOrFunc, ClassContext,
+		ClassProofs, ExistQVars, HeadTypeParams,
+		UnprovenBodyConstraints, User, Indexes, Assertions,
+		MaybeInstanceConstraints).
 
 pred_info_create(ModuleName, SymName, TypeVarSet, ExistQVars, Types, Cond,
 		Context, Status, Markers, PredOrFunc, ClassContext, User,
@@ -967,6 +1011,7 @@
 	unqualify_name(SymName, PredName),
 	% The empty list of clauses is a little white lie.
 	Clauses = [],
+	Attributes = [],
 	map__init(TVarNameMap),
 	ClausesInfo = clauses_info(VarSet, VarTypes, TVarNameMap,
 		VarTypes, HeadVars, Clauses, TypeInfoMap, TypeClassInfoMap),
@@ -978,9 +1023,10 @@
 	MaybeInstanceConstraints = no,
 	PredInfo = predicate(TypeVarSet, Types, Cond, ClausesInfo, Procs,
 		Context, ModuleName, PredName, Arity, Status, TypeVarSet,
-		clauses, Markers, PredOrFunc, ClassContext, ClassProofs,
-		ExistQVars, HeadTypeParams, UnprovenBodyConstraints, User,
-		Indexes, Assertions, MaybeInstanceConstraints).
+		clauses, Markers, Attributes, PredOrFunc, ClassContext,
+		ClassProofs, ExistQVars, HeadTypeParams,
+		UnprovenBodyConstraints, User, Indexes, Assertions,
+		MaybeInstanceConstraints).
 
 pred_info_all_procids(PredInfo, ProcIds) :-
 	ProcTable = PredInfo ^ procedures,
@@ -1165,6 +1211,10 @@
 
 pred_info_set_markers(PredInfo, X, PredInfo^markers := X).
 
+pred_info_get_attributes(PredInfo, PredInfo ^ attributes).
+
+pred_info_set_attributes(PredInfo, X, PredInfo ^ attributes := X).
+
 pred_info_get_is_pred_or_func(PredInfo, PredInfo^is_pred_or_func).
 
 pred_info_set_class_context(PredInfo, X, PredInfo^class_context := X).
@@ -1245,6 +1295,23 @@
 markers_to_marker_list(Markers, Markers).
 
 marker_list_to_markers(Markers, Markers).
+
+:- type pred_attributes == list(attribute).
+
+init_attributes([]).
+
+check_attribute(Attributes, Attribute) :-
+	list__member(Attribute, Attributes).
+
+add_attribute(Attributes, Attribute, [Attribute | Attributes]).
+
+remove_attribute(Attributes0, Attribute, Attributes) :-
+	list__delete_all(Attributes0, Attribute, Attributes).
+
+attributes_to_attribute_list(Attributes, Attributes).
+
+attribute_list_to_attributes(Attributes, Attributes).
+
 
 %-----------------------------------------------------------------------------%
 
Index: compiler/il_peephole.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/il_peephole.m,v
retrieving revision 1.2
diff -u -r1.2 il_peephole.m
--- compiler/il_peephole.m	2001/03/16 04:17:46	1.2
+++ compiler/il_peephole.m	2001/05/18 12:50:11
@@ -64,10 +64,10 @@
 	% optimizations.
 :- pred optimize_decl(decl::in, decl::out, bool::in, bool::out) is det.
 optimize_decl(Decl0, Decl, Mod0, Mod) :-
-	( Decl0 = class(A, B, C, D, ClassDecls0) ->
-		list__map_foldl(optimize_class_decl, ClassDecls0, ClassDecls, 
-			Mod0, Mod),
-		Decl = class(A, B, C, D, ClassDecls)
+	( Decl0 = class(A, B, C, D, ClassMembers0) ->
+		list__map_foldl(optimize_class_decl, ClassMembers0,
+			ClassMembers, Mod0, Mod),
+		Decl = class(A, B, C, D, ClassMembers)
 	; Decl0 = method(A, MethodDecls0) ->
 		list__map_foldl(optimize_method_decl, MethodDecls0,
 			MethodDecls, Mod0, Mod),
@@ -81,7 +81,7 @@
 	 	Decl0 = Decl 
 	).
 
-:- pred optimize_class_decl(classdecl::in, classdecl::out, 
+:- pred optimize_class_decl(class_member::in, class_member::out, 
 	bool::in, bool::out) is det.
 optimize_class_decl(Decl0, Decl, Mod0, Mod) :-
 	( Decl0 = method(A, MethodDecls0) ->
Index: compiler/ilasm.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ilasm.m,v
retrieving revision 1.5.4.4
diff -u -r1.5.4.4 ilasm.m
--- compiler/ilasm.m	2001/04/24 23:12:10	1.5.4.4
+++ compiler/ilasm.m	2001/05/18 12:50:12
@@ -47,7 +47,7 @@
 			extends,		% what is the parent class
 			implements, 		% what interfaces are 
 						% implemented
-			list(classdecl)		% methods and fields
+			list(class_member)		% methods and fields
 		)
 		% .namespace declaration
 	;	namespace(
@@ -80,6 +80,10 @@
 		% defines an assembly
 	;	assembly(ilds__id)
 
+		% .custom
+		% a custom attribute
+	;	custom(custom_decl)
+
 		% comments
 	;	comment_term(term)
 			% print almost anything using pprint__to_doc
@@ -90,7 +94,9 @@
 :- type assembly_decl 
 	--->	version(int, int, int, int)	% version number
 	;	hash(list(int8))		% hash 
-	;	public_key_token(list(int8)).	% public key token
+	;	public_key_token(list(int8))	% public key token
+	;	custom(custom_decl).		% a custom attribute
+
 
 	% a method definition is just a list of body decls.
 :- type method_defn == list(method_body_decl).
@@ -103,7 +109,7 @@
 			list(implattr)		% implementation attributes
 	).
 
-:- type classdecl
+:- type class_member
 		% .method (a class method)
 	--->	method(
 			methodhead,		% name, signature, attributes
@@ -124,8 +130,9 @@
 			extends,		% what is the parent class
 			implements, 		% what interfaces are 
 						% implemented
-			list(classdecl)		% methods and fields
+			list(class_member)		% methods and fields
 		)
+	;	custom(custom_decl)		% custom attribute
 		% comments
 	;	comment_term(term)
 	;	comment(string)
@@ -172,6 +179,7 @@
 			% words or something else?
 	;	entrypoint		% is this "main"?
 	;	zeroinit		% initialize locals to zero.
+	;	custom(custom_decl)	% custom attribute
 	;	instrs(list(instr))	% instructions
 	;	label(string).		% a label
 
@@ -226,6 +234,22 @@
 	;	bytearray(list(byte)).	% output as two digit hex, e.g.
 					% 01 F7 0A
 
+:- type custom_decl ---> 
+	custom_decl(
+		custom_type, 
+		maybe(custom_type),
+		qstring_or_bytes).
+
+:- type qstring_or_bytes
+	--->	qstring(string)
+	;	bytes(list(int8))
+	; 	no_initalizer.
+
+:- type custom_type
+	--->	type(ilds__type)
+	;	methodref(ilds__methodref).
+
+
 :- implementation.
 
 :- import_module char, string, pprint, getopt.
@@ -286,6 +310,8 @@
 :- pred ilasm__output_decl(decl::in, ilasm_info::in, ilasm_info::out,
 		io__state::di, io__state::uo) is det.
 
+ilasm__output_decl(custom(CustomDecl), Info0, Info) --> 
+	output_custom_decl(CustomDecl, Info0, Info).
 ilasm__output_decl(class(Attrs, Id, Extends, Implements, Contents),
 		Info0, Info) --> 
 	io__write_string(".class "),
@@ -315,7 +341,7 @@
 		{ Info2 = Info1 }
 	),
 	io__write_string(" {\n"),
-	ilasm__write_list(Contents, "\n", output_classdecl, Info2, Info),
+	ilasm__write_list(Contents, "\n", output_class_member, Info2, Info),
 	io__write_string("\n}").
 ilasm__output_decl(namespace(DottedName, Contents), Info0, Info) --> 
 	( { DottedName \= [] } ->
@@ -378,11 +404,14 @@
 		[]
 	).
 
-ilasm__output_decl(extern_assembly(AsmName, AssemblyDecls), Info, Info) --> 
+ilasm__output_decl(extern_assembly(AsmName, AssemblyDecls), Info0, Info) --> 
 	io__write_string(".assembly extern "),
 	output_id(AsmName),
 	io__write_string("{\n"),
-	io__write_list(AssemblyDecls, "\n\t", output_assembly_decl),
+	list__foldl2((pred(A::in, I0::in, I::out, di, uo) is det -->
+			output_assembly_decl(A, I0, I),
+			io__write_string("\n\t")
+		), AssemblyDecls, Info0, Info),
 	io__write_string("\n}\n").
 
 
@@ -392,10 +421,10 @@
 	{ Info = Info0 ^ current_assembly := AsmName },
 	io__write_string(" { }").
 
-:- pred ilasm__output_classdecl(classdecl::in, ilasm_info::in, ilasm_info::out,
-	io__state::di, io__state::uo) is det.
+:- pred ilasm__output_class_member(class_member::in, ilasm_info::in,
+	ilasm_info::out, io__state::di, io__state::uo) is det.
 
-ilasm__output_classdecl(method(MethodHead, MethodDecls), Info0, Info) -->
+ilasm__output_class_member(method(MethodHead, MethodDecls), Info0, Info) -->
 		% Don't do debug output on class constructors, since
 		% they are automatically generated and take forever to
 		% run.
@@ -410,7 +439,7 @@
 			Info0, Info)
 	).
 
-ilasm__output_classdecl(
+ilasm__output_class_member(
 		field(FieldAttrs, Type, IlId, MaybeOffset, Initializer),
 		Info0, Info) -->
 	io__write_string(".field "),
@@ -431,12 +460,15 @@
 	output_id(IlId),
 	output_field_initializer(Initializer).
 
-ilasm__output_classdecl(nested_class(Attrs, Id, Extends, Implements, Contents),
-		Info0, Info) --> 
+ilasm__output_class_member(nested_class(Attrs, Id, Extends, Implements,
+		Contents), Info0, Info) --> 
 	ilasm__output_decl(class(Attrs, Id, Extends, Implements, Contents),
 		Info0, Info).
 
-ilasm__output_classdecl(comment(CommentStr), Info, Info) --> 
+ilasm__output_class_member(custom(CustomDecl), Info0, Info) --> 
+	output_custom_decl(CustomDecl, Info0, Info).
+
+ilasm__output_class_member(comment(CommentStr), Info, Info) --> 
 	globals__io_lookup_bool_option(auto_comments, PrintComments),
 	( { PrintComments = yes } ->
 		output_comment_string(CommentStr)
@@ -444,7 +476,7 @@
 		[]
 	).
 
-ilasm__output_classdecl(comment_term(CommentTerm), Info, Info) --> 
+ilasm__output_class_member(comment_term(CommentTerm), Info, Info) --> 
 	globals__io_lookup_bool_option(auto_comments, PrintComments),
 	( { PrintComments = yes } ->
 		io__write_string("// "),
@@ -455,7 +487,7 @@
 		[]
 	).
 
-ilasm__output_classdecl(comment_thing(Thing), Info, Info) --> 
+ilasm__output_class_member(comment_thing(Thing), Info, Info) --> 
 	globals__io_lookup_bool_option(auto_comments, PrintComments),
 	( { PrintComments = yes } ->
 		{ Doc = label("// ", to_doc(Thing)) },
@@ -487,6 +519,9 @@
 	io__write_string(".emitbyte "),
 	output_int32(Int32).
 
+ilasm__output_method_body_decl(custom(CustomDecl), Info0, Info) -->
+	output_custom_decl(CustomDecl, Info0, Info).
+
 ilasm__output_method_body_decl(maxstack(Int32), I, I) -->
 	io__write_string(".maxstack "),
 	output_int32(Int32).
@@ -1315,19 +1350,52 @@
 	ilasm__write_list(ArgTypes, ", ", output_type, Info1, Info),
 	io__write_string(")").
 
-:- pred ilasm__output_assembly_decl(assembly_decl::in, 
-	io__state::di, io__state::uo) is det.
+:- pred ilasm__output_assembly_decl(assembly_decl::in, ilasm_info::in,
+		ilasm_info::out, io__state::di, io__state::uo) is det.
 
-ilasm__output_assembly_decl(version(A, B, C, D)) -->
+ilasm__output_assembly_decl(version(A, B, C, D), I, I) -->
 	io__format(".ver %d:%d:%d:%d", [i(A), i(B), i(C), i(D)]).
-ilasm__output_assembly_decl(public_key_token(Token)) -->
+ilasm__output_assembly_decl(public_key_token(Token), I, I) -->
 	io__write_string(".publickeytoken = ( "),
 	io__write_list(Token, " ", output_hexbyte),
 	io__write_string(" ) ").
-ilasm__output_assembly_decl(hash(Hash)) -->
+ilasm__output_assembly_decl(hash(Hash), I, I) -->
 	io__write_string(".hash = ( "),
 	io__write_list(Hash, " ", output_hexbyte),
 	io__write_string(" ) ").
+ilasm__output_assembly_decl(custom(CustomDecl), Info0, Info) -->
+	output_custom_decl(CustomDecl, Info0, Info).
+
+:- pred output_custom_decl(custom_decl::in, ilasm_info::in, ilasm_info::out,
+		io__state::di, io__state::uo) is det.
+output_custom_decl(custom_decl(Type, MaybeOwner, StringOrBytes), 
+		Info0, Info) -->
+	io__write_string(".custom "),
+
+	( { MaybeOwner = yes(Owner) } ->
+		io__write_string(" ("),
+		output_custom_type(Owner, Info0, Info1),
+		io__write_string(") ")
+	;
+		{ Info1 = Info0 }
+	),
+	output_custom_type(Type, Info1, Info),
+	( { StringOrBytes = bytes(Bytes) } ->
+		io__write_string(" = ("),
+		io__write_list(Bytes, " ", output_hexbyte),
+		io__write_string(")")
+	;
+		[]
+	),
+	io__write_string("\n").
+
+:- pred output_custom_type(custom_type::in, ilasm_info::in, ilasm_info::out,
+		io__state::di, io__state::uo) is det.
+output_custom_type(type(Type), Info0, Info) -->
+	output_type(Type, Info0, Info).
+output_custom_type(methodref(MethodRef), Info0, Info) -->
+	output_methodref(MethodRef, Info0, Info).
+
 
 :- pred output_index(index::in, io__state::di, io__state::uo) is det.
 output_index(Index) -->
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.368.2.4
diff -u -r1.368.2.4 make_hlds.m
--- compiler/make_hlds.m	2001/05/08 11:46:17	1.368.2.4
+++ compiler/make_hlds.m	2001/05/18 12:50:14
@@ -563,6 +563,10 @@
 			ImportStatus, Context, check_termination, 
 			[terminates, does_not_terminate], 
 			Module)
+	;
+		{ Pragma = attribute(Pred, Arity, AttributeType) },
+		module_add_pragma_attribute(Pred, Arity, AttributeType, 
+			ImportStatus, Context, Module0, Module)
 	).
 
 add_item_decl_pass_2(func(_TypeVarSet, _InstVarSet, _ExistQVars, FuncName,
@@ -7974,3 +7978,47 @@
 	).
 
 %-----------------------------------------------------------------------------%
+% Add a `pragma attribute' declaration to the HLDS. 
+
+:- pred module_add_pragma_attribute(sym_name, arity, type, 
+		import_status, prog_context, module_info, module_info,
+		io__state, io__state).
+:- mode module_add_pragma_attribute(in, in, in, in, in, in, out, 
+		di, uo) is det.
+
+module_add_pragma_attribute(Pred, Arity, AttributeType, _Status, Context,
+		Module0, Module) -->
+	{ module_info_get_predicate_table(Module0, PredicateTable) },
+	(
+		{ predicate_table_search_sym_arity(PredicateTable, Pred, 
+			Arity, PredIDs) },
+		{ PredIDs = [_ | _] }
+	->
+		( 
+			{ PredIDs = [PredID] }
+		->
+			{ module_info_pred_info(Module0, PredID, PredInfo0) },
+			{ pred_info_get_attributes(PredInfo0, Attributes) },
+			{ add_attribute(Attributes, custom(AttributeType),
+				NewAttributes) },
+			{ pred_info_set_attributes(PredInfo0, NewAttributes,
+				PredInfo) },
+			{ module_info_set_pred_info(Module0, PredID, PredInfo,
+				Module) }
+		;
+			io__set_exit_status(1),
+			prog_out__write_context(Context),
+			io__write_string("In pragma attribute for `"),
+			prog_out__write_sym_name_and_arity(Pred/Arity),
+			io__write_string("':\n"),
+			prog_out__write_context(Context),
+			io__write_string(
+			    "  error: ambiguous predicate/function name.\n"),
+			{ Module = Module0 }
+		)
+	;
+		undefined_pred_or_func_error(Pred, Arity, Context, 
+			"`:- pragma fact_table' declaration"),
+		{ Module = Module0 }
+	).
+
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.184.2.4
diff -u -r1.184.2.4 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m	2001/05/14 11:25:20	1.184.2.4
+++ compiler/mercury_to_mercury.m	2001/05/18 12:50:15
@@ -468,6 +468,9 @@
 		{ Pragma = check_termination(Pred, Arity) },
 		mercury_output_pragma_decl(Pred, Arity, predicate,
 			"check_termination")
+	;
+		{ Pragma = attribute(Pred, Arity, AttributeTerm) },
+		mercury_output_pragma_attribute(Pred, Arity, AttributeTerm)
 	).
 
 mercury_output_item(assertion(Goal, VarSet), _) -->
@@ -2566,6 +2569,22 @@
 	io__write_string(", ["),
 	mercury_output_int_list(Attrs),
 	io__write_string("]").
+
+%-----------------------------------------------------------------------------%
+
+	% Output the given pragma attribute declaration
+:- pred mercury_output_pragma_attribute(sym_name, arity, type, 
+		io__state, io__state).
+:- mode mercury_output_pragma_attribute(in, in, in, di, uo) is det.
+
+mercury_output_pragma_attribute(Pred, Arity, AttributeType) -->
+	io__write_string(":- pragma attribute("),
+	mercury_output_sym_name(Pred),
+	io__write_string("/"),
+	io__write_int(Arity),
+	io__write_string(", "),
+	output_type(varset__init, no, AttributeType),
+	io__write_string(").\n").
 
 %-----------------------------------------------------------------------------%
 
Index: compiler/ml_code_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.80.2.7
diff -u -r1.80.2.7 ml_code_gen.m
--- compiler/ml_code_gen.m	2001/05/14 12:21:49	1.80.2.7
+++ compiler/ml_code_gen.m	2001/05/18 12:50:16
@@ -1104,8 +1104,15 @@
 			Context),
 		MaybeStatement = yes(MLDS_Statement)
 	),
+
+	pred_info_get_attributes(PredInfo, Attributes),
+	attributes_to_attribute_list(Attributes, AttributeList),
+
+	MLDSAttributes = attributes_to_mlds_attributes(ModuleInfo,
+		AttributeList),
+	
 	MLDS_ProcDefnBody = mlds__function(yes(proc(PredId, ProcId)),
-			MLDS_Params, MaybeStatement).
+			MLDS_Params, MaybeStatement, MLDSAttributes).
 
 	% for model_det and model_semi procedures,
 	% figure out which output variables are returned by
@@ -3080,6 +3087,22 @@
 			{ error("model_non disj in model_det disjunction") }
 		)
 	).
+
+%-----------------------------------------------------------------------------%
+%
+% Code for handling attributes
+%
+
+:- func attributes_to_mlds_attributes(module_info, list(hlds_pred__attribute))
+		= list(mlds__attribute).
+attributes_to_mlds_attributes(ModuleInfo, Attrs) =
+	list__map(attribute_to_mlds_attribute(ModuleInfo), Attrs).
+
+:- func attribute_to_mlds_attribute(module_info, hlds_pred__attribute)
+	= mlds__attribute.
+attribute_to_mlds_attribute(ModuleInfo, custom(Type)) = 
+	custom(mercury_type_to_mlds_type(ModuleInfo, Type)).
+
 
 :- func this_file = string.
 this_file = "mlds_to_c.m".
Index: compiler/ml_code_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_util.m,v
retrieving revision 1.33.4.2
diff -u -r1.33.4.2 ml_code_util.m
--- compiler/ml_code_util.m	2001/05/14 12:21:51	1.33.4.2
+++ compiler/ml_code_util.m	2001/05/18 12:50:17
@@ -912,7 +912,9 @@
 	%
 	{ DeclFlags = ml_gen_label_func_decl_flags },
 	{ MaybePredProcId = no },
-	{ FuncDefn = function(MaybePredProcId, FuncParams, yes(Statement)) },
+	{ Attributes = [] },
+	{ FuncDefn = function(MaybePredProcId, FuncParams, yes(Statement),
+		Attributes) },
 	{ Func = mlds__defn(FuncName, mlds__make_context(Context), DeclFlags,
 			FuncDefn) }.
 
@@ -1760,14 +1762,13 @@
 
 	{ 
 		Defn = mlds__defn(function(PredLabel, ProcId, 
-			yes(SeqNum), _), _, _, function(_, _, yes(_)))
+			yes(SeqNum), _), _, _, function(_, _, yes(_), _))
 	->
 		% We call the proxy function.
 		QualProcLabel = qual(MLDS_Module, PredLabel - ProcId),
 		ProxyFuncRval = const(code_addr_const(
 			internal(QualProcLabel, SeqNum, ProxySignature))),
 
-	
 		% Put it inside a block where we call it.
 		MLDS_Stmt = call(ProxySignature, ProxyFuncRval, ObjectRval,
 			ProxyArgRvals, RetLvals, CallOrTailcall),
Index: compiler/ml_elim_nested.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_elim_nested.m,v
retrieving revision 1.23.4.2
diff -u -r1.23.4.2 ml_elim_nested.m
--- compiler/ml_elim_nested.m	2001/05/14 12:21:51	1.23.4.2
+++ compiler/ml_elim_nested.m	2001/05/18 12:50:17
@@ -161,7 +161,8 @@
 		mlds__defn) = list(mlds__defn).
 ml_elim_nested_defns(ModuleName, Globals, OuterVars, Defn0) = FlatDefns :-
 	Defn0 = mlds__defn(Name, Context, Flags, DefnBody0),
-	( DefnBody0 = mlds__function(PredProcId, Params, yes(FuncBody0)) ->
+	( DefnBody0 = mlds__function(PredProcId, Params, yes(FuncBody0),
+			Attributes) ->
 		EnvName = ml_env_name(Name),
 			% XXX this should be optimized to generate 
 			% EnvTypeName from just EnvName
@@ -270,7 +271,8 @@
 				HoistedDefns = HoistedDefns0
 			)
 		),
-		DefnBody = mlds__function(PredProcId, Params, yes(FuncBody)),
+		DefnBody = mlds__function(PredProcId, Params, yes(FuncBody),
+			Attributes),
 		Defn = mlds__defn(Name, Context, Flags, DefnBody),
 		FlatDefns = list__append(HoistedDefns, [Defn])
 	;
@@ -465,7 +467,8 @@
 ml_insert_init_env(TypeName, ModuleName, Globals, Defn0, Defn, Init0, Init) :-
 	Defn0 = mlds__defn(Name, Context, Flags, DefnBody0),
 	(
-		DefnBody0 = mlds__function(PredProcId, Params, yes(FuncBody0)),
+		DefnBody0 = mlds__function(PredProcId, Params, yes(FuncBody0),
+			Attributes),
 		statement_contains_var(FuncBody0, qual(ModuleName,
 			mlds__var_name("env_ptr", no)))
 	->
@@ -476,7 +479,8 @@
 			EnvPtrDecl, InitEnvPtr),
 		FuncBody = mlds__statement(block([EnvPtrDecl],
 				[InitEnvPtr, FuncBody0]), Context),
-		DefnBody = mlds__function(PredProcId, Params, yes(FuncBody)),
+		DefnBody = mlds__function(PredProcId, Params, yes(FuncBody),
+			Attributes),
 		Defn = mlds__defn(Name, Context, Flags, DefnBody),
 		Init = yes
 	;
@@ -782,7 +786,8 @@
 flatten_nested_defn(Defn0, FollowingDefns, FollowingStatements, Defns) -->
 	{ Defn0 = mlds__defn(Name, Context, Flags0, DefnBody0) },
 	(
-		{ DefnBody0 = mlds__function(PredProcId, Params, FuncBody0) },
+		{ DefnBody0 = mlds__function(PredProcId, Params, FuncBody0,
+			Attributes) },
 		%
 		% recursively flatten the nested function
 		%
@@ -796,7 +801,8 @@
 		{ Flags1 = set_access(Flags0, private) },
 		{ Flags = set_per_instance(Flags1, one_copy) },
 
-		{ DefnBody = mlds__function(PredProcId, Params, FuncBody) },
+		{ DefnBody = mlds__function(PredProcId, Params, FuncBody,
+			Attributes) },
 		{ Defn = mlds__defn(Name, Context, Flags, DefnBody) },
 
 		% Note that we assume that we can safely hoist stuff
@@ -883,7 +889,7 @@
 	),
 	(
 		FollowingDefn = mlds__defn(_, _, _,
-			mlds__function(_, _, _)),
+			mlds__function(_, _, _, _)),
 		defn_contains_var(FollowingDefn, QualVarName)
 	;
 		FollowingDefn = mlds__defn(_, _, _,
@@ -1184,7 +1190,7 @@
 :- mode defn_body_contains_defn(in, out) is nondet.
 
 % defn_body_contains_defn(mlds__data(_Type, _Initializer), _Defn) :- fail.
-defn_body_contains_defn(mlds__function(_PredProcId, _Params, MaybeBody),
+defn_body_contains_defn(mlds__function(_PredProcId, _Params, MaybeBody, _Attrs),
 		Name) :-
 	maybe_statement_contains_defn(MaybeBody, Name).
 defn_body_contains_defn(mlds__class(ClassDefn), Name) :-
@@ -1312,7 +1318,7 @@
 
 defn_body_contains_var(mlds__data(_Type, Initializer), Name) :-
 	initializer_contains_var(Initializer, Name).
-defn_body_contains_var(mlds__function(_PredProcId, _Params, MaybeBody),
+defn_body_contains_var(mlds__function(_PredProcId, _Params, MaybeBody, _Attrs),
 		Name) :-
 	maybe_statement_contains_var(MaybeBody, Name).
 defn_body_contains_var(mlds__class(ClassDefn), Name) :-
Index: compiler/ml_optimize.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_optimize.m,v
retrieving revision 1.7.4.1
diff -u -r1.7.4.1 ml_optimize.m
--- compiler/ml_optimize.m	2001/05/03 13:04:47	1.7.4.1
+++ compiler/ml_optimize.m	2001/05/18 12:50:17
@@ -74,13 +74,15 @@
 optimize_in_defn(ModuleName, Globals, Defn0) = Defn :-
 	Defn0 = mlds__defn(Name, Context, Flags, DefnBody0),
 	(
-		DefnBody0 = mlds__function(PredProcId, Params, FuncBody0),
+		DefnBody0 = mlds__function(PredProcId, Params, FuncBody0,
+			Attributes),
 		OptInfo = opt_info(Globals, ModuleName, Name, Params, Context),
 
 		FuncBody1 = optimize_func(OptInfo, FuncBody0),
 		FuncBody = optimize_in_maybe_statement(OptInfo, FuncBody1),
 
-		DefnBody = mlds__function(PredProcId, Params, FuncBody),
+		DefnBody = mlds__function(PredProcId, Params, FuncBody,
+			Attributes),
 		Defn = mlds__defn(Name, Context, Flags, DefnBody)
 	;
 		DefnBody0 = mlds__data(_, _),
Index: compiler/ml_tailcall.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_tailcall.m,v
retrieving revision 1.6
diff -u -r1.6 ml_tailcall.m
--- compiler/ml_tailcall.m	2001/02/20 07:52:18	1.6
+++ compiler/ml_tailcall.m	2001/05/18 12:50:17
@@ -113,7 +113,8 @@
 mark_tailcalls_in_defn(Defn0) = Defn :-
 	Defn0 = mlds__defn(Name, Context, Flags, DefnBody0),
 	(
-		DefnBody0 = mlds__function(PredProcId, Params, FuncBody0),
+		DefnBody0 = mlds__function(PredProcId, Params, FuncBody0,
+			Attributes),
 		%
 		% Compute the initial value of the `Locals' and
 		% `AtTail' arguments.
@@ -127,7 +128,8 @@
 		),
 		FuncBody = mark_tailcalls_in_maybe_statement(FuncBody0,
 			AtTail, Locals),
-		DefnBody = mlds__function(PredProcId, Params, FuncBody),
+		DefnBody = mlds__function(PredProcId, Params, FuncBody,
+			Attributes),
 		Defn = mlds__defn(Name, Context, Flags, DefnBody)
 	;
 		DefnBody0 = mlds__data(_, _),
Index: compiler/ml_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_util.m,v
retrieving revision 1.7.4.2
diff -u -r1.7.4.2 ml_util.m
--- compiler/ml_util.m	2001/05/14 12:21:52	1.7.4.2
+++ compiler/ml_util.m	2001/05/18 12:50:18
@@ -279,7 +279,7 @@
 
 defn_contains_foreign_code(NativeTargetLang, Defn) :-
 	Defn = mlds__defn(_Name, _Context, _Flags, Body),
-	Body = function(_, _, yes(FunctionBody)),
+	Body = function(_, _, yes(FunctionBody), _),
 	statement_contains_statement(FunctionBody, Statement),
 	Statement = mlds__statement(Stmt, _),
 	( 
@@ -291,7 +291,7 @@
 
 defn_contains_outline_foreign_proc(ForeignLang, Defn) :-
 	Defn = mlds__defn(_Name, _Context, _Flags, Body),
-	Body = function(_, _, yes(FunctionBody)),
+	Body = function(_, _, yes(FunctionBody), _),
 	statement_contains_statement(FunctionBody, Statement),
 	Statement = mlds__statement(Stmt, _),
 	Stmt = atomic(outline_foreign_proc(ForeignLang, _, _)).
Index: compiler/mlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds.m,v
retrieving revision 1.49.4.6
diff -u -r1.49.4.6 mlds.m
--- compiler/mlds.m	2001/05/14 12:21:52	1.49.4.6
+++ compiler/mlds.m	2001/05/18 12:50:18
@@ -416,12 +416,13 @@
 			maybe(pred_proc_id),	% identifies the original
 						% Mercury procedure, if any
 			mlds__func_params,	% the arguments & return types
-			maybe(mlds__statement)	% the function body, or `no'
+			maybe(mlds__statement),	% the function body, or `no'
 						% if the function is abstract
 						% or if the function is defined
 						% externally (i.e. the original
 						% Mercury procedure was declared
 						% `:- external').
+			list(mlds__attribute)	% attributes
 		)
 		% packages, classes, interfaces, structs, enums
 	;	mlds__class(
@@ -687,6 +688,15 @@
 		mlds__context
 	).
 
+%-----------------------------------------------------------------------------%
+%
+% Attributes
+%
+
+:- type mlds__attribute
+	---> custom(
+		mlds__type
+	).
 
 %-----------------------------------------------------------------------------%
 %
Index: compiler/mlds_to_c.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_c.m,v
retrieving revision 1.83.4.6
diff -u -r1.83.4.6 mlds_to_c.m
--- compiler/mlds_to_c.m	2001/05/14 12:21:52	1.83.4.6
+++ compiler/mlds_to_c.m	2001/05/18 12:50:19
@@ -776,7 +776,7 @@
 		globals__io_lookup_bool_option(highlevel_data, HighLevelData),
 		(
 			{ HighLevelData = yes },
-			{ DefnBody = mlds__function(_, Signature, _) }
+			{ DefnBody = mlds__function(_, Signature, _, _) }
 		->
 			{ Signature = mlds__func_params(Parameters,
 				_RetTypes) },
@@ -883,7 +883,7 @@
 		mlds_output_data_decl(Name, Type, initializer_array_size(Initializer))
 	;
 		{ DefnBody = mlds__function(MaybePredProcId, Signature,
-			_MaybeBody) },
+			_MaybeBody, _Attrs) },
 		mlds_output_maybe(MaybePredProcId, mlds_output_pred_proc_id),
 		mlds_output_func_decl(Indent, Name, Context, Signature)
 	;
@@ -902,7 +902,7 @@
 		mlds_output_data_defn(Name, Type, Initializer)
 	;
 		{ DefnBody = mlds__function(MaybePredProcId, Signature,
-			MaybeBody) },
+			MaybeBody, _Attributes) },
 		mlds_output_maybe(MaybePredProcId, mlds_output_pred_proc_id),
 		mlds_output_func(Indent, Name, Context, Signature, MaybeBody)
 	;
@@ -1799,7 +1799,7 @@
 		{ Name \= type(_, _) },
 		% Don't output "static" for functions that don't have a body.
 		% This can happen for Mercury procedures declared `:- external'
-		{ DefnBody \= mlds__function(_, _, no) }
+		{ DefnBody \= mlds__function(_, _, no, _) }
 	->
 		io__write_string("static ")
 	;
Index: compiler/mlds_to_csharp.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_csharp.m,v
retrieving revision 1.1.2.3
diff -u -r1.1.2.3 mlds_to_csharp.m
--- compiler/mlds_to_csharp.m	2001/05/08 11:46:26	1.1.2.3
+++ compiler/mlds_to_csharp.m	2001/05/18 12:50:20
@@ -195,7 +195,9 @@
 	_Context, _DeclFlags, Entity)) -->
 
 	( 
-		{ Entity = mlds__function(_, Params, yes(Statement)) },
+			% XXX we ignore the attributes
+		{ Entity = mlds__function(_, Params, yes(Statement),
+			_Attributes) },
 		{ has_foreign_languages(Statement, Langs) },
 		{ list__member(csharp, Langs) }
 	->
Index: compiler/mlds_to_gcc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_gcc.m,v
retrieving revision 1.36.4.2
diff -u -r1.36.4.2 mlds_to_gcc.m
--- compiler/mlds_to_gcc.m	2001/05/14 12:21:54	1.36.4.2
+++ compiler/mlds_to_gcc.m	2001/05/18 12:50:20
@@ -788,7 +788,7 @@
 		{ GlobalInfo = GlobalInfo0 ^ global_vars := GlobalVars }
 	;
 		{ DefnBody = mlds__function(_MaybePredProcId, Signature,
-			MaybeBody) },
+			MaybeBody, _Attributes) },
 		gen_func(Name, Context, Flags, Signature, MaybeBody,
 			GlobalInfo0, GlobalInfo)
 	;
@@ -808,7 +808,7 @@
 		build_local_data_defn(Name, Flags, Type,
 			Initializer, DefnInfo, GCC_Defn)
 	;
-		{ DefnBody = mlds__function(_, _, _) },
+		{ DefnBody = mlds__function(_, _, _, _) },
 		% nested functions should get eliminated by ml_elim_nested,
 		% unless --gcc-nested-functions is enabled.
 		% XXX --gcc-nested-functions is not yet implemented
@@ -835,7 +835,7 @@
 			GCC_Defn),
 		add_field_decl_flags(Flags, GCC_Defn)
 	;
-		{ DefnBody = mlds__function(_, _, _) },
+		{ DefnBody = mlds__function(_, _, _, _) },
 		{ unexpected(this_file, "function nested in type") }
 	;
 		{ DefnBody = mlds__class(_) },
@@ -1661,7 +1661,7 @@
 		gcc__type, io__state, io__state).
 :- mode build_type(in, in, in, out, di, uo) is det.
 
-build_type(mercury_type(Type, TypeCategory), _, _, GCC_Type) -->
+build_type(mercury_type(Type, TypeCategory, _ExportType), _, _, GCC_Type) -->
 	build_mercury_type(Type, TypeCategory, GCC_Type).
 build_type(mlds__native_int_type, _, _, gcc__integer_type_node) --> [].
 build_type(mlds__native_float_type, _, _, gcc__double_type_node) --> [].
@@ -2796,7 +2796,7 @@
 	% sanity check (copied from mlds_to_c.m)
 	(
 		{ FieldType = mlds__generic_type
-		; FieldType = mlds__mercury_type(term__variable(_), _)
+		; FieldType = mlds__mercury_type(term__variable(_), _, _)
 		}
 	->
 		[]
@@ -2995,7 +2995,7 @@
 :- pred type_is_float(mlds__type::in) is semidet.
 type_is_float(Type) :-
 	( Type = mlds__mercury_type(term__functor(term__atom("float"),
-			[], _), _)
+			[], _), _, _)
 	; Type = mlds__native_float_type
 	).
 
Index: compiler/mlds_to_il.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_il.m,v
retrieving revision 1.15.4.16
diff -u -r1.15.4.16 mlds_to_il.m
--- compiler/mlds_to_il.m	2001/05/14 14:30:29	1.15.4.16
+++ compiler/mlds_to_il.m	2001/05/18 12:50:21
@@ -162,7 +162,7 @@
 		% class-wide attributes (all accumulate)
 	alloc_instrs	:: instr_tree,		% .cctor allocation instructions
 	init_instrs	:: instr_tree,		% .cctor init instructions
-	classdecls	:: list(classdecl),	% class methods and fields 
+	class_members	:: list(class_member),	% class methods and fields 
 	has_main	:: bool,		% class contains main
 	class_foreign_langs :: set(foreign_language),% class foreign code
 		% method-wide attributes (accumulating)
@@ -202,7 +202,7 @@
 	;
 		Info2 = Info1
 	),
-	ClassDecls = Info2 ^ classdecls,
+	ClassMembers = Info2 ^ class_members,
 	InitInstrs = list__condense(tree__flatten(Info2 ^ init_instrs)),
 	AllocInstrs = list__condense(tree__flatten(Info2 ^ alloc_instrs)),
 
@@ -251,11 +251,11 @@
 		AllocDoneFieldRef, AllocDoneField),
 
 		% Generate a class constructor.
-	make_class_constructor_classdecl(AllocDoneFieldRef,
+	make_class_constructor_class_member(AllocDoneFieldRef,
 		Imports, AllocInstrs, InitInstrs, CCtor, Info3, _Info),
 
 		% The declarations in this class.
-	MethodDecls = [AllocDoneField, CCtor | ClassDecls],
+	MethodDecls = [AllocDoneField, CCtor | ClassMembers],
 
 	SimpleClassName = get_class_suffix(ClassName),
 	NamespaceName = get_class_namespace(ClassName),
@@ -288,7 +288,8 @@
 generate_method_defn(FunctionDefn) -->
 	{ FunctionDefn = defn(function(PredLabel, ProcId, MaybeSeqNum, PredId), 
 		Context, DeclsFlags, Entity) },
-	( { Entity = mlds__function(_PredProcId, Params, MaybeStatement) } ->
+	( { Entity = mlds__function(_PredProcId, Params, MaybeStatement,
+		Attributes) } ->
 
 		il_info_get_module_name(ModuleName),
 			% Generate a term (we use it to emit the complete
@@ -345,6 +346,10 @@
 			{ EntryPoint = [] }
 		),
 
+			% Generate the custom attributes
+		{ CustomAttrs = attributes_to_custom_attributes(DataRep,
+			Attributes) },
+
 			% Need to insert a ret for functions returning
 			% void (MLDS doesn't).
 		{ Returns = [] ->
@@ -367,20 +372,33 @@
 
 			% Generate the entire method contents.
 		{ MethodBody = make_method_defn(InstrsTree) },
-		{ list__append(EntryPoint, MethodBody, MethodContents) },
+		{ list__condense([EntryPoint, CustomAttrs, MethodBody],
+			MethodContents) },
 
 			% Add this method and a comment to the class
 			% declarations.
-		{ ClassDecls = [
+		{ ClassMembers = [
 			comment_term(MLDSDefnTerm),
 			ilasm__method(methodhead([static], id(Id), 
 				ILSignature, []), MethodContents)
 		] },
-		il_info_add_classdecls(ClassDecls)
+		il_info_add_class_members(ClassMembers)
 	;
 		{ error("entity not a function") }
 	).
 
+:- func attributes_to_custom_attributes(il_data_rep, list(mlds__attribute))
+		= list(method_body_decl).
+attributes_to_custom_attributes(DataRep, Attrs) = 
+	list__map(attribute_to_custom_attribute(DataRep), Attrs).
+
+:- func attribute_to_custom_attribute(il_data_rep, mlds__attribute)
+		= method_body_decl.
+attribute_to_custom_attribute(DataRep, custom(MLDSType)) = custom(CustomDecl) :-
+	ClassName = mlds_type_to_ilds_class_name(DataRep, MLDSType),
+	MethodRef = get_constructor_methoddef(ClassName),
+	CustomDecl = custom_decl(methodref(MethodRef), no, no_initalizer).
+
 
 generate_method_defn(DataDefn) --> 
 	{ DataDefn = defn(data(DataName), Context, _DeclsFlags, Entity) },
@@ -481,11 +499,11 @@
 			% and a comment term to the class decls.
 		{ Field = field([public, static], il_array_type,
 			FieldName, no, none) },
-		{ ClassDecls = [comment_term(MLDSDefnTerm), Field] }
+		{ ClassMembers = [comment_term(MLDSDefnTerm), Field] }
 	;
 		{ error("entity not data") }
 	),
-	il_info_add_classdecls(ClassDecls).
+	il_info_add_class_members(ClassMembers).
 	
 	% Generate top level declarations for "other" things (e.g.
 	% anything that is not a method in the main class).
@@ -657,32 +675,32 @@
 % Code to turn MLDS definitions into IL class declarations.
 %
 
-:- pred defn_to_class_decl(mlds__defn, ilasm__classdecl, il_info, il_info).
+:- pred defn_to_class_decl(mlds__defn, class_member, il_info, il_info).
 :- mode defn_to_class_decl(in, out, in, out) is det.
 
 	% XXX shouldn't we re-use the code for creating fieldrefs here?
 	% IL doesn't allow byrefs in classes, so we don't use them.
 	% XXX really this should be a transformation done in advance
 defn_to_class_decl(mlds__defn(Name, _Context, _DeclFlags, 
-		mlds__data(Type, _Initializer)), ILClassDecl) -->
+		mlds__data(Type, _Initializer)), ILClassMember) -->
 	DataRep =^ il_data_rep,
 	{ ILType = remove_byrefs_from_type(
 			mlds_type_to_ilds_type(DataRep, Type)) },
 	{ Name = data(DataName) ->
 		mangle_dataname(DataName, MangledName),
-		ILClassDecl = field([], ILType, MangledName, no, none) 
+		ILClassMember = field([], ILType, MangledName, no, none) 
 	;
 		error("definintion name was not data/1")
 	}.
 
 	% XXX this needs to be implemented
 defn_to_class_decl(mlds__defn(_Name, _Context, _DeclFlags,
-	mlds__function(_PredProcId, _Params, _MaybeStatements)),
-		ILClassDecl) -->
-	{ ILClassDecl = comment("unimplemented: functions in classes") }.
+	mlds__function(_PredProcId, _Params, _MaybeStatements, _Attributes)),
+		ILClassMember) -->
+	{ ILClassMember = comment("unimplemented: functions in classes") }.
 
 defn_to_class_decl(mlds__defn(EntityName, _Context, _DeclFlags,
-		mlds__class(ClassDefn)), ILClassDecl) -->
+		mlds__class(ClassDefn)), ILClassMember) -->
 	DataRep =^ il_data_rep,
 	( { EntityName = type(TypeName0, Arity) } ->
 		{ TypeName = string__format("%s_%d",
@@ -694,7 +712,7 @@
 		{ make_constructor(DataRep, FullClassName, ClassDefn,
 			ConstructorILDefn) },
 		{ Extends = mlds_inherits_to_ilds_inherits(DataRep, Inherits) },
-		{ ILClassDecl = nested_class([public], TypeName, Extends,
+		{ ILClassMember = nested_class([public], TypeName, Extends,
 			implements([]), [ConstructorILDefn | ILDefns]) }
 	;
 		{ error("expected type entity name for a nested class") }
@@ -1751,10 +1769,11 @@
 	% 	<initialization instructions generated by field initializers>
 	%
 
-:- pred make_class_constructor_classdecl(fieldref, mlds__imports,
-	list(instr), list(instr), classdecl, il_info, il_info).
-:- mode make_class_constructor_classdecl(in, in, in, in, out, in, out) is det.
-make_class_constructor_classdecl(DoneFieldRef, Imports, AllocInstrs, 
+:- pred make_class_constructor_class_member(fieldref, mlds__imports,
+	list(instr), list(instr), class_member, il_info, il_info).
+:- mode make_class_constructor_class_member(in, in, in, in,
+	out, in, out) is det.
+make_class_constructor_class_member(DoneFieldRef, Imports, AllocInstrs, 
 		InitInstrs, Method) -->
 	{ Method = method(methodhead([static], cctor, 
 		signature(call_conv(no, default), void, []), []),
@@ -1787,7 +1806,7 @@
 
 
 :- pred generate_rtti_initialization_field(ilds__class_name, 
-		fieldref, classdecl).
+		fieldref, class_member).
 :- mode generate_rtti_initialization_field(in, out, out) is det.
 generate_rtti_initialization_field(ClassName, AllocDoneFieldRef,
 		AllocDoneField) :-
@@ -2738,7 +2757,7 @@
 	% to intialize any class.
 
 :- pred make_constructor(il_data_rep, ilds__class_name, mlds__class_defn,
-	ilasm__classdecl).
+	ilasm__class_member).
 :- mode make_constructor(in, in, in, out) is det.
 make_constructor(DataRep, ClassName, 
 		mlds__class_defn(_,  _Imports, Inherits, _Implements, Defns),
@@ -2758,7 +2777,7 @@
 		 node(FieldConstrInstrs),
 		 instr_node(ret)
 		 ])),
-	ILDecl = make_constructor_classdecl(MethodDecls).
+	ILDecl = make_constructor_class_member(MethodDecls).
 
 
 	% XXX This should really be generated at a higher level	
@@ -2845,8 +2864,8 @@
 	methoddef(call_conv(no, default), RetType,
 		class_member_name(ClassName, MethodName), TypeParams).
 
-:- func make_constructor_classdecl(method_defn) = classdecl.
-make_constructor_classdecl(MethodDecls) = method(
+:- func make_constructor_class_member(method_defn) = class_member.
+make_constructor_class_member(MethodDecls) = method(
 	methodhead([], ctor, signature(call_conv(no, default), 
 		void, []), []), MethodDecls).
 
@@ -2964,11 +2983,11 @@
 	map__delete_list(Info0 ^ locals, Keys, NewLocals),
 	Info = Info0 ^ locals := NewLocals.
 
-:- pred il_info_add_classdecls(list(classdecl), il_info, il_info).
-:- mode il_info_add_classdecls(in, in, out) is det.
-il_info_add_classdecls(ClassDecls, Info0, Info) :- 
-	Info = Info0 ^ classdecls := 
-		list__append(ClassDecls, Info0 ^ classdecls).
+:- pred il_info_add_class_members(list(class_member), il_info, il_info).
+:- mode il_info_add_class_members(in, in, out) is det.
+il_info_add_class_members(ClassMembers, Info0, Info) :- 
+	Info = Info0 ^ class_members := 
+		list__append(ClassMembers, Info0 ^ class_members).
 
 :- pred il_info_add_instructions(list(instr), il_info, il_info).
 :- mode il_info_add_instructions(in, in, out) is det.
Index: compiler/mlds_to_java.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_java.m,v
retrieving revision 1.2.4.5
diff -u -r1.2.4.5 mlds_to_java.m
--- compiler/mlds_to_java.m	2001/05/14 12:21:56	1.2.4.5
+++ compiler/mlds_to_java.m	2001/05/18 12:50:22
@@ -419,7 +419,7 @@
 	(
 		Name0 = function(_Label0, ProcID, MaybeSeqNum, PredID),
 		Body0 = mlds__function(MaybeID, Params0, 
-			MaybeStatements0),
+			MaybeStatements0, Attributes),
 		MaybeStatements0 = yes(Statements0),
 		Statements0 = mlds__statement(
 			block(BlockDefns0, _BlockList0), _) 
@@ -456,7 +456,8 @@
 		% Put it all together.
 		%
 		Params = mlds__func_params(Args, RetTypes),
-		Body   = mlds__function(MaybeID, Params, yes(Statements)),
+		Body   = mlds__function(MaybeID, Params, yes(Statements),
+			Attributes),
 		Flags  = ml_gen_special_member_decl_flags,	
 		Defn   = mlds__defn(Name, Context, Flags, Body) 
 	;
@@ -622,7 +623,8 @@
 output_defn_body(_, Name, _, mlds__data(Type, Initializer)) -->
 	output_data_defn(Name, Type, Initializer).
 output_defn_body(Indent, Name, Context, 
-		mlds__function(MaybePredProcId, Signature, MaybeBody)) -->
+		mlds__function(MaybePredProcId, Signature, MaybeBody,
+			_Attributes)) -->
 	output_maybe(MaybePredProcId, output_pred_proc_id),
 	output_func(Indent, Name, Context, Signature, MaybeBody).
 output_defn_body(Indent, Name, Context, mlds__class(ClassDefn)) -->
Index: compiler/mlds_to_mcpp.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds_to_mcpp.m,v
retrieving revision 1.2.2.3
diff -u -r1.2.2.3 mlds_to_mcpp.m
--- compiler/mlds_to_mcpp.m	2001/05/14 14:30:30	1.2.2.3
+++ compiler/mlds_to_mcpp.m	2001/05/18 12:50:22
@@ -210,7 +210,8 @@
 		defn(function(PredLabel, ProcId, MaybeSeqNum, _PredId), 
 	_Context, _DeclFlags, Entity)) -->
 	( 
-		{ Entity = mlds__function(_, Params, yes(Statement)) },
+			% XXX we ignore the attributes
+		{ Entity = mlds__function(_, Params, yes(Statement), _) },
 		( 
 			{ has_inline_target_code_statement(Statement) }
 		;
Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.65.2.3
diff -u -r1.65.2.3 module_qual.m
--- compiler/module_qual.m	2001/05/08 11:46:28	1.65.2.3
+++ compiler/module_qual.m	2001/05/18 12:50:23
@@ -1002,6 +1002,8 @@
 		Info, Info) --> [].
 qualify_pragma(check_termination(A, B), check_termination(A, B), Info, 
 		Info) --> [].
+qualify_pragma(attribute(A, B, Type0), attribute(A, B, Type), Info0, Info) -->
+	qualify_type(Type0, Type, Info0, Info).
 
 :- pred qualify_pragma_vars(list(pragma_var)::in, list(pragma_var)::out,
 		mq_info::in, mq_info::out, io__state::di, io__state::uo) is det.
Index: compiler/modules.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.158.2.5
diff -u -r1.158.2.5 modules.m
--- compiler/modules.m	2001/05/14 12:21:57	1.158.2.5
+++ compiler/modules.m	2001/05/18 12:50:24
@@ -1047,6 +1047,7 @@
 pragma_allowed_in_interface(terminates(_, _), yes).
 pragma_allowed_in_interface(does_not_terminate(_, _), yes).
 pragma_allowed_in_interface(check_termination(_, _), yes).
+pragma_allowed_in_interface(attribute(_, _, _), no).
 	% `aditi', `base_relation', `index' and `owner' pragmas must be in the
 	% interface for exported preds. This is checked in make_hlds.m.
 pragma_allowed_in_interface(aditi(_, _), yes).
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.65.2.4
diff -u -r1.65.2.4 prog_data.m
--- compiler/prog_data.m	2001/05/08 11:46:32	1.65.2.4
+++ compiler/prog_data.m	2001/05/18 12:50:26
@@ -275,8 +275,11 @@
 	;	does_not_terminate(sym_name, arity)
 			% Predname, Arity
 
-	;	check_termination(sym_name, arity).
+	;	check_termination(sym_name, arity)
 			% Predname, Arity
+	
+	;	attribute(sym_name, arity, type).
+			% Predname, Arity, TypeName
 
 %
 % Stuff for tabling pragmas
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.30.2.2
diff -u -r1.30.2.2 prog_io_pragma.m
--- compiler/prog_io_pragma.m	2001/04/11 11:16:23	1.30.2.2
+++ compiler/prog_io_pragma.m	2001/05/18 12:50:27
@@ -74,7 +74,7 @@
             ErrorTerm, _VarSet, Result) :-
     ( PragmaTerms = [MercuryName, ForeignName, ForeignLocation] ->
 	parse_implicitly_qualified_term(ModuleName, MercuryName,
-		ErrorTerm, "`:- pragma unused_args' declaration",
+		ErrorTerm, "`:- pragma foreign_type' declaration",
 		MaybeMercuryType),
 	(
 	    MaybeMercuryType = ok(MercuryTypeSymName, MercuryArgs),
@@ -1086,6 +1086,40 @@
 		lambda([Name::in, Arity::in, Pragma::out] is det,
 			Pragma = check_termination(Name, Arity)),
 		PragmaTerms, ErrorTerm, Result).
+
+parse_pragma_type(ModuleName, "attribute", PragmaTerms,
+				ErrorTerm, _VarSet, Result) :-
+	PragmaType = "attribute",
+	( PragmaTerms = [PredAndArityTerm, TypeTerm] ->
+	    parse_pred_name_and_arity(ModuleName, PragmaType,
+		PredAndArityTerm, ErrorTerm, NameArityResult),
+	    (
+	    	NameArityResult = ok(PredName, Arity),
+		parse_implicitly_qualified_term(ModuleName, TypeTerm,
+		    ErrorTerm, "`:- pragma attribute' declaration",
+		    MaybeMercuryType),
+		(
+		    MaybeMercuryType = ok(_MercuryTypeSymName, MercuryArgs),
+		    ( MercuryArgs = [] ->
+			term__coerce(TypeTerm, MercuryType),
+			Pragma = attribute(PredName, Arity, MercuryType),
+			Result = ok(pragma(Pragma))
+		    ;
+			Result = error("attribute type arity not 0", ErrorTerm)
+		    )
+		;
+		    MaybeMercuryType = error(String, Term),
+		    Result = error(String, Term)
+		)
+	    ;
+		NameArityResult = error(ErrorMsg, _),
+	        Result = error(ErrorMsg, PredAndArityTerm)
+	    )
+	;
+	    string__append_list(["wrong number of arguments in `:- pragma ",
+		 PragmaType, "' declaration"], ErrorMsg),
+	    Result = error(ErrorMsg, ErrorTerm)
+	).
 
 :- pred parse_simple_pragma(module_name, string,
 			pred(sym_name, int, pragma_type),


-- 
       Tyson Dowd           # 
                            #  Surreal humour isn't everyone's cup of fur.
     trd at cs.mu.oz.au        # 
http://www.cs.mu.oz.au/~trd #
--------------------------------------------------------------------------
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