[m-rev.] uncommitted diff: pragma attribute syntax

[Tyson Dowd]

For the record here is the patch which adds the pragma attribute syntax
from the dotnet-foreign branch.  It was merged up with the latest
Mercury compiler, but I didn't commit as the syntax is not yet final.


Index: make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.381
diff -u -r1.381 make_hlds.m
--- make_hlds.m	2001/08/20 15:15:21	1.381
+++ make_hlds.m	2001/08/24 12:51:18
@@ -522,6 +522,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(
@@ -8311,3 +8315,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: mercury_to_mercury.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.191
diff -u -r1.191 mercury_to_mercury.m
--- mercury_to_mercury.m	2001/08/10 08:29:27	1.191
+++ mercury_to_mercury.m	2001/08/24 12:51:19
@@ -557,6 +557,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), _) -->
@@ -2874,6 +2877,23 @@
 	add_string(", ["),
 	mercury_format_int_list(Attrs),
 	add_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(", "),
+	format_type(varset__init, no, AttributeType),
+	io__write_string(").\n").
 
 %-----------------------------------------------------------------------------%
 
Index: module_qual.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.68
diff -u -r1.68 module_qual.m
--- module_qual.m	2001/06/27 05:04:15	1.68
+++ module_qual.m	2001/08/24 12:51:30
@@ -955,6 +955,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: modules.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.196
diff -u -r1.196 modules.m
--- modules.m	2001/08/20 14:07:20	1.196
+++ modules.m	2001/08/24 12:51:33
@@ -1158,6 +1158,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: prog_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.69
diff -u -r1.69 prog_data.m
--- prog_data.m	2001/07/18 10:20:57	1.69
+++ prog_data.m	2001/08/24 12:51:33
@@ -270,8 +270,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: prog_io_pragma.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.33
diff -u -r1.33 prog_io_pragma.m
--- prog_io_pragma.m	2001/07/18 10:20:58	1.33
+++ prog_io_pragma.m	2001/08/24 12:51:34
@@ -1069,6 +1069,40 @@
 			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),
 			list(term), term, maybe1(item)).
Index: recompilation_version.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/recompilation_version.m,v
retrieving revision 1.4
diff -u -r1.4 recompilation_version.m
--- recompilation_version.m	2001/07/24 17:16:43	1.4
+++ recompilation_version.m	2001/08/24 12:51:34
@@ -487,6 +487,7 @@
 is_pred_pragma(terminates(Name, Arity), yes(no - Name / Arity)).
 is_pred_pragma(does_not_terminate(Name, Arity), yes(no - Name / Arity)).
 is_pred_pragma(check_termination(Name, Arity), yes(no - Name / Arity)).
+is_pred_pragma(attribute(Name, Arity, _), yes(no - Name / Arity)).
 
 	% XXX This is a bit brittle (need to be careful with term__contexts).
 	% For example, it won't work for clauses.
--------------------------------------------------------------------------
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
--------------------------------------------------------------------------