for review: pragma import
Fergus Henderson
fjh at cs.mu.oz.au
Thu Jan 8 17:31:29 AEDT 1998
Zoltan, can you please review this one?
I'm skipping the documentation for this now, to avoid CVS conflicts,
since zs is currently editing the same part of the reference manual.
----------------------------------------------------------------------
Estimated hours taken: 16
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:
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.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/08 06:19:03
@@ -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,11 @@
Vars, VarSet, C_Code, Status, Context, no,
Module0, Module, Info0, Info)
;
+ { Pragma = import(Name, PredOrFunc, Modes, C_Function) }
+ ->
+ module_add_pragma_import(Name, PredOrFunc, Modes, C_Function,
+ Status, Context, Module0, Module, Info0, Info)
+ ;
{ Pragma = c_code(MayCallMercury, Pred, PredOrFunc, Vars,
SavedVars, LabelNames, VarSet, C_Code) }
->
@@ -616,10 +626,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) --> [].
%-----------------------------------------------------------------------------%
@@ -1898,6 +1908,321 @@
C_Body_List = [C_Body_Code - Context | C_Body_List0],
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 `c_code' instruction.
+% (Note: `pragma import' and `pragma c_code' are distinct at the
+% parse_tree stage, but make_hlds converts `pragma import' into the
+% same HLDS representation as `pragma c_code'.)
+%
+% 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), 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, out,
+ in, out, di, uo) is det.
+
+module_add_pragma_import(PredName, PredOrFunc, Modes, 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) },
+ { 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 clauses preceding.\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,
+ 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, 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, out, in, out,
+ di, uo) is det.
+pred_add_pragma_import(PredInfo0, PredId, ProcId, 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 },
+ % XXX the syntax should allow will_not_call_mercury too
+ { MayCallMercury = may_call_mercury },
+ 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):
+% Figure 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. Construct an C code fragment `C_Code0' which
+% assigns the return value (if any) to the appropriate place,
+% and 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,
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/06 05:25:56
@@ -295,6 +295,10 @@
mercury_output_pragma_c_code(MayCallMercury, Pred, PredOrFunc,
Vars, yes(SavedVars - LabelNames), VarSet, C_CodeString)
;
+ { Pragma = import(Pred, PredOrFunc, ModeList, C_Function) },
+ mercury_output_pragma_import(Pred, PredOrFunc, ModeList,
+ C_Function)
+ ;
{ Pragma = export(Pred, PredOrFunc, ModeList, C_Function) },
mercury_output_pragma_export(Pred, PredOrFunc, ModeList,
C_Function)
@@ -1917,6 +1921,30 @@
io__write_string(").\n").
%-----------------------------------------------------------------------------%
+
+:- pred mercury_output_pragma_import(sym_name, pred_or_func, list(mode),
+ string, io__state, io__state).
+:- mode mercury_output_pragma_import(in, in, in, in, di, uo) is det.
+
+mercury_output_pragma_import(Name, PredOrFunc, ModeList, 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("), ")
+ ),
+ 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).
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/06 04:40:12
@@ -647,6 +647,9 @@
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, CFunc),
+ import(Name, PredOrFunc, Modes, 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/05 09:55:27
@@ -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
@@ -125,6 +125,11 @@
% Predname, Arity
; export(sym_name, pred_or_func, list(mode),
+ string)
+ % Predname, Predicate/function, Modes,
+ % C function name.
+
+ ; import(sym_name, pred_or_func, list(mode),
string)
% Predname, Predicate/function, Modes,
% C function name.
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/06 05:35:49
@@ -150,6 +150,73 @@
ErrorTerm)
).
+parse_pragma_type(_ModuleName, "import", PragmaTerms,
+ ErrorTerm, _VarSet, Result) :-
+ (
+ PragmaTerms = [PredAndModesTerm, C_FunctionTerm]
+ ->
+ (
+ PredAndModesTerm = term__functor(_, _, _),
+ C_FunctionTerm = term__functor(term__string(C_Function), [], _)
+ ->
+ (
+ PredAndModesTerm = term__functor(term__atom("="),
+ [FuncAndArgModesTerm, RetModeTerm], _)
+ ->
+ parse_qualified_term(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, C_Function)))
+ ;
+ Result = error(
+ "expected pragma import(FuncName(ModeList) = Mode, C_Function)",
+ PredAndModesTerm)
+ )
+ ;
+ FuncAndArgModesResult = error(Msg, Term),
+ Result = error(Msg, Term)
+ )
+ ;
+ parse_qualified_term(PredAndModesTerm, ErrorTerm,
+ "pragma import declaration", PredAndModesResult),
+ (
+ PredAndModesResult = ok(PredName, ModeTerms),
+ (
+ convert_mode_list(ModeTerms, Modes)
+ ->
+ Result =
+ ok(pragma(import(PredName, predicate, Modes,
+ 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/08 06:14:55
@@ -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 `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.m
===================================================================
RCS file: pragma_import.m
diff -N pragma_import.m
--- /dev/null Thu Jan 8 17:12:55 1998
+++ pragma_import.m Thu Jan 8 17:00:17 1998
@@ -0,0 +1,82 @@
+:- 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,
+ ( { baz(300, Y1) = Y2 } ->
+ print("Y1 = "), print(Y1), nl,
+ print("Y2 = "), print(Y2), nl
+ ;
+ print("baz failed"), 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"), 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 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, "cbar").
+:- pragma import(baz(in, out) = out, "cbaz").
+:- pragma import(quux(in, out), "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