for review: pragma import

Fergus Henderson fjh at cs.mu.oz.au
Fri Jan 9 22:38:02 AEDT 1998


The following version addresses Zoltan's review comments.

----------------------------------------------------------------------

Estimated hours taken: 20

Add support for `pragma import', which is a simplified form of
`pragma c_code'.  With `pragma import', the user specifies only
the C function name, rather than a C code fragment, and the
Mercury compiler handles the argument-passing automatically.

TODO:
- add documentation to doc/reference_manual.texi.

WISHLIST:
- change `pragma import' and `pragma export'
  to take an additional parameter indicating the language
  (e.g. C, Prolog, Ada, Fortran, etc.)

compiler/prog_data.m:
	Add `pragma import' to the parse tree data structure.

compiler/prog_io_pragma.m:
	Add code to parse `pragma import' declarations.

compiler/mercury_to_mercury.m:
	Add code to pretty-print `pragma import' declarations.

compiler/module_qual.m:
	Add code to module-qualify `pragma import' declarations.

compiler/make_hlds.m:
	Add code to process `pragma import' declarations,
	by converting them to clauses with HLDS `c_code' instructions.

compiler/export.m:
	Declare `export__exclude_argument_type' in the interface,
	for use by the code for handling `pragma import' in make_hlds.m.
	Change the documentation to say that this procedure is used for
	both exported and imported procedures.

compiler/notes/compiler_design.html:
	Document how the compiler handles `pragma import' declarations.

tests/hard_coded/Mmakefile:
tests/hard_coded/pragma_import.m:
tests/hard_coded/pragma_import.exp:
	Add some test cases for `pragma import'.

cvs diff  TODO WISHLIST compiler/export.m compiler/make_hlds.m compiler/mercury_to_mercury.m compiler/module_qual.m compiler/notes/compiler_design.html compiler/prog_data.m compiler/prog_io_pragma.m tests/hard_coded/Mmakefile tests/hard_coded/pragma_import.exp tests/hard_coded/pragma_import.m
cvs diff: I know nothing about TODO
cvs diff: I know nothing about WISHLIST
Index: compiler/export.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/export.m,v
retrieving revision 1.17
diff -u -r1.17 export.m
--- export.m	1997/11/24 22:44:09	1.17
+++ export.m	1998/01/08 06:18:16
@@ -7,6 +7,9 @@
 % This module defines predicates to produce the functions which are
 % exported to C via a `pragma export' declaration.
 
+% Note: any changes here might also require similar changes to the handling
+% of `pragma import' declarations, which are handled in make_hlds.m.
+
 % Main authors: dgj.
 
 %-----------------------------------------------------------------------------%
@@ -45,6 +48,14 @@
 :- pred convert_type_from_mercury(string, type, string).
 :- mode convert_type_from_mercury(in, in, out) is det.
 
+	% Certain types, namely io__state and store__store(S),
+	% are just dummy types used to ensure logical semantics;
+	% there is no need to actually pass them, and so when
+	% importing or exporting procedures to/from C, we don't
+	% include arguments with these types.
+:- pred export__exclude_argument_type(type).
+:- mode export__exclude_argument_type(in) is semidet.
+
 :- implementation.
 
 :- import_module code_gen, code_util, hlds_pred, llds, llds_out.
@@ -413,10 +424,9 @@
 % Certain types, namely io__state and store__store(S),
 % are just dummy types used to ensure logical semantics;
 % there is no need to actually pass them, and so when
-% exporting procedures to C, we don't include arguments with
-% these types.
+% importing or exporting procedures to/from C, we don't
+% include arguments with these types.
 
-:- pred export__exclude_argument_type((type)::in) is semidet.
 export__exclude_argument_type(Type) :-
 	Type = term__functor(term__atom(":"), [
 			term__functor(term__atom(ModuleName), [], _),
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.249
diff -u -r1.249 make_hlds.m
--- make_hlds.m	1998/01/05 07:50:44	1.249
+++ make_hlds.m	1998/01/09 11:07:54
@@ -61,7 +61,7 @@
 :- import_module make_tags, quantification, (inst).
 :- import_module code_util, unify_proc, special_pred, type_util, mode_util.
 :- import_module mercury_to_mercury, passes_aux, clause_to_proc, inst_match.
-:- import_module fact_table, purity, term_util.
+:- import_module fact_table, purity, term_util, export, llds.
 
 :- import_module string, char, int, set, bintree, list, map, require.
 :- import_module bool, getopt, assoc_list, term, term_io, varset.
@@ -329,6 +329,11 @@
 		add_pred_marker(Module0, "obsolete", Name, Arity, Context,
 			obsolete, [], Module)
 	;
+		% Handle pragma import decls later on (when we process
+		% clauses and pragma c_code).
+		{ Pragma = import(_, _, _, _, _) },
+		{ Module = Module0 }
+	;
 		{ Pragma = export(Name, PredOrFunc, Modes, C_Function) },
 		{ module_info_get_predicate_table(Module0, PredTable) },
 		{ list__length(Modes, Arity) },
@@ -597,6 +602,13 @@
 			Vars, VarSet, C_Code, Status, Context, no,
 			Module0, Module, Info0, Info)
 	;
+		{ Pragma = import(Name, PredOrFunc, Modes, MayCallMercury,
+			C_Function) }
+	->
+		module_add_pragma_import(Name, PredOrFunc, Modes,
+			MayCallMercury, C_Function, Status, Context,
+			Module0, Module, Info0, Info)
+	;
 		{ Pragma = c_code(MayCallMercury, Pred, PredOrFunc, Vars, 
 			SavedVars, LabelNames, VarSet, C_Code) }
 	->
@@ -616,10 +628,10 @@
 		{ Info = Info0 }	
 	).
 add_item_clause(nothing, Status, Status, _, Module, Module, Info, Info) --> [].
