diff options
Diffstat (limited to 'lib/ic/src/ic_cserver.erl')
| -rw-r--r-- | lib/ic/src/ic_cserver.erl | 2420 |
1 files changed, 0 insertions, 2420 deletions
diff --git a/lib/ic/src/ic_cserver.erl b/lib/ic/src/ic_cserver.erl deleted file mode 100644 index 7c7506367e..0000000000 --- a/lib/ic/src/ic_cserver.erl +++ /dev/null @@ -1,2420 +0,0 @@ -%% -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 1998-2016. All Rights Reserved. -%% -%% Licensed under the Apache License, Version 2.0 (the "License"); -%% you may not use this file except in compliance with the License. -%% You may obtain a copy of the License at -%% -%% http://www.apache.org/licenses/LICENSE-2.0 -%% -%% Unless required by applicable law or agreed to in writing, software -%% distributed under the License is distributed on an "AS IS" BASIS, -%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -%% See the License for the specific language governing permissions and -%% limitations under the License. -%% -%% %CopyrightEnd% -%% -%% --module(ic_cserver). - -%% This module implements generation of C server code, where the -%% server acts as an Erlang C-node, where the functionality is that of -%% a gen_server (in C), and where the communication thus is according -%% to the Erlang distribution protocol. -%% - --export([do_gen/3]). - -%% Silly dialyzer. --export([filterzip/3]). - -%%------------------------------------------------------------ -%% -%% Internal stuff -%% -%%------------------------------------------------------------ - --import(lists, [foreach/2, foldl/3, foldr/3, map/2]). --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(OE_MSGBUFSIZE, "OE_MSGBUFSIZE"). --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_server), - gen_headers(G2, [], Form), - R = gen(G2, [], Form), - ic_file:filename_pop(G2, c), - R. - -remove_ext(File) -> - filename:rootname(filename:basename(File)). - -%%------------------------------------------------------------ -%% -%% Generate the server side C stub and header files. -%% -%% For each module a separate file is generated. -%% -%% -%%------------------------------------------------------------ - -gen(G, N, [X| Xs]) when is_record(X, preproc) -> - NewG = change_file_stack(G, N, X#preproc.cat, X), - gen(NewG, 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_server), - N2 = [ic_forms:get_id2(X)| N], - gen_prototypes(G2, N2, X), - gen_serv(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) -> - 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, [_| Xs]) -> - gen(G, N, Xs); - -gen(_G, _N, []) -> - ok. - -%%------------------------------------------------------------ -%% Change file stack -%%------------------------------------------------------------ - -change_file_stack(G, _N, line_nr, X) -> - 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, _Other, _X) -> - G. - -%%------------------------------------------------------------ -%% Generate headers -%%------------------------------------------------------------ - -%% 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_server); - false -> ok - end; -gen_headers(G, [], _X) -> - case ic_genobj:is_hrlfile_open(G) of - true -> - HFd = ic_genobj:hrlfiled(G), - emit(HFd, "#include <stdlib.h>\n"), - 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_server); - false -> ok - end; -gen_headers(_G, _N, _X) -> - ok. - -%%------------------------------------------------------------ -%% Generate prototypes -%%------------------------------------------------------------ - -gen_prototypes(G, N, X) -> - case ic_genobj:is_hrlfile_open(G) of - true -> - 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, - - IName = ic_util:to_undersc(N), - INameUC = ic_util:to_uppercase(IName), - - emit(HFd, "#include \"~s\"\n", [filename:basename(Filename)]), - ic_code:gen_includes(HFd, G, X, c_server), - ic_codegen:nl(HFd), - - emit(HFd, "\n#ifndef __~s__\n", [ic_util:to_uppercase(IName)]), - emit(HFd, "#define __~s__\n", [ic_util:to_uppercase(IName)]), - ic_codegen:mcomment_light(HFd, - [io_lib:format("Interface " - "object " - "definition: ~s", - [IName])], c), - case get_c_timeout(G, "") of - "" -> - ok; - {SendTmo, RecvTmo} -> - emit(HFd, "#define OE_~s_SEND_TIMEOUT ~s\n", - [INameUC, SendTmo]), - emit(HFd, "#define OE_~s_RECV_TIMEOUT ~s\n", - [INameUC, 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\n", [IName]), - emit(HFd, "#endif\n\n"), - - Bodies = [{N, ic_forms:get_body(X)}| X#interface.inherit_body], - - emit(HFd, "\n/* Structure definitions */\n", []), - foreach(fun({N2, Body}) -> - emit_structs_inside_module(G, HFd, N2, Body) end, - Bodies), - - emit(HFd, "\n/* Switch and exec functions */\n", []), - emit(HFd, "int ~s__switch(~s oe_obj, CORBA_Environment " - "*oe_env);\n", [IName, IName]), - foreach(fun({_N2, Body}) -> - emit_exec_prototypes(G, HFd, N, Body) end, - Bodies), - - emit(HFd, "\n/* Generic decoder */\n", []), - emit(HFd, "int ~s__call_info(~s oe_obj, CORBA_Environment " - "*oe_env);\n", [IName, IName]), - - emit(HFd, "\n/* Restore function typedefs */\n", []), - foreach(fun({_N2, Body}) -> - emit_restore_typedefs(G, HFd, N, Body) end, - Bodies), - - emit(HFd, "\n/* Callback functions */\n", []), - foreach(fun({_N2, Body}) -> - emit_callback_prototypes(G, HFd, N, Body) end, - Bodies), - - emit(HFd, "\n/* Parameter decoders */\n", []), - foreach(fun({_N2, Body}) -> - emit_decoder_prototypes(G, HFd, N, Body) end, - Bodies), - - emit(HFd, "\n/* Message encoders */\n", []), - foreach(fun({_N2, Body}) -> - emit_encoder_prototypes(G, HFd, N, Body) end, - Bodies), - - %% Emit operation mapping structures - emit_operation_mapping_declaration(G, HFd, N, Bodies), - - ok; - - false -> - ok - end. - -%%------------------------------------------------------------ -%% Generate the server encoding/decoding function -%%------------------------------------------------------------ - - -gen_serv(G, N, X) -> - case ic_genobj:is_stubfile_open(G) of - true -> - Fd = ic_genobj:stubfiled(G), - - emit_switch(G, Fd, N, X), - emit_server_generic_decoding(G, Fd, N), - - %% Sets the temporary variable counter. - put(op_variable_count, 0), - put(tmp_declarations, []), - - %% Generate exec, decode and encoding functions, and - %% table of exec functions. - Bodies = [{N, ic_forms:get_body(X)}| - X#interface.inherit_body], - - foreach(fun({_N2, Body}) -> - emit_dispatch(G, Fd, N, Body) end, - Bodies), - emit_operation_mapping(G, Fd, N, Bodies); - false -> - ok - end. - -%%------------------------------------------------------------ -%% Emit structs inside module -%%------------------------------------------------------------ - -emit_structs_inside_module(G, _Fd, N, Xs)-> - lists:foreach( - fun(X) when is_record(X, enum) -> - icenum:enum_gen(G, N, X, c); - (X) when is_record(X, typedef) -> - icstruct:struct_gen(G, N, X, c); - (X) when is_record(X, struct) -> - icstruct:struct_gen(G, N, X, c); - (X) when is_record(X, union) -> - icstruct:struct_gen(G, N, X, c); - (_) -> - ok - end, Xs). - -%%------------------------------------------------------------ -%% Emit exec prototypes -%%------------------------------------------------------------ - -emit_exec_prototypes(G, Fd, N, Xs) -> - lists:foreach( - fun(X) when is_record(X, op) -> - {ScopedName, _, _} = ic_cbe:extract_info(G, N, X), - emit(Fd, - "int ~s__exec(~s oe_obj, CORBA_Environment *oe_env);\n", - [ScopedName, ic_util:to_undersc(N)]); - (X) when is_record(X, const) -> - emit_constant(G, N, X); - (_) -> - ok - end, Xs). - -%%------------------------------------------------------------ -%% Emit restore typedefs -%%------------------------------------------------------------ - -emit_restore_typedefs(G, Fd, N, [X| Xs]) when is_record(X, op) -> - %% Check if to use scoped call names - {ScopedName, ArgNames, Types} = ic_cbe:extract_info(G, N, X), - {RetType, ParTypes, _} = Types, - TypeAttrArgs = mk_type_attr_arg_list(ParTypes, ArgNames), - RT = mk_c_ret_type(G, N, RetType), - - PL = ic_util:mk_list(mk_par_list_for_callback_prototypes(G, N, X, - TypeAttrArgs)), - RPL = case PL of - "" -> - ""; - _PL -> - ", " ++ PL - end, - - case RT of - "void" -> - case PL of - "" -> - emit(Fd, "typedef void (*~s__rs(~s oe_obj, " - "CORBA_Environment *oe_env));\n", - [ScopedName, ic_util:to_undersc(N)]); - _ -> - emit(Fd, "typedef void (*~s__rs(~s oe_obj, ~s, " - "CORBA_Environment *oe_env));\n", - [ScopedName, ic_util:to_undersc(N), PL]) - end; - - "erlang_port*" -> - emit(Fd, "typedef void (*~s__rs(~s oe_obj, ~s~s, " - "CORBA_Environment *oe_env));\n", - [ScopedName, ic_util:to_undersc(N), RT, RPL]); - - "erlang_pid*" -> - emit(Fd, "typedef void (*~s__rs(~s oe_obj, ~s~s, " - "CORBA_Environment *oe_env));\n", - [ScopedName, ic_util:to_undersc(N), RT, RPL]); - - "erlang_ref*" -> - emit(Fd, "typedef void (*~s__rs(~s oe_obj, ~s~s, " - "CORBA_Environment *oe_env));\n", - [ScopedName, ic_util:to_undersc(N), RT, RPL]); - - _ -> - case ictype:isArray(G, N, RetType) of - true -> - emit(Fd, "typedef void (*~s__rs(~s oe_obj, ~s~s, " - "CORBA_Environment *oe_env));\n", - [ScopedName, ic_util:to_undersc(N), RT, RPL]); - false -> - emit(Fd, "typedef void (*~s__rs(~s oe_obj, ~s*~s, " - "CORBA_Environment *oe_env));\n", - [ScopedName, ic_util:to_undersc(N), RT, RPL]) - end - end, - emit_restore_typedefs(G, Fd, N, Xs); -emit_restore_typedefs(G, Fd, N, [X| Xs]) when is_record(X, attr) -> - emit_restore_typedefs(G, Fd, N, Xs); -emit_restore_typedefs(G, Fd, N, [_X| Xs]) -> - emit_restore_typedefs(G, Fd, N, Xs); -emit_restore_typedefs(_G, _Fd, _N, []) -> ok. - - -%%------------------------------------------------------------ -%% Emit call-back prototypes -%%------------------------------------------------------------ - -emit_callback_prototypes(G, Fd, N, [X| Xs]) when is_record(X, op) -> - %% Check scoped names XXX - {ScopedName, ArgNames, Types} = ic_cbe:extract_info(G, N, X), - {RetType, ParTypes, _} = Types, - TypeAttrArgs = mk_type_attr_arg_list(ParTypes, ArgNames), - RT = mk_c_ret_type(G, N, RetType), - - PL = ic_util:mk_list(mk_par_list_for_callback_prototypes(G, N, X, - TypeAttrArgs)), - CBPL = case PL of - "" -> - ""; - _PL -> - ", " ++ PL - end, - case RT of - "void" -> - case PL of - "" -> - emit(Fd, "~s__rs* ~s__cb(~s oe_obj, " - "CORBA_Environment *oe_env);\n", - [ScopedName, ScopedName, ic_util:to_undersc(N)]); - _ -> - emit(Fd, "~s__rs* ~s__cb(~s oe_obj, ~s, " - "CORBA_Environment *oe_env);\n", - [ScopedName, ScopedName, ic_util:to_undersc(N), PL]) - end; - "erlang_port*" -> - emit(Fd, "~s__rs* ~s__cb(~s oe_obj, ~s~s, " - "CORBA_Environment *oe_env);\n", - [ScopedName, ScopedName, ic_util:to_undersc(N), RT, CBPL]); - - "erlang_pid*" -> - emit(Fd, "~s__rs* ~s__cb(~s oe_obj, ~s~s, " - "CORBA_Environment *oe_env);\n", - [ScopedName, ScopedName, ic_util:to_undersc(N), RT, CBPL]); - - "erlang_ref*" -> - emit(Fd, "~s__rs* ~s__cb(~s oe_obj, ~s~s, " - "CORBA_Environment *oe_env);\n", - [ScopedName, ScopedName, ic_util:to_undersc(N), RT, CBPL]); - - _ -> - case ictype:isArray(G, N, RetType) of - true -> - emit(Fd, "~s__rs* ~s__cb(~s oe_obj, ~s~s, " - "CORBA_Environment *oe_env);\n", - [ScopedName, ScopedName, ic_util:to_undersc(N), RT, - CBPL]); - false -> - emit(Fd, "~s__rs* ~s__cb(~s oe_obj, ~s*~s, " - "CORBA_Environment *oe_env);\n", - [ScopedName, ScopedName, ic_util:to_undersc(N), RT, - CBPL]) - end - end, - emit_callback_prototypes(G, Fd, N, Xs); -emit_callback_prototypes(G, Fd, N, [X| Xs]) when is_record(X, attr) -> - emit_callback_prototypes(G, Fd, N, Xs); -emit_callback_prototypes(G, Fd, N, [_X| Xs]) -> - emit_callback_prototypes(G, Fd, N, Xs); -emit_callback_prototypes(_G, _Fd, _N, []) -> ok. - -%%------------------------------------------------------------ -%% Emit decoder prototypes -%%------------------------------------------------------------ - -emit_decoder_prototypes(G, Fd, N, [X| Xs]) when is_record(X, op) -> - %% Check if to use scoped call names - {ScopedName, ArgNames, Types} = ic_cbe:extract_info(G, N, X), - {_RetType, ParTypes, _} = Types, - TypeAttrArgs = mk_type_attr_arg_list(ParTypes, ArgNames), - case ic_util:mk_list(mk_par_list_for_decoder_prototypes(G, N, X, - TypeAttrArgs)) of - "" -> - ok; - PLFDP -> - emit(Fd, "int ~s__dec(~s oe_obj, ~s, CORBA_Environment " - "*oe_env);\n", - [ScopedName, ic_util:to_undersc(N), PLFDP]) - end, - emit_decoder_prototypes(G, Fd, N, Xs); -emit_decoder_prototypes(G, Fd, N, [X| Xs]) when is_record(X, attr) -> - emit_decoder_prototypes(G, Fd, N, Xs); -emit_decoder_prototypes(G, Fd, N, [_X| Xs]) -> - emit_decoder_prototypes(G, Fd, N, Xs); -emit_decoder_prototypes(_G, _Fd, _N, []) -> ok. - - -%%------------------------------------------------------------ -%% Emit encoder prototypes -%%------------------------------------------------------------ - -emit_encoder_prototypes(G, Fd, N, [X| Xs]) when is_record(X, op) -> - case ic_forms:is_oneway(X) of - true -> - emit_encoder_prototypes(G, Fd, N, Xs); - false -> - %% Check if to use scoped call names - {ScopedName, ArgNames, Types} = ic_cbe:extract_info(G, N, X), - {RetType, ParTypes, _} = Types, - TypeAttrArgs = mk_type_attr_arg_list(ParTypes, ArgNames), - RType = mk_c_ret_type(G, N, RetType), - case ic_util:mk_list(mk_par_list_for_encoder_prototypes( - G, N, X, TypeAttrArgs)) of - "" -> - case RType of - "void" -> - emit(Fd, "int ~s__enc(~s oe_obj, " - "CORBA_Environment *oe_env);\n", - [ScopedName, ic_util:to_undersc(N)]); - _ -> - emit(Fd, "int ~s__enc(~s oe_obj, ~s, " - "CORBA_Environment *oe_env);\n", - [ScopedName, ic_util:to_undersc(N), RType]) - end; - PLFEP -> - case RType of - "void" -> - emit(Fd, "int ~s__enc(~s oe_obj, ~s, " - "CORBA_Environment *oe_env);\n", - [ScopedName, ic_util:to_undersc(N), PLFEP]); - _ -> - emit(Fd, "int ~s__enc(~s oe_obj, ~s, ~s, " - "CORBA_Environment *oe_env);\n", - [ScopedName, ic_util:to_undersc(N), RType, - PLFEP]) - end - end, - emit_encoder_prototypes(G, Fd, N, Xs) - end; -emit_encoder_prototypes(G, Fd, N, [X| Xs]) when is_record(X, attr) -> - emit_encoder_prototypes(G, Fd, N, Xs); -emit_encoder_prototypes(G, Fd, N, [_X| Xs]) -> - emit_encoder_prototypes(G, Fd, N, Xs); -emit_encoder_prototypes(_G, _Fd, _N, []) -> ok. - -%%------------------------------------------------------------ -%% Emit operation mapping declaration -%%------------------------------------------------------------ - -emit_operation_mapping_declaration(G, Fd, N, Bodies) -> - Interface = ic_util:to_undersc(N), - Length = erlang:length(get_all_opnames(G, N, Bodies)), - emit(Fd, "\n/* Operation mapping */\n", []), - emit(Fd, "extern oe_map_t oe_~s_map;\n", [Interface]), - emit(Fd, "/* For backward compatibility */\n"), - emit(Fd, "#define ___~s_map___ oe_~s_map\n", - [Interface, Interface]), - case Length of - 0 -> - ok; - _ -> - emit(Fd, "extern oe_operation_t oe_~s_operations[];\n", - [Interface]), - emit(Fd, "/* For backward compatibility */\n"), - emit(Fd, "#define ___~s_operations___ oe_~s_operations\n", - [Interface, Interface]) - end. - - -%% Returns a list of {OpName, ScopedOpName} for all operations, where -%% OpName == ScopedOpName in case the `scoped_op_calls' option has -%% been set. -%% -get_all_opnames(G, N, Bodies) -> - ScNF = fun(X) -> - {ScName, _, _} = ic_cbe:extract_info(G, N, X), - ScName - end, - NF = case ic_options:get_opt(G, scoped_op_calls) of - true -> - ScNF; - false -> - fun(X) -> ic_forms:get_id2(X) end - end, - Filter = fun(X) when is_record(X, op) -> - {true, {NF(X), ScNF(X)}}; - (_) -> - false - end, - %% zf == filtermap - lists:flatmap(fun({_, Xs}) -> lists:zf(Filter, Xs) end, Bodies). - -%%------------------------------------------------------------ -%% Emit switch -%%------------------------------------------------------------ - -emit_switch(G, Fd, N, _X) -> - 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, - StartCode = - "#include \"ic.h\"\n" - "#include \"erl_interface.h\"\n" - "#include \"ei.h\"\n" - "#include \"~s__s.h\"\n\n" - "/*\n" - " * Main switch\n" - " */\n\n" - "int ~s__switch(~s oe_obj, CORBA_Environment *oe_env)\n" - "{\n" - " return oe_exec_switch(oe_obj, oe_env, &oe_~s_map);\n" - "}\n\n", - ScopedName = ic_util:to_undersc(N), - emit(Fd, StartCode, [ScopedName, ScopedName, ScopedName, ScopedName]). - -%%------------------------------------------------------------ -%% Emit server generic decoding. -%%------------------------------------------------------------ - -emit_server_generic_decoding(G, Fd, N) -> - UserProto = get_user_proto(G, oe), - Code = - "/*\n" - " * Returns call identity (left only for backward compatibility)\n" - " */\n\n" - "int ~s__call_info(~s oe_obj, CORBA_Environment *oe_env)\n" - "{\n" - " return ~s_prepare_request_decoding(oe_env);\n" - "}\n\n", - IName = ic_util:to_undersc(N), - emit(Fd, Code, [IName, IName, UserProto]). - -%%------------------------------------------------------------ -%% Emit dispatch -%%------------------------------------------------------------ - -emit_dispatch(G, Fd, N, Xs) -> - lists:foreach( - fun(X) when is_record(X, op) -> - {Name, ArgNames, Types} = ic_cbe:extract_info(G, N, X), - {RetType, ParTypes, _} = Types, - TypeAttrArgs = mk_type_attr_arg_list(ParTypes, ArgNames), - emit_exec_function(G, Fd, N, X, Name, RetType, TypeAttrArgs), - emit_parameter_decoder(G, Fd, N, X, Name, RetType, TypeAttrArgs), - emit_message_encoder(G, Fd, N, X, Name, RetType, TypeAttrArgs); - (_) -> - ok - end, Xs). - -%%------------------------------------------------------------ -%% Emit operation mapping -%%------------------------------------------------------------ - -emit_operation_mapping(G, Fd, N, Bodies) -> - OpNames = get_all_opnames(G, N, Bodies), - Interface = ic_util:to_undersc(N), - Length = erlang:length(OpNames), - emit(Fd, "\n/* Operation mapping */\n\n", []), - case Length of - 0 -> - emit(Fd, "oe_map_t oe_~s_map = { 0, NULL };\n\n", [Interface]); - _ -> - emit(Fd, "\noe_operation_t oe_~s_operations[~p] = {\n", - [Interface, Length]), - Members = lists:map( - fun({OpN, ScOpN}) -> - Name = ic_util:to_undersc([OpN]), - ScName = ic_util:to_undersc([ScOpN]), - io_lib:fwrite(" {~p, ~p, ~s__exec}", - [Interface, Name, ScName]) - end, OpNames), - emit(Fd, ic_util:join(Members, ",\n")), - emit(Fd, "};\n\n", []), - emit(Fd, "oe_map_t oe_~s_map = " - "{~p, oe_~s_operations};\n\n", - [Interface, Length, Interface]) - 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\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\n", [CName, - ConstRecord#const.val]); - true -> - emit(Fd, "#define ~s ~p\n\n", [CName, - ConstRecord#const.val]) - end, - - emit(Fd, "#endif\n\n") - end. - -%%------------------------------------------------------------ -%% Emit exec function -%%------------------------------------------------------------ - -emit_exec_function(G, Fd, N, X, Name, RetType, TypeAttrArgs) -> - %% Decoding operation specific part - InTypeAttrArgs = lists:filter(fun({_, in, _}) -> true; - ({_, _, _}) -> false - end, TypeAttrArgs), - ic_codegen:nl(Fd), - - emit(Fd, - "int ~s__exec(~s oe_obj, CORBA_Environment *oe_env)\n" - "{\n", - [Name, ic_util:to_undersc(N)]), - - emit(Fd, " if (oe_env->_received != ~p) {\n", [length(InTypeAttrArgs)]), - emit(Fd, " CORBA_exc_set(oe_env, CORBA_SYSTEM_EXCEPTION, BAD_PARAM, " - "\"Wrong number of operation parameters\");\n"), - emit_c_dec_rpt(Fd, " ", "wrong number of parameters", []), - emit_c_dec_rpt(Fd, " ", "server exec ~s\\n====\\n", [Name]), - emit(Fd, " return -1;\n", []), - emit(Fd, " }\n"), - emit(Fd, " else {\n", []), - - case InTypeAttrArgs of - [] -> - true; - _ -> - emit(Fd, " int oe_error_code = 0;\n") - end, - - %% Callback variable definition - emit_variable_defs(G, Fd, N, X, Name, RetType, TypeAttrArgs), - - %% Call to parameter decoder - emit_parameter_decoder_call(G, Fd, N, X, Name, RetType, TypeAttrArgs), - - %% Callback to user code - emit_callback(G, Fd, N, X, Name, RetType, TypeAttrArgs), - - %% Call to return message encoder - case ic_forms:is_oneway(X) of - true -> - true; - false -> - emit_message_encoder_call(G, Fd, N, X, Name, RetType, TypeAttrArgs) - end, - - %% Restore function call - emit_restore(G, Fd, N, X, Name, RetType, TypeAttrArgs), - - emit(Fd, " }\n return 0;\n}\n\n"). - -%%------------------------------------------------------------ -%% Emit parameter decoder -%%------------------------------------------------------------ - -emit_parameter_decoder(G, Fd, N, X, Name, _RetType, TypeAttrArgs) -> - %% Decoding operation specific part - InTypeAttrArgs = - lists:filter(fun({_, in, _}) -> true; - ({_, _, _}) -> false - end, TypeAttrArgs), - case InTypeAttrArgs of - [] -> - ok; - _ -> - case ic_util:mk_list(mk_par_list_for_decoder(G, N, X, - TypeAttrArgs)) of - "" -> - emit(Fd, "int ~s__dec(~s oe_obj, CORBA_Environment " - "*oe_env)\n{\n int oe_error_code;\n\n", - [Name, ic_util:to_undersc(N)]); - PLFD -> - emit(Fd, "int ~s__dec(~s oe_obj, ~s, CORBA_Environment " - "*oe_env)\n{\n", - [Name, ic_util:to_undersc(N), PLFD]), - emit(Fd, " int oe_error_code;\n\n") - end, - - APars = [], % XXX Alloced parameters - foldl( - fun({{'void', _}, _, _}, _Acc) -> - ok; - ({T1, A1, N1}, Acc) -> - emit_one_decoding(G, N, Fd, T1, A1, N1, Acc) - end, APars, InTypeAttrArgs), - - emit(Fd, " return 0;\n}\n\n") - end. - -%%------------------------------------------------------------ -%% Emit one decoding -%%------------------------------------------------------------ - -emit_one_decoding(G, N, Fd, T1, A1, N1, AllocedPars) -> - IndOp = mk_ind_op(A1), - case ic_cbe:is_variable_size(G, N, T1) of - false -> - %% The last parameter "oe_outindex" is not used in - %% the static case but must be there anyhow. - emit_decoding_stmt(G, N, Fd, T1, - N1, "", "oe_env->_inbuf", 1, "&oe_outindex", - caller, AllocedPars), - ic_codegen:nl(Fd), - AllocedPars; - true -> - emit_encoding_comment(G, N, Fd, "Decode", IndOp, T1, N1), - emit(Fd, " {\n"), - emit(Fd, " int oe_size_count_index = oe_env->_iin;\n"), - emit(Fd, " int oe_malloc_size = 0;\n"), - emit(Fd, " void *oe_first = NULL;\n"), - ic_cbe:emit_malloc_size_stmt(G, N, Fd, T1, - "oe_env->_inbuf", 1, caller), - %% This is the only malloc call in this file - emit(Fd, - " OE_MALLOC_SIZE_CHECK(oe_env, oe_malloc_size);\n" - " if ((*~s = oe_first = " - "malloc(oe_malloc_size)) == NULL) {\n", [N1]), - ic_cbe:emit_dealloc_stmts(Fd, " ", AllocedPars), - emit(Fd, - " CORBA_exc_set(oe_env, CORBA_SYSTEM_EXCEPTION, " - "NO_MEMORY, \"Cannot malloc\");\n" - " return -1;\n" - " }\n"), - ParName = "*" ++ N1, % XXX Why not IndOp? - NAllocedPars = [ParName| AllocedPars], - case ictype:isArray(G, N, T1) of - true -> - emit_decoding_stmt(G, N, Fd, T1, - "(*" ++ IndOp ++ N1 ++ ")", "", - "oe_env->_inbuf", 1, "&oe_outindex", - array_dyn, NAllocedPars); - false -> - emit_decoding_stmt(G, N, Fd, T1, - "(*" ++ IndOp ++ N1 ++ ")", "", - "oe_env->_inbuf", 1, "&oe_outindex", - caller_dyn, NAllocedPars) - end, - emit(Fd, " }\n\n"), - NAllocedPars - end. - -%%------------------------------------------------------------ -%% Emit message encoder -%%------------------------------------------------------------ - -emit_message_encoder(G, Fd, N, X, Name, RetType, TypeAttrArgs) -> - case ic_forms:is_oneway(X) of - false -> - %% Encoding operation specific part - emit(Fd, - "\nint ~s__enc(~s oe_obj", - [Name, ic_util:to_undersc(N)]), - RType = mk_c_ret_type(G, N, RetType), - ParList = mk_par_list_for_encoder(G, N, X, TypeAttrArgs), - case ic_util:mk_list(ParList) of - "" -> - case RType of - "void" -> - emit(Fd, ", CORBA_Environment *oe_env)\n{"); - _ -> - emit(Fd, ", ~s oe_return, CORBA_Environment " - "*oe_env)\n{", [RType]) - end; - PLFD -> - case RType of - "void" -> - emit(Fd, ", ~s, CORBA_Environment " - "*oe_env)\n{", [PLFD]); - _ -> - emit(Fd, ", ~s oe_return~s, CORBA_Environment " - "*oe_env)\n{", [RType, ", " ++ PLFD]) - end - end, - - - emit(Fd, "\n"), - emit(Fd, " int oe_error_code;\n\n"), - UserProto = get_user_proto(G, oe), - emit(Fd, " ~s_prepare_reply_encoding(oe_env);\n", [UserProto]), - - OutTypeAttrArgs = - lists:filter(fun({_, out, _}) -> true; - ({_, _, _}) -> false - end, TypeAttrArgs), - - OutLength = length(OutTypeAttrArgs), - case OutLength > 0 of - false -> - ic_codegen:nl(Fd); - true -> - emit(Fd, " oe_ei_encode_tuple_header(oe_env, ~p);\n\n", - [OutLength+1]) - - end, - - emit_encoding_comment(G, N, Fd, "Encode", "", RetType, - "oe_return"), - emit_encoding_stmt(G, N, X, Fd, RetType, "oe_return"), - - foreach(fun({T1, _A1, N1}) -> - case T1 of - {'void', _} -> - ok; - _ -> - emit_encoding_comment(G, N, Fd, "Encode", - "", T1, N1), - emit_encoding_stmt(G, N, X, Fd, T1, N1) - end - end, OutTypeAttrArgs), - emit(Fd, " return 0;\n}\n\n"); - _ -> - %% Oneway - ok - end. - -%%------------------------------------------------------------ -%% Emit message encoder call -%%------------------------------------------------------------ - -emit_message_encoder_call(G, Fd, N, X, Name, RetType, TypeAttrArgs) -> - emit(Fd, " /* Encoding reply message */\n"), - RType = mk_c_ret_type(G, N, RetType), - case ic_util:mk_list(mk_enc_par_list(G, N, X, TypeAttrArgs)) of - "" -> - case RType of - "void" -> - emit(Fd, " ~s(oe_obj, oe_env);\n", - [Name ++ "__enc"]); - "erlang_pid*" -> - emit(Fd, " ~s(oe_obj, &oe_return, oe_env);\n", - [Name ++ "__enc"]); - "erlang_port*" -> - emit(Fd, " ~s(oe_obj, &oe_return, oe_env);\n", - [Name ++ "__enc"]); - "erlang_ref*" -> - emit(Fd, " ~s(oe_obj, &oe_return, oe_env);\n", - [Name ++ "__enc"]); - _ -> - emit(Fd, " ~s(oe_obj, oe_return, oe_env);\n", - [Name ++ "__enc"]) - end; - - PLFE -> - case RType of - "void" -> - emit(Fd, " ~s(oe_obj, ~s, oe_env);\n", - [Name ++ "__enc", PLFE]); - "erlang_pid*" -> - emit(Fd, " ~s(oe_obj, &oe_return, ~s, oe_env);\n", - [Name ++ "__enc", PLFE]); - "erlang_port*" -> - emit(Fd, " ~s(oe_obj, &oe_return, ~s, oe_env);\n", - [Name ++ "__enc", PLFE]); - "erlang_ref*" -> - emit(Fd, " ~s(oe_obj, &oe_return, ~s, oe_env);\n", - [Name ++ "__enc", PLFE]); - _ -> - emit(Fd, " ~s(oe_obj, oe_return, ~s, oe_env);\n", - [Name ++ "__enc", PLFE]) - end - end, - ic_codegen:nl(Fd). - -%%------------------------------------------------------------ -%% Emit parameter decoding call -%%------------------------------------------------------------ - -emit_parameter_decoder_call(G, Fd, N, X, Name, _R, TypeAttrArgs) -> - case ic_util:mk_list(mk_dec_par_list(G, N, X, TypeAttrArgs)) of - "" -> %% No parameters ! skip it ! - ok; - PLFDC -> - ParDecName = Name ++ "__dec", - emit(Fd, - " /* Decode parameters */\n" - " if((oe_error_code = ~s(oe_obj, ~s, oe_env)) < 0) {\n", - [ParDecName, PLFDC]), - emit_c_dec_rpt(Fd, " ", "parmeters", []), - emit(Fd, - " if(oe_env->_major == CORBA_NO_EXCEPTION)\n" - " CORBA_exc_set(oe_env, CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad parameter on decode\");\n" - " return oe_error_code;\n }\n\n") - end. - -%%------------------------------------------------------------ -%% Emit call-back -%%------------------------------------------------------------ - -emit_callback(G, Fd, N, X, Name, RetType, TypeAttrArgs) -> - CallBackName = Name ++ "__cb", - emit(Fd, " /* Callback function call */\n"), - PL = ic_util:mk_list(mk_cb_par_list(G, N, X, TypeAttrArgs)), - case ic_forms:is_oneway(X) of - true -> - case PL of - "" -> - emit(Fd, " oe_restore = ~s(oe_obj, oe_env);\n\n", - [CallBackName]); - _ -> - emit(Fd, " oe_restore = ~s(oe_obj, ~s, oe_env);\n\n", - [CallBackName, PL]) - end; - false -> - CBPL = case PL of - "" -> - ""; - _PL -> - ", " ++ PL - end, - case mk_c_ret_type(G, N, RetType) of - "void" -> - case PL of - "" -> - emit(Fd, " oe_restore = ~s(oe_obj, oe_env);" - "\n\n", [CallBackName]); - _ -> - emit(Fd, " oe_restore = ~s(oe_obj, ~s, oe_env);" - "\n\n", [CallBackName, PL]) - end; - _ -> - case ictype:isArray(G, N, RetType) of - true -> - emit(Fd, - " oe_restore = ~s(oe_obj, oe_return~s, " - " oe_env);\n\n", [CallBackName, CBPL]); - false -> - emit(Fd, " oe_restore = ~s(oe_obj, " - "&oe_return~s, oe_env);\n\n", - [CallBackName, CBPL]) - end - end - end. - -%%------------------------------------------------------------ -%% Emit restore -%%------------------------------------------------------------ - -emit_restore(G, Fd, N, X, _Name, RetType, TypeAttrArgs) -> - emit(Fd, " /* Restore function call */\n"), - emit(Fd, " if (oe_restore != NULL)\n"), - PL = ic_util:mk_list(mk_cb_par_list(G, N, X, TypeAttrArgs)), - case ic_forms:is_oneway(X) of - true -> - case PL of - "" -> - emit(Fd, " (*oe_restore)(oe_obj, oe_env);\n\n"); - _ -> - emit(Fd, " (*oe_restore)(oe_obj, ~s, oe_env);\n\n", - [PL]) - end; - false -> - RPL = case PL of - "" -> - ""; - _PL -> - ", " ++ PL - end, - case mk_c_ret_type(G, N, RetType) of - "void" -> - case PL of - "" -> - emit(Fd, " (*oe_restore)(oe_obj, oe_env);" - "\n\n"); - _ -> - emit(Fd, " (*oe_restore)(oe_obj, ~s, oe_env);" - "\n\n", [PL]) - end; - _ -> - case ictype:isArray(G, N, RetType) of - true -> - emit(Fd, - " (*oe_restore)(oe_obj, oe_return~s, " - " oe_env);\n\n", [RPL]); - false -> - emit(Fd, " (*oe_restore)(oe_obj, " - "&oe_return~s, oe_env);\n\n", [RPL]) - end - end - end. - -%%------------------------------------------------------------ -%% Emit variable defs -%%------------------------------------------------------------ - -emit_variable_defs(G, Fd, N, X, _Name, RetType, TypeAttrArgs) -> - {ScopedName, _, _} = ic_cbe:extract_info(G, N, X), - emit(Fd, " ~s__rs* oe_restore = NULL;\n", [ScopedName]), - RestVars = mk_var_list(mk_var_decl_list(G, N, X, TypeAttrArgs)), - case ic_forms:is_oneway(X) of - true -> - emit(Fd, "~s\n\n", [RestVars]); - false -> - RType = mk_c_ret_type(G, N, RetType), - case RType of - "void" -> - emit(Fd, "~s\n\n", [RestVars]); - "CORBA_unsigned_long" -> - emit(Fd, "~s ~s oe_return = 0;\n\n", [RestVars, RType]); - "CORBA_unsigned_long_long" -> - emit(Fd, "~s ~s oe_return = 0;\n\n", [RestVars, RType]); - "CORBA_unsigned_short" -> - emit(Fd, "~s ~s oe_return = 0;\n\n", [RestVars, RType]); - "CORBA_short" -> - emit(Fd, "~s ~s oe_return = 0;\n\n", [RestVars, RType]); - "CORBA_long" -> - emit(Fd, "~s ~s oe_return = 0;\n\n", [RestVars, RType]); - "CORBA_long_long" -> - emit(Fd, "~s ~s oe_return = 0;\n\n", [RestVars, RType]); - "CORBA_float" -> - emit(Fd, "~s ~s oe_return = 0;\n\n", [RestVars, RType]); - "CORBA_double" -> - emit(Fd, "~s ~s oe_return = 0;\n\n", [RestVars, RType]); - "CORBA_char" -> - emit(Fd, "~s ~s oe_return = 0;\n\n", [RestVars, RType]); - "CORBA_wchar" -> %% WCHAR - emit(Fd, "~s ~s oe_return = 0;\n\n", [RestVars, RType]); - "CORBA_boolean" -> - emit(Fd, "~s ~s oe_return = 0;\n\n", [RestVars, RType]); - "CORBA_octet" -> - emit(Fd, "~s ~s oe_return = 0;\n\n", [RestVars, RType]); - _ -> - case ic_cbe:is_variable_size(G, N, RetType) of - true -> - emit(Fd, "~s ~s oe_return;\n\n", - [RestVars, RType]); - false -> - TK = ic_forms:get_tk(X), - case TK of - {tk_enum, _, _, _List} -> - emit(Fd, "~s ~s oe_return;\n\n", - [RestVars, RType]); - _ -> - case RType of - "erlang_binary*" -> - emit(Fd, "~s erlang_binary " - "oe_return;\n\n", [RestVars]); - "erlang_pid*" -> - emit(Fd, "~s erlang_pid " - "oe_return;\n\n", [RestVars]); - "erlang_port*" -> - emit(Fd, "~s erlang_port " - "oe_return;\n\n", [RestVars]); - "erlang_ref*" -> - emit(Fd, "~s erlang_ref " - "oe_return;\n\n", [RestVars]); - _ -> - %% Structures are - %% initiated by memset - emit(Fd, "~s ~s " - "oe_return;\n\n", - [RestVars, RType]) - end, - emit(Fd, " memset(&oe_return, 0, " - "sizeof(oe_return));\n\n") - end - end - end - end. - -%%------------------------------------------------------------ -%% Make variable list -%%------------------------------------------------------------ - -%% XXX Modify -mk_var_list([]) -> - ""; -mk_var_list([Arg| Args]) -> - " " ++ Arg ++ ";\n" ++ mk_var_list(Args). - -%%------------------------------------------------------------ -%% Make return type -%%------------------------------------------------------------ - -mk_c_ret_type(G, N, Type) -> - Ctype = 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) -> %% WSTRING - "*"; - Ctype == "CORBA_wchar *" -> %% WSTRING - ""; - true -> - case ictype:isArray(G, N, Type) of - true -> - ""; - _ -> - "*" - end - end; - false -> - if - Ctype == "erlang_pid" -> - "*"; - Ctype == "erlang_port" -> - "*"; - Ctype == "erlang_ref" -> - "*"; - true -> - "" - end - end, - Ctype ++ Dyn. - -%%------------------------------------------------------------ -%% Make call-back parameter list -%%------------------------------------------------------------ - -mk_cb_par_list(G, N, X, TypeAttrArgs0) -> - TypeAttrArgs1 = filter_type_attr_arg_list(G, X, [in, out], TypeAttrArgs0), - lists:map( - fun({Type, Attr, Arg}) -> - case ic_cbe:is_variable_size(G, N, Type) of - true -> - case Attr of - in -> - Arg; - out -> - case ictype:isArray(G, N, Type) of - true -> - Arg; - _ -> - "&" ++ Arg - end - end; - false -> - case ictype:isArray(G, N, Type) of - true -> - Arg; - _ -> - "&" ++ Arg - end - end - end, TypeAttrArgs1). - -%%------------------------------------------------------------ -%% Make decoder parameter list -%%------------------------------------------------------------ - -mk_dec_par_list(G, N, X, TypeAttrArgs0) -> - TypeAttrArgs1 = filter_type_attr_arg_list(G, X, [in], - TypeAttrArgs0), - lists:map( - fun({Type, _Attr, Arg}) -> - Ctype = mk_c_type(G, N, Type), - case ic_cbe:is_variable_size(G, N, Type) of - true -> - if - is_record(Type, string) -> - "&" ++ Arg; - Ctype == "CORBA_char *" -> - Arg; - is_record(Type, wstring) -> - "&" ++ Arg; - Ctype == "CORBA_wchar *" -> - Arg; - true -> - "&" ++ Arg - end; - false -> - case ictype:isArray(G, N, Type) of - true -> - Arg; - _ -> - "&" ++ Arg - end - end - end, TypeAttrArgs1). - -%%------------------------------------------------------------ -%% Make encoder parameter list -%%------------------------------------------------------------ - -mk_enc_par_list(G, N, X, TypeAttrArgs0) -> - TypeAttrArgs1 = filter_type_attr_arg_list(G, X, [out], - TypeAttrArgs0), - lists:map( - fun({Type, _Attr, Arg}) -> - Ctype = mk_c_type(G, N, Type), - case Ctype of - "erlang_pid" -> - "&" ++ Arg; - "erlang_port" -> - "&" ++ Arg; - "erlang_ref" -> - "&" ++ Arg; - _ -> - Arg - end - end, TypeAttrArgs1). - -%%------------------------------------------------------------ -%% Make type argument list -%%------------------------------------------------------------ - -mk_type_attr_arg_list(Types, Args) -> - filterzip( - fun(Type, {Attr, Arg}) -> - {true, {Type, Attr, Arg}} - end, Types, Args). - -%%------------------------------------------------------------ -%% Filter type argument list -%%------------------------------------------------------------ - -filter_type_attr_arg_list(G, X, InOrOut, TypeAttrArgs) -> - lists:filter( - - fun({_Type, inout, Arg}) -> - ic_error:error(G, {inout_spec_for_c, X, Arg}), - false; - ({_Type, Attr, _Arg}) -> - lists:member(Attr, InOrOut) - end, TypeAttrArgs). - -%%------------------------------------------------------------ -%% Make indirection operator -%%------------------------------------------------------------ - -mk_ind_op(in) -> - ""; -mk_ind_op(inout) -> - error; -mk_ind_op(_) -> - "*". - -%%------------------------------------------------------------ -%% Make parameter list for decoder -%%------------------------------------------------------------ - -mk_par_list_for_decoder(G, N, X, TypeAttrArgs0) -> - TypeAttrArgs1 = filter_type_attr_arg_list(G, X, [in], TypeAttrArgs0), - lists:map( - fun({Type, Attr, Arg}) -> - Ctype = 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) -> %% WSTRING - "**"; - Ctype == "CORBA_wchar *" -> %% WSTRING - ""; - true -> - case ictype:isArray(G, N, Type) of - true -> - slice(Attr) ++ "*"; - _ -> - "**" - end - end; - false -> - case ictype:isArray(G, N, Type) of - true -> - ""; - _ -> - "*" - end - end, - Ctype ++ Dyn ++ " " ++ Arg - end, TypeAttrArgs1). - -%%------------------------------------------------------------ -%% Make parameter list for encoder -%%------------------------------------------------------------ - -mk_par_list_for_encoder(G, N, X, TypeAttrArgs0) -> - TypeAttrArgs1 = filter_type_attr_arg_list(G, X, [out], TypeAttrArgs0), - lists:map( - fun({Type, _Attr, Arg}) -> - Ctype = 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) -> %% WSTRING - "*"; - Ctype == "CORBA_wchar *" -> %% WSTRING - ""; - true -> - case ictype:isArray(G, N, Type) of - true -> - ""; - _ -> - "*" - end - end; - false -> - if - Ctype == "erlang_pid" -> - "*"; - Ctype == "erlang_port" -> - "*"; - Ctype == "erlang_ref" -> - "*"; - true -> - "" - end - end, - Ctype ++ " " ++ Dyn ++ Arg - end, TypeAttrArgs1). - -%%------------------------------------------------------------ -%% Make parameter list for decoder prototypes -%%------------------------------------------------------------ - -mk_par_list_for_decoder_prototypes(G, N, X, TypeAttrArgs0) -> - TypeAttrArgs1 = filter_type_attr_arg_list(G, X, [in], TypeAttrArgs0), - lists:map( - fun({Type, Attr, _Arg}) -> - Ctype = 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) -> %% WSTRING - "**"; - Ctype == "CORBA_wchar *" -> %% WSTRING - ""; - true -> - case ictype:isArray(G, N, Type) of - true -> - slice(Attr) ++ "*"; - _ -> - "**" - end - end; - false -> - case ictype:isArray(G, N, Type) of - true -> - ""; - _ -> - "*" - end - end, - Ctype ++ Dyn - end, TypeAttrArgs1). - -%%------------------------------------------------------------ -%% Make parameter list for encoder prototypes -%%------------------------------------------------------------ - -mk_par_list_for_encoder_prototypes(G, N, X, TypeAttrArgs0) -> - TypeAttrArgs1 = filter_type_attr_arg_list(G, X, [out], TypeAttrArgs0), - lists:map( - fun({Type, _Attr, _Arg}) -> - Ctype = 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) -> %% WSTRING - "*"; - Ctype == "CORBA_wchar *" -> %% WSTRING - ""; - true -> - case ictype:isArray(G, N, Type) of - true -> - ""; - _ -> - "*" - end - end; - false -> - if - Ctype == "erlang_pid" -> - "*"; - Ctype == "erlang_port" -> - "*"; - Ctype == "erlang_ref" -> - "*"; - true -> - "" - end - end, - Ctype ++ Dyn - end, TypeAttrArgs1). - -%%------------------------------------------------------------ -%% Make parameter list for call-back prototypes -%%------------------------------------------------------------ - -mk_par_list_for_callback_prototypes(G, N, X, TypeAttrArgs0) -> - TypeAttrArgs1 = filter_type_attr_arg_list(G, X, [in, out], - TypeAttrArgs0), - lists:map( - fun({Type, Attr, _Arg}) -> - IndOp = mk_ind_op(Attr), - Ctype = mk_c_type(G, N, Type), - Dyn = case ic_cbe:is_variable_size(G, N, Type) of - true -> - if - is_record(Type, string) -> - "*" ++ IndOp; - Ctype == "CORBA_char *" -> - "" ++ IndOp; - is_record(Type, wstring) -> %% WSTRING - "*" ++ IndOp; - Ctype == "CORBA_wchar *" -> %% WSTRING - "" ++ IndOp; - true -> - case ictype:isArray(G, N, Type) of - true -> - ""; - _ -> - "*" ++ IndOp - end - end; - false -> - case ictype:isArray(G, N, Type) of - true -> - ""; - _ -> - case Attr of %% Should just be IndOp - in -> - "*" ++ IndOp; - out -> - IndOp - end - end - end, - Ctype ++ Dyn - end, TypeAttrArgs1). - -%%------------------------------------------------------------ -%% Make variable declaration list -%%------------------------------------------------------------ - -mk_var_decl_list(G, N, X, TypeAttrArgs0) -> - TypeAttrArgs1 = filter_type_attr_arg_list(G, X, [in, out], - TypeAttrArgs0), - lists:map( - fun({Type, Attr, Arg}) -> - Ctype = mk_c_type(G, N, Type), - VarDecl = case ic_cbe:is_variable_size(G, N, Type) of - true -> - if - is_record(Type, string) -> - Ctype ++ "* " ++ Arg ++ " = NULL"; - Ctype == "CORBA_char *" -> - Ctype ++ " " ++ Arg ++ " = NULL"; - is_record(Type, wstring) -> %% WSTRING - Ctype ++ "* " ++ Arg ++ " = NULL"; - Ctype == "CORBA_wchar *" -> %% WSTRING - Ctype ++ " " ++ Arg ++ " = NULL"; - true -> - case ictype:isArray(G, N, Type) of - true -> - Ctype ++ slice(Attr) ++ " " ++ - Arg; - _ -> - Ctype ++ "* " ++ Arg - end - end; - false -> - Ctype ++ " " ++ Arg - end, - - VarDecl - end, TypeAttrArgs1). - -%%------------------------------------------------------------ -%% Slice -%%------------------------------------------------------------ - -slice(in) -> - "_slice*"; -slice(_) -> - "". - -%%------------------------------------------------------------ -%% Special comment functions -%%------------------------------------------------------------ - -emit_encoding_comment(G, N, F, String, RefOrVal, Type, Name) -> - emit(F, [io_lib:format(" /* ~s parameter: ~s~s ~s */\n", - [String, mk_c_type(G, N, Type), - RefOrVal, Name])]). - - -%%------------------------------------------------------------ -%% Make C type -%%------------------------------------------------------------ - -%% -%% Warning this is NOT identical to mk_c_type in ic_cbe.erl -%% -mk_c_type(G, N, S) -> - mk_c_type(G, N, S, evaluate). - -mk_c_type(G, N, S, evaluate) when element(1, S) == scoped_id -> - {FullScopedName, _T, _TK, _} = ic_symtab:get_full_scoped_name(G, N, S), - BT = ic_code:get_basetype(G, ic_util:to_undersc(FullScopedName)), - case BT of - "erlang_binary" -> - "erlang_binary"; - "erlang_pid" -> - "erlang_pid"; - "erlang_port" -> - "erlang_port"; - "erlang_ref" -> - "erlang_ref"; - "erlang_term" -> - "ETERM*"; - {enum, Type} -> - mk_c_type(G, N, Type, evaluate); - Type -> - mk_c_type(G, N, Type, evaluate) - end; -mk_c_type(G, N, S, evaluate_not) when element(1, S) == scoped_id -> - {FullScopedName, _T, _TK, _} = ic_symtab:get_full_scoped_name(G, N, S), - BT = ic_code:get_basetype(G, ic_util:to_undersc(FullScopedName)), - case BT of - "erlang_binary" -> - "erlang_binary"; - "erlang_pid" -> - "erlang_pid"; - "erlang_port" -> - "erlang_port"; - "erlang_ref" -> - "erlang_ref"; - "erlang_term" -> - "ETERM*"; - Type -> - Type - end; -mk_c_type(_G, _N, S, _) when is_list(S) -> - S; -mk_c_type(_G, _N, S, _) when is_record(S, string) -> - "CORBA_char"; -mk_c_type(_G, _N, S, _) when is_record(S, wstring) -> %% WSTRING - "CORBA_wchar"; -mk_c_type(_G, _N, {boolean, _}, _) -> - "CORBA_boolean"; -mk_c_type(_G, _N, {octet, _}, _) -> - "CORBA_octet"; -mk_c_type(_G, _N, {void, _}, _) -> - "void"; -mk_c_type(_G, _N, {unsigned, U}, _) -> - case U of - {short, _} -> - "CORBA_unsigned_short"; - {long, _} -> - "CORBA_unsigned_long"; - {'long long', _} -> - "CORBA_unsigned_long_long" - end; -mk_c_type(_G, _N, {'long long', _}, _) -> - "CORBA_long_long"; -mk_c_type(_G, _N, {'any', _}, _) -> %% Fix for any type - "CORBA_long"; -mk_c_type(_G, _N, {T, _}, _) -> - "CORBA_" ++ atom_to_list(T). - -%%------------------------------------------------------------ -%% Emit encoding statement -%%------------------------------------------------------------ - -%% emit_encoding_stmt(G, N, X, Fd, T, LName) -%% -%% -emit_encoding_stmt(G, N, X, Fd, T, LName) when element(1, T) == scoped_id -> - case mk_c_type(G, N, T, evaluate_not) of - "erlang_pid" -> - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_pid(oe_env, ~s)) < 0) {\n", - [LName]), - emit_c_enc_rpt(Fd, " ", "oe_ei_encode_pid", []), - emit(Fd, " return oe_error_code;\n }\n"); - "erlang_port" -> - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_port(oe_env, ~s)) < 0) {\n", - [LName]), - emit_c_enc_rpt(Fd, " ", "oe_ei_encode_port", []), - emit(Fd, " return oe_error_code;\n }\n"); - "erlang_ref" -> - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_ref(oe_env, ~s)) < 0) {\n", - [LName]), - emit_c_enc_rpt(Fd, " ", "oe_ei_encode_ref", []), - emit(Fd, " return oe_error_code;\n }\n"); - "ETERM*" -> - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_term(oe_env, ~s)) < 0) {\n", - [LName]), - emit_c_enc_rpt(Fd, " ", "oe_ei_encode_term", []), - emit(Fd, " return oe_error_code;\n }\n"); - {enum, FSN} -> - emit_encoding_stmt(G, N, X, Fd, FSN, LName); - FSN -> - emit_encoding_stmt(G, N, X, Fd, FSN, LName) - end; -emit_encoding_stmt(G, N, X, Fd, T, LName) when is_list(T) -> - %% Already a fullscoped name - case get_param_tk(LName, X) of - error -> - emit(Fd, " if ((oe_error_code = ~s~s(oe_env, ~s)) < 0) {\n", - [ic_util:mk_oe_name(G, "encode_"), T, LName]); - ParamTK -> - case ic_cbe:is_variable_size(ParamTK) of - true -> - emit(Fd, " if ((oe_error_code = ~s~s(oe_env, ~s)) < 0)" - " {\n", - [ic_util:mk_oe_name(G, "encode_"), T, LName]), - emit(Fd, " CORBA_exc_set(oe_env, " - "CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation parameter on encode\");" - "\n"), - ?emit_c_enc_rpt(Fd, " ", "", []), - emit(Fd, " return oe_error_code;\n }\n\n"); - false -> - if is_atom(ParamTK) -> - case ParamTK of - tk_ushort -> - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_ulong(oe_env, " - "(unsigned long) ~s)) < 0) {\n", - [LName]), - emit(Fd, " CORBA_exc_set(oe_env, " - "CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation " - "parameter on encode\");\n"), - ?emit_c_enc_rpt(Fd, " ", "ushort", []), - emit(Fd, " return " - "oe_error_code;\n }\n\n"); - tk_ulong -> - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_ulong(oe_env, " - "~s)) < 0) {\n", [LName]), - emit(Fd, " CORBA_exc_set(oe_env, " - "CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation " - "parameter on encode\");\n"), - ?emit_c_enc_rpt(Fd, " ", "ulong", []), - emit(Fd, " return " - "oe_error_code;\n }\n\n"); - tk_ulonglong -> - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_ulonglong(oe_env, " - "~s)) < 0) {\n", [LName]), - emit(Fd, " CORBA_exc_set(oe_env, " - "CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation " - "parameter on encode\");\n"), - ?emit_c_enc_rpt(Fd, " ", "ulonglong", []), - emit(Fd, " return " - "oe_error_code;\n }\n\n"); - tk_short -> - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_long(oe_env, " - "(long) ~s)) < 0) {\n", [LName]), - emit(Fd, " CORBA_exc_set(oe_env, " - "CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation " - "parameter on encode\");\n"), - ?emit_c_enc_rpt(Fd, " ", "short", []), - emit(Fd, " return " - "oe_error_code;\n }\n\n"); - tk_long -> - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_long(oe_env, " - "~s)) < 0) {\n", [LName]), - emit(Fd, " CORBA_exc_set(oe_env, " - "CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation " - "parameter on encode\");\n"), - ?emit_c_enc_rpt(Fd, " ", "long", []), - emit(Fd, " return " - "oe_error_code;\n }\n\n"); - tk_longlong -> - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_longlong(oe_env, " - "~s)) < 0) {\n", [LName]), - emit(Fd, " CORBA_exc_set(oe_env, " - "CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation " - "parameter on encode\");\n"), - ?emit_c_enc_rpt(Fd, " ", "longlong", []), - emit(Fd, " return " - "oe_error_code;\n }\n\n"); - tk_float -> - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_double(oe_env, " - "(double) ~s)) < 0) {\n", [LName]), - emit(Fd, " CORBA_exc_set(oe_env, " - "CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation " - "parameter on encode\");\n"), - ?emit_c_enc_rpt(Fd, " ", "float", []), - emit(Fd, " return " - "oe_error_code;\n }\n\n"); - tk_double -> - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_double(oe_env, " - "~s)) < 0) {\n", [LName]), - emit(Fd, " CORBA_exc_set(oe_env, " - "CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation " - "parameter on encode\");\n"), - ?emit_c_enc_rpt(Fd, " ", "double", []), - emit(Fd, " return " - "oe_error_code;\n }\n\n"); - tk_boolean -> - emit(Fd, " switch(~s) {\n", [LName]), - emit(Fd, " case 0 :\n"), - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_atom(oe_env, " - "\"false\")) < 0) {\n"), - emit(Fd, " CORBA_exc_set(oe_env, " - "CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation " - "parameter on encode\");\n"), - ?emit_c_enc_rpt(Fd, " ", "boolean", []), - emit(Fd, " return " - "oe_error_code;\n }\n"), - emit(Fd, " break;\n"), - emit(Fd, " case 1 :\n"), - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_atom(oe_env, " - "\"true\")) < 0) {\n"), - emit(Fd, " CORBA_exc_set(oe_env, " - "CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation " - "parameter on encode\");\n"), - ?emit_c_enc_rpt(Fd, " ", "boolean", []), - emit(Fd, " return " - "oe_error_code;\n }\n"), - emit(Fd, " break;\n"), - emit(Fd, " default :\n"), - emit(Fd, " CORBA_exc_set(oe_env, " - "CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation " - "parameter on encode\");\n"), - ?emit_c_enc_rpt(Fd, " ", "boolean", []), - emit(Fd, " return -1;\n"), - emit(Fd, " }\n\n"); - tk_char -> - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_char(oe_env, " - "~s)) < 0) {\n", [LName]), - emit(Fd, " CORBA_exc_set(oe_env, " - "CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation " - "parameter on encode\");\n"), - ?emit_c_enc_rpt(Fd, " ", "char", []), - emit(Fd, " return " - "oe_error_code;\n }\n\n"); - tk_wchar -> %% WCHAR - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_wchar(oe_env, " - "~s)) < 0) {\n", [LName]), - emit(Fd, " CORBA_exc_set(oe_env, " - "CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation " - "parameter on encode\");\n"), - ?emit_c_enc_rpt(Fd, " ", "wchar", []), - emit(Fd, " return " - "oe_error_code;\n }\n\n"); - tk_octet -> - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_char(oe_env, " - "~s)) < 0) {\n", [LName]), - emit(Fd, " CORBA_exc_set(oe_env, " - "CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation " - "parameter on encode\");\n"), - ?emit_c_enc_rpt(Fd, " ", "octet", []), - emit(Fd, " return " - "oe_error_code;\n }\n\n"); - tk_any -> - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_long(oe_env, " - "~s)) < 0) {\n", [LName]), - emit(Fd, " CORBA_exc_set(oe_env, " - "CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation " - "parameter on encode\");\n"), - ?emit_c_enc_rpt(Fd, " ", "any", []), - emit(Fd, " return " - "oe_error_code;\n }\n\n"); - _ -> - emit(Fd, " CORBA_exc_set(oe_env, " - "CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation " - "parameter on encode\");\n"), - ?emit_c_enc_rpt(Fd, " ", "tk_unknown", []), - emit(Fd, " return " - "oe_error_code;\n }\n\n"), - ok - end; - true -> - case element(1, ParamTK) of - tk_enum -> - emit(Fd, " if ((oe_error_code = " - "~s~s(oe_env, ~s)) < 0) {\n", - [ic_util:mk_oe_name(G, "encode_"), - T, LName]), - ?emit_c_enc_rpt(Fd, " ", "enum", []); - tk_array -> - emit(Fd, " if ((oe_error_code = " - "~s~s(oe_env, ~s)) < 0) {\n", - [ic_util:mk_oe_name(G, "encode_"), - T, LName]), - ?emit_c_enc_rpt(Fd, " ", "array", []); - _ -> - emit(Fd, " if ((oe_error_code = " - "~s~s(oe_env, &~s)) < 0) {\n", - [ic_util:mk_oe_name(G, "encode_"), - T, LName]), - ?emit_c_enc_rpt(Fd, " ", "", []) - end, - emit(Fd, " CORBA_exc_set(oe_env, " - "CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation " - "parameter on encode\");\n"), - emit(Fd, " return oe_error_code;\n }\n\n") - end - end - end; -emit_encoding_stmt(G, N, _X, Fd, T, LName) when is_record(T, string) -> - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_string(oe_env, (const char*) ~s)) < 0) {\n", - [LName]), - emit(Fd, " CORBA_exc_set(oe_env, CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Cannot encode string\");\n"), - ?emit_c_enc_rpt(Fd, " ", "string", []), - emit(Fd, " return oe_error_code;\n }\n\n"); -emit_encoding_stmt(G, N, _X, Fd, T, LName) when is_record(T, wstring) -> - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_wstring(oe_env, ~s)) < 0) {\n", - [LName]), - ?emit_c_enc_rpt(Fd, " ", "wstring", []), - emit(Fd, " CORBA_exc_set(oe_env, CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Cannot encode string\");\n"), - emit(Fd, " return oe_error_code;\n }\n\n"); -emit_encoding_stmt(G, N, _X, Fd, T, LName) -> - case T of - {unsigned, {short, _}} -> - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_ulong(oe_env, (unsigned long) ~s)) < 0) {\n", - [LName]), - ?emit_c_enc_rpt(Fd, " ", "ushort", []), - emit(Fd, " CORBA_exc_set(oe_env, CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation parameter on encode\");\n"), - emit(Fd, " return oe_error_code;\n }\n\n"); - {unsigned, {long, _}} -> - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_ulong(oe_env, ~s)) < 0) {\n", - [LName]), - ?emit_c_enc_rpt(Fd, " ", "ulong", []), - emit(Fd, " CORBA_exc_set(oe_env, CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation parameter on encode\");\n"), - emit(Fd, " return oe_error_code;\n }\n\n"); - {unsigned, {'long long', _}} -> - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_ulonglong(oe_env, ~s)) < 0) {\n", - [LName]), - ?emit_c_enc_rpt(Fd, " ", "ulonglong", []), - emit(Fd, " CORBA_exc_set(oe_env, CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation parameter on encode\");\n"), - emit(Fd, " return oe_error_code;\n }\n\n"); - {short, _} -> - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_long(oe_env, (long) ~s)) < 0) {\n", - [LName]), - ?emit_c_enc_rpt(Fd, " ", "short", []), - emit(Fd, " CORBA_exc_set(oe_env, CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation parameter on encode\");\n"), - emit(Fd, " return oe_error_code;\n }\n\n"); - {long, _} -> - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_long(oe_env, ~s)) < 0) {\n", - [LName]), - ?emit_c_enc_rpt(Fd, " ", "long", []), - emit(Fd, " CORBA_exc_set(oe_env, CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation parameter on encode\");\n"), - emit(Fd, " return oe_error_code;\n }\n\n"); - {'long long', _} -> - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_longlong(oe_env, ~s)) < 0) {\n", - [LName]), - ?emit_c_enc_rpt(Fd, " ", "longlong", []), - emit(Fd, " CORBA_exc_set(oe_env, CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation parameter on encode\");\n"), - emit(Fd, " return oe_error_code;\n }\n\n"); - {float, _} -> - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_double(oe_env, (double) ~s)) < 0) {\n", - [LName]), - ?emit_c_enc_rpt(Fd, " ", "float", []), - emit(Fd, " CORBA_exc_set(oe_env, CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation parameter on encode\");\n"), - emit(Fd, " return oe_error_code;\n }\n\n"); - {double, _} -> - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_double(oe_env, ~s)) < 0) {\n", - [LName]), - ?emit_c_enc_rpt(Fd, " ", "double", []), - emit(Fd, " CORBA_exc_set(oe_env, CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation parameter on encode\");\n"), - emit(Fd, " return oe_error_code;\n }\n\n"); - {boolean, _} -> - emit(Fd, " switch(~s) {\n", [LName]), - emit(Fd, " case 0 :\n"), - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_atom(oe_env, \"false\")) < 0) {\n"), - ?emit_c_enc_rpt(Fd, " ", "boolean", []), - emit(Fd, " CORBA_exc_set(oe_env, CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation parameter on encode\");\n"), - emit(Fd, " return oe_error_code;\n }\n"), - emit(Fd, " break;\n"), - emit(Fd, " case 1 :\n"), - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_atom(oe_env, \"true\")) < 0) {\n"), - ?emit_c_enc_rpt(Fd, " ", "boolean", []), - emit(Fd, " CORBA_exc_set(oe_env, CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation parameter on encode\");\n"), - emit(Fd, " return oe_error_code;\n }\n"), - emit(Fd, " break;\n"), - emit(Fd, " default :\n"), - ?emit_c_enc_rpt(Fd, " ", "boolean", []), - emit(Fd, " CORBA_exc_set(oe_env, CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation parameter on encode\");\n"), - emit(Fd, " return -1;\n"), - emit(Fd, " }\n\n"); - {char, _} -> - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_char(oe_env, ~s)) < 0) {\n", - [LName]), - ?emit_c_enc_rpt(Fd, " ", "char", []), - emit(Fd, " CORBA_exc_set(oe_env, CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation parameter on encode\");\n"), - emit(Fd, " return oe_error_code;\n }\n\n"); - {wchar, _} -> %% WCHAR - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_wchar(oe_env, ~s)) < 0) {\n", - [LName]), - ?emit_c_enc_rpt(Fd, " ", "wchar", []), - emit(Fd, " CORBA_exc_set(oe_env, CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation parameter on encode\");\n"), - emit(Fd, " return oe_error_code;\n }\n\n"); - {octet, _} -> - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_char(oe_env, ~s)) < 0) {\n", - [LName]), - ?emit_c_enc_rpt(Fd, " ", "octet", []), - emit(Fd, " CORBA_exc_set(oe_env, CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation parameter on encode\");\n"), - emit(Fd, " return oe_error_code;\n }\n\n"); - {void, _} -> - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_atom(oe_env, \"void\")) < 0) {\n"), - ?emit_c_enc_rpt(Fd, " ", "void", []), - emit(Fd, " CORBA_exc_set(oe_env, CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation parameter on encode\");\n"), - emit(Fd, " return oe_error_code;\n }\n\n"); - {sequence, _, _} -> - ?emit_c_enc_rpt(Fd, " ", "sequence", []), - emit(Fd, " CORBA_exc_set(oe_env, CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation parameter on encode\");\n"), - emit(Fd, " return oe_error_code;\n }\n\n"); - {any, _} -> %% Fix for any type - emit(Fd, " if ((oe_error_code = " - "oe_ei_encode_long(oe_env, ~s)) < 0) {\n", - [LName]), - ?emit_c_enc_rpt(Fd, " ", "any", []), - emit(Fd, " CORBA_exc_set(oe_env, CORBA_SYSTEM_EXCEPTION, " - "BAD_PARAM, \"Bad operation parameter on encode\");\n"), - emit(Fd, " return oe_error_code;\n }\n\n"); - _ -> - ic_error:fatal_error(G, {illegal_typecode_for_c, T, N}) - end. - -%%------------------------------------------------------------ -%% Get type kind parameter -%%------------------------------------------------------------ - -%% Useful functions -get_param_tk("oe_return", Op) -> - ic_forms:get_tk(Op); -get_param_tk(Name, Op) -> - case get_param(Name, Op) of - error -> - error; - Param -> - ic_forms:get_tk(Param) - end. - -%%------------------------------------------------------------ -%% Get parameter (for what? XXX) -%%------------------------------------------------------------ - -get_param(Name, Op) when is_record(Op, op) -> - get_param_loop(Name, Op#op.params); -get_param(_Name, _Op) -> - error. - -get_param_loop(_Name, []) -> - error; -get_param_loop(Name, [Param| Params]) -> - case ic_forms:get_id2(Param) of - Name -> - Param; - _ -> - get_param_loop(Name, Params) - end. - -%%------------------------------------------------------------ -%% Emit decoding statement -%%------------------------------------------------------------ - -emit_decoding_stmt(G, N, Fd, T, LName, IndOp, InBuffer, Align, NextPos, - DecType, AllocedPars) when element(1, T) == scoped_id -> - case mk_c_type(G, N, T, evaluate_not) of - "erlang_pid" -> - emit(Fd, " if ((oe_error_code = ei_decode_pid(~s, " - "&oe_env->_iin, ~s~s)) < 0) {\n", - [InBuffer, IndOp, LName]), - ic_cbe:emit_dealloc_stmts(Fd, " ", AllocedPars), - ?emit_c_dec_rpt(Fd, " ", "", []), - emit(Fd, " return oe_error_code;\n"), - emit(Fd, " }\n\n"); - "erlang_port" -> - emit(Fd, " if ((oe_error_code = ei_decode_port(~s, " - "&oe_env->_iin, ~s~s)) < 0) {\n", - [InBuffer, IndOp, LName]), - ic_cbe:emit_dealloc_stmts(Fd, " ", AllocedPars), - ?emit_c_dec_rpt(Fd, " ", "", []), - emit(Fd, " return oe_error_code;\n"), - emit(Fd, " }\n\n"); - "erlang_ref" -> - emit(Fd, " if ((oe_error_code = ei_decode_ref(~s, " - "&oe_env->_iin, ~s~s)) < 0) {\n", - [InBuffer, IndOp, LName]), - ic_cbe:emit_dealloc_stmts(Fd, " ", AllocedPars), - ?emit_c_dec_rpt(Fd, " ", "", []), - emit(Fd, " return oe_error_code;\n"), - emit(Fd, " }\n\n"); - "ETERM*" -> - emit(Fd, " if ((oe_error_code = ei_decode_term(~s, " - "&oe_env->_iin, (void**)~s~s)) < 0) {\n", - [InBuffer, IndOp, LName]), - ic_cbe:emit_dealloc_stmts(Fd, " ", AllocedPars), - ?emit_c_dec_rpt(Fd, " ", "", []), - emit(Fd, " return oe_error_code;\n"), - emit(Fd, " }\n\n"); - {enum, FSN} -> - emit_decoding_stmt(G, N, Fd, FSN, LName, IndOp, - InBuffer, Align, NextPos, DecType, AllocedPars); - FSN -> - emit_decoding_stmt(G, N, Fd, FSN, LName, IndOp, - InBuffer, Align, NextPos, DecType, AllocedPars) - end; -emit_decoding_stmt(G, N, Fd, T, LName, IndOp, InBuffer, _Align, NextPos, - DecType, AllocedPars) when is_list(T) -> - %% Already a fullscoped name - Type = ictype:name2type(G, T), - case ictype:isBasicType(Type) of - true -> - emit_decoding_stmt_for_basic_type(Fd, Type, InBuffer, IndOp, - LName, AllocedPars); - false -> - emit(Fd, " {\n"), - case DecType of - caller -> %% No malloc used, define oe_first anyhow. - emit(Fd, " void *oe_first = NULL;\n"), - emit(Fd, " int oe_outindex = 0;\n\n"); - array_dyn -> %% Malloc used - emit(Fd, " int oe_outindex = 0;\n\n"); - %% [ic_util:mk_align(io_lib:format("sizeof(~s)", [T]))]); - caller_dyn -> %% Malloc used - emit(Fd, " int oe_outindex = 0;\n\n") - end, - emit(Fd, " if ((oe_error_code = ~s~s(oe_env, oe_first, " - "~s, ~s)) < 0) {\n", - [ic_util:mk_oe_name(G, "decode_"), - T, NextPos, LName]), - ic_cbe:emit_dealloc_stmts(Fd, " ", AllocedPars), - ?emit_c_dec_rpt(Fd, " ", "", []), - emit(Fd, " return oe_error_code;\n"), - emit(Fd, " }\n"), - emit(Fd, " }\n") - end; -emit_decoding_stmt(G, N, Fd, T, LName, IndOp, InBuffer, _Align, _NextPos, - _DecType, AllocedPars) when is_record(T, string) -> - emit(Fd, " if ((oe_error_code = ei_decode_string(~s, " - "&oe_env->_iin, ~s~s)) < 0) {\n", - [InBuffer, IndOp, LName]), - ic_cbe:emit_dealloc_stmts(Fd, " ", AllocedPars), - ?emit_c_dec_rpt(Fd, " ", "", []), - emit(Fd, " return oe_error_code;\n"), - emit(Fd, " }\n"); -emit_decoding_stmt(G, N, Fd, T, LName, IndOp, InBuffer, _Align, _NextPos, - _DecType, AllocedPars) when is_record(T, wstring) -> - %% WSTRING - emit(Fd, " if ((oe_error_code = " - "oe_ei_decode_wstring(~s, " - "&oe_env->_iin, ~s~s)) < 0) {\n", - [InBuffer, IndOp, LName]), - ic_cbe:emit_dealloc_stmts(Fd, " ", AllocedPars), - ?emit_c_dec_rpt(Fd, " ", "", []), - emit(Fd, " return oe_error_code;\n\n"), - emit(Fd, " }\n"); -emit_decoding_stmt(G, N, Fd, T, LName, IndOp, InBuffer, _Align, _NextPos, - _DecType, AllocedPars) -> - case ic_cbe:normalize_type(T) of - {basic, Type} -> - emit_decoding_stmt_for_basic_type(Fd, Type, InBuffer, IndOp, - LName, AllocedPars); - _ -> - case T of - {void, _} -> - emit(Fd, - " if ((oe_error_code = ei_decode_atom(~s, " - "&oe_env->_iin, 0)) < 0) {\n", - [InBuffer]), - ic_cbe:emit_dealloc_stmts(Fd, " ", AllocedPars), - ?emit_c_dec_rpt(Fd, " ", "", []), - emit(Fd, " return oe_error_code;\n"), - emit(Fd, " }\n"); - {sequence, _, _} -> - %% XXX XXX Why? - ?emit_c_dec_rpt(Fd, " ", "", []), - emit(Fd, " return oe_error_code;\n\n"); - {any, _} -> %% Fix for any type - emit(Fd, - " if ((oe_error_code = ei_decode_long(~s, " - "&oe_env->_iin, ~s~s)) < 0) {\n", - [InBuffer, IndOp, LName]), - ic_cbe:emit_dealloc_stmts(Fd, " ", AllocedPars), - ?emit_c_dec_rpt(Fd, " ", "", []), - emit(Fd, " return oe_error_code;\n\n"), - emit(Fd, " }\n"); - _ -> - ic_error:fatal_error(G, {illegal_typecode_for_c, T, N}) - end - end. - -emit_decoding_stmt_for_basic_type(Fd, Type, InBuffer, IndOp, - LName, AllocedPars) -> - Fmt = - " if ((oe_error_code = ~sei_decode_~s(~s, &oe_env->_iin, " - "~s~s)) < 0) {\n", - Ret = - " return oe_error_code;\n" - "}\n", - - {Pre, DecType} = - case Type of - ushort -> {"", "ulong"}; - ulong -> {"", "ulong"}; - ulonglong -> {"oe_", "ulonglong"}; - short -> {"", "long"}; - long -> {"", "long"}; - longlong -> {"oe_", "longlong"}; - float -> {"", "double"}; - double -> {"", "double"}; - boolean -> {"", "atom"}; - char -> {"", "char"}; - wchar -> {"oe_", "wchar"}; - octet -> {"", "char"}; - any -> {"", "long"} - end, - case Type of - ushort -> - emit(Fd, " {\n"), - emit(Fd, " unsigned long oe_ulong;\n"), - emit(Fd, " if ((oe_error_code = ei_decode_ulong(~s, " - "&oe_env->_iin, &oe_ulong)) < 0) {\n", [InBuffer]), - ic_cbe:emit_dealloc_stmts(Fd, " ", AllocedPars), - emit_c_dec_rpt(Fd, " ", "ushort", []), - emit(Fd, " return oe_error_code;\n"), - emit(Fd, " }\n"), - emit(Fd, " *~s = (unsigned short) oe_ulong;\n", [LName]), - emit(Fd, " }\n\n"); - short -> - emit(Fd, " {\n"), - emit(Fd, " long oe_long;\n"), - emit(Fd, " if ((oe_error_code = ei_decode_long(~s, " - "&oe_env->_iin, &oe_long)) < 0) {\n", [InBuffer]), - ic_cbe:emit_dealloc_stmts(Fd, " ", AllocedPars), - emit_c_dec_rpt(Fd, " ", "short", []), - emit(Fd, " return oe_error_code;\n"), - emit(Fd, " }\n"), - emit(Fd, " *~s = (short) oe_long;\n", [LName]), - emit(Fd, " }\n\n"); - float -> - emit(Fd, " {\n"), - emit(Fd, " double oe_double;\n"), - emit(Fd, " if ((oe_error_code = ei_decode_double(~s, " - "&oe_env->_iin, &oe_double)) < 0) {\n", [InBuffer]), - ic_cbe:emit_dealloc_stmts(Fd, " ", AllocedPars), - emit_c_dec_rpt(Fd, " ", "float", []), - emit(Fd, " return oe_error_code;\n"), - emit(Fd, " }\n"), - emit(Fd, " *~s = (float) oe_double;\n", [LName]), - emit(Fd, " }\n\n"); - boolean -> - emit(Fd, " {\n"), - emit(Fd, " char oe_bool[25];\n\n"), - emit(Fd, " if ((oe_error_code = ei_decode_atom(~s, " - "&oe_env->_iin, oe_bool)) < 0) {\n", [InBuffer]), - ic_cbe:emit_dealloc_stmts(Fd, " ", AllocedPars), - emit_c_dec_rpt(Fd, " ", "boolean", []), - emit(Fd, " return oe_error_code;\n"), - emit(Fd, " }\n"), - emit(Fd, " if (strcmp(oe_bool, \"false\") == 0) {\n"), - emit(Fd, " *(~s) = 0;\n", [LName]), - emit(Fd, " }\n"), - emit(Fd, " else if (strcmp(oe_bool, \"true\") == 0) {\n"), - emit(Fd, " *(~s) = 1;\n", [LName]), - emit(Fd, " } else {\n"), - ic_cbe:emit_dealloc_stmts(Fd, " ", AllocedPars), - emit_c_dec_rpt(Fd, " ", "boolean", []), - emit(Fd, " return -1;\n"), - emit(Fd, " }\n"), - emit(Fd, " }\n\n"); - _ -> - emit(Fd, Fmt, [Pre, DecType, InBuffer, IndOp, LName]), - ic_cbe:emit_dealloc_stmts(Fd, " ", AllocedPars), - emit(Fd, Ret) - end. - - -%%------------------------------------------------------------ -%% 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(_, [], []) -> - []. - - |