diff options
Diffstat (limited to 'lib/ic/src/ic_cclient.erl')
| -rw-r--r-- | lib/ic/src/ic_cclient.erl | 1209 |
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. |