-add_item_clause(typeclass(_, _, _, _, _)
-	, Status, Status, _, Module, Module, Info, Info) --> [].
-add_item_clause(instance(_, _, _, _, _)
-	, Status, Status, _, Module, Module, Info, Info) --> [].
+add_item_clause(typeclass(_, _, _, _, _),
+	Status, Status, _, Module, Module, Info, Info) --> [].
+add_item_clause(instance(_, _, _, _, _),
+	Status, Status, _, Module, Module, Info, Info) --> [].
 
 %-----------------------------------------------------------------------------%
 
@@ -1786,7 +1798,7 @@
 module_add_clause(ModuleInfo0, ClauseVarSet, PredName, Args, Body, Status,
 			Context, PredOrFunc, ModuleInfo, Info0, Info) -->
 		% Lookup the pred declaration in the predicate table.
-		% (if it's not there, call maybe_undefined_pred_error
+		% (If it's not there, call maybe_undefined_pred_error
 		% and insert an implicit declaration for the predicate.)
 	{ module_info_name(ModuleInfo0, ModuleName) },
 	{ list__length(Args, Arity) },
@@ -1812,6 +1824,8 @@
 		% and then save the pred_info.
 	{ predicate_table_get_preds(PredicateTable1, Preds0) },
 	{ map__lookup(Preds0, PredId, PredInfo0) },
+	% opt_imported preds are initially tagged as imported and are
+	% tagged as opt_imported only if/when we see a clause for them
 	{ Status = opt_imported ->
 		pred_info_set_import_status(PredInfo0, opt_imported, PredInfo1)
 	;
@@ -1899,6 +1913,328 @@
 	module_info_set_c_body_code(Module0, C_Body_List, Module).
 	
 %-----------------------------------------------------------------------------%
+%
+% module_add_pragma_import:
+%	Handles `pragma import' declarations, by figuring out which predicate
+%	the `pragma import' declaration applies to, and adding a clause
+%	for that predicate containing an appropriate HLDS `pragma_c_code'
+%	instruction.
+%	(Note: `pragma import' and `pragma c_code' are distinct at the
+%	parse_tree stage, but make_hlds converts both `pragma import'
+%	and `pragma c_code' into HLDS `pragma_c_code' instructions,
+%	so from HLDS onwards they are indistinguishable.)
+%
+%	NB. Any changes here might also require similar changes to the
+%	handling of `pragma export' declarations, in export.m.
+
+:- pred module_add_pragma_import(sym_name, pred_or_func, list(mode),
+		may_call_mercury, string, import_status, term__context,
+		module_info, module_info, qual_info, qual_info,
+		io__state, io__state).
+:- mode module_add_pragma_import(in, in, in, in, in, in, in, in, out,
+		in, out, di, uo) is det.
+
+module_add_pragma_import(PredName, PredOrFunc, Modes, MayCallMercury,
+		C_Function, Status, Context, ModuleInfo0, ModuleInfo,
+		Info0, Info) -->
+	{ module_info_name(ModuleInfo0, ModuleName) },
+	{ list__length(Modes, Arity) },
+
+		%
+		% print out a progress message
+		%
+	globals__io_lookup_bool_option(very_verbose, VeryVerbose),
+	( 
+		{ VeryVerbose = yes }
+	->
+		io__write_string("% Processing `:- pragma import' for "),
+		hlds_out__write_call_id(PredOrFunc, PredName/Arity),
+		io__write_string("...\n")
+	;
+		[]
+	),
+
+		%
+		% Lookup the pred declaration in the predicate table.
+		% (If it's not there, print an error message and insert
+		% a dummy declaration for the predicate.) 
+		%
+	{ module_info_get_predicate_table(ModuleInfo0, PredicateTable0) }, 
+	( 
+		{ predicate_table_search_pf_sym_arity(PredicateTable0,
+			PredOrFunc, PredName, Arity, [PredId0]) }
+	->
+		{ PredId = PredId0 },
+		{ PredicateTable1 = PredicateTable0 }
+	;
+		maybe_undefined_pred_error(PredName, Arity, PredOrFunc,
+			Context, "`:- pragma import' declaration"),
+		{ preds_add_implicit(PredicateTable0,
+				ModuleName, PredName, Arity, Context,
+				PredOrFunc, PredId, PredicateTable1) }
+	),
+		%
+		% Lookup the pred_info for this pred,
+		% and check that it is valid.
+		%
+	{ predicate_table_get_preds(PredicateTable1, Preds0) },
+	{ map__lookup(Preds0, PredId, PredInfo0) },
+	% opt_imported preds are initially tagged as imported and are
+	% tagged as opt_imported only if/when we see a clause (including
+	% a `pragma import' clause) for them
+	{ Status = opt_imported ->
+		pred_info_set_import_status(PredInfo0, opt_imported, PredInfo1)
+	;
+		PredInfo1 = PredInfo0
+	},
+	( 
+		{ pred_info_is_imported(PredInfo1) }
+	->
+		{ module_info_incr_errors(ModuleInfo0, ModuleInfo) },
+		prog_out__write_context(Context),
+		io__write_string("Error: `:- pragma import' "),
+		io__write_string("declaration for imported "),
+		hlds_out__write_call_id(PredOrFunc, PredName/Arity),
+		io__write_string(".\n"),
+		{ Info = Info0 }
+	;	
+		{ pred_info_get_goal_type(PredInfo1, clauses) }
+	->
+		{ module_info_incr_errors(ModuleInfo0, ModuleInfo) },
+		prog_out__write_context(Context),
+		io__write_string("Error: `:- pragma import' declaration "),
+		io__write_string("for "),
+		hlds_out__write_call_id(PredOrFunc, PredName/Arity),
+		io__write_string("\n"),
+		prog_out__write_context(Context),
+		io__write_string("  with preceding clauses.\n"),
+		{ Info = Info0 }
+	;
+		{ pred_info_set_goal_type(PredInfo1, pragmas, PredInfo2) },
+		%
+		% add the pragma declaration to the proc_info for this procedure
+		%
+		{ pred_info_procedures(PredInfo2, Procs) },
+		{ map__to_assoc_list(Procs, ExistingProcs) },
+		(
+			{ get_procedure_matching_argmodes(ExistingProcs, Modes,
+						ModuleInfo0, ProcId) }
+		->
+			pred_add_pragma_import(PredInfo2, PredId, ProcId,
+				MayCallMercury, C_Function, Context,
+				ModuleInfo0, PredInfo, Info0, Info),
+			{ map__det_update(Preds0, PredId, PredInfo, Preds) },
+			{ predicate_table_set_preds(PredicateTable1, Preds,
+				PredicateTable) },
+			{ module_info_set_predicate_table(ModuleInfo0,
+				PredicateTable, ModuleInfo) }
+		;
+			{ module_info_incr_errors(ModuleInfo0, ModuleInfo) }, 
+			io__stderr_stream(StdErr),
+			io__set_output_stream(StdErr, OldStream),
+			prog_out__write_context(Context),
+			io__write_string("Error: `:- pragma import' "),
+			io__write_string("declaration for undeclared mode "),
+			io__write_string("of "),
+			hlds_out__write_call_id(PredOrFunc, PredName/Arity),
+			io__write_string(".\n"),
+			io__set_output_stream(OldStream, _),
+			{ Info = Info0 }
+		)
+	).
+
+% pred_add_pragma_import:
+%	This is a subroutine of module_add_pragma_import which adds
+%	the c_code for a `pragma import' declaration to a pred_info.
+
+:- pred pred_add_pragma_import(pred_info, pred_id, proc_id, may_call_mercury,
+		string, term__context, module_info, pred_info,
+		qual_info, qual_info, io__state, io__state).
+:- mode pred_add_pragma_import(in, in, in, in, in, in, in, out, in, out,
+		di, uo) is det.
+pred_add_pragma_import(PredInfo0, PredId, ProcId, MayCallMercury, C_Function,
+		Context, ModuleInfo, PredInfo, Info0, Info) -->
+	%
+	% lookup some information we need from the pred_info and proc_info
+	%
+	{ pred_info_get_is_pred_or_func(PredInfo0, PredOrFunc) },
+	{ pred_info_clauses_info(PredInfo0, Clauses0) },
+	{ pred_info_arg_types(PredInfo0, _TVarSet, ArgTypes) },
+	{ pred_info_get_purity(PredInfo0, Purity) },
+	{ pred_info_procedures(PredInfo0, Procs) },
+	{ map__lookup(Procs, ProcId, ProcInfo) },
+	{ proc_info_argmodes(ProcInfo, Modes) },
+	{ proc_info_interface_code_model(ProcInfo, CodeModel) },
+
+	%
+	% Build a list of argument variables, together with their
+	% names, modes, and types.
+	%
+	{ varset__init(VarSet0) },
+	{ list__length(Modes, Arity) },
+	{ varset__new_vars(VarSet0, Arity, Vars, VarSet) },
+	{ create_pragma_vars(Vars, Modes, 0, PragmaVars) },
+	{ assoc_list__from_corresponding_lists(PragmaVars, ArgTypes,
+			PragmaVarsAndTypes) },
+
+	%
+	% Construct the C_Code string for calling C_Function.
+	% This C code fragment invokes the specified C function
+	% with the appropriate arguments from the list constructed
+	% above, passed in the appropriate manner (by value, or by
+	% passing the address to simulate pass-by-reference), and
+	% assigns the return value (if any) to the appropriate place.
+	%
+	{ handle_return_value(CodeModel, PredOrFunc, PragmaVarsAndTypes,
+			ModuleInfo, ArgPragmaVarsAndTypes, C_Code0) },
+	{ string__append_list([C_Code0, C_Function, "("], C_Code1) },
+	{ assoc_list__keys(ArgPragmaVarsAndTypes, ArgPragmaVars) },
+	{ create_pragma_import_c_code(ArgPragmaVars, ModuleInfo,
+			C_Code1, C_Code2) },
+	{ string__append(C_Code2, ");", C_Code) },
+
+	%
+	% Add the C_Code for this `pragma import' to the clauses_info
+	%
+	{ ExtraInfo = no },
+	clauses_info_add_pragma_c_code(Clauses0, Purity, MayCallMercury,
+		PredId, ProcId, VarSet, PragmaVars, ArgTypes, C_Code, Context,
+		ExtraInfo, Clauses, Info0, Info),
+
+	%
+	% Store the clauses_info etc. back into the pred_info
+	%
+	{ pred_info_set_clauses_info(PredInfo0, Clauses, PredInfo) }.
+
+%
+% handle_return_value(CodeModel, PredOrFunc, Args0, M, Args, C_Code0):
+%	Figures out what to do with the C function's return value,
+%	based on Mercury procedure's code model, whether it is a predicate
+%	or a function, and (if it is a function) the type and mode of the
+%	function result.  Constructs a C code fragment `C_Code0' which
+%	is a string of the form "<Something> =" that assigns the return
+%	value to the appropriate place, if there is a return value,
+%	or is an empty string, if there is no return value.
+%	Returns in Args all of Args0 that must be passed as arguments
+%	(i.e. all of them, or all of them except the return value).
+%
+:- pred handle_return_value(code_model, pred_or_func,
+		assoc_list(pragma_var, type), module_info,
+		assoc_list(pragma_var, type), string).
+:- mode handle_return_value(in, in, in, in, out, out) is det.
+
+handle_return_value(CodeModel, PredOrFunc, Args0, ModuleInfo, Args, C_Code0) :-
+	( CodeModel = model_det,
+		(
+			PredOrFunc = function,
+			pred_args_to_func_args(Args0, Args1, RetArg),
+			RetArg = pragma_var(_, RetArgName, RetMode) - RetType,
+			mode_to_arg_mode(ModuleInfo, RetMode, RetType,
+				RetArgMode),
+			RetArgMode = top_out,
+			\+ export__exclude_argument_type(RetType)
+		->
+			string__append(RetArgName, " = ", C_Code0),
+			Args2 = Args1
+		;
+			C_Code0 = "",
+			Args2 = Args0
+		)
+	; CodeModel = model_semi,
+		% we treat semidet functions the same as semidet predicates,
+		% which means that for Mercury functions the Mercury return
+		% value becomes the last argument, and the C return value
+		% is a bool that is used to indicate success or failure.
+		C_Code0 = "SUCCESS_INDICATOR = ",
+		Args2 = Args0
+	; CodeModel = model_non,
+		% XXX we should report an error here, rather than generating
+		% C code with `#error'...
+		C_Code0 = "\n#error ""cannot import nondet procedure""\n",
+		Args2 = Args0
+	),
+	list__filter(include_import_arg(ModuleInfo), Args2, Args).
+
+%
+% include_import_arg(M, Arg):
+%	Succeeds iff Arg should be included in the arguments of the C
+%	function.  Fails if `Arg' has a type such as `io__state' that
+%	is just a dummy argument that should not be passed to C.
+%
+:- pred include_import_arg(module_info, pair(pragma_var, type)).
+:- mode include_import_arg(in, in) is semidet.
+
+include_import_arg(ModuleInfo, pragma_var(_Var, _Name, Mode) - Type) :-
+	mode_to_arg_mode(ModuleInfo, Mode, Type, ArgMode),
+	ArgMode \= top_unused,
+	\+ export__exclude_argument_type(Type).
+
+%
+% create_pragma_vars(Vars, Modes, ArgNum0, PragmaVars):
+%	given list of vars and modes, and an initial argument number,
+%	allocate names to all the variables, and
+%	construct a single list containing the variables, names, and modes.
+%
+:- pred create_pragma_vars(list(var), list(mode), int, list(pragma_var)).
+:- mode create_pragma_vars(in, in, in, out) is det.
+
+create_pragma_vars([], [], _Num, []).
+
+create_pragma_vars([Var|Vars], [Mode|Modes], ArgNum0,
+		[PragmaVar | PragmaVars]) :-
+	%
+	% Figure out a name for the C variable which will hold this argument
+	%
+	ArgNum is ArgNum0 + 1,
+	string__int_to_string(ArgNum, ArgNumString),
+	string__append("Arg", ArgNumString, ArgName),
+
+	PragmaVar = pragma_var(Var, ArgName, Mode),
+
+	create_pragma_vars(Vars, Modes, ArgNum, PragmaVars).
+
+create_pragma_vars([_|_], [], _, _) :-
+	error("create_pragma_vars: length mis-match").
+create_pragma_vars([], [_|_], _, _) :-
+	error("create_pragma_vars: length mis-match").
+
+%
+% create_pragma_import_c_code(PragmaVars, M, C_Code0, C_Code):
+%	This predicate creates the C code fragments for each argument
+%	in PragmaVars, and appends them to C_Code0, returning C_Code.
+%
+:- pred create_pragma_import_c_code(list(pragma_var), module_info,
+				string, string).
+:- mode create_pragma_import_c_code(in, in, in, out) is det.
+
+create_pragma_import_c_code([], _ModuleInfo, C_Code, C_Code).
+
+create_pragma_import_c_code([PragmaVar | PragmaVars], ModuleInfo,
+		C_Code0, C_Code) :-
+	PragmaVar = pragma_var(_Var, ArgName, Mode),
+
+	%
+	% Construct the C code fragment for passing this argument,
+	% and append it to C_Code0.
+	% Note that C handles output arguments by passing the variable'
+	% address, so if the mode is output, we need to put an `&' before
+	% the variable name.
+	%
+	( mode_is_output(ModuleInfo, Mode) ->
+		string__append(C_Code0, "&", C_Code1)
+	;
+		C_Code1 = C_Code0
+	),
+	string__append(C_Code1, ArgName, C_Code2),
+	( PragmaVars \= [] ->
+		string__append(C_Code2, ", ", C_Code3)
+	;
+		C_Code3 = C_Code2
+	),
+
+	create_pragma_import_c_code(PragmaVars, ModuleInfo, C_Code3, C_Code).
+
+%-----------------------------------------------------------------------------%
 
 :- pred module_add_pragma_c_code(may_call_mercury, sym_name, pred_or_func, 
 		list(pragma_var), varset, string, import_status, term__context, 
@@ -1925,7 +2261,7 @@
 	),
 
 		% Lookup the pred declaration in the predicate table.
-		% (if it's not there, print an error message and insert
+		% (If it's not there, print an error message and insert
 		% a dummy declaration for the predicate.) 
 	{ module_info_get_predicate_table(ModuleInfo0, PredicateTable0) }, 
 	( 
@@ -1946,6 +2282,9 @@
 		% pred_info, and save the pred_info.
 	{ predicate_table_get_preds(PredicateTable1, Preds0) },
 	{ map__lookup(Preds0, PredId, PredInfo0) },
+	% opt_imported preds are initially tagged as imported and are
+	% tagged as opt_imported only if/when we see a clause (including
+	% a `pragma c_code' clause) for them
 	{ Status = opt_imported ->
 		pred_info_set_import_status(PredInfo0, opt_imported, PredInfo1)
 	;
@@ -1971,7 +2310,7 @@
 		hlds_out__write_call_id(PredOrFunc, PredName/Arity),
 		io__write_string("\n"),
 		prog_out__write_context(Context),
-		io__write_string("  with clauses preceding.\n"),
+		io__write_string("  with preceding clauses.\n"),
 		{ Info = Info0 }
 	;
 		% add the pragma declaration to the proc_info for this procedure
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.124
diff -u -r1.124 mercury_to_mercury.m
--- mercury_to_mercury.m	1997/12/22 09:56:00	1.124
+++ mercury_to_mercury.m	1998/01/09 11:26:31
@@ -295,6 +295,11 @@
 		mercury_output_pragma_c_code(MayCallMercury, Pred, PredOrFunc, 
 			Vars, yes(SavedVars - LabelNames), VarSet, C_CodeString)
 	;
+		{ Pragma = import(Pred, PredOrFunc, ModeList, MayCallMercury,
+			C_Function) },
+		mercury_output_pragma_import(Pred, PredOrFunc, ModeList,
+			MayCallMercury, C_Function)
+	;
 		{ Pragma = export(Pred, PredOrFunc, ModeList, C_Function) },
 		mercury_output_pragma_export(Pred, PredOrFunc, ModeList,
 			C_Function)
@@ -1918,6 +1923,38 @@
 
 %-----------------------------------------------------------------------------%
 
+:- pred mercury_output_pragma_import(sym_name, pred_or_func, list(mode),
+	may_call_mercury, string, io__state, io__state).
+:- mode mercury_output_pragma_import(in, in, in, in, in, di, uo) is det.
+
+mercury_output_pragma_import(Name, PredOrFunc, ModeList, MayCallMercury,
+		C_Function) -->
+	{ varset__init(Varset) }, % the varset isn't really used.
+	io__write_string(":- pragma import("),
+	mercury_output_sym_name(Name),
+	(
+		{ PredOrFunc = function },
+		{ pred_args_to_func_args(ModeList, ArgModes, RetMode) },
+		io__write_string("("),
+		mercury_output_mode_list(ArgModes, Varset),
+		io__write_string(") = "),
+		mercury_output_mode(RetMode, Varset)
+	;
+		{ PredOrFunc = predicate },
+		io__write_string("("),
+		mercury_output_mode_list(ModeList, Varset),
+		io__write_string(")")
+	),
+	(
+		{ MayCallMercury = may_call_mercury },
+		io__write_string(", may_call_mercury, ")
+	; 
+		{ MayCallMercury = will_not_call_mercury },
+		io__write_string(", will_not_call_mercury, ")
+	),
+	io__write_string(C_Function),
+	io__write_string(").\n").
+
 :- pred mercury_output_pragma_export(sym_name, pred_or_func, list(mode),
 	string, io__state, io__state).
 :- mode mercury_output_pragma_export(in, in, in, in, di, uo) is det.
@@ -1937,8 +1974,9 @@
 		{ PredOrFunc = predicate },
 		io__write_string("("),
 		mercury_output_mode_list(ModeList, Varset),
-		io__write_string("), ")
+		io__write_string(")")
 	),
