aboutsummaryrefslogtreecommitdiffstats
path: root/lib/ic/src/ic_cclient.erl
diff options
context:
space:
mode:
authorErlang/OTP <[email protected]>2009-11-20 14:54:40 +0000
committerErlang/OTP <[email protected]>2009-11-20 14:54:40 +0000
commit84adefa331c4159d432d22840663c38f155cd4c1 (patch)
treebff9a9c66adda4df2106dfd0e5c053ab182a12bd /lib/ic/src/ic_cclient.erl
downloadotp-84adefa331c4159d432d22840663c38f155cd4c1.tar.gz
otp-84adefa331c4159d432d22840663c38f155cd4c1.tar.bz2
otp-84adefa331c4159d432d22840663c38f155cd4c1.zip
The R13B03 release.OTP_R13B03
Diffstat (limited to 'lib/ic/src/ic_cclient.erl')
-rw-r--r--lib/ic/src/ic_cclient.erl1209
1 files changed, 1209 insertions, 0 deletions
diff --git a/lib/ic/src/ic_cclient.erl b/lib/ic/src/ic_cclient.erl
new file mode 100644
index 0000000000..ebe7e0c207
--- /dev/null
+++ b/lib/ic/src/ic_cclient.erl
@@ -0,0 +1,1209 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2002-2009. All Rights Reserved.
+%%
+%% The contents of this file are subject to the Erlang Public License,
+%% Version 1.1, (the "License"); you may not use this file except in
+%% compliance with the License. You should have received a copy of the
+%% Erlang Public License along with this software. If not, it can be
+%% retrieved online at http://www.erlang.org/.
+%%
+%% Software distributed under the License is distributed on an "AS IS"
+%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
+%% the License for the specific language governing rights and limitations
+%% under the License.
+%%
+%% %CopyrightEnd%
+%%
+%%
+-module(ic_cclient).
+
+%% This module implements generation of C client code, where the
+%% client acts as an Erlang C-node, and where the communication thus
+%% is according to the Erlang distribution protocol.
+%%
+
+-export([do_gen/3]).
+
+%%------------------------------------------------------------
+%% IMPLEMENTATION CONVENTIONS
+%%------------------------------------------------------------
+%% Functions:
+%%
+%% mk_* returns things to be used. No side effects.
+%% emit_* Writes to file. Has Fd in arguments.
+%% gen_* Same, but has no Fd. Usually for larger things.
+%%
+%% Terminology for generating C:
+%%
+%% par_list list of identifiers with types, types only, or with
+%% parameters (arguments) only.
+%% arg_list list of identifiers only (for function calls)
+%%
+
+%%------------------------------------------------------------
+%% Internal stuff
+%%------------------------------------------------------------
+
+-import(lists, [foreach/2, foldl/3, foldr/3]).
+-import(ic_codegen, [emit/2, emit/3, emit/4, emit_c_enc_rpt/4, emit_c_dec_rpt/4]).
+
+-include("icforms.hrl").
+-include("ic.hrl").
+-include_lib("stdlib/include/erl_compile.hrl").
+
+-define(IC_HEADER, "ic.h").
+-define(ERL_INTERFACEHEADER, "erl_interface.h").
+-define(EICONVHEADER, "ei.h").
+-define(ERLANGATOMLENGTH, "256").
+
+
+%%------------------------------------------------------------
+%% ENTRY POINT
+%%------------------------------------------------------------
+do_gen(G, File, Form) ->
+ OeName = ic_util:mk_oe_name(G, remove_ext(ic_util:to_list(File))),
+ G2 = ic_file:filename_push(G, [], OeName, c),
+ gen_headers(G2, [], Form),
+ R = gen(G2, [], Form),
+ ic_file:filename_pop(G2, c),
+ R.
+
+remove_ext(File) ->
+ filename:rootname(filename:basename(File)).
+
+%%------------------------------------------------------------
+%%
+%% Generate client side C stubs.
+%%
+%% - each module definition results in a separate file.
+%% - each interface definition results in a separate file.
+%%
+%% G = record(genobj) (see ic.hrl)
+%% N = scoped names in reverse
+%% X = current form to consider.
+%%------------------------------------------------------------
+
+gen(G, N, [X| Xs]) when is_record(X, preproc) ->
+ G1 = change_file_stack(G, N, X),
+ gen(G1, N, Xs);
+
+gen(G, N, [X| Xs]) when is_record(X, module) ->
+ CD = ic_code:codeDirective(G, X),
+ G2 = ic_file:filename_push(G, N, X, CD),
+ N2 = [ic_forms:get_id2(X)| N],
+ gen_headers(G2, N2, X),
+ gen(G2, N2, ic_forms:get_body(X)),
+ G3 = ic_file:filename_pop(G2, CD),
+ gen(G3, N, Xs);
+
+gen(G, N, [X| Xs]) when is_record(X, interface) ->
+
+ G2 = ic_file:filename_push(G, N, X, c),
+ N2 = [ic_forms:get_id2(X)| N],
+
+ %% Sets the temporary variable counter.
+ put(op_variable_count, 0),
+ put(tmp_declarations, []),
+
+ gen_headers(G2, N2, X),
+
+ gen(G2, N2, ic_forms:get_body(X)),
+
+ lists:foreach(
+ fun({_Name, Body}) ->
+ gen(G2, N2, Body) end,
+ X#interface.inherit_body),
+
+ %% Generate Prototypes
+ gen_prototypes(G2, N2, X),
+
+ %% Generate generic preparation for decoding
+ gen_receive_info(G2, N2, X),
+
+ G3 = ic_file:filename_pop(G2, c),
+
+ gen(G3, N, Xs);
+
+gen(G, N, [X| Xs]) when is_record(X, const) ->
+ emit_constant(G, N, X),
+ gen(G, N, Xs);
+
+gen(G, N, [X| Xs]) when is_record(X, op) ->
+ {OpName, ArgNames, RetParTypes} = ic_cbe:extract_info(G, N, X),
+ %% XXX Note: N is the list of scoped ids of the *interface*.
+ gen_operation(G, N, X, OpName, ArgNames, RetParTypes),
+ gen_encoder(G, N, X, OpName, ArgNames, RetParTypes),
+ gen_decoder(G, N, X, OpName, ArgNames, RetParTypes),
+ gen(G, N, Xs);
+
+gen(G, N, [X| Xs]) when is_record(X, attr) ->
+ gen(G, N, Xs);
+
+gen(G, N, [X| Xs]) when is_record(X, except) ->
+ icstruct:except_gen(G, N, X, c),
+ gen(G, N, Xs);
+
+gen(G, N, [X| Xs]) when is_record(X, enum) ->
+ icenum:enum_gen(G, N, X, c),
+ gen(G, N, Xs);
+
+gen(G, N, [X| Xs]) when is_record(X, typedef) ->
+ icstruct:struct_gen(G, N, X, c),
+ gen(G, N, Xs);
+
+gen(G, N, [X| Xs]) when is_record(X, struct) ->
+ icstruct:struct_gen(G, N, X, c),
+ gen(G, N, Xs);
+
+gen(G, N, [X| Xs]) when is_record(X, union) ->
+ icstruct:struct_gen(G, N, X, c),
+ gen(G, N, Xs);
+
+gen(G, N, [_X| Xs]) ->
+ %% XXX Should have debug message here.
+ gen(G, N, Xs);
+
+gen(_G, _N, []) ->
+ ok.
+
+%%------------------------------------------------------------
+%% Change file stack
+%%------------------------------------------------------------
+
+change_file_stack(G, _N, X) when X#preproc.cat == line_nr ->
+ Id = ic_forms:get_id2(X),
+ Flags = X#preproc.aux,
+ case Flags of
+ [] ->
+ ic_genobj:push_file(G, Id);
+ _ ->
+ foldr(
+ fun({_, _, "1"}, G1) ->
+ ic_genobj:push_file(G1, Id);
+ ({_, _, "2"}, G1) ->
+ ic_genobj:pop_file(G1, Id);
+ ({_, _, "3"}, G1) ->
+ ic_genobj:sys_file(G1, Id)
+ end, G, Flags)
+ end;
+change_file_stack(G, _N, _X) ->
+ G.
+
+%%------------------------------------------------------------
+%% Generate headers in stubfiles and header files
+%%------------------------------------------------------------
+
+gen_headers(G, N, X) when is_record(X, interface) ->
+ case ic_genobj:is_hrlfile_open(G) of
+ true ->
+ %% Set the temporary variable counter
+ put(op_variable_count, 0),
+ put(tmp_declarations, []),
+ HFd = ic_genobj:hrlfiled(G),
+ IncludeFileStack = ic_genobj:include_file_stack(G),
+ L = length(N),
+ Filename =
+ if
+ L < 2 ->
+ lists:nth(L + 1, IncludeFileStack);
+ true ->
+ lists:nth(2, IncludeFileStack)
+ end,
+ emit(HFd, "#include \"~s\"\n", [filename:basename(Filename)]),
+ ic_code:gen_includes(HFd, G, X, c_client),
+
+ IfName = ic_util:to_undersc(N),
+ IfNameUC = ic_util:to_uppercase(IfName),
+ emit(HFd, "\n#ifndef __~s__\n", [IfNameUC]),
+ emit(HFd, "#define __~s__\n", [IfNameUC]),
+ LCmt = io_lib:format("Interface object definition: ~s", [IfName]),
+ ic_codegen:mcomment_light(HFd, [LCmt], c),
+ case get_c_timeout(G, "") of
+ "" ->
+ ok;
+ {SendTmo, RecvTmo} ->
+ emit(HFd, "#define OE_~s_SEND_TIMEOUT ~s\n",
+ [IfNameUC, SendTmo]),
+ emit(HFd, "#define OE_~s_RECV_TIMEOUT ~s\n",
+ [IfNameUC, RecvTmo]),
+ emit(HFd, "#ifndef EI_HAVE_TIMEOUT\n"),
+ emit(HFd, "#error Functions for send and receive with "
+ "timeout not defined in erl_interface\n"),
+ emit(HFd, "#endif\n\n")
+ end,
+
+ emit(HFd, "typedef CORBA_Object ~s;\n", [IfName]),
+ emit(HFd, "#endif\n\n");
+
+ false -> ok
+ end,
+ case ic_genobj:is_stubfile_open(G) of
+ true ->
+ Fd = ic_genobj:stubfiled(G),
+ ic_codegen:nl(Fd),
+ emit(Fd, "#include <stdlib.h>\n"),
+ emit(Fd, "#include <string.h>\n"),
+ case ic_options:get_opt(G, c_report) of
+ true ->
+ emit(Fd, "#ifndef OE_C_REPORT\n"),
+ emit(Fd, "#define OE_C_REPORT\n"),
+ emit(Fd, "#include <stdio.h>\n"),
+ emit(Fd, "#endif\n");
+ _ ->
+ ok
+ end,
+ emit(Fd, "#include \"~s\"\n", [?IC_HEADER]),
+ emit(Fd, "#include \"~s\"\n", [?ERL_INTERFACEHEADER]),
+ emit(Fd, "#include \"~s\"\n", [?EICONVHEADER]),
+ emit(Fd, "#include \"~s\"\n",
+ [filename:basename(ic_genobj:include_file(G))]),
+ ic_codegen:nl(Fd), ic_codegen:nl(Fd),
+ Fd; % XXX ??
+ false ->
+ ok
+ end;
+
+%% Some items have extra includes
+gen_headers(G, N, X) when is_record(X, module) ->
+ case ic_genobj:is_hrlfile_open(G) of
+ true ->
+ HFd = ic_genobj:hrlfiled(G),
+ IncludeFileStack = ic_genobj:include_file_stack(G),
+ Filename = lists:nth(length(N) + 1, IncludeFileStack),
+ emit(HFd, "#include \"~s\"\n", [filename:basename(Filename)]),
+ ic_code:gen_includes(HFd, G, X, c_client);
+ false -> ok
+ end;
+gen_headers(G, [], _X) ->
+ case ic_genobj:is_hrlfile_open(G) of
+ true ->
+ HFd = ic_genobj:hrlfiled(G),
+ case ic_options:get_opt(G, c_report) of
+ true ->
+ emit(HFd, "#ifndef OE_C_REPORT\n"),
+ emit(HFd, "#define OE_C_REPORT\n"),
+ emit(HFd, "#include <stdio.h>\n"),
+ emit(HFd, "#endif\n");
+ _ ->
+ ok
+ end,
+ emit(HFd, "#include \"~s\"\n", [?IC_HEADER]),
+ emit(HFd, "#include \"~s\"\n", [?ERL_INTERFACEHEADER]),
+ emit(HFd, "#include \"~s\"\n", [?EICONVHEADER]),
+ ic_code:gen_includes(HFd, G, c_client);
+ false -> ok
+ end;
+gen_headers(_G, _N, _X) ->
+ ok.
+
+
+%%------------------------------------------------------------
+%% Generate all prototypes (for interface)
+%%------------------------------------------------------------
+gen_prototypes(G, N, X) ->
+ case ic_genobj:is_hrlfile_open(G) of
+ false ->
+ ok;
+ true ->
+ HFd = ic_genobj:hrlfiled(G),
+ IfName = ic_util:to_undersc(N),
+
+ %% Emit generated function prototypes
+ emit(HFd, "\n/* Operation functions */\n"),
+ lists:foreach(fun({_Name, Body}) ->
+ emit_operation_prototypes(G, HFd, N, Body)
+ end, [{x, ic_forms:get_body(X)}|
+ X#interface.inherit_body]),
+
+ UserProto = get_user_proto(G, false),
+ %% Emit generic function prototypes
+ case UserProto of
+ false ->
+ ok;
+ UserProto ->
+ emit(HFd,
+ "\n/* Generic user defined encoders */\n"),
+ emit(HFd,
+ "int ~s_prepare_notification_encoding("
+ "CORBA_Environment*);"
+ "\n", [UserProto]),
+ emit(HFd,
+ "int ~s_prepare_request_encoding(CORBA_Environment*);"
+ "\n", [UserProto])
+ end,
+ %% Emit encoding function prototypes
+ emit(HFd, "\n/* Input encoders */\n"),
+ lists:foreach(fun({_Name, Body}) ->
+ emit_encoder_prototypes(G, HFd, N, Body)
+ end,
+ [{x, ic_forms:get_body(X)}|
+ X#interface.inherit_body]),
+
+ %% Emit generic function prototypes
+ emit(HFd, "\n/* Generic decoders */\n"),
+ emit(HFd, "int ~s__receive_info(~s, CORBA_Environment*);\n",
+ [IfName, IfName]),
+
+ case UserProto of
+ false ->
+ ok;
+ UserProto ->
+ emit(HFd, "\n/* Generic user defined decoders */\n"),
+ emit(HFd,
+ "int ~s_prepare_reply_decoding(CORBA_Environment*);"
+ "\n", [UserProto])
+ end,
+ %% Emit decode function prototypes
+ emit(HFd, "\n/* Result decoders */\n"),
+ lists:foreach(fun({_Name, Body}) ->
+ emit_decoder_prototypes(G, HFd, N, Body)
+ end, [{x, ic_forms:get_body(X)}|
+ X#interface.inherit_body]),
+ case UserProto of
+ false ->
+ ok;
+ UserProto ->
+ %% Emit generic send and receive_prototypes
+ {Sfx, TmoType} = case get_c_timeout(G, "") of
+ "" ->
+ {"", ""};
+ _ ->
+ {"_tmo", ", unsigned int"}
+ end,
+ emit(HFd,
+ "\n/* Generic user defined send and receive "
+ "functions */\n"),
+ emit(HFd,
+ "int ~s_send_notification~s(CORBA_Environment*~s);\n",
+ [UserProto, Sfx, TmoType]),
+ emit(HFd,
+ "int ~s_send_request_and_receive_reply~s("
+ "CORBA_Environment*~s~s);\n",
+ [UserProto, Sfx, TmoType, TmoType])
+ end
+ end.
+
+%%------------------------------------------------------------
+%% Generate receive_info() (generic part for message reception)
+%% (for interface). For backward compatibility only.
+%%------------------------------------------------------------
+
+gen_receive_info(G, N, _X) ->
+ case ic_genobj:is_stubfile_open(G) of
+ false ->
+ ok;
+ true ->
+ Fd = ic_genobj:stubfiled(G),
+ IfName = ic_util:to_undersc(N),
+ UserProto = get_user_proto(G, oe),
+ Code =
+ "
+/*
+ * Generic function, used to return received message information.
+ * Not used by oneways. Always generated. For backward compatibility only.
+ */
+
+int ~s__receive_info(~s oe_obj, CORBA_Environment *oe_env)
+{
+ return ~s_prepare_reply_decoding(oe_env);
+}\n",
+ emit(Fd, Code, [IfName, IfName, UserProto])
+end.
+
+%%------------------------------------------------------------
+%% Emit constant
+%%------------------------------------------------------------
+
+emit_constant(G, N, ConstRecord) ->
+ case ic_genobj:is_hrlfile_open(G) of
+ false -> ok;
+ true ->
+ Fd = ic_genobj:hrlfiled(G),
+ CName = ic_util:to_undersc(
+ [ic_forms:get_id(ConstRecord#const.id)| N]),
+ UCName = ic_util:to_uppercase(CName),
+
+ emit(Fd, "\n#ifndef __~s__\n", [UCName]),
+ emit(Fd, "#define __~s__\n", [UCName]),
+
+ emit(Fd, "/* Constant: ~s */\n", [CName]),
+
+ if is_record(ConstRecord#const.type, wstring) ->
+ %% If wstring, add 'L'
+ emit(Fd, "#define ~s L~p\n",
+ [CName, ConstRecord#const.val]);
+ true ->
+ emit(Fd, "#define ~s ~p\n",
+ [CName, ConstRecord#const.val])
+ end,
+ emit(Fd, "#endif\n\n")
+ end.
+
+%%------------------------------------------------------------
+%% Generate operation (for interface)
+%%------------------------------------------------------------
+
+%% N is the list of scoped ids of the *interface*.
+%% X is the operation
+gen_operation(G, N, X, OpName, ArgNames, RetParTypes) ->
+ case ic_genobj:is_stubfile_open(G) of
+ true ->
+ do_gen_operation(G, N, X, OpName, ArgNames, RetParTypes);
+ false ->
+ ok
+ end.
+
+do_gen_operation(G, N, X, OpName, ArgNames, RetParTypes) ->
+ Fd = ic_genobj:stubfiled(G),
+ IfName = ic_util:to_undersc(N),
+ IfNameUC = ic_util:to_uppercase(IfName),
+
+ {R, ParTypes, _} = RetParTypes,
+
+ IsOneway = ic_forms:is_oneway(X),
+
+ emit(Fd, "\n"
+ "/***\n"
+ " *** Operation function \"~s\" ~s\n"
+ " ***/\n\n",
+ [OpName, ifelse(IsOneway, "(oneway)", "")]),
+
+ RV = element(1, R),
+ Ret = case IsOneway of
+ false ->
+ if RV /= void ->
+ mk_ret_type(G, N, R);
+ true ->
+ "void"
+ end;
+ true ->
+ "void"
+ end,
+ ParListStr = ic_util:chain(mk_par_type_list(G, N, X, [in, out],
+ [types, args],
+ ParTypes, ArgNames), ", "),
+ emit(Fd,
+ "~s ~s(~s, ~sCORBA_Environment *oe_env)\n{\n",
+ [Ret, OpName, [IfName, " ", "oe_obj"], ParListStr]),
+
+ case IsOneway of
+ true ->
+ ok;
+ false ->
+ case ictype:isArray(G, N, R) of
+ true ->
+ emit(Fd, " ~s oe_return = NULL;\n\n",
+ [mk_ret_type(G, N, R)]);
+ false ->
+ if RV /= void ->
+ emit(Fd, " ~s oe_return;\n\n",
+ [Ret]);
+ true ->
+ ok
+ end
+ end,
+ emit(Fd,
+ " /* Initiating the message reference */\n"
+ " ic_init_ref(oe_env, &oe_env->_unique);\n")
+ end,
+
+ emit(Fd,
+ " /* Initiating exception indicator */ \n"
+ " oe_env->_major = CORBA_NO_EXCEPTION;\n"),
+
+ %% XXX Add pointer checks: checks of in-parameter
+ %% pointers, and non-variable out-parameter pointers.
+
+ emit(Fd," /* Creating ~s message */ \n",
+ [ifelse(IsOneway, "cast", "call")]),
+
+ EncParListStr = ic_util:chain(mk_arg_list_for_encoder(G, N, X,
+ ParTypes, ArgNames),
+ ", "),
+ emit(Fd,
+ " if (~s__client_enc(oe_obj, ~s""oe_env) < 0) {\n",
+ [OpName, EncParListStr]),
+ emit(Fd,
+ " CORBA_exc_set(oe_env, CORBA_SYSTEM_EXCEPTION, "
+ "DATA_CONVERSION, \"Cannot encode message\");\n"),
+
+ RetVar = ifelse(RV /= void, " oe_return", ""),
+ emit_c_enc_rpt(Fd, " ", "client operation ~s\\n====\\n", [OpName]),
+
+ emit(Fd, " return~s;\n }\n", [RetVar]),
+
+ emit(Fd," /* Sending ~s message */ \n",
+ [ifelse(IsOneway, "cast", "call")]),
+
+ UserProto = get_user_proto(G, oe),
+ {Sfx, SendTmo, RecvTmo} = case get_c_timeout(G, "") of
+ "" ->
+ {"", "", ""};
+ _ ->
+ {"_tmo",
+ [", OE_", IfNameUC, "_SEND_TIMEOUT"],
+ [", OE_", IfNameUC, "_RECV_TIMEOUT"]}
+ end,
+
+ case IsOneway of
+ true ->
+ emit(Fd,
+ " if (~s_send_notification~s(oe_env~s) < 0)\n"
+ " return~s;\n", [UserProto, Sfx, SendTmo, RetVar]);
+ false ->
+ emit(Fd,
+ " if (~s_send_request_and_receive_reply~s(oe_env~s~s) < 0)\n"
+ " return~s;\n",
+ [UserProto, Sfx, SendTmo, RecvTmo, RetVar]),
+
+ DecParList0 = mk_arg_list_for_decoder(G, N, X,
+ ParTypes, ArgNames),
+ DecParList1 = case mk_ret_type(G, N, R) of
+ "void" ->
+ DecParList0;
+ _ ->
+ ["&oe_return"| DecParList0]
+ end,
+
+ DecParListStr = ic_util:chain(DecParList1, ", "),
+ %% YYY Extracting results
+ emit(Fd,
+ " /* Extracting result value(s) */ \n"
+ " if (~s__client_dec(oe_obj, ~s""oe_env) < 0) {\n",
+ [OpName, DecParListStr]),
+ emit(Fd,
+ " CORBA_exc_set(oe_env, "
+ "CORBA_SYSTEM_EXCEPTION, DATA_CONVERSION, "
+ "\"Bad result value(s)\");\n"),
+ emit_c_dec_rpt(Fd, " ", "client operation ~s\\n=====\\n", [OpName]),
+ emit(Fd,
+ " return~s;\n"
+ " }\n", [RetVar])
+ end,
+ emit(Fd, " return~s;\n", [RetVar]),
+ emit(Fd, "}\n\n\n").
+
+%%------------------------------------------------------------
+%% Generate encoder
+%%------------------------------------------------------------
+%% N is the list of scoped ids of the *interface*.
+%% X is the operation
+gen_encoder(G, N, X, OpName, ArgNames, RetParTypes)->
+ case ic_genobj:is_stubfile_open(G) of
+ true ->
+ Fd = ic_genobj:stubfiled(G),
+ IfName = ic_util:to_undersc(N),
+ {_R, ParTypes, _} = RetParTypes,
+ TypeAttrArgs = mk_type_attr_arg_list(ParTypes, ArgNames),
+ emit(Fd, "/*\n * Encode operation input for \"~s\"\n */\n\n",
+ [OpName]),
+ ParList = ic_util:chain(
+ mk_par_type_list(G, N, X, [in], [types, args],
+ ParTypes, ArgNames), ", "),
+ emit(Fd,
+ "int ~s__client_enc(~s oe_obj, ~s"
+ "CORBA_Environment *oe_env)\n{\n",
+ [OpName, IfName, ParList]),
+
+ InTypeAttrArgs = lists:filter(fun({_, in, _}) -> true;
+ ({_, _, _}) -> false
+ end, TypeAttrArgs),
+ case InTypeAttrArgs of
+ [] ->
+ ok;
+ _ ->
+ emit(Fd,
+ " int oe_error_code = 0;\n\n")
+ end,
+
+ emit_encodings(G, N, Fd, X, InTypeAttrArgs,
+ ic_forms:is_oneway(X)),
+ emit(Fd, " return 0;\n}\n\n"),
+ ok;
+
+ false ->
+ ok
+ end.
+
+%%------------------------------------------------------------
+%% Generate decoder
+%%------------------------------------------------------------
+%% N is the list of scoped ids of the *interface*.
+%% X is the operation
+gen_decoder(G, N, X, OpName, ArgNames, RetParTypes)->
+ case ic_forms:is_oneway(X) of
+ true ->
+ ok;
+ false ->
+ case ic_genobj:is_stubfile_open(G) of
+ true ->
+ Fd = ic_genobj:stubfiled(G),
+ IfName = ic_util:to_undersc(N),
+ {R, ParTypes, _} = RetParTypes,
+ TypeAttrArgs = mk_type_attr_arg_list(ParTypes, ArgNames),
+ emit(Fd, "/*\n * Decode operation results for "
+ "\"~s\"\n */\n\n", [OpName]),
+ ParList0 = mk_par_type_list(G, N, X, [out],
+ [types, args],
+ ParTypes, ArgNames),
+ PARLIST = case mk_ret_type(G, N, R) of
+ "void" ->
+ ParList0;
+ Else ->
+ [Else ++ "* oe_return"| ParList0]
+ end,
+ PLFCD = ic_util:chain(PARLIST, ", "),
+ emit(Fd,
+ "int ~s__client_dec(~s oe_obj, ~s"
+ "CORBA_Environment *oe_env)\n{\n",
+ [OpName, IfName, PLFCD]),
+ emit(Fd, " int oe_error_code = 0;\n"),
+ OutTypeAttrArgs = lists:filter(fun({_, out, _}) -> true;
+ ({_, _, _}) -> false
+ end, TypeAttrArgs),
+ emit_decodings(G, N, Fd, R, OutTypeAttrArgs),
+ emit(Fd, " return 0;\n}\n\n"),
+ ok;
+
+ false ->
+ ok
+ end
+ end.
+
+%%------------------------------------------------------------
+%% EMIT ENCODINGS/DECODINGS
+%%------------------------------------------------------------
+%%------------------------------------------------------------
+%% Emit encodings
+%%------------------------------------------------------------
+%% N is the list of scoped ids of the *interface*.
+%% X is the operation
+%% emit_encodings(G, N, Fd, X, TypeAttrArgs, IsOneWay)
+%%
+emit_encodings(G, N, Fd, X, TypeAttrArgs, true) ->
+ %% Cast
+ UserProto = get_user_proto(G, oe),
+ emit(Fd,
+ " if (~s_prepare_notification_encoding(oe_env) < 0)\n"
+ " return -1;\n", [UserProto]),
+ emit_encodings_1(G, N, Fd, X, TypeAttrArgs);
+emit_encodings(G, N, Fd, X, TypeAttrArgs, false) ->
+ %% Call
+ UserProto = get_user_proto(G, oe),
+ emit(Fd,
+ " if (~s_prepare_request_encoding(oe_env) < 0)\n"
+ " return -1;\n", [UserProto]),
+ emit_encodings_1(G, N, Fd, X, TypeAttrArgs).
+
+emit_encodings_1(G, N, Fd, X, TypeAttrArgs) ->
+ {ScopedName, _, _} = ic_cbe:extract_info(G, N, X),
+ Name = case ic_options:get_opt(G, scoped_op_calls) of
+ true ->
+ ScopedName;
+ false ->
+ ic_forms:get_id2(X)
+ end,
+ if
+ TypeAttrArgs /= [] ->
+ emit(Fd, " if (oe_ei_encode_tuple_header(oe_env, ~p) < 0) {\n",
+ [length(TypeAttrArgs) + 1]),
+ emit_c_enc_rpt(Fd, " ", "ei_encode_tuple_header", []),
+ emit(Fd, " return -1;\n }\n");
+ true ->
+ ok
+ end,
+ emit(Fd, " if (oe_ei_encode_atom(oe_env, ~p) < 0) {\n", [Name]),
+ emit_c_enc_rpt(Fd, " ", "oe_ei_encode_atom", []),
+ emit(Fd, " return -1;\n }\n"),
+
+ foreach(fun({{'void', _}, _, _}) ->
+ ok;
+ ({T1, A1, N1}) ->
+ IndOp = mk_ind_op(A1),
+ emit_coding_comment(G, N, Fd, "Encode", IndOp,
+ T1, N1),
+ ic_cbe:emit_encoding_stmt(G, N, X, Fd, T1, IndOp ++ N1,
+ "oe_env->_outbuf")
+ end, TypeAttrArgs),
+ ok.
+
+%%------------------------------------------------------------
+%% Emit dedodings
+%%------------------------------------------------------------
+%% XXX Unfortunately we have to retain the silly `oe_first' variable,
+%% since its name is hardcoded in other modules (icstruct, icunion,
+%% etc).
+%% N is the list of scoped ids of the *interface*.
+%% X is the operation
+emit_decodings(G, N, Fd, RetType, TypeAttrArgs) ->
+ if
+ TypeAttrArgs /= [] ->
+ %% Only if there are out parameters
+ emit(Fd, " if ((oe_error_code = ei_decode_tuple_header("
+ "oe_env->_inbuf, &oe_env->_iin, "
+ "&oe_env->_received)) < 0) {\n"),
+ emit_c_dec_rpt(Fd, " ", "ei_decode_tuple_header", []),
+ emit(Fd, " return oe_error_code;\n }\n"),
+ Len = length(TypeAttrArgs) + 1,
+ emit(Fd, " if (oe_env->_received != ~p) {\n", [Len]),
+ emit_c_dec_rpt(Fd, " ", "tuple header size != ~p", [Len]),
+ emit(Fd, " return -1;\n }\n");
+ true ->
+ ok
+ end,
+
+ %% Fetch the return value
+ emit_coding_comment(G, N, Fd, "Decode return value", "*", RetType, "oe_return"),
+ APars =
+ case ic_cbe:is_variable_size(G, N, RetType) of
+ true ->
+ emit(Fd,
+ " {\n"
+ " int oe_size_count_index = oe_env->_iin;\n"
+ " int oe_malloc_size = 0;\n"
+ " void *oe_first = NULL;\n"),
+ ic_cbe:emit_malloc_size_stmt(G, N, Fd, RetType,
+ "oe_env->_inbuf",
+ 1, caller),
+ %% XXX Add malloc prefix from option
+ emit(Fd,
+ " OE_MALLOC_SIZE_CHECK(oe_env, oe_malloc_size);\n"
+ " if ((*oe_return = oe_first = "
+ "malloc(oe_malloc_size)) == NULL) {\n"
+ " CORBA_exc_set(oe_env, CORBA_SYSTEM_EXCEPTION, "
+ "NO_MEMORY, \"Cannot malloc\");\n"
+ " return -1;\n"
+ " }\n"),
+ Pars = ["*oe_return"],
+ DecType = case ictype:isArray(G, N, RetType) of
+ true -> array_dyn;
+ false -> caller_dyn
+ end,
+ ic_cbe:emit_decoding_stmt(G, N, Fd, RetType,
+ "(*oe_return)",
+ "", "oe_env->_inbuf", 1,
+ "&oe_outindex", DecType,
+ Pars),
+ emit(Fd, " }\n"),
+ Pars;
+ false ->
+ case ictype:isArray(G, N, RetType) of
+ true ->
+ Pars = ["*oe_return"],
+ emit(Fd,
+ " {\n"
+ " int oe_size_count_index = oe_env->_iin;\n"
+ " int oe_malloc_size = 0;\n"
+ " void *oe_first = NULL;\n"),
+ ic_cbe:emit_malloc_size_stmt(G, N, Fd, RetType,
+ "oe_env->_inbuf",
+ 1, caller),
+ %% XXX Add malloc prefix from option
+ emit(Fd,
+ " OE_MALLOC_SIZE_CHECK(oe_env, "
+ "oe_malloc_size);\n"
+ " if ((*oe_return = oe_first = "
+ "malloc(oe_malloc_size)) == NULL) {\n"
+ " CORBA_exc_set(oe_env, "
+ "CORBA_SYSTEM_EXCEPTION, NO_MEMORY, "
+ "\"Cannot malloc\");\n"
+ " return -1;"
+ " }\n"),
+ ic_cbe:emit_decoding_stmt(G, N, Fd, RetType,
+ "oe_return", "",
+ "oe_env->_inbuf", 1,
+ "&oe_outindex",
+ array_fix_ret,
+ Pars),
+ emit(Fd, " }\n"),
+ Pars;
+ false ->
+ Pars = [],
+ %% The last parameter "oe_outindex" is not interesting
+ %% in the static case.
+ ic_cbe:emit_decoding_stmt(G, N, Fd, RetType,
+ "oe_return", "",
+ "oe_env->_inbuf", 1,
+ "&oe_outindex",
+ caller, Pars),
+ ic_codegen:nl(Fd),
+ Pars
+ end
+ end,
+
+ foldl(fun({{'void', _}, _, _}, Acc) ->
+ Acc;
+ ({T, A, N1}, Acc) ->
+ emit_one_decoding(G, N, Fd, T, A, N1, Acc)
+ end, APars, TypeAttrArgs),
+ ok.
+
+emit_one_decoding(G, N, Fd, T, A, N1, Acc) ->
+ IndOp = mk_ind_op(A),
+ case ic_cbe:is_variable_size(G, N, T) of
+ true ->
+ emit_coding_comment(G, N, Fd, "Decode", IndOp,
+ T, N1),
+ emit(Fd,
+ " {\n"
+ " int oe_size_count_index = oe_env->_iin;\n"
+ " int oe_malloc_size = 0;\n"
+ " void *oe_first = NULL;\n"),
+ ic_cbe:emit_malloc_size_stmt(G, N, Fd, T,
+ "oe_env->_inbuf",
+ 1, caller),
+ %% XXX Add malloc prefix from option
+ emit(Fd,
+ " OE_MALLOC_SIZE_CHECK(oe_env, oe_malloc_size);\n"
+ " if ((~s~s = oe_first = "
+ "malloc(oe_malloc_size)) == NULL) {\n", [IndOp, N1]),
+ ic_cbe:emit_dealloc_stmts(Fd, " ", Acc),
+ emit(Fd,
+ " CORBA_exc_set(oe_env, CORBA_SYSTEM_EXCEPTION, "
+ "NO_MEMORY, \"Cannot malloc\");\n"
+ " return -1;\n"
+ " }\n"),
+ NAcc = [IndOp ++ N1| Acc],
+ DecType = case ictype:isArray(G, N, T) of
+ true ->
+ array_dyn;
+ false ->
+ caller_dyn
+ end,
+ ic_cbe:emit_decoding_stmt(G, N, Fd, T,
+ "(" ++ IndOp
+ ++ N1 ++ ")", "",
+ "oe_env->_inbuf", 1,
+ "&oe_outindex",
+ DecType, NAcc),
+ emit(Fd, " }\n"),
+ NAcc;
+ false ->
+ case ictype:isArray(G, N, T) of
+ true ->
+ emit_coding_comment(G, N, Fd, "Decode", "",
+ T, N1),
+ ic_cbe:emit_decoding_stmt(G, N, Fd, T, N1,
+ "", "oe_env->_inbuf",
+ 1, "&oe_outindex",
+ array_fix_out, Acc),
+ ic_codegen:nl(Fd),
+ [N1| Acc];
+ false ->
+ %% The last parameter "oe_outindex" is
+ %% not interesting in the static case, but
+ %% must be present anyhow.
+ emit_coding_comment(G, N, Fd, "Decode",
+ IndOp, T, N1),
+ ic_cbe:emit_decoding_stmt(G, N, Fd, T, N1,
+ "", "oe_env->_inbuf",
+ 1, "&oe_outindex",
+ caller, Acc),
+ ic_codegen:nl(Fd),
+ Acc
+ end
+ end.
+
+%%------------------------------------------------------------
+%% GENERATE PROTOTYPES
+%%------------------------------------------------------------
+%%------------------------------------------------------------
+%% Generate operation prototypes
+%%------------------------------------------------------------
+emit_operation_prototypes(G, Fd, N, Xs) ->
+ lists:foreach(
+ fun(X) when is_record(X, op) ->
+ {ScopedName, ArgNames, RetParTypes} =
+ ic_cbe:extract_info(G, N, X),
+ {R, ParTypes, _} = RetParTypes,
+ IfName = ic_util:to_undersc(N),
+ RT = mk_ret_type(G, N, R),
+ ParList =
+ ic_util:chain(
+ mk_par_type_list(G, N, X, [in, out], [types],
+ ParTypes, ArgNames),
+ ", "),
+ emit(Fd, "~s ~s(~s, ~sCORBA_Environment*);\n",
+ [RT, ScopedName, IfName, ParList]);
+ (_) ->
+ ok
+ end, Xs).
+
+%%------------------------------------------------------------
+%% Generate encoder prototypes
+%%------------------------------------------------------------
+emit_encoder_prototypes(G, Fd, N, Xs) ->
+ lists:foreach(
+ fun(X) when is_record(X, op) ->
+ {ScopedName, ArgNames, RetParTypes} =
+ ic_cbe:extract_info(G, N, X),
+ {_R, ParTypes, _} = RetParTypes,
+ IfName = ic_util:to_undersc(N),
+ ParList = ic_util:chain(
+ mk_par_type_list(G, N, X, [in], [types],
+ ParTypes, ArgNames),
+ ", "),
+ emit(Fd, "int ~s__client_enc(~s, ~sCORBA_Environment*);\n",
+ [ScopedName, IfName, ParList]);
+ (_) ->
+ ok
+ end, Xs).
+
+%%------------------------------------------------------------
+%% Generate decoder prototypes
+%%------------------------------------------------------------
+emit_decoder_prototypes(G, Fd, N, Xs) ->
+ lists:foreach(
+ fun(X) when is_record(X, op) ->
+ case ic_forms:is_oneway(X) of
+ true ->
+ true;
+ false ->
+ IfName = ic_util:to_undersc(N),
+ {ScopedName, ArgNames, RetParTypes} =
+ ic_cbe:extract_info(G, N, X),
+ {R, ParTypes, _} = RetParTypes,
+ ParList0 =
+ mk_par_type_list(G, N, X, [out], [types],
+ ParTypes, ArgNames),
+ PARLIST = case mk_ret_type(G, N, R) of
+ "void" ->
+ ParList0;
+ Else ->
+ [Else ++ "*"| ParList0]
+ end,
+ ParList = ic_util:chain(PARLIST, ", "),
+ emit(Fd, "int ~s__client_dec(~s, ~s"
+ "CORBA_Environment*);\n",
+ [ScopedName, IfName, ParList])
+ end;
+ (_) ->
+ ok
+ end, Xs).
+
+%%------------------------------------------------------------
+%% PARAMETER TYPE LISTS
+%%------------------------------------------------------------
+%%------------------------------------------------------------
+%% Make parameter type list
+%%
+%% InOrOut = in | out | [in | out]
+%% TypesOrArgs = types | args | [types | args]
+%%------------------------------------------------------------
+mk_par_type_list(G, N, X, InOrOut, TypesOrArgs, Types, Args) ->
+ TypeAttrArgs =
+ filterzip(
+ fun(_, {inout, Arg}) ->
+ ic_error:error(G, {inout_spec_for_c, X, Arg}),
+ false;
+ (Type, {Attr, Arg}) ->
+ case lists:member(Attr, InOrOut) of
+ true ->
+ {true, {Type, Attr, Arg}};
+ false ->
+ false
+ end
+ end, Types, Args),
+ lists:map(
+ fun({Type, Attr, Arg}) ->
+ Ctype = ic_cbe:mk_c_type(G, N, Type),
+ IsArray = ictype:isArray(G, N, Type),
+ IsStruct = ictype:isStruct(G, N, Type),
+ IsUnion = ictype:isUnion(G, N, Type),
+ Dyn =
+ case ic_cbe:is_variable_size(G, N, Type) of
+ true ->
+ if
+ is_record(Type, string) -> "";
+ Ctype == "CORBA_char *" -> "";
+ is_record(Type, wstring) -> "";
+ Ctype == "CORBA_wchar *" -> "";
+ true ->
+ case IsArray of
+ true ->
+ "_slice*";
+ false ->
+ "*"
+ end
+ end;
+ false ->
+ if
+ Attr == in, Ctype == "erlang_pid" ->
+ "*";
+ Attr == in, Ctype == "erlang_port" ->
+ "*";
+ Attr == in, Ctype == "erlang_ref" ->
+ "*";
+ Attr == in, IsStruct == true ->
+ "*";
+ Attr == in, IsUnion == true ->
+ "*";
+ Attr == in, IsArray == true ->
+ "_slice*";
+ Attr == out, IsArray == true ->
+ "_slice";
+ true ->
+ ""
+ end
+ end,
+ IndOp = mk_ind_op(Attr),
+ case {lists:member(types, TypesOrArgs),
+ lists:member(args, TypesOrArgs)} of
+ {true, true} ->
+ Ctype ++ Dyn ++ IndOp ++ " " ++ Arg;
+ {true, false} ->
+ Ctype ++ Dyn ++ IndOp;
+ {false, true} ->
+ Arg;
+ {false, false} ->
+ ""
+ end
+ end, TypeAttrArgs).
+
+%%------------------------------------------------------------
+%% ENCODER ARG LIST
+%%------------------------------------------------------------
+%%------------------------------------------------------------
+%% Make encoder argument list XXX
+%%------------------------------------------------------------
+mk_arg_list_for_encoder(G, _N, X, Types, Args) ->
+ filterzip(
+ fun(_, {out, _}) ->
+ false;
+ (_, {inout, Arg}) ->
+ ic_error:error(G, {inout_spec_for_c, X, Arg}),
+ false;
+ (_Type, {in, Arg}) ->
+ {true, Arg}
+ end, Types, Args).
+
+%%------------------------------------------------------------
+%% DECODER ARG LIST
+%%------------------------------------------------------------
+%%------------------------------------------------------------
+%% Make decoder argument list XXX
+%%------------------------------------------------------------
+mk_arg_list_for_decoder(G, _N, X, Types, Args) ->
+ filterzip(fun(_, {in, _}) ->
+ false;
+ (_, {inout, Arg}) ->
+ ic_error:error(G, {inout_spec_for_c, X, Arg}),
+ false;
+ (_, {out, Arg}) ->
+ {true, Arg}
+ end, Types, Args).
+
+%%------------------------------------------------------------
+%% MISC
+%%------------------------------------------------------------
+%%------------------------------------------------------------
+%% Make list of {Type, Attr, Arg}
+%%------------------------------------------------------------
+mk_type_attr_arg_list(Types, Args) ->
+ filterzip(fun(Type, {Attr, Arg}) ->
+ {true, {Type, Attr, Arg}}
+ end, Types, Args).
+
+%%------------------------------------------------------------
+%% Make return type
+%%------------------------------------------------------------
+mk_ret_type(G, N, Type) ->
+ Ctype = ic_cbe:mk_c_type(G, N, Type),
+ Dyn = case ic_cbe:is_variable_size(G, N, Type) of
+ true ->
+ if
+ is_record(Type, string) ->
+ "";
+ Ctype == "CORBA_char *" ->
+ "";
+ is_record(Type, wstring) ->
+ "";
+ Ctype == "CORBA_wchar *" ->
+ "";
+ true ->
+ case ictype:isArray(G, N, Type) of
+ true ->
+ "_slice*";
+ false ->
+ "*"
+ end
+ end;
+ false ->
+ case ictype:isArray(G, N, Type) of
+ true ->
+ "_slice*";
+ false ->
+ ""
+ end
+ end,
+ Ctype ++ Dyn.
+
+
+%%------------------------------------------------------------
+%% Make indirection operator (to "*" or not to "*").
+%%------------------------------------------------------------
+mk_ind_op(in) ->
+ "";
+mk_ind_op(inout) ->
+ error;
+mk_ind_op(out) ->
+ "*".
+
+%%------------------------------------------------------------
+%% Emit encoding/decoding comment
+%%------------------------------------------------------------
+emit_coding_comment(G, N, Fd, String, RefOrVal, Type, Name) ->
+ emit(Fd, " /* ~s parameter: ~s~s ~s */\n",
+ [String, ic_cbe:mk_c_type(G, N, Type), RefOrVal, Name]).
+
+%%------------------------------------------------------------
+%% User protocol prefix for generic functions
+%%------------------------------------------------------------
+get_user_proto(G, Default) ->
+ case ic_options:get_opt(G, user_protocol) of
+ false ->
+ Default;
+ Pfx ->
+ Pfx
+ end.
+
+%%------------------------------------------------------------
+%% Timeout. Returns a string (or Default).
+%%------------------------------------------------------------
+get_c_timeout(G, Default) ->
+ case ic_options:get_opt(G, c_timeout) of
+ Tmo when is_integer(Tmo) ->
+ TmoStr = integer_to_list(Tmo),
+ {TmoStr, TmoStr};
+ {SendTmo, RecvTmo} when is_integer(SendTmo) andalso is_integer(RecvTmo) ->
+ {integer_to_list(SendTmo), integer_to_list(RecvTmo)};
+ false ->
+ Default
+ end.
+
+%%------------------------------------------------------------
+%% ZIPPERS (merging of successive elements of two lists).
+%%------------------------------------------------------------
+
+%% zip([H1| T1], [H2| T2]) ->
+%% [{H1, H2}| zip(T1, T2)];
+%% zip([], []) ->
+%% [].
+
+filterzip(F, [H1| T1], [H2| T2]) ->
+ case F(H1, H2) of
+ false ->
+ filterzip(F, T1, T2);
+ {true, Val} ->
+ [Val| filterzip(F, T1, T2)]
+ end;
+filterzip(_, [], []) ->
+ [].
+
+
+ifelse(true, A, _) ->
+ A;
+ifelse(false, _, B) ->
+ B.