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