+	io__write_string(", "),
 	io__write_string(C_Function),
 	io__write_string(").\n").
 
Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.27
diff -u -r1.27 module_qual.m
--- module_qual.m	1997/12/22 09:56:07	1.27
+++ module_qual.m	1998/01/09 11:05:52
@@ -647,6 +647,10 @@
 qualify_pragma(inline(A, B), inline(A, B), Info, Info) --> [].
 qualify_pragma(no_inline(A, B), no_inline(A, B), Info, Info) --> [].
 qualify_pragma(obsolete(A, B), obsolete(A, B), Info, Info) --> [].
+qualify_pragma(import(Name, PredOrFunc, Modes0, MayCallMercury, CFunc),
+		import(Name, PredOrFunc, Modes, MayCallMercury, CFunc),
+		Info0, Info) -->
+	qualify_mode_list(Modes0, Modes, Info0, Info).
 qualify_pragma(export(Name, PredOrFunc, Modes0, CFunc),
 		export(Name, PredOrFunc, Modes, CFunc), Info0, Info) -->
 	qualify_mode_list(Modes0, Modes, Info0, Info).
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.29
diff -u -r1.29 prog_data.m
--- prog_data.m	1997/12/22 09:56:16	1.29
+++ prog_data.m	1998/01/09 10:40:35
@@ -110,7 +110,7 @@
 			varset, string)
 			% Whether or not the C code may call Mercury,
 			% PredName, Predicate or Function, Vars/Mode, 
-			% SavedeVars, LabelNames, VarNames, C Code
+			% SavedVars, LabelNames, VarNames, C Code
 
 	;	memo(sym_name, arity)
 			% Predname, Arity
@@ -127,6 +127,12 @@
 	;	export(sym_name, pred_or_func, list(mode),
 			string)
 			% Predname, Predicate/function, Modes,
+			% C function name.
+
+	;	import(sym_name, pred_or_func, list(mode),
+			may_call_mercury, string)
+			% Predname, Predicate/function, Modes,
+			% whether or not the C function may call Mercury,
 			% C function name.
 
 	;	source_file(string)
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.10
diff -u -r1.10 prog_io_pragma.m
--- prog_io_pragma.m	1997/12/22 09:56:18	1.10
+++ prog_io_pragma.m	1998/01/09 11:27:12
@@ -150,6 +150,149 @@
 		    ErrorTerm)
 	).
 
+parse_pragma_type(ModuleName, "import", PragmaTerms,
+			ErrorTerm, _VarSet, Result) :-
+       (
+	    PragmaTerms = [PredAndModesTerm, MayCallMercuryTerm,
+			C_FunctionTerm]
+       ->
+	    (
+		PredAndModesTerm = term__functor(_, _, _),
+		C_FunctionTerm = term__functor(term__string(C_Function), [], _)
+	    ->
+		(
+		    PredAndModesTerm = term__functor(term__atom("="),
+				[FuncAndArgModesTerm, RetModeTerm], _)
+		->
+		    parse_qualified_term(ModuleName, FuncAndArgModesTerm,
+			PredAndModesTerm, "pragma import declaration",
+			FuncAndArgModesResult),  
+		    (
+			FuncAndArgModesResult = ok(FuncName, ArgModeTerms),
+			(
+		    	    convert_mode_list(ArgModeTerms, ArgModes),
+			    convert_mode(RetModeTerm, RetMode)
+			->
+			    list__append(ArgModes, [RetMode], Modes),
+			    (
+				parse_may_call_mercury(MayCallMercuryTerm,
+					MayCallMercury)
+			    ->
+			        Result = ok(pragma(import(FuncName, function,
+				    Modes, MayCallMercury, C_Function)))
+			    ;
+				Result = error("invalid second argument in `:- pragma import/3' declaration -- expecting either `may_call_mercury' or `will_not_call_mercury'",
+					MayCallMercuryTerm)
+			    )
+			;
+	   		    Result = error(
+"expected pragma import(FuncName(ModeList) = Mode, MayCallMercury, C_Function)",
+				PredAndModesTerm)
+			)
+		    ;
+			FuncAndArgModesResult = error(Msg, Term),
+			Result = error(Msg, Term)
+		    )
+		;
+		    parse_qualified_term(ModuleName, PredAndModesTerm,
+			ErrorTerm, "pragma import declaration",
+			PredAndModesResult),  
+		    (
+			PredAndModesResult = ok(PredName, ModeTerms),
+			(
+		    	    convert_mode_list(ModeTerms, Modes)
+			->
+			    (
+				parse_may_call_mercury(MayCallMercuryTerm,
+					MayCallMercury)
+			    ->
+			        Result = ok(pragma(import(PredName, predicate,
+				    Modes, MayCallMercury, C_Function)))
+			    ;
+				Result = error("invalid second argument in `:- pragma import/3' declaration -- expecting either `may_call_mercury' or `will_not_call_mercury'",
+					MayCallMercuryTerm)
+			    )
+			;
+	   		    Result = error(
+"expected pragma import(PredName(ModeList), MayCallMercury, C_Function)",
+				PredAndModesTerm)
+			)
+		    ;
+			PredAndModesResult = error(Msg, Term),
+			Result = error(Msg, Term)
+		    )
+		)
+	    ;
+	    	Result = error(
+"expected pragma import(PredName(ModeList), MayCallMercury, C_Function)",
+		     PredAndModesTerm)
+	    )
+	;
+	    PragmaTerms = [PredAndModesTerm, C_FunctionTerm]
+	->
+	    MayCallMercury = may_call_mercury,
+	    (
+		PredAndModesTerm = term__functor(_, _, _),
+		C_FunctionTerm = term__functor(term__string(C_Function), [], _)
+	    ->
+		(
+		    PredAndModesTerm = term__functor(term__atom("="),
+				[FuncAndArgModesTerm, RetModeTerm], _)
+		->
+		    parse_qualified_term(ModuleName, FuncAndArgModesTerm,
+			PredAndModesTerm, "pragma import declaration",
+			FuncAndArgModesResult),  
+		    (
+			FuncAndArgModesResult = ok(FuncName, ArgModeTerms),
+			(
+		    	    convert_mode_list(ArgModeTerms, ArgModes),
+			    convert_mode(RetModeTerm, RetMode)
+			->
+			    list__append(ArgModes, [RetMode], Modes),
+			    Result = ok(pragma(import(FuncName, function,
+				    Modes, MayCallMercury, C_Function)))
+			;
+	   		    Result = error(
+"expected pragma import(FuncName(ModeList) = Mode, C_Function)",
+				PredAndModesTerm)
+			)
+		    ;
+			FuncAndArgModesResult = error(Msg, Term),
+			Result = error(Msg, Term)
+		    )
+		;
+		    parse_qualified_term(ModuleName, PredAndModesTerm,
+			ErrorTerm, "pragma import declaration",
+			PredAndModesResult),  
+		    (
+			PredAndModesResult = ok(PredName, ModeTerms),
+			(
+		    	    convert_mode_list(ModeTerms, Modes)
+			->
+			    Result = ok(pragma(import(PredName, predicate,
+				    Modes, MayCallMercury, C_Function)))
+			;
+	   		    Result = error(
+	"expected pragma import(PredName(ModeList), C_Function)",
+				PredAndModesTerm)
+			)
+		    ;
+			PredAndModesResult = error(Msg, Term),
+			Result = error(Msg, Term)
+		    )
+		)
+	    ;
+	    	Result = error(
+	"expected pragma import(PredName(ModeList), C_Function)",
+		     PredAndModesTerm)
+	    )
+	;
+	    Result = 
+	    	error(
+		"wrong number of arguments in `pragma import(...)' declaration",
+		ErrorTerm)
+       ).
+
 parse_pragma_type(_ModuleName, "export", PragmaTerms,
 			ErrorTerm, _VarSet, Result) :-
        (
Index: compiler/notes/compiler_design.html
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/notes/compiler_design.html,v
retrieving revision 1.15
diff -u -r1.15 compiler_design.html
--- compiler_design.html	1998/01/08 06:13:22	1.15
+++ compiler_design.html	1998/01/09 10:17:37
@@ -158,6 +158,8 @@
 
 	make_hlds.m transforms the code into superhomogeneous form,
 	and at the same time converts the parse tree into the HLDS.
+	It converts `pragma import' and `pragma c_code' declarations
+	into clauses with HLDS `pragma_c_code' instructions for bodies.
 	make_hlds.m also calls make_tags.m which chooses the data
 	representation for each discriminated union type by
 	assigning tags to each functor.
Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/Mmakefile,v
retrieving revision 1.4
diff -u -r1.4 Mmakefile
--- Mmakefile	1997/12/30 06:42:23	1.4
+++ Mmakefile	1998/01/08 06:01:53
@@ -48,6 +48,7 @@
 	nullary_ho_func \
 	pragma_c_code \
 	pragma_inline \
+	pragma_import \
 	purity \
 	qual_adv_test \
 	qual_basic_test \
Index: tests/hard_coded/pragma_import.exp
===================================================================
RCS file: pragma_import.exp
diff -N pragma_import.exp
--- /dev/null	Fri Jan  9 22:21:07 1998
+++ pragma_import.exp	Fri Jan  9 22:14:54 1998
@@ -0,0 +1,12 @@
+X = 101
+Y = 201.000000000000
+S = Foo
+X1 = 1
+X2 = 102
+XX1 = 1
+XX2 = 102
+Y1 = 301
+Y2 = 302
+baz failed, as expected
+Z = 401
+quux failed, as expected
Index: tests/hard_coded/pragma_import.m
===================================================================
RCS file: pragma_import.m
diff -N pragma_import.m
--- /dev/null	Fri Jan  9 22:21:07 1998
+++ pragma_import.m	Fri Jan  9 22:14:35 1998
@@ -0,0 +1,88 @@
+:- module foo.
+:- interface.
+:- import_module io.
+
+:- pred main(io__state::di, io__state::uo) is det.
+
+:- implementation.
+
+main -->
+	foo(100, X, 200.0, Y, "Foo", S),
+	print("X = "), print(X), nl,
+	print("Y = "), print(Y), nl,
+	print("S = "), print(S), nl,
+	{ bar(X, X1) = X2 },
+	print("X1 = "), print(X1), nl,
+	print("X2 = "), print(X2), nl,
+	{ bar2(X, XX1) = XX2 },
+	print("XX1 = "), print(XX1), nl,
+	print("XX2 = "), print(XX2), nl,
+	( { baz(300, Y1) = Y2 } ->
+		print("Y1 = "), print(Y1), nl,
+		print("Y2 = "), print(Y2), nl
+	;
+		print("baz failed unexpectedly"), nl
+	),
+	( { baz(-300, _) = _ } ->
+		print("baz succeeded unexpectedly"), nl
+	;
+		print("baz failed, as expected"), nl
+	),
+	( { quux(400, Z) } ->
+		print("Z = "), print(Z), nl
+	;
+		print("quux failed unexpectedly"), nl
+	),
+	( { quux(-400, _) } ->
+		print("quux succeeded unexpectedly"), nl
+	;
+		print("quux failed, as expected"), nl
+	).
+
+:- pred foo(int::in, int::out, float::in, float::out, string::in, string::out,
+		io__state::di, io__state::uo) is det.
+:- func bar(int::in, int::out) = (int::out) is det.
+:- func bar2(int::in, int::out) = (int::out) is det.
+:- func baz(int::in, int::out) = (int::out) is semidet.
+:- pred quux(int::in, int::out) is semidet.
+
+:- pragma import(foo(in, out, in, out, in, out, di, uo), "cfoo").
+:- pragma import(bar(in, out) = out, will_not_call_mercury, "cbar").
+:- pragma export(bar(in, out) = out, "mbar").
+:- pragma import(bar2(in, out) = out, may_call_mercury, "mbar").
+:- pragma import(baz(in, out) = out, "cbaz").
+:- pragma import(quux(in, out), may_call_mercury, "cquux").
+
+:- pragma c_header_code("
+	typedef Integer Int;
+	void cfoo(Int, Int *, Float, Float *, String, String *);
+	Int cbar(Int, Int *);
+	bool cbaz(Int, Int *, Int *);
+	bool cquux(Int, Int *);
+").
+
+:- pragma c_code("
+
+void cfoo(Int a1, Int *a2, Float a3, Float *a4, String a5, String *a6) {
+	*a2 = a1 + 1;
+	*a4 = a3 + 1.0;
+	*a6 = a5;
+}
+
+Int cbar(Int a1, Int *a2) {
+	*a2 = 1;
+	return a1 + *a2;
+}
+
+bool cbaz(Int a1, Int *a2, Int *a3) {
+	*a2 = a1 + 1;
+	*a3 = a1 + 2;
+	return a1 + *a2 + *a3 > 0;
+}
+
+bool cquux(Int a1, Int *a2) {
+	*a2 = a1 + 1;
+	return a1 + *a2 > 0;
+}
+
+").


-- 
Fergus Henderson <fjh at cs.mu.oz.au>   |  "I have always known that the pursuit
WWW: <http://www.cs.mu.oz.au/~fjh>   |  of excellence is a lethal habit"
PGP: finger fjh at 128.250.37.3         |     -- the last words of T. S. Garp.



More information about the developers mailing list