From 84adefa331c4159d432d22840663c38f155cd4c1 Mon Sep 17 00:00:00 2001 From: Erlang/OTP Date: Fri, 20 Nov 2009 14:54:40 +0000 Subject: The R13B03 release. --- lib/ic/src/Makefile | 218 ++++ lib/ic/src/ic.app.src | 52 + lib/ic/src/ic.erl | 414 +++++++ lib/ic/src/ic.hrl | 158 +++ lib/ic/src/ic_array_java.erl | 295 +++++ lib/ic/src/ic_attribute_java.erl | 412 +++++++ lib/ic/src/ic_cbe.erl | 1306 ++++++++++++++++++++ lib/ic/src/ic_cclient.erl | 1209 +++++++++++++++++++ lib/ic/src/ic_code.erl | 584 +++++++++ lib/ic/src/ic_codegen.erl | 419 +++++++ lib/ic/src/ic_constant_java.erl | 99 ++ lib/ic/src/ic_cserver.erl | 2419 ++++++++++++++++++++++++++++++++++++++ lib/ic/src/ic_debug.hrl | 37 + lib/ic/src/ic_enum_java.erl | 312 +++++ lib/ic/src/ic_erl_template.erl | 639 ++++++++++ lib/ic/src/ic_erlbe.erl | 1141 ++++++++++++++++++ lib/ic/src/ic_error.erl | 375 ++++++ lib/ic/src/ic_fetch.erl | 388 ++++++ lib/ic/src/ic_file.erl | 447 +++++++ lib/ic/src/ic_forms.erl | 437 +++++++ lib/ic/src/ic_genobj.erl | 244 ++++ lib/ic/src/ic_java_type.erl | 1213 +++++++++++++++++++ lib/ic/src/ic_jbe.erl | 1487 +++++++++++++++++++++++ lib/ic/src/ic_noc.erl | 1113 ++++++++++++++++++ lib/ic/src/ic_options.erl | 363 ++++++ lib/ic/src/ic_plainbe.erl | 355 ++++++ lib/ic/src/ic_pp.erl | 2139 +++++++++++++++++++++++++++++++++ lib/ic/src/ic_pragma.erl | 1957 ++++++++++++++++++++++++++++++ lib/ic/src/ic_sequence_java.erl | 239 ++++ lib/ic/src/ic_struct_java.erl | 314 +++++ lib/ic/src/ic_symtab.erl | 232 ++++ lib/ic/src/ic_union_java.erl | 754 ++++++++++++ lib/ic/src/ic_util.erl | 313 +++++ lib/ic/src/icenum.erl | 205 ++++ lib/ic/src/iceval.erl | 555 +++++++++ lib/ic/src/icforms.hrl | 68 ++ lib/ic/src/icparse.yrl | 864 ++++++++++++++ lib/ic/src/icpreproc.erl | 111 ++ lib/ic/src/icscan.erl | 452 +++++++ lib/ic/src/icstruct.erl | 1916 ++++++++++++++++++++++++++++++ lib/ic/src/ictk.erl | 873 ++++++++++++++ lib/ic/src/ictype.erl | 1413 ++++++++++++++++++++++ lib/ic/src/icunion.erl | 1490 +++++++++++++++++++++++ lib/ic/src/icyeccpre.hrl | 124 ++ 44 files changed, 30155 insertions(+) create mode 100644 lib/ic/src/Makefile create mode 100644 lib/ic/src/ic.app.src create mode 100644 lib/ic/src/ic.erl create mode 100644 lib/ic/src/ic.hrl create mode 100644 lib/ic/src/ic_array_java.erl create mode 100644 lib/ic/src/ic_attribute_java.erl create mode 100644 lib/ic/src/ic_cbe.erl create mode 100644 lib/ic/src/ic_cclient.erl create mode 100644 lib/ic/src/ic_code.erl create mode 100644 lib/ic/src/ic_codegen.erl create mode 100644 lib/ic/src/ic_constant_java.erl create mode 100644 lib/ic/src/ic_cserver.erl create mode 100644 lib/ic/src/ic_debug.hrl create mode 100644 lib/ic/src/ic_enum_java.erl create mode 100644 lib/ic/src/ic_erl_template.erl create mode 100644 lib/ic/src/ic_erlbe.erl create mode 100644 lib/ic/src/ic_error.erl create mode 100644 lib/ic/src/ic_fetch.erl create mode 100644 lib/ic/src/ic_file.erl create mode 100644 lib/ic/src/ic_forms.erl create mode 100644 lib/ic/src/ic_genobj.erl create mode 100644 lib/ic/src/ic_java_type.erl create mode 100644 lib/ic/src/ic_jbe.erl create mode 100644 lib/ic/src/ic_noc.erl create mode 100644 lib/ic/src/ic_options.erl create mode 100644 lib/ic/src/ic_plainbe.erl create mode 100644 lib/ic/src/ic_pp.erl create mode 100644 lib/ic/src/ic_pragma.erl create mode 100644 lib/ic/src/ic_sequence_java.erl create mode 100644 lib/ic/src/ic_struct_java.erl create mode 100644 lib/ic/src/ic_symtab.erl create mode 100644 lib/ic/src/ic_union_java.erl create mode 100644 lib/ic/src/ic_util.erl create mode 100644 lib/ic/src/icenum.erl create mode 100644 lib/ic/src/iceval.erl create mode 100644 lib/ic/src/icforms.hrl create mode 100644 lib/ic/src/icparse.yrl create mode 100644 lib/ic/src/icpreproc.erl create mode 100644 lib/ic/src/icscan.erl create mode 100644 lib/ic/src/icstruct.erl create mode 100644 lib/ic/src/ictk.erl create mode 100644 lib/ic/src/ictype.erl create mode 100644 lib/ic/src/icunion.erl create mode 100644 lib/ic/src/icyeccpre.hrl (limited to 'lib/ic/src') diff --git a/lib/ic/src/Makefile b/lib/ic/src/Makefile new file mode 100644 index 0000000000..5dac304e32 --- /dev/null +++ b/lib/ic/src/Makefile @@ -0,0 +1,218 @@ +# +# %CopyrightBegin% +# +# Copyright Ericsson AB 1998-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% +# +# +include $(ERL_TOP)/make/target.mk + +ifeq ($(TYPE),debug) +ERL_COMPILE_FLAGS += -Ddebug -W +endif + +include $(ERL_TOP)/make/$(TARGET)/otp.mk + +# ---------------------------------------------------- +# Application version +# ---------------------------------------------------- +include ../vsn.mk +VSN=$(IC_VSN) + +# ---------------------------------------------------- +# Release directory specification +# ---------------------------------------------------- +RELSYSDIR = $(RELEASE_PATH)/lib/ic-$(VSN) + +# ---------------------------------------------------- +# Target Specs +# ---------------------------------------------------- + +MODULES= \ + ic \ + ic_erlbe \ + ic_cbe \ + icscan \ + icparse \ + iceval \ + ictype \ + ictk \ + icstruct \ + icenum \ + icpreproc \ + icunion \ + ic_pp \ + ic_pragma \ + ic_noc \ + ic_plainbe \ + ic_cclient \ + ic_cserver \ + ic_fetch \ + ic_code \ + ic_codegen \ + ic_error \ + ic_file \ + ic_forms \ + ic_genobj \ + ic_options \ + ic_symtab \ + ic_util \ + ic_jbe \ + ic_struct_java \ + ic_union_java \ + ic_enum_java \ + ic_constant_java \ + ic_sequence_java \ + ic_array_java \ + ic_attribute_java \ + ic_java_type \ + ic_erl_template + + +CCL_EX_FILES = \ + ../examples/c-client/ReadMe \ + ../examples/c-client/Makefile \ + ../examples/c-client/client.c \ + ../examples/c-client/random.idl \ + ../examples/c-client/rmod_random_impl.erl \ + ../examples/c-client/test.erl + +CSRV_EX_FILES = \ + ../examples/c-server/ReadMe \ + ../examples/c-server/Makefile \ + ../examples/c-server/client.c \ + ../examples/c-server/client.erl \ + ../examples/c-server/server.c \ + ../examples/c-server/callbacks.c \ + ../examples/c-server/random.idl + +EPL_EX_FILES = \ + ../examples/erl-plain/ReadMe \ + ../examples/erl-plain/rmod_random_impl.erl \ + ../examples/erl-plain/random.idl + + +ESRV_EX_FILES = \ + ../examples/erl-genserv/ReadMe \ + ../examples/erl-genserv/rmod_random_impl.erl \ + ../examples/erl-genserv/random.idl + +JAVA_EX_FILES = \ + ../examples/java-client-server/ReadMe \ + ../examples/java-client-server/client.java \ + ../examples/java-client-server/server.java \ + ../examples/java-client-server/serverImpl.java \ + ../examples/java-client-server/random.idl + +MIXED_EX_FILES = \ + ../examples/all-against-all/ReadMe \ + ../examples/all-against-all/Makefile \ + ../examples/all-against-all/client.erl \ + ../examples/all-against-all/server.erl \ + ../examples/all-against-all/client.c \ + ../examples/all-against-all/server.c \ + ../examples/all-against-all/callbacks.c \ + ../examples/all-against-all/client.java \ + ../examples/all-against-all/server.java \ + ../examples/all-against-all/serverImpl.java \ + ../examples/all-against-all/random.idl + + +EXTERNAL_HRL_FILES= + +INTERNAL_HRL_FILES = \ + ic.hrl \ + ic_debug.hrl \ + icforms.hrl + +ERL_FILES= $(MODULES:%=%.erl) + +TARGET_FILES = $(MODULES:%=$(EBIN)/%.$(EMULATOR)) + +YRL_FILE = icparse.yrl + +GEN_FILES = icparse.erl + +APP_FILE = ic.app +APP_SRC = $(APP_FILE).src +APP_TARGET = $(EBIN)/$(APP_FILE) + +# ---------------------------------------------------- +# FLAGS +# ---------------------------------------------------- +ERL_LOCAL_FLAGS += -pa ../../ic/ebin +# The -pa option is just used temporary until erlc can handle +# includes from other directories than ../include . +ERL_COMPILE_FLAGS += \ + $(ERL_LOCAL_FLAGS) \ + +'{parse_transform,sys_pre_attributes}' \ + +'{attribute,insert,app_vsn,"ic_$(VSN)"}' \ + -D'COMPILERVSN="$(VSN)"' +YRL_FLAGS = -Iicyeccpre.hrl + +# ---------------------------------------------------- +# Targets +# ---------------------------------------------------- +debug: + @${MAKE} TYPE=debug opt + +opt: $(TARGET_FILES) $(APP_TARGET) + +clean: + rm -f $(TARGET_FILES) $(GEN_FILES) $(APP_TARGET) + rm -f errs core *~ + +$(APP_TARGET): $(APP_SRC) ../vsn.mk + sed -e 's;%VSN%;$(VSN);' $< > $@ + +docs: + +# ---------------------------------------------------- +# Special Build Targets +# ---------------------------------------------------- +../ebin/icparse.beam: icparse.erl + $(ERLC) $(ERL_COMPILE_FLAGS) +nowarn_unused_vars +nowarn_unused_function -o$(EBIN) +pj $< + +icparse.erl: icparse.yrl icyeccpre.hrl + +### $(ERLC) $(YRL_FLAGS) $< + +# ---------------------------------------------------- +# Release Target +# ---------------------------------------------------- +include $(ERL_TOP)/make/otp_release_targets.mk + + +release_spec: opt + $(INSTALL_DIR) $(RELSYSDIR)/ebin + $(INSTALL_DATA) $(TARGET_FILES) $(APP_TARGET) $(RELSYSDIR)/ebin + $(INSTALL_DIR) $(RELSYSDIR)/src + $(INSTALL_DATA) $(ERL_FILES) $(YRL_FILE) $(INTERNAL_HRL_FILES) $(RELSYSDIR)/src + $(INSTALL_DIR) $(RELSYSDIR)/examples + $(INSTALL_DIR) $(RELSYSDIR)/examples/c-client + $(INSTALL_DATA) $(CCL_EX_FILES) $(RELSYSDIR)/examples/c-client + $(INSTALL_DIR) $(RELSYSDIR)/examples/c-server + $(INSTALL_DATA) $(CSRV_EX_FILES) $(RELSYSDIR)/examples/c-server + $(INSTALL_DIR) $(RELSYSDIR)/examples/erl-plain + $(INSTALL_DATA) $(EPL_EX_FILES) $(RELSYSDIR)/examples/erl-plain + $(INSTALL_DIR) $(RELSYSDIR)/examples/erl-genserv + $(INSTALL_DATA) $(ESRV_EX_FILES) $(RELSYSDIR)/examples/erl-genserv + $(INSTALL_DIR) $(RELSYSDIR)/examples/java-client-server + $(INSTALL_DATA) $(JAVA_EX_FILES) $(RELSYSDIR)/examples/java-client-server + $(INSTALL_DIR) $(RELSYSDIR)/examples/all-against-all + $(INSTALL_DATA) $(MIXED_EX_FILES) $(RELSYSDIR)/examples/all-against-all + +release_docs_spec: + diff --git a/lib/ic/src/ic.app.src b/lib/ic/src/ic.app.src new file mode 100644 index 0000000000..29aa6def00 --- /dev/null +++ b/lib/ic/src/ic.app.src @@ -0,0 +1,52 @@ +{application, ic, + [{description, "The IDL Compiler"}, + {vsn, "%VSN%"}, + {modules, + [ + ic, + ic_cclient, + ic_cbe, + ic_cserver, + ic_erlbe, + ic_fetch, + ic_noc, + ic_plainbe, + ic_pp, + ic_pragma, + icenum, + iceval, + icparse, + icpreproc, + icscan, + icstruct, + ictk, + ictype, + ic_array_java, + ic_attribute_java, + ic_code, + ic_codegen, + ic_constant_java, + ic_enum_java, + ic_error, + ic_file, + ic_forms, + ic_genobj, + ic_java_type, + ic_jbe, + ic_options, + ic_sequence_java, + ic_struct_java, + ic_symtab, + ic_union_java, + ic_util, + icunion, + ic_erl_template + ] + }, + {registered, []}, + {applications, [stdlib, kernel]}, + {env, []}, + {mod, {ic, []}} +]}. + + diff --git a/lib/ic/src/ic.erl b/lib/ic/src/ic.erl new file mode 100644 index 0000000000..3c6ce3d9d6 --- /dev/null +++ b/lib/ic/src/ic.erl @@ -0,0 +1,414 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1997-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). + + +-export([sgen/1, gen/1, gen/2, help/0, compile/3]). + + +%%------------------------------------------------------------ +%% +%% Internal stuff +%% +%%------------------------------------------------------------ + +-export([filter_params/2, handle_preproc/4, do_gen/4]). + +-import(lists, [foldr/3]). + + +-include("icforms.hrl"). +-include("ic.hrl"). + +-include_lib("stdlib/include/erl_compile.hrl"). + +-export([make_erl_options/1]). % For erlc + +-export([main/3, do_scan/1, do_parse/2, do_type/2]). + + +%%------------------------------------------------------------ +%% +%% Entry point +%% +%%------------------------------------------------------------ + +%% compile(AbsFileName, Outfile, Options) +%% Compile entry point for erl_compile. + +compile(File, _OutFile, Options) -> + case gen(File, make_erl_options(Options)) of + ok -> ok; + Other -> Other + end. + + +%% Entry for the -s switch +sgen(ArgList) -> +%%% io:format("sgen called w ~p~n", [ArgList]), + apply(?MODULE, gen, ArgList). + + +gen(File) -> + gen(File, []). + +gen(File, Opts) -> + G = ic_genobj:new(Opts), + IdlFile = ic_file:add_dot_idl(File), + case ic_options:get_opt(G, show_opts) of + true -> + io:format("Opts: ~p~n", [ic_options:which_opts(G)]); + _ -> ok + end, + ic_genobj:set_idlfile(G, IdlFile), + case catch gen2(G, File, Opts) of + {_, {'EXIT', R}} -> + ic_genobj:free_table_space(G), %% Free space for all ETS tables + io:format("Fatal error : ~p~n",[R]), + error; + {_, {'EXIT', _, R}} -> + ic_genobj:free_table_space(G), %% Free space for all ETS tables + io:format("Fatal error : ~p~n",[R]), + error; + {'EXIT', R} -> + ic_genobj:free_table_space(G), %% Free space for all ETS tables + io:format("Fatal error : ~p~n",[R]), + error; + {'EXIT', _, R} -> + ic_genobj:free_table_space(G), %% Free space for all ETS tables + io:format("Fatal error : ~p~n",[R]), + error; + %% In this case, the pragma registration + %% found errors so this should return error. + error -> + ic_genobj:free_table_space(G), %% Free space for all ETS tables + error; + _ -> + X = ic_error:return(G), + ic_genobj:free_table_space(G), %% Free space for all ETS tables + X + end. + + +gen2(G, File, Opts) -> + case ic_options:get_opt(G, time) of + true -> + time("TOTAL ", ic, main, [G, File, Opts]); + _ -> + case main(G, File, Opts) of + error -> + error; + _ -> + ok + end + end. + + + +do_gen(erl_corba, G, File, T) -> + ic_erlbe:do_gen(G, File, T); +do_gen(erl_template, G, File, T) -> + ic_erl_template:do_gen(G, File, T); +do_gen(erl_genserv, G, File, T) -> + ic_erlbe:do_gen(G, File, T); +do_gen(c_genserv, G, File, T) -> + ic_cclient:do_gen(G, File, T); +do_gen(noc, G, File, T) -> + ic_noc:do_gen(G, File, T); +do_gen(erl_plain, G, File, T) -> + ic_plainbe:do_gen(G, File, T); +do_gen(c_server, G, File, T) -> + ic_cserver:do_gen(G, File, T); +do_gen(c_client, G, File, T) -> + ic_cclient:do_gen(G, File, T); +%% Java backend +do_gen(java, G, File, T) -> + ic_jbe:do_gen(G, File, T); +%% No language choice +do_gen(_,_,_,_) -> + ok. + +do_scan(G) -> + icscan:scan(G, ic_genobj:idlfile(G)). + + +do_parse(G, Tokens) -> + case icparse:parse(Tokens) of + {ok, L} -> L; + X when element(1, X) == error -> + Err = element(2, X), + ic_error:fatal_error(G, {parse_error, element(1, Err), + element(3, Err)}); + X -> exit(X) + end. + + +do_type(G, Form) -> + ictype:type_check(G, Form). + +time(STR,M,F,A) -> + case timer:tc(M, F, A) of + {_, {'EXIT', R}} -> exit(R); + {_, {'EXIT', _, R}} -> exit(R); + {_, _X} when element(1, _X)==error -> throw(_X); + {_T, _R} -> + io:format("Time for ~s: ~10.2f~n", [STR, _T/1000000]), + _R + end. + + + +%% Filters parameters so that only those with certain attributes are +%% seen. The filter parameter is a list of attributes that will be +%% seen, ex. [in] or [inout, out] +filter_params(Filter, Params) -> + lists:filter(fun(P) -> + lists:member(get_param_attr(P#param.inout), Filter) end, + Params). + + +%% Access primitive to get the attribute name (and discard the line +%% number). +get_param_attr({A, _N}) -> A. + + +%% +%% Fixing the preproc directives +%% +handle_preproc(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"}, Gprim) -> ic_genobj:push_file(Gprim, Id); + ({_, _, "2"}, Gprim) -> ic_genobj:pop_file(Gprim, Id); + ({_, _, "3"}, Gprim) -> ic_genobj:sys_file(Gprim, Id) end, + G, Flags) + end; +handle_preproc(G, _N, _Other, _X) -> + G. + + + +%%------------------------------------------------------------ +%% +%% The help department +%% +%% +%% +%%------------------------------------------------------------ + +help() -> + io:format("No help available at the moment~n", []), + ok. + +print_version_str(G) -> + case {ic_options:get_opt(G, silent), ic_options:get_opt(G, silent2)} of + {true, _} -> ok; + {_, true} -> ok; + _ -> + io:format("Erlang IDL compiler version ~s~n", [?COMPILERVSN]) + end. + + + +%% +%% Converts generic compiler options to specific options. +%% +%% Used by erlc +%% + +make_erl_options(Opts) -> + + %% This way of extracting will work even if the record passed + %% has more fields than known during compilation. + + Includes1 = Opts#options.includes, + Defines = Opts#options.defines, + Outdir = Opts#options.outdir, + Warning = Opts#options.warning, + Verbose = Opts#options.verbose, + Specific = Opts#options.specific, + Optimize = Opts#options.optimize, + PreProc = + lists:flatten( + lists:map(fun(D) -> io_lib:format("-I~s ", [ic_util:to_list(D)]) end, + Includes1)++ + lists:map( + fun ({Name, Value}) -> + io_lib:format("-D~s=~s ", [ic_util:to_list(Name), ic_util:to_list(Value)]); + (Name) -> + io_lib:format("-D~s ", [ic_util:to_list(Name)]) + end, + Defines)), + Options = + case Verbose of + true -> []; + false -> [] + end ++ + case Warning of + 0 -> [nowarn]; + _ -> ['Wall'] + end ++ + case Optimize of + 0 -> []; + _ -> [] + end, + + Options++[{outdir, Outdir}, {preproc_flags, PreProc}]++Specific. + + +%%% +%%% NEW main, avoids memory fragmentation +%%% +main(G, File, _Opts) -> + print_version_str(G), + ?ifopt(G, time, io:format("File ~p compilation started : ~p/~p/~p ~p:~2.2.0p~n", + [ic_genobj:idlfile(G), + element(1,date()), + element(2, date()), + element(3, date()), + element(1, time()), + element(2, time())])), + + case ic_options:get_opt(G, help) of + true -> help(); + + _ -> + scanning(G, File) + end. + + + +scanning(G, File) -> + S = ?ifopt2(G, time, + time("input file scanning ", ic, do_scan, [G]), + ic:do_scan(G)), + ?ifopt2(G, tokens, io:format("TOKENS: ~p~n", [S]), + parsing(G, File, S)). + +parsing(G, File, S) -> + T = ?ifopt2(G, + time, + time("input file parsing ", ic, do_parse, [G,S]), + ic:do_parse(G,S)), + ?ifopt2(G, form, io:format("PARSE FORM: ~p~n", [T]), + pragma(G, File, T)). + + + +pragma(G, File, T) -> + case ?ifopt2(G, + time, + time("pragma registration ", ic_pragma, pragma_reg, [G,T]), + ic_pragma:pragma_reg(G,T)) of + %% All pragmas were succesfully applied + {ok,Clean} -> + typing(G, File, Clean); + + error -> + error + end. + + +typing(G, File, Clean) -> + case catch ?ifopt2(G, + time, + time("type code appliance ", ic, do_type, [G,Clean]), + ic:do_type(G,Clean)) of + {'EXIT',Reason} -> + io:format("Error under type appliance : ~p~n",[Reason]), + error; + + T2 -> + ?ifopt2(G, tform, io:format("TYPE FORM: ~p~n", [T2]), + generation(G, File, T2)) + end. + + + +generation(G, File, T2) -> + case ic_options:get_opt(G, multiple_be) of + false -> + single_generation(G, File, T2); + List -> + OutDir = + case ic_options:get_opt(G, outdir) of + false -> + []; + Dir -> + Dir + end, + + case ic_options:get_opt(G, be) of + false -> + ok; + Be -> + %% Generate this first + ic_options:add_opt(G,[{outdir,OutDir++atom_to_list(Be)}],true), + single_generation(G, File, T2) + end, + multiple_generation(G, File, T2, OutDir, List) + end. + +multiple_generation(_G, _File, _T2, _RootDir, []) -> + ok; +multiple_generation(G, File, T2, RootDir, [Be|Bes]) -> + ic_options:add_opt(G,[{outdir,RootDir++atom_to_list(Be)}],true), + ic_options:add_opt(G,[{be,Be}],true), + single_generation(G, File, T2), + + case ic_error:get_error_count(G) of + 0 -> + multiple_generation(G,File,T2,RootDir,Bes); + _ -> + %% Errors reported, abort + ok + end. + + +single_generation(G, File, T2) -> + case ic_error:get_error_count(G) of + 0 -> + %% Check if user has sett backend option + case ic_options:get_opt(G, be) of + false -> + %% Use default backend option + DefaultBe = ic_options:defaultBe(), + ic_options:add_opt(G,[{be,DefaultBe}],true), + + ?ifopt2(G, + time, + time("code generation ", ic, do_gen, [DefaultBe, G, File, T2]), + ic:do_gen(DefaultBe, G, File, T2)); + Be -> + %% Use user defined backend + ?ifopt2(G, + time, + time("code generation ", ic, do_gen, [Be, G, File, T2]), + ic:do_gen(Be, G, File, T2)) + end; + _ -> + ok %% Does not matter + end. + + + diff --git a/lib/ic/src/ic.hrl b/lib/ic/src/ic.hrl new file mode 100644 index 0000000000..974e6088f4 --- /dev/null +++ b/lib/ic/src/ic.hrl @@ -0,0 +1,158 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1997-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% +%% +%% + + +%%------------------------------------------------------------ +%% Configuration macros +-define(CORBAMOD, corba). +-define(ORBNAME, orber). +-define(CORBAHRL, "corba.hrl"). +-define(CALL, "call"). +-define(CAST, "cast"). +-define(IFRREGID, "register"). +-define(IFRTYPESHRL, "ifr_types.hrl"). + +-define(GENSERVMOD, gen_server). + +%%------------------------------------------------------------ +%% Flags. NOTE! Once assigned value may NOT be changed. Deprecate ok. +%% Default flags. Can be changed if we change the default behavior. +-define(IC_FLAG_TEMPLATE_1, 16#01). +-define(IC_FLAG_TEMPLATE_2, 16#02). + +-define(IC_INIT_FLAGS, 16#00). + +%% Flag operations +%% USAGE: Boolean = ?IC_FLAG_TEST(Flags, ?IC_ATTRIBUTE) +-define(IC_FLAG_TEST(_F1, _I1), ((_F1 band _I1) == _I1)). + +%% USAGE: NewFlags = ?IC_SET_TRUE(Flags, ?IC_ATTRIBUTE) +-define(IC_SET_TRUE(_F2, _I2), (_I2 bor _F2)). + +%% USAGE: NewFlags = ?IC_SET_FALSE(Flags, ?IC_ATTRIBUTE) +-define(IC_SET_FALSE(_F3, _I3), ((_I3 bxor 16#ff) band _F3)). + +%% USAGE: NewFlags = ?IC_SET_FALSE_LIST(Flags, [?IC_SEC_ATTRIBUTE, ?IC_SOME]) +-define(IC_SET_FALSE_LIST(_F4, _IList1), + lists:foldl(fun(_I4, _F5) -> + ((_I4 bxor 16#ff) band _F5) + end, + _F4, _IList1)). + +%% USAGE: NewFlags = ?IC_SET_TRUE_LIST(Flags, [?IC_ATTRIBUTE, ?IC_SOME]) +-define(IC_SET_TRUE_LIST(_F6, _IList2), + lists:foldl(fun(_I6, _F7) -> + (_I6 bor _F7) + end, + _F6, _IList2)). + +%% USAGE: Boolean = ?IC_FLAG_TEST_LIST(Flags, [?IC_CONTEXT, ?IC_THING]) +-define(IC_FLAG_TEST_LIST(_F8, _IList3), + lists:all(fun(_I7) -> + ((_F8 band _I7) == _I7) + end, + _IList3)). + + +%%------------------------------------------------------------ +%% Usefull macros + +-define(ifthen(P,ACTION), if P -> ACTION; true->true end). + + +%%------------------------------------------------------------ +%% Option macros + +-define(ifopt(G,OPT,ACTION), + case ic_options:get_opt(G,OPT) of true -> ACTION; _ -> ok end). + +-define(ifopt2(G,OPT,ACT1,ACT2), + case ic_options:get_opt(G,OPT) of true -> ACT1; _ -> ACT2 end). + +-define(ifnopt(G,OPT,ACTION), + case ic_options:get_opt(G,OPT) of false -> ACTION; _ -> ok end). + + +%% Internal record +-record(id_of, {id, type, tk}). + +%%-------------------------------------------------------------------- +%% The generator object definition + +-record(genobj, {symtab, impl, options, warnings, auxtab, + tktab, pragmatab, c_typedeftab, + skelfile=[], skelfiled=[], skelscope=[], + stubfile=[], stubfiled=[], stubscope=[], + includefile=[], includefiled=[], + interfacefile=[],interfacefiled=[], + helperfile=[],helperfiled=[], + holderfile=[],holderfiled=[], + filestack=0, do_gen=true, sysfile=false}). + +%%-------------------------------------------------------------------- +%% The scooped id definition +-record(scoped_id, {type=local, line=-1, id=""}). + + + + + + + + +%%-------------------------------------------------------------------- +%% Secret macros +%% +%% NOTE these macros are not general, they cannot be used +%% everywhere. +%% +-define(lookup(T,K), case ets:lookup(T, K) of [{_X, _Y}] -> _Y; _->[] end). +-define(insert(T,K,V), ets:insert(T, {K, V})). + + +%%--------------------------------------------------------------------- +%% +%% Java specific macros +%% +%% +-define(ERLANGPACKAGE,"com.ericsson.otp.erlang."). +-define(ICPACKAGE,"com.ericsson.otp.ic."). + + +%% +%% Macros for reporting encode/decode errors in C back-ends. +%% +%% + +-define(emit_c_enc_rpt(Fd, Fill, Fmt, Vals), + begin + CType = ic_cbe:mk_c_type2(G, N, T), + ic_codegen:emit_c_enc_rpt(Fd, Fill, "~s : " ++ Fmt, [CType| Vals]) + end). +-define(emit_c_dec_rpt(Fd, Fill, Fmt, Vals), + begin + CType = ic_cbe:mk_c_type2(G, N, T), + ic_codegen:emit_c_dec_rpt(Fd, Fill, "~s : " ++ Fmt, [CType| Vals]) + end). + + + + + diff --git a/lib/ic/src/ic_array_java.erl b/lib/ic/src/ic_array_java.erl new file mode 100644 index 0000000000..e21d646bf5 --- /dev/null +++ b/lib/ic/src/ic_array_java.erl @@ -0,0 +1,295 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1999-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_array_java). + +-export([gen/4]). + +-include("ic.hrl"). +-include("icforms.hrl"). + + +gen(G, N, X, Array) when is_record(X, member) -> + ArrayName = ic_forms:get_java_id(Array), + ArrayElement = ic_forms:get_type(X), + emit_holder_class(G, N, X, Array, ArrayName, ArrayElement), + emit_helper_class(G, N, X, Array, ArrayName, ArrayElement); +gen(G, N, X, Array) when is_record(X, case_dcl) -> + ArrayName = ic_forms:get_java_id(Array), + ArrayElement = ic_forms:get_type(X), + emit_holder_class(G, N, X, Array, ArrayName, ArrayElement), + emit_helper_class(G, N, X, Array, ArrayName, ArrayElement); +gen(G, N, X, Array) -> + ArrayName = ic_forms:get_java_id(Array), + ArrayElement = ic_forms:get_body(X), + emit_holder_class(G, N, X, Array, ArrayName, ArrayElement), + emit_helper_class(G, N, X, Array, ArrayName, ArrayElement). + + + +%%----------------------------------------------------------------- +%% Func: emit_holder_class/4 +%%----------------------------------------------------------------- +emit_holder_class(G, N, _X, Array, ArrayName, ArrayElement) -> + SName = string:concat(ArrayName, "Holder"), + {Fd, _}= ic_file:open_java_file(G, N, SName), + + ArrayElementName = ic_java_type:getType(G, N, ArrayElement), + EmptyDim = arrayEmptyDim(Array), + + ic_codegen:emit(Fd, "final public class ~sHolder {\n",[ArrayName]), + + ic_codegen:emit(Fd, " // instance variables\n", []), + ic_codegen:emit(Fd, " public ~s~s value;\n\n", + [ArrayElementName,EmptyDim]), + + ic_codegen:emit(Fd, " // constructors\n", []), + ic_codegen:emit(Fd, " public ~sHolder() {}\n", [ArrayName]), + ic_codegen:emit(Fd, " public ~sHolder(~s~s initial) {\n", + [ArrayName,ArrayElementName,EmptyDim]), + ic_codegen:emit(Fd, " value = initial;\n", []), + ic_codegen:emit(Fd, " }\n", []), + ic_codegen:nl(Fd), + + ic_codegen:emit(Fd, " // methods\n", []), + + ic_codegen:emit(Fd, " public void _marshal(~sOtpOutputStream out)\n", [?ERLANGPACKAGE]), + ic_codegen:emit(Fd, " throws java.lang.Exception {\n"), + ic_codegen:emit(Fd, " ~sHelper.marshal(out, value);\n", [ArrayName]), + ic_codegen:emit(Fd, " }\n"), + ic_codegen:nl(Fd), + ic_codegen:emit(Fd, " public void _unmarshal(~sOtpInputStream in)\n", [?ERLANGPACKAGE]), + ic_codegen:emit(Fd, " throws java.lang.Exception {\n"), + ic_codegen:emit(Fd, " value = ~sHelper.unmarshal(in);\n", [ArrayName]), + ic_codegen:emit(Fd, " }\n", []), + ic_codegen:nl(Fd), + + ic_codegen:emit(Fd, "}\n", []), + file:close(Fd). + + +%%----------------------------------------------------------------- +%% Func: emit_helper_class/4 +%%----------------------------------------------------------------- +emit_helper_class(G, N, X, Array, ArrayName, ArrayElement) -> + SName = string:concat(ArrayName, "Helper"), + {Fd, _}= ic_file:open_java_file(G, N, SName), + + ArrayElementName = ic_java_type:getType(G, N, ArrayElement), + EmptyDim = arrayEmptyDim(Array), +% Dim = arrayDim(G,N,Array), + + ic_codegen:emit(Fd, "public class ~sHelper {\n",[ArrayName]), + + ic_codegen:emit(Fd, " // constructors\n"), + ic_codegen:emit(Fd, " private ~sHelper() {}\n\n", [ArrayName]), + + ic_codegen:emit(Fd, " // methods\n"), + + ic_codegen:emit(Fd, " public static void marshal(~sOtpOutputStream _out, ~s~s _value)\n", + [?ERLANGPACKAGE,ArrayElementName,EmptyDim]), + ic_codegen:emit(Fd, " throws java.lang.Exception {\n\n"), + emit_array_marshal_loop(G,N,X,Array,ArrayElement,Fd), + ic_codegen:emit(Fd, " }\n"), + ic_codegen:nl(Fd), + ic_codegen:emit(Fd, " public static ~s~s unmarshal(~sOtpInputStream _in)\n", + [ArrayElementName,EmptyDim,?ERLANGPACKAGE]), + ic_codegen:emit(Fd, " throws java.lang.Exception {\n\n"), + ic_codegen:emit(Fd, " ~s~s _value = new ~s;\n\n", + [ArrayElementName,EmptyDim,ic_java_type:getFullType(G, N, X, Array)]), + emit_array_unmarshal_loop(G,N,X,Array,ArrayElement,Fd), + ic_codegen:emit(Fd, " return _value;\n"), + ic_codegen:emit(Fd, " }\n\n"), + + ic_codegen:emit(Fd, " public static String id() {\n", []), + ic_codegen:emit(Fd, " return ~p;\n",[ictk:get_IR_ID(G, N, Array)]), + ic_codegen:emit(Fd, " }\n\n"), + + ic_codegen:emit(Fd, " public static String name() {\n", []), + ic_codegen:emit(Fd, " return ~p;\n",[ArrayName]), + ic_codegen:emit(Fd, " }\n\n"), + + ic_jbe:emit_type_function(G, N, X, Fd), + + ic_codegen:emit(Fd, " public static void insert(~sAny _any, ~s~s _this)\n", + [?ICPACKAGE,ArrayElementName,EmptyDim]), + ic_codegen:emit(Fd, " throws java.lang.Exception {\n\n"), + + ic_codegen:emit(Fd, " ~sOtpOutputStream _os = \n",[?ERLANGPACKAGE]), + ic_codegen:emit(Fd, " new ~sOtpOutputStream();\n\n",[?ERLANGPACKAGE]), + + ic_codegen:emit(Fd, " _any.type(type());\n"), + ic_codegen:emit(Fd, " marshal(_os, _this);\n"), + ic_codegen:emit(Fd, " _any.insert_Streamable(_os);\n"), + ic_codegen:emit(Fd, " }\n\n"), + + ic_codegen:emit(Fd, " public static ~s~s extract(~sAny _any)\n", + [ArrayElementName,EmptyDim,?ICPACKAGE]), + ic_codegen:emit(Fd, " throws java.lang.Exception {\n\n"), + + ic_codegen:emit(Fd, " return unmarshal(_any.extract_Streamable());\n"), + ic_codegen:emit(Fd, " }\n\n"), + + ic_codegen:emit(Fd, "}\n"), + file:close(Fd). + + + + +emit_array_marshal_loop(G,N,X,Array,AEl,Fd) -> + DimList = mk_array_dim_list(G,N,Array), + emit_array_marshal_loop_1(G,N,X,Array,AEl,DimList,0,Fd). + + +emit_array_marshal_loop_1(G,N,X,Array,AEl,[D],C,Fd) -> + + DimList = mk_array_dim_list(G,N,Array), + + ic_codegen:emit(Fd, " _out.write_tuple_head(~s);\n\n",[D]), + + ic_codegen:emit(Fd, " for(int _tmp~p = 0; _tmp~p < ~s; _tmp~p++)\n",[C,C,D,C]), + + case ic_java_type:isBasicType(G, N, AEl) of + true -> + ic_codegen:emit(Fd, " _out~s(_value", + [ic_java_type:marshalFun(G, N, X, AEl)]); + false -> + ic_codegen:emit(Fd, " ~s(_out, _value", + [ic_java_type:marshalFun(G, N, X, AEl)]) + end, + + emit_array_dimensions(DimList,0,Fd), + + ic_codegen:emit(Fd, ");\n\n"); + +emit_array_marshal_loop_1(G,N,X,Array,AEl,[D|Ds],C,Fd) -> +% DimList = mk_array_dim_list(G,N,Array), + + ic_codegen:emit(Fd, " _out.write_tuple_head(~s);\n\n",[D]), + + ic_codegen:emit(Fd, " for(int _tmp~p = 0; _tmp~p < ~s; _tmp~p++) {\n",[C,C,D,C]), + + emit_array_marshal_loop_1(G,N,X,Array,AEl,Ds,C+1,Fd), + + ic_codegen:emit(Fd, " }\n\n"). + + + + + +emit_array_unmarshal_loop(G,N,X,Array,AEl,Fd) -> + DimList = mk_array_dim_list(G,N,Array), + case length(DimList) > 0 of + true -> + ic_codegen:emit(Fd, " _in.read_tuple_head();\n\n"), + + ic_codegen:emit(Fd, " for(int _tmp0 = 0; _tmp0 < ~s; _tmp0++) {\n\n",[hd(DimList)]), + emit_array_unmarshal_loop_1(G,N,X,Array,AEl,tl(DimList),1,Fd), + ic_codegen:emit(Fd, " }\n\n"); + false -> + emit_array_unmarshal_loop_1(G,N,X,Array,AEl,DimList,0,Fd) + end. + +emit_array_unmarshal_loop_1(G,N,X,_Array,AEl,[],1,Fd) -> %% One dimensional array + case ic_java_type:isBasicType(G, N, AEl) of + true -> + ic_codegen:emit(Fd, " _value[_tmp0] = _in~s;\n", + [ic_java_type:unMarshalFun(G, N, X, AEl)]); + false -> + ic_codegen:emit(Fd, " _value[_tmp0] = ~s.unmarshal(_in);\n\n", + [ic_java_type:getUnmarshalType(G, N, X, AEl)]) + end; +emit_array_unmarshal_loop_1(G,N,X,Array,AEl,[],_C,Fd) -> + DimList = mk_array_dim_list(G,N,Array), + ic_codegen:emit(Fd, " _value"), + emit_array_dimensions(DimList,0,Fd), + case ic_java_type:isBasicType(G,N,AEl) of + true -> + ic_codegen:emit(Fd, " = _in~s;\n", + [ic_java_type:unMarshalFun(G, N, X, AEl)]); + false -> + ic_codegen:emit(Fd, " = ~s.unmarshal(_in);\n", + [ic_java_type:getUnmarshalType(G, N, X, AEl)]) + end; +emit_array_unmarshal_loop_1(G,N,X,Array,AEl,[D|Ds],C,Fd) -> + ic_codegen:emit(Fd, " _in.read_tuple_head();\n\n"), + + ic_codegen:emit(Fd, " for(int _tmp~p = 0; _tmp~p < ~s; _tmp~p++) {\n\n",[C,C,D,C]), + emit_array_unmarshal_loop_1(G,N,X,Array,AEl,Ds,C+1,Fd), + ic_codegen:emit(Fd, " }\n"). + + + + + +%%--------------------------------------------------- +%% Utilities +%%--------------------------------------------------- + +mk_array_dim_list(G,N,Array) -> + mk_array_dim_list2(G,N,Array#array.size). + + +mk_array_dim_list2(_G,_N,[]) -> + []; + +mk_array_dim_list2(G,N,[D |Ds]) when is_record(D,scoped_id) -> + {FSN, _, _, _} = ic_symtab:get_full_scoped_name(G, N, D), + [ ic_util:to_dot(G,FSN) | mk_array_dim_list2(G,N,Ds)]; + +mk_array_dim_list2(G,N,[D |Ds]) -> + [ic_util:eval_java(G,N,D) | mk_array_dim_list2(G,N,Ds)]. + + + +%% Array dimension string +%arrayDim(G,N,X) -> +% arrayDim2(G,N,X#array.size). + +%arrayDim2(_G,_N,[]) -> +% ""; +%arrayDim2(G,N,[D|Ds]) when record(D,scoped_id) -> +% {FSN, _, _, _} = ic_symtab:get_full_scoped_name(G, N, D), +% "[" ++ ic_util:to_dot(G,FSN) ++ "]" ++ arrayDim2(G,N,Ds); +%arrayDim2(G,N,[D|Ds]) -> +% "[" ++ ic_util:eval_java(G,N,D) ++ "]" ++ arrayDim2(G,N,Ds). + + +%% Array Empty dimension string +arrayEmptyDim(X) -> + arrayEmptyDim2(X#array.size). + +arrayEmptyDim2([_D]) -> + "[]"; +arrayEmptyDim2([_D |Ds]) -> + "[]" ++ arrayEmptyDim2(Ds). + + +emit_array_dimensions([_D],C,Fd) -> + ic_codegen:emit(Fd, "[_tmp~p]",[C]); +emit_array_dimensions([_D|Ds],C,Fd) -> + ic_codegen:emit(Fd, "[_tmp~p]",[C]), + emit_array_dimensions(Ds,C+1,Fd). + + + + + + diff --git a/lib/ic/src/ic_attribute_java.erl b/lib/ic/src/ic_attribute_java.erl new file mode 100644 index 0000000000..6352dcf608 --- /dev/null +++ b/lib/ic/src/ic_attribute_java.erl @@ -0,0 +1,412 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1999-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_attribute_java). + +-include("icforms.hrl"). +-include("ic.hrl"). + +%%----------------------------------------------------------------- +%% External exports +%%----------------------------------------------------------------- +-export([emit_attribute_prototype/4, + emit_attribute_stub_code/4, + emit_atrribute_on_dictionary/5, + emit_attribute_switch_case/5]). + + + + + +%%%----------------------------------------------------- +%%% +%%% Generates operation in interface +%%% +%%%----------------------------------------------------- +emit_attribute_prototype(G, N, X, Fd) -> + emit_attribute_prototype(G, N, X, Fd, ic_forms:get_idlist(X)). + +emit_attribute_prototype(_G, _N, _X, _Fd, []) -> + ok; +emit_attribute_prototype(G, N, X, Fd, [V|Vs]) -> + WireAttrName = ic_forms:get_id(V), + AttrName = ic_forms:get_java_id(WireAttrName), + emit_attr_prototype(G, N, X, Fd, AttrName,WireAttrName), + emit_attribute_prototype(G, N, X, Fd, Vs). + + +emit_attr_prototype(G, N, X, Fd, OpName, WireOpName) -> + + ic_codegen:emit(Fd, "/****\n"), + ic_codegen:emit(Fd, " * Attribute ~p interface functions \n", [ic_util:to_colon([WireOpName|N])]), + ic_codegen:emit(Fd, " *\n"), + ic_codegen:emit(Fd, " */\n\n"), + + AT = ic_forms:get_type(X), + Type = ic_java_type:getType(G, N, AT), +% HolderType = ic_java_type:getHolderType(G, N, AT), + + ic_codegen:emit(Fd, " ~s ~s() throws java.lang.Exception;\n\n",[Type, OpName]), + + case X#attr.readonly of + {readonly, _} -> + ok; + _ -> + ic_codegen:emit(Fd, " void ~s(~s _value) throws java.lang.Exception;\n\n",[OpName, Type]) + end. + + + +%%%----------------------------------------------------- +%%% +%%% Generates attribute insertion in dictionary +%%% +%%%----------------------------------------------------- +emit_atrribute_on_dictionary(G, N, X, Fd, C) -> + emit_atrribute_on_dictionary(G, N, X, Fd, C, ic_forms:get_idlist(X)). + +emit_atrribute_on_dictionary(_G, _N, _X, _Fd, C, []) -> + C; +emit_atrribute_on_dictionary(G, N, X, Fd, C, [V|Vs]) -> + + WireAttrName = ic_forms:get_id(V), + + ic_codegen:emit(Fd, " _operations.put(\"_get_~s\", new java.lang.Integer(~p));\n", + [WireAttrName,C]), + + case X#attr.readonly of + {readonly, _} -> + + emit_atrribute_on_dictionary(G, N, X, Fd, C+1, Vs); + + _ -> + + ic_codegen:emit(Fd, " _operations.put(\"_set_~s\", new java.lang.Integer(~p));\n", + [WireAttrName,C+1]), + + emit_atrribute_on_dictionary(G, N, X, Fd, C+2, Vs) + end. + + + +%%%----------------------------------------------------- +%%% +%%% Generates attribute case in server switch +%%% +%%%----------------------------------------------------- +emit_attribute_switch_case(G, N, X, Fd, C) -> + Tk = ic_forms:get_tk(X), + emit_attribute_switch_case(G, N, X, Fd, Tk, C, ic_forms:get_idlist(X)). + +emit_attribute_switch_case(_G, _N, _X, _Fd, _Tk, C, []) -> + C; +emit_attribute_switch_case(G, N, X, Fd, Tk, C, [V|Vs]) -> + AttrName = ic_forms:get_java_id(V), + + emit_attribute_switch_case1(G,N,X,Fd,"_get_",AttrName,Tk,C), + + case X#attr.readonly of + {readonly, _} -> + emit_attribute_switch_case(G, N, X, Fd, Tk, C+1, Vs); + + _ -> + emit_attribute_switch_case1(G,N,X,Fd,"_set_",AttrName,Tk,C+1), + emit_attribute_switch_case(G, N, X, Fd, Tk, C+2, Vs) + end. + + +emit_attribute_switch_case1(G, N, X, Fd, "_get_", Name, _Tk, C) -> + + R = ic_forms:get_type(X), + RT = ic_java_type:getParamType(G,N,R,ret), + + ic_codegen:emit(Fd, " case ~p: { // Get operation for attribute ~s\n\n",[C,ic_util:to_dot([Name|N])]), + + ic_codegen:emit(Fd, " // Calling implementation function\n"), + ic_codegen:emit(Fd, " ~s _result = this.~s();\n\n", [RT, Name]), + + ic_codegen:emit(Fd, " // Marshalling output\n"), + ic_codegen:emit(Fd, " ~sOtpErlangRef __ref = __env.getSref();\n",[?ERLANGPACKAGE]), + ic_codegen:emit(Fd, " __os.write_tuple_head(2);\n"), + ic_codegen:emit(Fd, " __os.write_ref(__ref.node(),__ref.id(),__ref.creation()); // Call reference\n"), + + case ic_java_type:isBasicType(G,N,R) of + true -> + ic_codegen:emit(Fd, " __os~s(_result); // Return value\n\n", + [ic_java_type:marshalFun(G,N,X,R)]); + false -> + ic_codegen:emit(Fd, " ~s(__os,_result); // Return value\n\n", + [ic_java_type:marshalFun(G,N,X,R)]) + end, + + ic_codegen:emit(Fd, " } break;\n\n"); + + +emit_attribute_switch_case1(G, N, X, Fd, "_set_", Name, _Tk, C) -> + ic_codegen:emit(Fd, " case ~p: { // Set operation for attribute ~s\n\n",[C,ic_util:to_dot([Name|N])]), + + Type = ic_forms:get_type(X), + + ic_codegen:emit(Fd, " // Preparing input\n"), + ic_codegen:emit(Fd, " ~sOtpInputStream __is = __env.getIs();\n",[?ERLANGPACKAGE]), + + case ic_java_type:isBasicType(G,N,Type) of + true -> + ic_codegen:emit(Fd, " ~s _value = __is~s; // In value\n\n", + [ic_java_type:getParamType(G,N,Type,in), + ic_java_type:unMarshalFun(G,N,X,Type)]); + false -> + ic_codegen:emit(Fd, " ~s _value = ~s.unmarshal(__is); // In value\n\n", + [ic_java_type:getParamType(G,N,Type,in), + ic_java_type:getUnmarshalType(G,N,X,Type)]) + end, + + + ic_codegen:emit(Fd, " // Calling implementation function\n"), + ic_codegen:emit(Fd, " this.~s(_value);\n\n", [Name]), + + ic_codegen:emit(Fd, " // Marshalling output\n"), + ic_codegen:emit(Fd, " ~sOtpErlangRef __ref = __env.getSref();\n",[?ERLANGPACKAGE]), + ic_codegen:emit(Fd, " __os.write_tuple_head(2);\n"), + ic_codegen:emit(Fd, " __os.write_ref(__ref.node(),__ref.id(),__ref.creation()); // Call reference\n"), + ic_codegen:emit(Fd, " __os.write_atom(\"ok\");\n\n"), + + ic_codegen:emit(Fd, " } break;\n\n"). + + + + + + + +%%%----------------------------------------------------- +%%% +%%% Generates attribute function in stub +%%% +%%%----------------------------------------------------- +emit_attribute_stub_code(G, N, X, Fd) -> + emit_attribute_stub_code(G, N, X, Fd, ic_forms:get_idlist(X)). + +emit_attribute_stub_code(_G, _N, _X, _Fd, []) -> + ok; +emit_attribute_stub_code(G, N, X, Fd, [V|Vs]) -> + WireAttrName = ic_forms:get_id(V), + AttrName = ic_forms:get_java_id(WireAttrName), + + emit_attribute_stub_code1(G,N,X,Fd,"_get_",AttrName,WireAttrName), + + case X#attr.readonly of + {readonly, _} -> + emit_attribute_stub_code(G, N, X, Fd, Vs); + + _ -> + emit_attribute_stub_code1(G,N,X,Fd,"_set_",AttrName,WireAttrName), + emit_attribute_stub_code(G, N, X, Fd, Vs) + end. + + +emit_attribute_stub_code1(G,N,X,Fd,"_get_",Name,WireName) -> + + Type = ic_forms:get_type(X), + RT = ic_java_type:getType(G,N,Type), + + %% + %% Main get operation + %% + ic_codegen:emit(Fd, " // Attribute ~p get operation implementation\n", [ic_util:to_colon([WireName|N])]), + ic_codegen:emit(Fd, " public ~s ~s() throws java.lang.Exception {\n\n", [RT, Name]), + + %% Function marshal call + ic_codegen:emit(Fd, " // Calling the marshal function\n"), + ic_codegen:emit(Fd, " _~s_marshal(_env);\n\n", [Name]), + + %% Sending call + ic_codegen:emit(Fd, " // Message send\n"), + ic_codegen:emit(Fd, " _env.send();\n\n"), + + %% Receiving return value + ic_codegen:emit(Fd, " // Message receive\n"), + ic_codegen:emit(Fd, " _env.receive();\n\n"), + + ic_codegen:emit(Fd, " // Calling the unmarshal function\n"), + ic_codegen:emit(Fd, " return _~s_get_unmarshal(_env);\n", [Name]), + ic_codegen:emit(Fd, " }\n\n"), + + + %% + %% Marshal get operation + %% + ic_codegen:emit(Fd, " // Marshal operation for get attribute ~p\n", [Name]), + ic_codegen:emit(Fd, " public static void _~s_marshal(~sEnvironment __env)\n", + [Name, ?ICPACKAGE]), + ic_codegen:emit(Fd, " throws java.lang.Exception {\n\n"), + + ic_codegen:emit(Fd, " // Get output stream\n"), + ic_codegen:emit(Fd, " ~sOtpOutputStream __os = __env.getOs();\n\n",[?ERLANGPACKAGE]), + + %% Initiating Message header + ic_codegen:emit(Fd, " // Message header assembly\n"), + ic_codegen:emit(Fd, " __os.reset();\n"), + ic_codegen:emit(Fd, " __os.write_tuple_head(3);\n"), + ic_codegen:emit(Fd, " __os.write_atom(\"$gen_call\");\n\n"), + + + %% Creating call identity tuple + ic_codegen:emit(Fd, " // Message identity part creation\n"), + ic_codegen:emit(Fd, " __os.write_tuple_head(2);\n"), + ic_codegen:emit(Fd, " __env.write_client_pid();\n"), + ic_codegen:emit(Fd, " __env.write_client_ref();\n\n"), + + OpCallName = case ic_options:get_opt(G, scoped_op_calls) of + true -> + ic_util:to_undersc(["_get_"++WireName|N]); + false -> + "_get_"++WireName + end, + + %% Creating operation identity + ic_codegen:emit(Fd, " // Message operation part creation\n"), + ic_codegen:emit(Fd, " __os.write_atom(~p);\n\n",[OpCallName]), + + ic_codegen:emit(Fd, " }\n\n"), + + + %% + %% Unmarshal get operation + %% + MRT = ic_java_type:getParamType(G,N,Type,ret), + + ic_codegen:emit(Fd, " // Unmarshal operation for get attribute ~p\n", [Name]), + ic_codegen:emit(Fd, " public static ~s _~s_get_unmarshal(~sEnvironment __env)\n", + [MRT, Name, ?ICPACKAGE]), + ic_codegen:emit(Fd, " throws java.lang.Exception {\n\n"), + + + ic_codegen:emit(Fd, " // Get input stream\n"), + ic_codegen:emit(Fd, " ~sOtpInputStream __is = __env.getIs();\n\n",[?ERLANGPACKAGE]), + + ic_codegen:emit(Fd, " // Extracting return value\n"), + case ic_java_type:isBasicType(G, N, Type) of + true -> + ic_codegen:emit(Fd, " return __is~s;\n", + [ic_java_type:unMarshalFun(G, N, X, Type)]); + false -> + ic_codegen:emit(Fd, " return ~s.unmarshal(__is);\n", + [ic_java_type:getUnmarshalType(G, N, X, Type)]) + end, + + ic_codegen:emit(Fd, " }\n\n"); + + +emit_attribute_stub_code1(G,N,X,Fd,"_set_",Name,WireName) -> + + Type = ic_forms:get_type(X), + + %% + %% Main set operation + %% + IT = ic_java_type:getType(G,N,Type), + + ic_codegen:emit(Fd, " // Attribute ~p set operation implementation\n", [ic_util:to_colon([WireName|N])]), + ic_codegen:emit(Fd, " public void ~s(~s _value) throws java.lang.Exception {\n\n", [Name,IT]), + + %% Function marshal call + ic_codegen:emit(Fd, " // Calling the marshal function\n"), + ic_codegen:emit(Fd, " _~s_marshal(_env, _value);\n\n", [Name]), + + %% Sending call + ic_codegen:emit(Fd, " // Message send\n"), + ic_codegen:emit(Fd, " _env.send();\n\n"), + + %% Receiving return value + ic_codegen:emit(Fd, " // Message receive\n"), + ic_codegen:emit(Fd, " _env.receive();\n\n"), + + ic_codegen:emit(Fd, " // Calling the unmarshal function\n"), + ic_codegen:emit(Fd, " _~s_set_unmarshal(_env);\n", [Name]), + + ic_codegen:emit(Fd, " }\n\n"), + + + %% + %% Marshal set operation + %% + IP = ic_java_type:getParamType(G, N, Type, in), + OpCallName = case ic_options:get_opt(G, scoped_op_calls) of + true -> + ic_util:to_undersc(["_set_"++WireName|N]); + false -> + "_set_"++WireName + end, + + ic_codegen:emit(Fd, " // Marshal operation for set attribute ~p\n", [Name]), + ic_codegen:emit(Fd, " public static void _~s_marshal(~sEnvironment __env, ~s _value)\n", + [Name, ?ICPACKAGE, IP]), + ic_codegen:emit(Fd, " throws java.lang.Exception {\n\n"), + + ic_codegen:emit(Fd, " // Get output stream\n"), + ic_codegen:emit(Fd, " ~sOtpOutputStream __os = __env.getOs();\n\n",[?ERLANGPACKAGE]), + + %% Initiating Message header + ic_codegen:emit(Fd, " // Message header assembly\n"), + ic_codegen:emit(Fd, " __os.reset();\n"), + ic_codegen:emit(Fd, " __os.write_tuple_head(3);\n"), + ic_codegen:emit(Fd, " __os.write_atom(\"$gen_call\");\n\n"), + + + %% Creating call identity tuple + ic_codegen:emit(Fd, " // Message identity part creation\n"), + ic_codegen:emit(Fd, " __os.write_tuple_head(2);\n"), + ic_codegen:emit(Fd, " __env.write_client_pid();\n"), + ic_codegen:emit(Fd, " __env.write_client_ref();\n\n"), + + + %% Creating operation identity + ic_codegen:emit(Fd, " // Message operation part creation\n"), + ic_codegen:emit(Fd, " __os.write_tuple_head(2);\n"), + ic_codegen:emit(Fd, " __os.write_atom(~p);\n",[OpCallName]), + + case ic_java_type:isBasicType(G, N, Type) of + true -> + ic_codegen:emit(Fd, " __os~s(_value);\n\n", + [ic_java_type:marshalFun(G, N, X, Type)]); + false -> + ic_codegen:emit(Fd, " ~s(__os, _value);\n\n", + [ic_java_type:marshalFun(G, N, X, Type)]) + end, + ic_codegen:emit(Fd, " }\n\n"), + + + ic_codegen:emit(Fd, " // Unmarshal operation for set attribute ~p\n", [Name]), + ic_codegen:emit(Fd, " public static void _~s_set_unmarshal(~sEnvironment __env)\n", + [Name, ?ICPACKAGE]), + ic_codegen:emit(Fd, " throws java.lang.Exception {\n\n"), + + ic_codegen:emit(Fd, " // Get input stream\n"), + ic_codegen:emit(Fd, " ~sOtpInputStream __is = __env.getIs();\n\n",[?ERLANGPACKAGE]), + + ic_codegen:emit(Fd, " __is.read_atom();\n"), + ic_codegen:emit(Fd, " }\n\n"). + + + + + + diff --git a/lib/ic/src/ic_cbe.erl b/lib/ic/src/ic_cbe.erl new file mode 100644 index 0000000000..1000e0d962 --- /dev/null +++ b/lib/ic/src/ic_cbe.erl @@ -0,0 +1,1306 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1998-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% +%% +%% + +%%------------------------------------------------------------ +%% +%% This module is a main module for generation of C code, both +%% for ic_cclient and ic_cserver. +%% +%% The former role of this module (ic_cbe) was to generate client +%% code only. +%% +-module(ic_cbe). + +-export([emit_malloc_size_stmt/7, emit_encoding_stmt/6, + emit_encoding_stmt/7, emit_decoding_stmt/10, + emit_decoding_stmt/11, emit_dealloc_stmts/3, + mk_variable_name/1, mk_c_type/3, mk_c_type/4, mk_c_type2/3, + is_variable_size/1, is_variable_size/3, mk_dim/1, + mk_slice_dim/1, emit_tmp_variables/1, store_tmp_decl/2, + extract_info/3, normalize_type/1]). + +%%------------------------------------------------------------ +%% +%% Internal stuff +%% +%%------------------------------------------------------------ + +-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"). + +%%------------------------------------------------------------ +%% ENCODING +%%------------------------------------------------------------ + +emit_encoding_stmt(G, N, Fd, T, LName, OutBuffer) when element(1, T) == scoped_id -> + case mk_c_type(G, N, T, evaluate_not) of + "erlang_pid" -> + %% Note prefix: oe_ei + emit(Fd, " if ((oe_error_code = " + "oe_ei_encode_pid(oe_env, ~s)) < 0) {\n", + [LName]), + ?emit_c_enc_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n }\n"); + "erlang_port" -> + %% Note prefix: oe_ei + emit(Fd, " if ((oe_error_code = " + "oe_ei_encode_port(oe_env, ~s)) < 0) {\n", + [LName]), + ?emit_c_enc_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n} \n"); + "erlang_ref" -> + %% Note prefix: oe_ei + emit(Fd, " if ((oe_error_code = " + "oe_ei_encode_ref(oe_env, ~s)) < 0) {\n", + [LName]), + ?emit_c_enc_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n }\n"); + "ETERM*" -> + %% Note prefix: oe_ei + emit(Fd, " if ((oe_error_code = " + "oe_ei_encode_term(oe_env, ~s)) < 0) {\n", + [LName]), + ?emit_c_enc_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n }\n"); + {enum, FSN} -> + emit_encoding_stmt(G, N, Fd, FSN, LName, OutBuffer); + FSN -> + emit_encoding_stmt(G, N, Fd, FSN, LName, OutBuffer) + end; + +%% XXX T is a string +emit_encoding_stmt(G, N, Fd, T, LName, _OutBuffer) when is_list(T) -> + %% Already a fullscoped name + Type = ictype:name2type(G,T), + case ictype:isBasicType(Type) of + true -> + emit_encoding_stmt_for_basic_type(G, N, T, Fd, Type, LName); + false -> + 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, " ", "~s", [LName]), % XXX list + emit(Fd, " return oe_error_code;\n }\n") + end; +emit_encoding_stmt(G, N, Fd, T, LName, _OutBuffer) when is_record(T, string) -> + %% Note prefix: oe_ei + emit(Fd, " if ((oe_error_code = oe_ei_encode_string(oe_env, " + " ~s)) < 0) {\n", + [LName]), + ?emit_c_enc_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n }\n"); +emit_encoding_stmt(G, N, Fd, T, LName, _OutBuffer) when is_record(T, wstring) -> + %% Note prefix: oe_ei + emit(Fd, " if ((oe_error_code = oe_ei_encode_wstring(oe_env, " + "~s)) < 0) {\n", + [LName]), + ?emit_c_enc_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n }\n"); +emit_encoding_stmt(G, N, Fd, T, LName, _OutBuffer) -> + case normalize_type(T) of + {basic, Type} -> + emit_encoding_stmt_for_basic_type(G, N, T, Fd, Type, LName); + %% XXX Why only returns? + {void, _} -> + ?emit_c_enc_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n }\n"); + {sequence, _, _} -> + ?emit_c_enc_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n }\n"); + {_ArrayType, {array, _, _}} -> + ?emit_c_enc_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n }\n"); + {union, _, _, _, _} -> + %% Union as a member in struct ! + ?emit_c_enc_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n }\n"); + {struct, _, _, _} -> + %% Struct as a member in struct ! + ?emit_c_enc_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n }\n"); + _ -> + ic_error:fatal_error(G, {illegal_typecode_for_c, T, N}) + end. + +%% Arity = 7. +%% +emit_encoding_stmt(G, N, X, Fd, T, LName, OutBuffer) when element(1, T) == scoped_id -> + case mk_c_type(G, N, T, evaluate_not) of + "erlang_pid" -> + %% Note prefix: oe_ei + emit(Fd, " if ((oe_error_code = " + "oe_ei_encode_pid(oe_env, ~s)) < 0) {\n", + [LName]), + ?emit_c_enc_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n }\n"); + "erlang_port" -> + %% Note prefix: oe_ei + emit(Fd, " if ((oe_error_code = " + "oe_ei_encode_port(oe_env, ~s)) < 0) {\n", + [LName]), + ?emit_c_enc_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n }\n"); + "erlang_ref" -> + %% Note prefix: oe_ei + emit(Fd, " if ((oe_error_code = " + "oe_ei_encode_ref(oe_env, ~s)) < 0) {\n", + [LName]), + ?emit_c_enc_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n }\n"); + "ETERM*" -> + %% Note prefix: oe_ei + emit(Fd, " if ((oe_error_code = " + "oe_ei_encode_term(oe_env, ~s)) < 0) {\n", + [LName]), + ?emit_c_enc_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n }\n"); + {enum, FSN} -> + emit_encoding_stmt(G, N, X, Fd, FSN, LName, OutBuffer); + FSN -> + emit_encoding_stmt(G, N, X, Fd, FSN, LName, OutBuffer) + end; + +%% XXX T is a string +emit_encoding_stmt(G, N, X, Fd, T, LName, _OutBuffer) 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]), + ?emit_c_enc_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n }\n"); + ParamTK -> + case is_variable_size(ParamTK) of + true -> + if is_tuple(ParamTK) -> + case element(1,ParamTK) of + tk_array -> + %% Array of dynamic data + 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, " ", "~s", [LName]), + emit(Fd, + " return " + "oe_error_code;\n }\n"); + _ -> + 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, " ", "~s", [LName]), + emit(Fd, " return " + "oe_error_code;\n }\n") + end; + true -> + 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, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n }\n") + end; + false -> + if is_atom(ParamTK) -> + case normalize_type(ParamTK) of + {basic, Type} -> + emit_encoding_stmt_for_basic_type(G, N, T, Fd, + Type, + LName); + _ -> + %% Why only return? + ?emit_c_enc_rpt(Fd, " ", "~/slist/~s", [T, LName]), + emit(Fd, " return oe_error_code;\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, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n }\n"); + 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, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n }\n"); + tk_struct -> + 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, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n }\n"); + tk_union -> + 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, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n }\n"); + _ -> + 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, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n }\n") + end + end + end + end; +emit_encoding_stmt(G, N, _X, Fd, T, LName, _OutBuffer) when is_record(T, string) -> + %% Note prefix: oe_ei + emit(Fd, " if ((oe_error_code = oe_ei_encode_string(oe_env, ~s)) < 0) {\n", + [LName]), + ?emit_c_enc_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n }\n"); +emit_encoding_stmt(G, N, _X, Fd, T, LName, _OutBuffer) when is_record(T, wstring) -> + %% Note prefix: oe_ei + emit(Fd, " if ((oe_error_code = " + "oe_ei_encode_wstring(oe_env, ~s)) < 0) {\n", + [LName]), + ?emit_c_enc_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n }\n"); +emit_encoding_stmt(G, N, _X, Fd, T, LName, _OutBuffer) -> + case normalize_type(T) of + {basic, Type} -> + emit_encoding_stmt_for_basic_type(G, N, T, Fd, Type, LName); + {void, _} -> + ?emit_c_enc_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n }\n"), + ok; + {sequence, _, _} -> + ?emit_c_enc_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n }\n"), + ok; + {_ArrayType, {array, _, _}} -> + ?emit_c_enc_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n }\n"), + ok; + {struct, _, _, _} -> %% Struct as a member in struct ! + ?emit_c_enc_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n }\n"), + ok; + _ -> + %%io:format("2 ------------> ~p~n", [T]), + ic_error:fatal_error(G, {illegal_typecode_for_c, T, N}) + end. + +%%------------------------------------------------------------ +emit_encoding_stmt_for_basic_type(G, N, T, Fd, Type, LName) -> + {Cast, DecType} = + case Type of + ushort -> {"(unsigned long) ", "ulong"}; + ulong -> {"", "ulong"}; + ulonglong -> {"", "ulonglong"}; + short -> {"(long) ", "long"}; + long -> {"", "long"}; + longlong -> {"", "longlong"}; + float -> {"(double) ", "double"}; + double -> {"", "double"}; + boolean -> {"", "atom"}; + char -> {"", "char"}; + wchar -> {"", "wchar"}; + octet -> {"", "char"}; + any -> {"", "long"} % Fix for any + end, + case Type of + boolean -> + %% Note prefix: oe_ei + 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, " ", "~s", [LName]), + 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, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n }\n"), + emit(Fd, " break;\n"), + emit(Fd, " default :\n"), + emit(Fd, " return -1;\n"), + emit(Fd, " }\n\n"); + _ -> + Fmt = + " if ((oe_error_code = oe_ei_encode_~s(oe_env, ~s~s)) < 0) {\n", + emit(Fd, Fmt, [DecType, Cast, LName]), + ?emit_c_enc_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n }\n") + end. + + +%%------------------------------------------------------------ +%% MALLOC SIZE (for Decode) +%%------------------------------------------------------------ + +emit_malloc_size_stmt(G, N, Fd, T, InBuffer, + Align, CalcType) when element(1, T) == scoped_id -> + case mk_c_type(G, N, T, evaluate_not) of + "erlang_pid" -> + emit(Fd, " oe_malloc_size += sizeof(erlang_pid);\n\n"), + emit(Fd, " if ((oe_error_code = ei_decode_pid(~s, " + "oe_size_count_index, NULL)) < 0) {\n", [InBuffer]), + ?emit_c_dec_rpt(Fd, " ", "erlang_pid", []), + emit(Fd, " return oe_error_code;\n }\n"); + "erlang_port" -> + emit(Fd, " oe_malloc_size += sizeof(erlang_port);\n\n"), + emit(Fd, " if ((oe_error_code = ei_decode_port(~s, " + "oe_size_count_index, NULL)) < 0) {\n", [InBuffer]), + ?emit_c_dec_rpt(Fd, " ", "erlang_port", []), + emit(Fd, " return oe_error_code;\n }\n"); + "erlang_ref" -> + emit(Fd, " oe_malloc_size += sizeof(erlang_ref);\n\n"), + emit(Fd, " if ((oe_error_code = ei_decode_ref(~s, " + "oe_size_count_index, NULL)) < 0) {\n", [InBuffer]), + ?emit_c_dec_rpt(Fd, " ", "erlang_ref", []), + emit(Fd, " return oe_error_code;\n }\n"); + "ETERM*" -> + emit(Fd, " oe_malloc_size += sizeof(char*);\n\n"), + emit(Fd, " if ((oe_error_code = ei_decode_term(~s, " + "oe_size_count_index, NULL)) < 0) {\n", [InBuffer]), + ?emit_c_dec_rpt(Fd, " ", "ETERM*", []), + emit(Fd, " return oe_error_code;\n }\n"); + {enum, FSN} -> + emit_malloc_size_stmt(G, N, Fd, FSN, InBuffer, Align, CalcType); + FSN -> + %% io:format("emit_malloc_size_stmt: ~p ~p~n",[FSN, + %% CalcType]), + emit_malloc_size_stmt(G, N, Fd, FSN, InBuffer, Align, CalcType) + end; + +%% XXX T is a string +emit_malloc_size_stmt(G, N, Fd, T, InBuffer, + _Align, CalcType) when is_list(T) -> + %% Already a fullscoped name + Type = ictype:name2type(G,T), + case ictype:isBasicType(Type) of + true -> + emit_malloc_size_stmt_for_basic_type(G, N, T, Fd, Type, InBuffer); + false -> + case CalcType of + generator -> + emit(Fd, " if ((oe_error_code = ~s~s(oe_env, " + "oe_size_count_index, &oe_malloc_size)) < 0) {\n", + [ic_util:mk_oe_name(G, "sizecalc_"), T]), + ?emit_c_dec_rpt(Fd, " ", "~s", [T]), + emit(Fd, " return oe_error_code;\n }\n"); + _ -> + emit(Fd, " if ((oe_error_code = ~s~s(oe_env, " + "&oe_size_count_index, &oe_malloc_size)) < 0) {\n", + [ic_util:mk_oe_name(G, "sizecalc_"), T]), + ?emit_c_dec_rpt(Fd, " ", "~s", [T]), + emit(Fd, " return oe_error_code;\n }\n") + end + end; +emit_malloc_size_stmt(G, N, Fd, T, InBuffer, _Align, + CalcType) when is_record(T, string) -> + Tname = mk_variable_name(op_variable_count), + store_tmp_decl(" int ~s = 0;\n",[Tname]), + case CalcType of + generator -> + emit(Fd, " if ((oe_error_code = ei_get_type(~s, " + "oe_size_count_index, &oe_type, &~s)) < 0) {\n", + [InBuffer, Tname]); + _ -> + emit(Fd, " int oe_type = 0;\n"), + emit(Fd, " int oe_temp = 0;\n\n"), + emit(Fd, " if ((oe_error_code = ei_get_type(~s, " + "&oe_size_count_index, &oe_type, &oe_temp)) < 0) {\n", + [InBuffer]) + end, + ?emit_c_dec_rpt(Fd, " ", "ei_get_type", []), + emit(Fd, " return oe_error_code;\n }\n"), + if + T#string.length == 0 -> + ok; + true -> + Length = ic_util:eval_c(G, N, T#string.length), + case CalcType of + generator -> + emit(Fd, " if (~s > ~s)\n",[Tname, Length]), + emit(Fd, " return -1;\n\n"); + _ -> + emit(Fd, " if (oe_temp > ~s)\n",[Length]), + emit(Fd, " return -1;\n\n") + end + end, + case CalcType of + generator -> + emit(Fd, " if ((oe_error_code = ei_decode_string(~s, " + "oe_size_count_index, NULL)) < 0) {\n", [InBuffer]); + _ -> + emit(Fd, " if ((oe_error_code = ei_decode_string(~s, " + "&oe_size_count_index, NULL)) < 0) {\n", [InBuffer]) + end, + ?emit_c_dec_rpt(Fd, " ", "ei_decode_string", []), + emit(Fd, " return oe_error_code;\n }\n"), + case CalcType of + generator -> + emit(Fd, " oe_malloc_size = ~s;\n\n", + [ic_util:mk_align("oe_malloc_size + " ++ Tname ++"+1")]); + _ -> + emit(Fd, " oe_malloc_size = ~s;\n\n", + [ic_util:mk_align("oe_malloc_size + oe_temp+1")]) + end; +emit_malloc_size_stmt(G, N, Fd, T, InBuffer, _Align, + CalcType) when is_record(T, wstring) -> + Tname = mk_variable_name(op_variable_count), + store_tmp_decl(" int ~s = 0;\n",[Tname]), + case CalcType of + generator -> + emit(Fd, " if ((oe_error_code = ei_get_type(~s, " + "oe_size_count_index, &oe_type, &~s)) < 0) {\n", + [InBuffer, Tname]); + _ -> + emit(Fd, " int oe_type = 0;\n"), + emit(Fd, " int oe_temp = 0;\n\n"), + emit(Fd, " if ((oe_error_code = ei_get_type(~s, " + "&oe_size_count_index, &oe_type, &oe_temp)) < 0) {\n", + [InBuffer]) + end, + ?emit_c_dec_rpt(Fd, " ", "ei_get_type", []), + emit(Fd, " return oe_error_code;\n }\n"), + if + T#wstring.length == 0 -> + ok; + true -> + Length = ic_util:eval_c(G, N, T#wstring.length), + case CalcType of + generator -> + emit(Fd, " if (~s > ~s)\n",[Tname, Length]), + emit(Fd, " return -1;\n\n"); + _ -> + emit(Fd, " if (oe_temp > ~s)\n",[Length]), + emit(Fd, " return -1;\n\n") + end + end, + case CalcType of + generator -> + %% Note prefix: oe_ei + emit(Fd, " if ((oe_error_code = oe_ei_decode_wstring(~s, " + "oe_size_count_index, NULL)) < 0) {\n", [InBuffer]); + _ -> + %% Note prefix: oe_ei + emit(Fd, " if ((oe_error_code = oe_ei_decode_wstring(~s, " + "&oe_size_count_index, NULL)) < 0) {\n", [InBuffer]) + end, + ?emit_c_dec_rpt(Fd, " ", "oe_ei_decode_wstring", []), + emit(Fd, " return oe_error_code;\n }\n"), + case CalcType of + generator -> + emit(Fd, " oe_malloc_size =\n ~s;\n\n", + [ic_util:mk_align("oe_malloc_size + ((" + ++ Tname + ++"+ 1) * __OE_WCHAR_SIZE_OF__)")]); + _ -> + emit(Fd, " oe_malloc_size =\n ~s;\n\n", + [ic_util:mk_align("oe_malloc_size + ((" + "oe_temp + 1) * __OE_WCHAR_SIZE_OF__)")]) + end; +emit_malloc_size_stmt(G, N, Fd, T, InBuffer, Align, CalcType) -> + case Align of + 0 -> + emit(Fd, " oe_malloc_size += sizeof(~s);\n\n", + [mk_c_type(G, N, T)]); + _ -> + ok + end, + case normalize_type(T) of + {basic, Type} -> + emit_malloc_size_stmt_for_basic_type(G, N, T, Fd, Type, InBuffer); + {void, _} -> + ok; + {sequence, _, _} -> + ok; + {_, {array, SId, _}} -> + case CalcType of + generator -> + emit(Fd, " if ((oe_error_code = ~s~s(oe_env, " + "oe_size_count_index, &oe_malloc_size)) < 0) {\n", + [ic_util:mk_oe_name(G, "sizecalc_"), + ic_forms:get_id2(SId)]), + ?emit_c_dec_rpt(Fd, " ", "array1", []), + emit(Fd, " return oe_error_code;\n\n"); + _ -> + emit(Fd, " if ((oe_error_code = ~s~s(oe_env, " + "&oe_size_count_index, &oe_malloc_size)) < 0) {\n", + [ic_util:mk_oe_name(G, "sizecalc_"), + ic_forms:get_id2(SId)]), + ?emit_c_dec_rpt(Fd, " ", "array2", []), + emit(Fd, " return oe_error_code;\n\n") + end; + {union, UId, _, _, _} -> + case CalcType of + generator -> + emit(Fd, " if ((oe_error_code = ~s~s(oe_env, " + "oe_size_count_index, &oe_malloc_size)) < 0) {\n", + [ic_util:mk_oe_name(G, "sizecalc_"), + ic_forms:get_id2(UId)]), + ?emit_c_dec_rpt(Fd, " ", "union1", []), + emit(Fd, " return oe_error_code;\n\n"); + _ -> + emit(Fd, " if ((oe_error_code = ~s~s(oe_env, " + "&oe_size_count_index, &oe_malloc_size)) < 0) {\n", + [ic_util:mk_oe_name(G, "sizecalc_"), + ic_forms:get_id2(UId)]), + ?emit_c_dec_rpt(Fd, " ", "union2", []), + emit(Fd, " return oe_error_code;\n\n") + end; + {struct, UId, _, _} -> %% Struct as a member in struct ! + case CalcType of + generator -> + emit(Fd, " if ((oe_error_code = ~s~s(oe_env, " + "oe_size_count_index, &oe_malloc_size)) < 0) {\n", + [ic_util:mk_oe_name(G, "sizecalc_"), + ic_forms:get_id2(UId)]), + ?emit_c_dec_rpt(Fd, " ", "struct1", []), + emit(Fd, " return oe_error_code;\n\n"); + _ -> + emit(Fd, " if ((oe_error_code = ~s~s(oe_env, " + "&oe_size_count_index, &oe_malloc_size)) < 0) {\n", + [ic_util:mk_oe_name(G, "sizecalc_"), + ic_forms:get_id2(UId)]), + ?emit_c_dec_rpt(Fd, " ", "struct2", []), + emit(Fd, " return oe_error_code;\n\n") + end; + {any, _} -> %% Fix for any type + emit(Fd, " if ((oe_error_code = ei_decode_long(~s, " + "oe_size_count_index, NULL)) < 0) {\n", + [InBuffer]), + ?emit_c_dec_rpt(Fd, " ", "any", []), + emit(Fd, " return oe_error_code;\n }\n"); + _ -> + ic_error:fatal_error(G, {illegal_typecode_for_c, T, N}) + end. + +%%------------------------------------------------------------ + +emit_malloc_size_stmt_for_basic_type(G, N, T, Fd, Type, InBuffer) -> + {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, + Fmt = + " if ((oe_error_code = ~sei_decode_~s(~s, oe_size_count_index, " + "NULL)) < 0) {\n", + emit(Fd, Fmt, [Pre, DecType, InBuffer]), + ?emit_c_dec_rpt(Fd, " ", "~s", [DecType]), + emit(Fd, " return oe_error_code;\n }\n"). + +%%------------------------------------------------------------ +%% DECODING +%%------------------------------------------------------------ + +emit_decoding_stmt(G, N, Fd, T, LName, IndOp, InBuffer, Align, + NextPos, DecType) -> + emit_decoding_stmt(G, N, Fd, T, LName, IndOp, InBuffer, Align, + NextPos, DecType, []). + +emit_decoding_stmt(G, N, Fd, T, LName, IndOp, InBuffer, Align, NextPos, + DecType, AllocedPars) when element(1, T) == scoped_id -> + Fmt = + " if ((oe_error_code = ei_decode_~s(~s, &oe_env->_iin, ~s~s)) < 0)" + " {\n", + Emit = fun(Type) -> + emit(Fd, Fmt, [Type, InBuffer, IndOp, LName]), + emit_dealloc_stmts(Fd, " ", AllocedPars), + ?emit_c_dec_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n"), + emit(Fd, " }\n") + end, + case mk_c_type(G, N, T, evaluate_not) of + "erlang_pid" -> + Emit("pid"); + "erlang_port" -> + Emit("port"); + "erlang_ref" -> + Emit("ref"); + "ETERM*" -> + Emit("term"); + {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; + +%% XXX T is a string +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(G, N, T, Fd, Type, InBuffer, IndOp, + LName, AllocedPars); + false -> + case DecType of + generator -> + 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]), + emit_dealloc_stmts(Fd, " ", AllocedPars), + ?emit_c_dec_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n"), + emit(Fd, " }\n"); + caller -> %% No malloc used, define oe_first + emit(Fd, " {\n"), + emit(Fd, " void *oe_first = NULL;\n"), + emit(Fd, " int oe_outindex = 0;\n\n"), + 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]), + emit_dealloc_stmts(Fd, " ", AllocedPars), + ?emit_c_dec_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n"), + emit(Fd, " }\n"), + emit(Fd, " }\n"); + caller_dyn -> %% Malloc used + emit(Fd, " {\n"), + emit(Fd, " int oe_outindex = 0;\n\n"), + 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]), + emit_dealloc_stmts(Fd, " ", AllocedPars), + ?emit_c_dec_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n"), + emit(Fd, " }\n"), + emit(Fd, " }\n"); + array_dyn -> %% Malloc used + emit(Fd, " {\n"), + emit(Fd, " int oe_outindex = 0;\n\n"), + 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]), + emit_dealloc_stmts(Fd, " ", AllocedPars), + ?emit_c_dec_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n"), + emit(Fd, " }\n"), + emit(Fd, " }\n"); + array_fix_ret -> + emit(Fd, " {\n"), + emit(Fd, " int oe_outindex = 0;\n\n"), + 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]), + emit_dealloc_stmts(Fd, " ", AllocedPars), + ?emit_c_dec_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n"), + emit(Fd, " }\n"), + emit(Fd, " }\n"); + array_fix_out -> %% No malloc used, define oe_first + emit(Fd, " {\n"), + emit(Fd, " void *oe_first = NULL;\n"), + emit(Fd, " int oe_outindex = 0;\n\n"), + 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]), + emit_dealloc_stmts(Fd, " ", AllocedPars), + ?emit_c_dec_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n"), + emit(Fd, " }\n"), + emit(Fd, " }\n") + end + end; +emit_decoding_stmt(G, N, Fd, T, LName, IndOp, InBuffer, _Align, _NextPos, + DecType, AllocedPars) when is_record(T, string) -> + case DecType of + caller_dyn -> + emit(Fd, " if ((oe_error_code = ei_decode_string(~s, " + "&oe_env->_iin, ~s~s)) < 0) {\n", + [InBuffer, IndOp, LName]), + emit_dealloc_stmts(Fd, " ", AllocedPars), + ?emit_c_dec_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n"), + emit(Fd, " }\n"); + _ -> + emit(Fd, " ~s~s = oe_first + *oe_outindex;\n\n", + [IndOp, LName]), + emit(Fd, " {\n"), + emit(Fd, " int oe_type=0;\n"), + emit(Fd, " int oe_string_ctr=0;\n\n"), + + emit(Fd, " (int) ei_get_type(~s, " + "&oe_env->_iin, &oe_type, &oe_string_ctr);\n\n", + [InBuffer]), + + emit(Fd, " if ((oe_error_code = ei_decode_string(~s, " + "&oe_env->_iin, ~s~s)) < 0) {\n", + [InBuffer, IndOp, LName]), + emit_dealloc_stmts(Fd, " ", AllocedPars), + ?emit_c_dec_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n"), + emit(Fd, " }\n"), + emit(Fd, " *oe_outindex = ~s;\n", + [ic_util:mk_align("*oe_outindex+oe_string_ctr+1")]), + emit(Fd, " }\n\n") + end; +emit_decoding_stmt(G, N, Fd, T, LName, IndOp, InBuffer, _Align, _NextPos, + DecType, AllocedPars) when is_record(T, wstring) -> + case DecType of + caller_dyn -> + %% Note prefix: oe_ei + emit(Fd, " if ((oe_error_code = oe_ei_decode_wstring(~s, " + "&oe_env->_iin, ~s~s)) < 0) {\n", + [InBuffer, IndOp, LName]), + emit_dealloc_stmts(Fd, " ", AllocedPars), + ?emit_c_dec_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n"), + emit(Fd, " }/* --- */\n"); % XXX + _ -> + emit(Fd, " ~s~s = oe_first + *oe_outindex;\n\n", + [IndOp, LName]), + + emit(Fd, " {\n"), + emit(Fd, " int oe_type=0;\n"), + emit(Fd, " int oe_string_ctr=0;\n\n"), + emit(Fd, " (int) ei_get_type(~s, " + "&oe_env->_iin, &oe_type, &oe_string_ctr);\n\n", + [InBuffer]), + %% Note prefix: oe_ei + emit(Fd, " if ((oe_error_code = oe_ei_decode_wstring(~s, " + "&oe_env->_iin, ~s~s)) < 0) {\n", + [InBuffer, IndOp, LName]), + emit_dealloc_stmts(Fd, " ", AllocedPars), + ?emit_c_dec_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n"), + emit(Fd, " }\n"), + emit(Fd, " *oe_outindex = ~s;\n", + [ic_util:mk_align("*oe_outindex+oe_string_ctr+1")]), + emit(Fd, " }\n") + end; +emit_decoding_stmt(G, N, Fd, T, LName, IndOp, InBuffer, _Align, NextPos, + _DecType, AllocedPars) -> + case normalize_type(T) of + {basic, Type} -> + emit_decoding_stmt_for_basic_type(G, N, T, Fd, Type, InBuffer, IndOp, + LName, AllocedPars); + {void, _} -> + emit(Fd, " if ((oe_error_code = ei_decode_atom(~s, " + "&oe_env->_iin, NULL)) < 0) {\n", + [InBuffer]), + emit_dealloc_stmts(Fd, " ", AllocedPars), + ?emit_c_dec_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n"), + emit(Fd, " }\n"); + {sequence, _, _} -> + ok; + {_, {array, SId, Dims}} -> + AName = ic_forms:get_id2({array, SId, Dims}), + Ptr = "oe_out->"++AName, + emit(Fd, " if ((oe_error_code = ~s~s(oe_env, " + "oe_first, ~s, ~s)) < 0) {\n", + [ic_util:mk_oe_name(G, "decode_"), + ic_forms:get_id2(SId), + NextPos, Ptr]), + emit_dealloc_stmts(Fd, " ", AllocedPars), + ?emit_c_dec_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n"), + emit(Fd, " }\n"); + {struct, _, _, _} -> %% Struct as a member in struct ! + ok; + _ -> + %%io:format("3 ------------> ~p~n", [T]), + ic_error:fatal_error(G, {illegal_typecode_for_c, T, N}) + end. + +%% XXX DecType used in two senses in this file. +emit_decoding_stmt_for_basic_type(G, N, T, 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]), + emit_dealloc_stmts(Fd, " ", AllocedPars), + ?emit_c_dec_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n"), + emit(Fd, "}\n"), + emit(Fd, " *(~s) = (unsigned short) oe_ulong;\n\n", + [LName]), + emit(Fd, " if (*(~s) != oe_ulong){\n", + [LName]), + emit_dealloc_stmts(Fd, " ", AllocedPars), + ?emit_c_dec_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return -1;\n"), + emit(Fd, " }\n"), + 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]), + emit_dealloc_stmts(Fd, " ", AllocedPars), + ?emit_c_dec_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n\n"), + emit(Fd, "}\n"), + emit(Fd, " *(~s) = (short) oe_long;\n\n",[LName]), + emit(Fd, " if (*(~s) != oe_long){\n", [LName]), + emit_dealloc_stmts(Fd, " ", AllocedPars), + ?emit_c_dec_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return -1;\n"), + emit(Fd, " }\n"), + emit(Fd, " }\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]), + emit_dealloc_stmts(Fd, " ", AllocedPars), + ?emit_c_dec_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return oe_error_code;\n\n"), + emit(Fd, "}\n"), + emit(Fd, " *(~s) = (float) oe_double;\n",[LName]), + emit(Fd, " }\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]), + emit_dealloc_stmts(Fd, " ", AllocedPars), + ?emit_c_dec_rpt(Fd, " ", "~s", [LName]), + 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, " }\n"), + emit(Fd, " else {\n"), + emit_dealloc_stmts(Fd, " ", AllocedPars), + ?emit_c_dec_rpt(Fd, " ", "~s", [LName]), + emit(Fd, " return -1;\n"), + emit(Fd, " }\n"), + emit(Fd, " }\n"); + _ -> + emit(Fd, Fmt, [Pre, DecType, InBuffer, IndOp, LName]), + ?emit_c_dec_rpt(Fd, " ", "~s", [LName]), + emit_dealloc_stmts(Fd, " ", AllocedPars), + emit(Fd, Ret) + end. + +%%------------------------------------------------------------ +%% +%%------------------------------------------------------------ +emit_dealloc_stmts(Fd, Prefix, AllocedPars) -> + Fmt = Prefix ++ "CORBA_free(~s);\n", + lists:foreach( + fun(Par) -> emit(Fd, Fmt, [Par]) end, + AllocedPars). + + +%%------------------------------------------------------------ +%% +%%------------------------------------------------------------ + +mk_variable_name(Var) -> + Nr = get(Var), + put(Var, Nr + 1), + "oe_tmp" ++ integer_to_list(Nr). + +%% IDL to C type conversion +%%------------------------------------------------------------ +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) -> + "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, S, _) when is_record(S, union)-> + ic_forms:get_id2(S); + +mk_c_type(_G, N, S, _) when is_record(S, struct) -> %% Locally defined member + Fullname = [ic_forms:get_id2(S) | N], + ic_util:to_undersc(Fullname); + +mk_c_type(_G, _N, {'any', _}, _) -> %% Fix for any type + "CORBA_long"; + +mk_c_type(_G, _N, {T, _}, _) -> + "CORBA_" ++ atom_to_list(T). + +%%------------------------------------------------------------------- +%% IDL to C type conversion used by the emit_c_*_rpt macros. +%%------------------------------------------------------------------- +mk_c_type2(G, N, S) 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_type2(G, N, Type); + Type -> + mk_c_type2(G, N, Type) + end; + +mk_c_type2(_G, _N, S) when is_list(S) -> + S; +mk_c_type2(_G, _N, S) when is_record(S, string) -> + "CORBA_char *"; +mk_c_type2(_G, _N, S) when is_record(S, wstring) -> + "CORBA_wchar *"; +mk_c_type2(_G, _N, {boolean, _}) -> + "CORBA_boolean"; +mk_c_type2(_G, _N, {octet, _}) -> + "CORBA_octet"; +mk_c_type2(_G, _N, {void, _}) -> + "void"; +mk_c_type2(_G, _N, {unsigned, U}) -> + case U of + {short,_} -> + "CORBA_unsigned_short"; + {long,_} -> + "CORBA_unsigned_long"; + {'long long',_} -> + "CORBA_unsigned_long_long" + end; + +mk_c_type2(_G, _N, {'long long', _}) -> + "CORBA_long_long"; + +mk_c_type2(_G, _N, S) when is_record(S, union)-> + ic_forms:get_id2(S); + +mk_c_type2(_G, N, S) when is_record(S, struct) -> + Fullname = [ic_forms:get_id2(S) | N], + ic_util:to_undersc(Fullname); + +mk_c_type2(_G, _N, S) when is_record(S, sequence) -> + mk_c_type2(_G, _N, S#sequence.type); + +mk_c_type2(_G, _N, {'any', _}) -> %% Fix for any type + "CORBA_long"; + +mk_c_type2(_G, _N, {T, _}) -> + "CORBA_" ++ atom_to_list(T). + +%%----- + +is_variable_size_rec(Es) -> + lists:any( + fun({_N, T}) -> is_variable_size(T); + ({_, _N, T}) -> is_variable_size(T) + end, Es). + +is_variable_size({'tk_struct', _IFRId, "port", _ElementList}) -> + false; +is_variable_size({'tk_struct', _IFRId, "pid", _ElementList}) -> + false; +is_variable_size({'tk_struct', _IFRId, "ref", _ElementList}) -> + false; +is_variable_size({'tk_struct', _IFRId, "term", _ElementList}) -> + false; +is_variable_size({'tk_struct', _IFRId, _Name, ElementList}) -> + is_variable_size_rec(ElementList); +is_variable_size({'tk_array', ElemTC, _Length}) -> + is_variable_size(ElemTC); +is_variable_size({'tk_string', _}) -> + true; +is_variable_size({'tk_wstring', _}) -> + true; +is_variable_size({'tk_sequence', _ElemTC, _MaxLsextractength}) -> + true; +is_variable_size({'tk_union', _IFRId, _Name, _, _, ElementList}) -> + is_variable_size_rec(ElementList); +is_variable_size(_Other) -> + false. + + +is_variable_size(_G, _N, T) when is_record(T, string) -> + true; +is_variable_size(_G, _N, T) when is_record(T, wstring) -> + true; +is_variable_size(_G, _N, T) when is_record(T, sequence) -> + true; +is_variable_size(G, N, T) when is_record(T, union) -> + %%io:format("~n~p = ~p~n",[ic_forms:get_id2(T),ictype:fetchTk(G, N, T)]), + is_variable_size(ictype:fetchTk(G, N, T)); +is_variable_size(G, N, T) when is_record(T, struct) -> + is_variable_size(ictype:fetchTk(G, N, T)); +is_variable_size(G, N, T) when element(1, T) == scoped_id -> + case ic_symtab:get_full_scoped_name(G, N, T) of + {_FullScopedName, _, TK, _} -> + is_variable_size(TK); + _ -> + ic_error:fatal_error(G, {name_not_found, T}) + end; +is_variable_size(_G, _N, _Other) -> + false. + +%% mk_dim produces +mk_dim([Arg | Args]) -> + "[" ++ Arg ++ "]" ++ mk_dim(Args); +mk_dim([]) -> []. + +mk_slice_dim(Args) -> + mk_dim(tl(Args)). + + +emit_tmp_variables(Fd) -> + DeclList = get(tmp_declarations), + emit_tmp_variables(Fd, DeclList), + ok. + +emit_tmp_variables(Fd, [Decl |Rest]) -> + emit_tmp_variables(Fd, Rest), + emit(Fd, "~s", [Decl]); +emit_tmp_variables(_Fd, []) -> + ok. + +store_tmp_decl(Format, Args) -> + Decl = io_lib:format(Format, Args), + DeclList = get(tmp_declarations), + put(tmp_declarations, [Decl |DeclList]). + +%%------------------------------------------------------------ +%% +%% Parser utilities +%% +%% Called from the yecc parser. Expands the identifier list of an +%% attribute so that the attribute generator never has to handle +%% lists. +%% +%%------------------------------------------------------------ + +extract_info(_G, N, X) when is_record(X, op) -> + Name = ic_util:to_undersc([ic_forms:get_id2(X) | N]), + Args = X#op.params, + ArgNames = mk_c_vars(Args), + TypeList = {ic_forms:get_type(X), + lists:map(fun(Y) -> ic_forms:get_type(Y) end, Args), + [] + }, + {Name, ArgNames, TypeList}; +extract_info(_G, N, X) -> + Name = ic_util:to_undersc([ic_forms:get_id2(X) | N]), + {Name, [], []}. + + + +%% Usefull functions +get_param_tk(Name, Op) -> + case get_param(Name, Op) of + error -> + error; + Param -> + ic_forms:get_tk(Param) + end. + +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,[Param|Params]) -> + case ic_forms:get_id2(Param) of + Name -> + Param; + _ -> + get_param_loop(Name,Params) + end; +get_param_loop(_Name, []) -> + error. + + +%% Input is a list of parameters (in parse form) and output is a list +%% of parameter attribute and variable names. +mk_c_vars(Params) -> + lists:map(fun(P) -> {A, _} = P#param.inout, + {A, ic_forms:get_id(P#param.id)} + end, + Params). + +normalize_type({unsigned, {short, _}}) -> {basic, ushort}; +normalize_type({unsigned, {long, _}}) -> {basic, ulong}; +normalize_type({unsigned, {'long long', _}}) -> {basic, ulonglong}; +normalize_type({short,_}) -> {basic, short}; +normalize_type({long, _}) -> {basic, long}; +normalize_type({'long long', _}) -> {basic, longlong}; +normalize_type({float,_}) -> {basic, float}; +normalize_type({double, _}) -> {basic, double}; +normalize_type({boolean, _}) -> {basic, boolean}; +normalize_type({char, _}) -> {basic, char}; +normalize_type({wchar, _}) -> {basic, wchar}; +normalize_type({octet, _}) -> {basic, octet}; +normalize_type({any, _}) -> {basic, any}; +normalize_type(tk_ushort) -> {basic, ushort}; +normalize_type(tk_ulong) -> {basic, ulong}; +normalize_type(tk_ulonglong) -> {basic, ulonglong}; +normalize_type(tk_short) -> {basic, short}; +normalize_type(tk_long) -> {basic, long}; +normalize_type(tk_longlong) -> {basic, longlong}; +normalize_type(tk_float) -> {basic, float}; +normalize_type(tk_double) -> {basic, double}; +normalize_type(tk_boolean) -> {basic, boolean}; +normalize_type(tk_char) -> {basic, char}; +normalize_type(tk_wchar) -> {basic, wchar}; +normalize_type(tk_octet) -> {basic, octet}; +normalize_type(tk_any) -> {basic, any}; +normalize_type(ushort) -> {basic, ushort}; +normalize_type(ulong) -> {basic, ulong}; +normalize_type(ulonglong) -> {basic, ulonglong}; +normalize_type(short) -> {basic, short}; +normalize_type(long) -> {basic, long}; +normalize_type(longlong) -> {basic, longlong}; +normalize_type(float) -> {basic, float}; +normalize_type(double) -> {basic, double}; +normalize_type(boolean) -> {basic, boolean}; +normalize_type(char) -> {basic, char}; +normalize_type(wchar) -> {basic, wchar}; +normalize_type(octet) -> {basic, octet}; +normalize_type(any) -> {basic, any}; +normalize_type(Type) -> Type. + 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 \n"), + emit(Fd, "#include \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 \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 \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. diff --git a/lib/ic/src/ic_code.erl b/lib/ic/src/ic_code.erl new file mode 100644 index 0000000000..6802b9ca65 --- /dev/null +++ b/lib/ic/src/ic_code.erl @@ -0,0 +1,584 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1998-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_code). + + +-include_lib("ic/src/ic.hrl"). +-include_lib("ic/src/icforms.hrl"). + +%%----------------------------------------------------------------- +%% External exports +%%----------------------------------------------------------------- +-export([get_basetype/2, insert_typedef/3, codeDirective/2]). +-export([gen_includes/3, gen_includes/4, mk_list/1]). + +-export([type_expand_op/4, type_expand_handle_op/4]). +-export([ type_expand_op_exec/4, type_expand_all/6, type_expand/7]). + +-export([type_expand_null/3, type_expand_void/3, type_expand_float/3, type_expand_double/3]). +-export([type_expand_short/3, type_expand_ushort/3, type_expand_long/3, type_expand_ulong/3]). +-export([type_expand_longlong/3, type_expand_ulonglong/3]). +-export([type_expand_char/3, type_expand_wchar/3, type_expand_boolean/3]). +-export([type_expand_octet/3, type_expand_any/3, type_expand_wstring/3]). +-export([type_expand_object/3, type_expand_string/3, type_expand_struct/7, type_expand_union/7]). +-export([type_expand_enum/4, type_expand_sequence/7, type_expand_array/7, type_expand_error/3]). + +-export([type_expand_struct_rule/3, type_expand_union_rule/2, type_expand_enum_rule/4]). +-export([type_expand_enum_elements/3, type_expand_longdouble/3, type_expand_typecode/3]). +-export([type_expand_principal/3, type_expand_exception/7]). + +%%----------------------------------------------------------------- +%% External functions +%%----------------------------------------------------------------- + +%%------------------------------------------------------------------------------------- +%% +%% Trackrecording of generated sequence type structs, thist is just used for C today. +%% +%%------------------------------------------------------------------------------------- + +get_basetype(G, MyId) -> + case ?lookup(ic_genobj:typedeftab(G), MyId) of + [] -> + MyId; + X -> + get_basetype(G, X) + end. + +insert_typedef(_G, "erlang_term", _) -> + ok; +insert_typedef(G, MyId, DefinedAsId) -> + ?insert(ic_genobj:typedeftab(G), MyId, DefinedAsId). + +codeDirective(G,X) -> + case produceCode(X) of + true -> + case ic_options:get_opt(G, be) of + c_genserv -> + c; + c_client -> + c; + c_server -> + c_server; + _ -> + erlang + end; + false -> + case ic_options:get_opt(G, be) of + c_genserv -> + c_no_stub; + c_client -> + c_no_stub; + c_server -> + c_server_no_stub; + _ -> + erlang_no_stub + end + end. + +%% Checks if X should produce code +produceCode(X) when is_record(X, module) -> + case ic_forms:get_body(X) of + [] -> + true; + List -> + produceModuleCode(List) + end; +produceCode(_X) -> + false. + +produceModuleCode([]) -> + false; +produceModuleCode([X|_Xs]) when is_record(X, const) -> + true; +produceModuleCode([_X|Xs]) -> + produceModuleCode(Xs). + +%% Includes needed c file headers for included idl files +gen_includes(Fd,G,Type) -> + case Type of + c_client -> + IncludeList = + ic_pragma:get_included_c_headers(G), + gen_includes_loop(Fd,IncludeList,Type); + c_server -> + IncludeList = + ic_pragma:get_included_c_headers(G), + gen_includes_loop(Fd,IncludeList,Type); + _ -> + ok + end, + ic_codegen:nl(Fd), + ic_codegen:emit(Fd, "#ifdef __cplusplus\n"), + ic_codegen:emit(Fd, "extern \"C\" {\n"), + ic_codegen:emit(Fd, "#endif\n\n"). + + +%% Includes needed c file headers for local interfaces +gen_includes(Fd,G,X,Type) -> + case Type of + c_client -> + IncludeList = + ic_pragma:get_local_c_headers(G,X), + gen_includes_loop(Fd,IncludeList,Type); + c_server -> + IncludeList = + ic_pragma:get_local_c_headers(G,X), + gen_includes_loop(Fd,IncludeList,Type); + _ -> + ok + end, + ic_codegen:nl(Fd), + ic_codegen:emit(Fd, "#ifdef __cplusplus\n"), + ic_codegen:emit(Fd, "extern \"C\" {\n"), + ic_codegen:emit(Fd, "#endif\n\n"). + + +gen_includes_loop(_,[],_) -> + ok; +gen_includes_loop(Fd,[I|Is],Type) -> + L = string:tokens(I,"/"), + File = lists:last(L), + case File of + "erlang" -> % Erlang is NOT generated that way ! + gen_includes_loop(Fd,Is,Type); + "oe_erlang" -> % Erlang is NOT generated that way ! + gen_includes_loop(Fd,Is,Type); + _ -> + case Type of + c_client -> + ic_codegen:emit(Fd, "#include \"~s.h\"\n", [File]); + c_server -> + ic_codegen:emit(Fd, "#include \"~s__s.h\"\n", [File]) + end, + gen_includes_loop(Fd,Is,Type) + end. + + + + +%% +%% Used in NOC only +%% + + +%% +%% Type expand on function head comments +%% +type_expand_op(G,N,X,Fd) -> + case catch type_expand_op_exec(G,N,X,Fd) of + {'EXIT',_Reason} -> + ic_codegen:nl(Fd), + ic_codegen:emit(Fd,"%% Error under type expansion, does not affect generated code.~n",[]), + ic_codegen:emit(Fd,"%%------------------------------------------------------------~n",[]); + _ -> + ic_codegen:emit(Fd,"%%------------------------------------------------------------~n",[]) + end. + + +type_expand_op_exec(G,N,X,Fd) -> + InArgs = ic:filter_params([in,inout], X#op.params), + OutArgs = ic:filter_params([out,inout], X#op.params), + ParamNr = length(InArgs)+1, + Tabs = "", + + ic_codegen:nl(Fd), + ic_codegen:emit(Fd,"%%------------------------------------------------------------~n",[]), + + case ic_forms:is_oneway(X) of + false -> + ic_codegen:emit(Fd,"%% Operation: ~s/~p~n",[ic_forms:get_id2(X),ParamNr]); + true -> + ic_codegen:emit(Fd,"%% Operation: ~s/~p (oneway)~n",[ic_forms:get_id2(X),ParamNr]) + end, + + if X#op.raises == [] -> []; + true -> + ic_codegen:emit(Fd,"%%~n",[]), + RaisesList=["%% Raises: " ++ + mk_list(lists:map(fun(E) -> ic_util:to_colon(E) end, + X#op.raises))], + ic_codegen:emit(Fd,RaisesList,[]), + ic_codegen:nl(Fd) + end, + + %% Print argument names + ic_codegen:emit(Fd,"%%\n",[]), + InArgNames = ["OE_Ref"]++[ic_util:mk_var(ic_forms:get_id(InArg#param.id)) || InArg <- InArgs ], + OutArgNames = ["Ret"]++[ic_util:mk_var(ic_forms:get_id(OutArg#param.id)) || OutArg <- OutArgs ], + case length(InArgNames) > 1 of + true -> + ic_codegen:emit(Fd,"%% Input value(s) : ~s~n",[mk_list(InArgNames)]); + false -> + ic_codegen:emit(Fd,"%% Input value : ~s~n",[mk_list(InArgNames)]) + end, + case length(OutArgNames) > 1 of + true -> + ic_codegen:emit(Fd,"%% Return value(s) : ~s~n",[mk_list(OutArgNames)]); + false -> + ic_codegen:emit(Fd,"%% Return value : ~s~n",[mk_list(OutArgNames)]) + end, + ic_codegen:emit(Fd,"%%\n",[]), + + InArgsTypeList = + [{ic_util:mk_var(ic_forms:get_id(InArg#param.id)),ic_forms:get_tk(InArg)} || InArg <- InArgs ], + case InArgsTypeList of + [] -> %% no input parameters + ok; + _ -> + ic_codegen:emit(Fd,"%% --input-params-~n",[]), + type_expand_all(G,N,X,Fd,Tabs,InArgsTypeList) + end, + + ReturnTypeList =[{"Ret",X#op.tk}], + ic_codegen:emit(Fd,"%% --return-value-~n",[]), + type_expand_all(G,N,X,Fd,Tabs,ReturnTypeList), + + OutArgsTypeList = + [{ic_util:mk_var(ic_forms:get_id(OutArg#param.id)),ic_forms:get_tk(OutArg)} || OutArg <- OutArgs ], + case OutArgsTypeList of + [] -> %% no input parameters + ok; + _ -> + ic_codegen:emit(Fd,"%% -output-values-~n",[]), + type_expand_all(G,N,X,Fd,Tabs,OutArgsTypeList) + end. + + + + +type_expand_handle_op(G,N,X,Fd) -> + case catch type_expand_handle_op_exec(G,N,X,Fd) of + {'EXIT',_Reason} -> + ic_codegen:nl(Fd), + ic_codegen:emit(Fd,"%% Error under type expansion, does not affect generated code.~n",[]), + ic_codegen:emit(Fd,"%%------------------------------------------------------------~n",[]); + _ -> + ic_codegen:emit(Fd,"%%------------------------------------------------------------~n",[]) + end. + + +type_expand_handle_op_exec(_G,_N,X,Fd) -> + InArgs = ic:filter_params([in,inout], X#op.params), + ParamNr = length(InArgs)+1, + + ic_codegen:nl(Fd), + ic_codegen:emit(Fd,"%%------------------------------------------------------------~n",[]), + + case ic_forms:is_oneway(X) of + false -> + ic_codegen:emit(Fd,"%% Handle operation: handle_call/3~n",[]); + true -> + ic_codegen:emit(Fd,"%% Handle operation: handle_cast/3~n",[]) + end, + ic_codegen:emit(Fd,"%%~n",[]), + ic_codegen:emit(Fd,"%% Used for operation ~s/~p implementation~n",[ic_forms:get_id2(X),ParamNr]). + + + +type_expand_all(_G,_N,_X,_Fd,_Tabs,[]) -> + ok; +type_expand_all(G,N,X,Fd,Tabs,[{ArgName,Type}|Rest]) -> + type_expand(G,N,X,Fd,Tabs,ArgName,Type), + type_expand_all(G,N,X,Fd,Tabs,Rest); +type_expand_all(G,N,X,Fd,Tabs,[{default,_ArgName,Type}|Rest]) -> + type_expand(G,N,X,Fd,Tabs,"Def",Type), + type_expand_all(G,N,X,Fd,Tabs,Rest); +type_expand_all(G,N,X,Fd,Tabs,[{LabelNr,_ArgName,Type}|Rest]) when is_integer(LabelNr) -> + type_expand(G,N,X,Fd,Tabs,"V" ++ integer_to_list(LabelNr),Type), + type_expand_all(G,N,X,Fd,Tabs,Rest); +type_expand_all(G,N,X,Fd,Tabs,[{Label,_ArgName,Type}|Rest]) -> + type_expand(G,N,X,Fd,Tabs,Label,Type), + type_expand_all(G,N,X,Fd,Tabs,Rest). + + + +type_expand(_G,_N,_X,Fd,Tabs,Name,tk_null) -> + type_expand_null(Fd,Tabs,Name); +type_expand(_G,_N,_X,Fd,Tabs,Name,tk_void) -> + type_expand_void(Fd,Tabs,Name); +type_expand(_G,_N,_X,Fd,Tabs,Name,tk_float) -> + type_expand_float(Fd,Tabs,Name); +type_expand(_G,_N,_X,Fd,Tabs,Name,tk_double) -> + type_expand_double(Fd,Tabs,Name); +type_expand(_G,_N,_X,Fd,Tabs,Name,tk_longdouble) -> + type_expand_longdouble(Fd,Tabs,Name); +type_expand(_G,_N,_X,Fd,Tabs,Name,tk_short) -> + type_expand_short(Fd,Tabs,Name); +type_expand(_G,_N,_X,Fd,Tabs,Name,tk_ushort) -> + type_expand_ushort(Fd,Tabs,Name); +type_expand(_G,_N,_X,Fd,Tabs,Name,tk_long) -> + type_expand_long(Fd,Tabs,Name); +type_expand(_G,_N,_X,Fd,Tabs,Name,tk_longlong) -> + type_expand_longlong(Fd,Tabs,Name); +type_expand(_G,_N,_X,Fd,Tabs,Name,tk_ulong) -> + type_expand_ulong(Fd,Tabs,Name); +type_expand(_G,_N,_X,Fd,Tabs,Name,tk_ulonglong) -> + type_expand_ulonglong(Fd,Tabs,Name); +type_expand(_G,_N,_X,Fd,Tabs,Name,tk_char) -> + type_expand_char(Fd,Tabs,Name); +type_expand(_G,_N,_X,Fd,Tabs,Name,tk_wchar) -> + type_expand_wchar(Fd,Tabs,Name); +type_expand(_G,_N,_X,Fd,Tabs,Name,tk_boolean) -> + type_expand_boolean(Fd,Tabs,Name); +type_expand(_G,_N,_X,Fd,Tabs,Name,tk_octet) -> + type_expand_octet(Fd,Tabs,Name); +type_expand(_G,_N,_X,Fd,Tabs,Name,tk_any) -> + type_expand_any(Fd,Tabs,Name); +type_expand(_G,_N,_X,Fd,Tabs,Name,tk_TypeCode) -> + type_expand_typecode(Fd,Tabs,Name); +type_expand(_G,_N,_X,Fd,Tabs,Name,tk_Principal) -> + type_expand_principal(Fd,Tabs,Name); +type_expand(G, N, X,Fd,Tabs,Name, {tk_except, Id, ExcName, ElementList}) -> + type_expand_exception(G, N, X, Fd,Tabs,Name, + {tk_except, Id, ExcName, ElementList}); +type_expand(_G,_N,_X,Fd,Tabs,Name,{tk_fixed, _Digits, _Scale}) -> + type_expand_fixed(Fd,Tabs,Name); +type_expand(_G,_N,_X,Fd,Tabs,Name,{tk_objref, _IFRId, _ObjTabs, _ObjName}) -> + type_expand_object(Fd,Tabs,Name); +type_expand(_G,_N,_X,Fd,Tabs,Name,{tk_objref, _IFRId, _ObjName}) -> + type_expand_object(Fd,Tabs,Name); +type_expand(_G,_N,_X,Fd,Tabs,Name,{tk_string, _Length}) -> + type_expand_string(Fd,Tabs,Name); +type_expand(_G,_N,_X,Fd,Tabs,Name,{tk_wstring, _Length}) -> + type_expand_wstring(Fd,Tabs,Name); +type_expand(G,N,X,Fd,Tabs,Name,{tk_union, IFRId, UnionName, DTC, DNr, LblList}) -> + type_expand_union(G,N,X,Fd,Tabs,Name,{tk_union, IFRId, UnionName, DTC, DNr, LblList}); +type_expand(_G,_N,_X,Fd,Tabs,Name,{tk_enum, IFRId, EnumName, ElemNameList}) -> + type_expand_enum(Fd,Tabs,Name,{tk_enum, IFRId, EnumName, ElemNameList}); +type_expand(G,N,X,Fd,Tabs,Name,{tk_sequence, ElemTC, Length}) -> + type_expand_sequence(G,N,X,Fd,Tabs,Name,{tk_sequence, ElemTC, Length}); +type_expand(G,N,X,Fd,Tabs,Name,{tk_array, ElemTC, Length}) -> + type_expand_array(G,N,X,Fd,Tabs,Name,{tk_array, ElemTC, Length}); +type_expand(G,N,X,Fd,Tabs,Name,{tk_struct, IFRId, StructName, TcList}) -> + type_expand_struct(G,N,X,Fd,Tabs,Name,{tk_struct, IFRId, StructName, TcList}); +type_expand(_G,_N,_X,Fd,Tabs,Name,_) -> + type_expand_error(Fd,Tabs,Name). + + +%% Basic OMG IDL types + +type_expand_null(Fd,Tabs,Name) -> + ic_codegen:emit(Fd,"%%~s ~s = null()~n",[Tabs,Name]). + +type_expand_void(Fd,Tabs,Name) -> + ic_codegen:emit(Fd,"%%~s ~s = void()~n",[Tabs,Name]). + +type_expand_float(Fd,Tabs,Name) -> + ic_codegen:emit(Fd,"%%~s ~s = float()~n",[Tabs,Name]). + +type_expand_double(Fd,Tabs,Name) -> + ic_codegen:emit(Fd,"%%~s ~s = double()~n",[Tabs,Name]). + +type_expand_longdouble(Fd,Tabs,Name) -> + ic_codegen:emit(Fd,"%%~s ~s = long_double()~n",[Tabs,Name]). + +type_expand_short(Fd,Tabs,Name) -> + ic_codegen:emit(Fd,"%%~s ~s = short()~n",[Tabs,Name]). + +type_expand_ushort(Fd,Tabs,Name) -> + ic_codegen:emit(Fd,"%%~s ~s = unsigned_Short()~n",[Tabs,Name]). + +type_expand_long(Fd,Tabs,Name) -> + ic_codegen:emit(Fd,"%%~s ~s = long()~n",[Tabs,Name]). + +type_expand_longlong(Fd,Tabs,Name) -> + ic_codegen:emit(Fd,"%%~s ~s = long_Long()~n",[Tabs,Name]). + +type_expand_ulong(Fd,Tabs,Name) -> + ic_codegen:emit(Fd,"%%~s ~s = unsigned_Long()~n",[Tabs,Name]). + +type_expand_ulonglong(Fd,Tabs,Name) -> + ic_codegen:emit(Fd,"%%~s ~s = unsigned_Long_Long()~n",[Tabs,Name]). + +type_expand_char(Fd,Tabs,Name) -> + ic_codegen:emit(Fd,"%%~s ~s = char()~n",[Tabs,Name]). + +type_expand_wchar(Fd,Tabs,Name) -> + ic_codegen:emit(Fd,"%%~s ~s = wchar()~n",[Tabs,Name]). + +type_expand_boolean(Fd,Tabs,Name) -> + ic_codegen:emit(Fd,"%%~s ~s = boolean()~n",[Tabs,Name]). + +type_expand_octet(Fd,Tabs,Name) -> + ic_codegen:emit(Fd,"%%~s ~s = octet()~n",[Tabs,Name]). + +type_expand_any(Fd,Tabs,Name) -> + ic_codegen:emit(Fd,"%%~s ~s = any()~n",[Tabs,Name]). + +type_expand_typecode(Fd,Tabs,Name) -> + ic_codegen:emit(Fd,"%%~s ~s = TypeCode()~n",[Tabs,Name]). + +type_expand_principal(Fd,Tabs,Name) -> + ic_codegen:emit(Fd,"%%~s ~s = principal()~n",[Tabs,Name]). + + +type_expand_fixed(Fd,Tabs,Name) -> + ic_codegen:emit(Fd,"%%~s ~s = fixed()~n",[Tabs,Name]). + +type_expand_object(Fd,Tabs,Name) -> + ic_codegen:emit(Fd,"%%~s ~s = Object_Ref()~n",[Tabs,Name]). + + +%% Constructed OMG IDL types + +type_expand_string(Fd,Tabs,Name) -> + ic_codegen:emit(Fd,"%%~s ~s = String()~n",[Tabs,Name]). + +type_expand_wstring(Fd,Tabs,Name) -> + ic_codegen:emit(Fd,"%%~s ~s = WString()~n",[Tabs,Name]). + +type_expand_exception(G, N, X, Fd, Tabs, Name, {tk_except, Id, ExcName, ElementList}) -> + ScopedStructName = getScopedName(G, N, ExcName, Id), + ic_codegen:emit(Fd,"%%~s ~s = ",[Tabs, Name]), + type_expand_exception_rule(Fd, ScopedStructName, ElementList), + type_expand_all(G, N, X, Fd, Tabs, ElementList). + +type_expand_struct(G,N,X,Fd,Tabs,Name,{tk_struct, IFRId, StructName, TcList}) -> + ScopedStructName = getScopedName(G,N,StructName,IFRId), + ic_codegen:emit(Fd,"%%~s ~s = ",[Tabs,Name]), + type_expand_struct_rule(Fd,ScopedStructName,TcList), + type_expand_all(G,N,X,Fd,Tabs,TcList). + +type_expand_union(G,N,X,Fd,Tabs,Name,{tk_union, IFRId, UnionName, DTC, _DNr, LblList}) -> + ScopedUnionName = getScopedName(G,N,UnionName,IFRId), + ic_codegen:emit(Fd,"%%~s ~s = #'~s'{label, value}\n",[Tabs,Name,ScopedUnionName]), + type_expand(G,N,X,Fd,Tabs,"label",DTC), + ic_codegen:emit(Fd,"%%~s value = ",[Tabs]), + type_expand_union_rule(Fd,LblList), + type_expand_all(G,N,X,Fd,Tabs,LblList). + +type_expand_enum(Fd,Tabs,Name,{tk_enum, _IFRId, EnumName, ElemNameList}) -> + ic_codegen:emit(Fd,"%%~s ~s = ~s~n",[Tabs,Name,EnumName]), + type_expand_enum_rule(Fd,Tabs,EnumName,ElemNameList). + +type_expand_sequence(G,N,X,Fd,Tabs,Name,{tk_sequence, ElemTC, _Length}) -> + ic_codegen:emit(Fd,"%%~s ~s = [ ~sElem ]~n",[Tabs,Name,Name]), + type_expand(G,N,X,Fd,Tabs,Name++"Elem",ElemTC). + +type_expand_array(G,N,X,Fd,Tabs,Name,{tk_array, ElemTC, _Length}) -> + ic_codegen:emit(Fd,"%%~s ~s = { ~sElem[,..~sElem] }~n",[Tabs,Name,Name,Name]), + type_expand(G,N,X,Fd,Tabs,Name++"Elem",ElemTC). + +type_expand_error(Fd,Tabs,Name) -> + ic_codegen:emit(Fd,"%%~s ~s = ????~n",[Tabs,Name]). + + +type_expand_exception_rule(Fd,_Name,[]) -> + ic_codegen:emit(Fd," ???? "); +type_expand_exception_rule(Fd,Name,TcList) -> + ic_codegen:emit(Fd,"#'~s'{",[Name]), + type_expand_exception_rule(Fd,TcList). + +type_expand_exception_rule(Fd,[{Name,_TC}]) -> + ic_codegen:emit(Fd,"~s}~n",[Name]); +type_expand_exception_rule(Fd,[{Name,_TC}|Rest]) -> + ic_codegen:emit(Fd,"~s,",[Name]), + type_expand_exception_rule(Fd,Rest). + +type_expand_struct_rule(Fd,_Name,[]) -> + ic_codegen:emit(Fd," ???? "); +type_expand_struct_rule(Fd,Name,TcList) -> + ic_codegen:emit(Fd,"#'~s'{",[Name]), + type_expand_struct_rule(Fd,TcList). + +type_expand_struct_rule(Fd,[{Name,_TC}]) -> + ic_codegen:emit(Fd,"~s}~n",[Name]); +type_expand_struct_rule(Fd,[{Name,_TC}|Rest]) -> + ic_codegen:emit(Fd,"~s,",[Name]), + type_expand_struct_rule(Fd,Rest). + + +type_expand_union_rule(Fd,[]) -> + ic_codegen:emit(Fd," ????"); +type_expand_union_rule(Fd,[{default,_Name,_TC}]) -> + ic_codegen:emit(Fd,"Def~n",[]); +type_expand_union_rule(Fd,[{LNr,_Name,_TC}]) when is_integer(LNr)-> + ic_codegen:emit(Fd,"V~p~n",[LNr]); +type_expand_union_rule(Fd,[{Label,_Name,_TC}]) -> + ic_codegen:emit(Fd,"~s~n",[Label]); +type_expand_union_rule(Fd,[{default,_Name,_TC}|Rest]) -> + ic_codegen:emit(Fd,"Default | "), + type_expand_union_rule(Fd,Rest); +type_expand_union_rule(Fd,[{LNr,_Name,_TC}|Rest]) when is_integer(LNr) -> + ic_codegen:emit(Fd,"V~p | ",[LNr]), + type_expand_union_rule(Fd,Rest); +type_expand_union_rule(Fd,[{Label,_Name,_TC}|Rest]) -> + ic_codegen:emit(Fd,"~s | ",[Label]), + type_expand_union_rule(Fd,Rest). + + +type_expand_enum_rule(Fd,Tabs,Name,[]) -> + ic_codegen:emit(Fd,"%%~s ~s = ????",[Tabs,Name]); +type_expand_enum_rule(Fd,Tabs,Name,ElList) -> + ic_codegen:emit(Fd,"%%~s ~s = ",[Tabs,Name]), + type_expand_enum_rule(Fd,ElList). + +type_expand_enum_rule(Fd,[ElName]) -> + ic_codegen:emit(Fd,"'~s' ~n",[ElName]); +type_expand_enum_rule(Fd,[First|Rest]) -> + ic_codegen:emit(Fd,"'~s' | ",[First]), + type_expand_enum_rule(Fd,Rest). + +type_expand_enum_elements(_Fd,_Tabs,[]) -> + ok; +type_expand_enum_elements(Fd,Tabs,[Elem|Elems]) -> + ic_codegen:emit(Fd,"%%~s ~s = Atom()~n",[Tabs,Elem]), + type_expand_enum_elements(Fd,Tabs,Elems). + + + +%% Returns the right scoped name to be used +%% along with the expansion comments +getScopedName(G,N,Name,IfrId) -> + PTab = ic_genobj:pragmatab(G), + case ets:match(PTab,{alias,'$0',IfrId}) of + [] -> %% No Alias - should never happen + ic_util:to_undersc(ic_pragma:mk_scope(IfrId)); + [[[_S|N]]] -> %% An alias + ic_util:to_undersc([Name|N]); + [[[S|FoundScope]]] -> %% Maybe inherited + case ic_pragma:is_inherited_by(FoundScope,N,PTab) of + false -> %% Not inherited + ic_util:to_undersc([S|FoundScope]); + true -> %% inherited + ic_util:to_undersc([Name|N]) + end + end. + + +%% mk_list produces a nice comma separated +%% string of variable names +mk_list([]) -> []; +mk_list([Arg | Args]) -> + Arg ++ mk_list2(Args). +mk_list2([Arg | Args]) -> + ", " ++ Arg ++ mk_list2(Args); +mk_list2([]) -> []. + + + +%%----------------------------------------------------------------- +%% Internal functions +%%----------------------------------------------------------------- + + + diff --git a/lib/ic/src/ic_codegen.erl b/lib/ic/src/ic_codegen.erl new file mode 100644 index 0000000000..f611c69bea --- /dev/null +++ b/lib/ic/src/ic_codegen.erl @@ -0,0 +1,419 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1998-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_codegen). + +-include_lib("ic/src/ic.hrl"). +-include_lib("ic/src/icforms.hrl"). + +%%----------------------------------------------------------------- +%% External exports +%%----------------------------------------------------------------- +-export([emit/2, emit/3]). +-export([emit_c_enc_rpt/4, emit_c_dec_rpt/4]). +-export([comment/2, comment/3, comment/4, comment_inlined/5, comment_prefixed/4]). +-export([mcomment/2, mcomment/3, mcomment_inlined/5, mcomment_prefixed/3]). +-export([mcomment_light/2, mcomment_light/3, mcomment_light_inlined/5, mcomment_light_prefixed/3]). +-export([nl/1, export/2]). +-export([record/5]). +-export([emit_stub_head/4, emit_hrl_head/4, emit_hrl_foot/2]). +%%----------------------------------------------------------------- +%% Internal exports +%%----------------------------------------------------------------- + +%%----------------------------------------------------------------- +%% External functions +%%----------------------------------------------------------------- + +%%-------------------------------------------------------------------- +%% Emit output as a formatted string, (old emit) +%%-------------------------------------------------------------------- +emit(nil, _) -> ok; +emit(Fd, Str) -> + file:write(Fd, Str). + +emit(nil, _, _) -> ok; +emit(Fd, Fmt, Args) -> + file:write(Fd, io_lib:format(Fmt, Args)). + +emit_c_enc_rpt(Fd, Prefix, Fmt, Args) -> + emit(Fd, Prefix ++ "OE_RPT_ERR(\"Encode error: " ++ Fmt ++ "\");\n", Args). + +emit_c_dec_rpt(Fd, Prefix, Fmt, Args) -> + emit(Fd, Prefix ++ "OE_RPT_ERR(\"Decode error: " ++ Fmt ++ "\");\n", Args). + +%%-------------------------------------------------------------------- +%% Emit comments +%%-------------------------------------------------------------------- +comment(Fd, C) -> + comment_prefixed(Fd, C, [], "%%"). + +comment(Fd, C, A) -> + comment_prefixed(Fd, C, A, "%%"). + +comment(Fd, C, A, c) -> + comment_inlined(Fd, C, A, "/*", "*/"); +comment(Fd, C, A, erl) -> + comment_prefixed(Fd, C, A, "%%"); +comment(Fd, C, A, java) -> + comment_prefixed(Fd, C, A, "//"); +%% Should be removed after a check if it's used !!!!! (LTH) +comment(Fd, C, A, CommentSequence) when is_list(CommentSequence) -> + comment_prefixed(Fd, C, A, CommentSequence). + +comment_inlined(Fd, C, A, Start, End) -> + emit(Fd, Start ++ " " ++ C ++ " " ++ End ++"\n", A). + +comment_prefixed(Fd, C, A, Prefix) -> + emit(Fd, Prefix ++ " " ++ C ++ "\n", A). + +%%-------------------------------------------------------------------- +%% Emit multiline comments with nice delimiters +%%-------------------------------------------------------------------- +mcomment(Fd, List) -> + mcomment_prefixed(Fd, List, "%%"). + +mcomment(Fd, List, c) -> + mcomment_inlined(Fd, List, "/*", "*/", " *"); +mcomment(Fd, List, erl) -> + mcomment_prefixed(Fd, List, "%%"); +mcomment(Fd, List, java) -> + mcomment_prefixed(Fd, List, "//"). + +mcomment_inlined(Fd, List, Start, End, Intermediate) -> + emit(Fd, Start ++ + "------------------------------------------------------------\n"), + emit(Fd, Intermediate ++ "\n"), + lists:foreach(fun(C) -> comment(Fd, C, [], Intermediate) end, List), + emit(Fd, Intermediate ++ "\n"), + emit(Fd, Intermediate ++ + "------------------------------------------------------------" ++ End ++ "\n"), + ok. +mcomment_prefixed(Fd, List, Prefix) -> + emit(Fd, Prefix ++ + "------------------------------------------------------------\n"), + emit(Fd, Prefix ++ "\n"), + lists:foreach(fun(C) -> comment(Fd, C, [], Prefix) end, List), + emit(Fd, Prefix ++ "\n"), + emit(Fd, Prefix ++ + "------------------------------------------------------------\n"), + ok. + + +%%-------------------------------------------------------------------- +%% Emit multiline comments with nice delimiters as above but a +%% little lighter +%%-------------------------------------------------------------------- +mcomment_light(Fd, List) -> + mcomment_light_prefixed(Fd, List, "%%"). + +mcomment_light(Fd, List, c) -> + mcomment_light_inlined(Fd, List, "/*", " */", " *"); +mcomment_light(Fd, List, erl) -> + mcomment_light_prefixed(Fd, List, "%%"); +mcomment_light(Fd, List, java) -> + mcomment_light_prefixed(Fd, List, "//"); +%% Should be removed after a check if it's used !!!!! (LTH) +mcomment_light(Fd, List, Prefix) when is_list(Prefix) -> + mcomment_light_prefixed(Fd, List, Prefix). + +mcomment_light_inlined(Fd, List, Start, End, Intermediate) -> + emit(Fd, "\n" ++ Start ++ "\n"), + lists:foreach(fun(C) -> comment(Fd, C, [], Intermediate) end, List), + emit(Fd, End ++ "\n"), + ok. + +mcomment_light_prefixed(Fd, List, Prefix) -> + emit(Fd, Prefix), + lists:foreach(fun(C) -> comment(Fd, C, [], Prefix) end, List), + emit(Fd, Prefix ++ "\n"), + ok. + +%%-------------------------------------------------------------------- +%% New line +%%-------------------------------------------------------------------- +nl(Fd) -> + emit(Fd, "\n"). + + +%%-------------------------------------------------------------------- +-define(IFRIDFIELD(G), ic_util:mk_name(G, "ID")). + +%%-------------------------------------------------------------------- +%% Emit record definitions for erlang +%%-------------------------------------------------------------------- +record(G, X, Name, _IFRID, Recs) when is_record(X, struct) -> + F = ic_genobj:hrlfiled(G), + emit(F, "-record(~p, {~p", [ic_util:to_atom(Name),hd(Recs)]), + lists:foreach(fun(Y) -> emit(F, ", ~p", [Y]) end, tl(Recs)), + emit(F, "}).\n"); +record(G, X, Name, _IFRID, _Recs) when is_record(X, union) -> + F = ic_genobj:hrlfiled(G), + emit(F, "-record(~p, {label, value}).\n",[ic_util:to_atom(Name)]); +record(G, _X, Name, IFRID, Recs) when length(Recs) > 3 -> + F = ic_genobj:hrlfiled(G), + emit(F, "-record(~p,~n {~p=~p", + [ic_util:to_atom(Name), ic_util:to_atom(?IFRIDFIELD(G)), IFRID]), + rec2(F, "", ", ", Recs), + emit(F, "}).\n"); +record(G, _X, Name, IFRID, Recs) -> + F = ic_genobj:hrlfiled(G), + emit(F, "-record(~p, {~p=~p", [ic_util:to_atom(Name), + ic_util:to_atom(?IFRIDFIELD(G)), + IFRID]), + lists:foreach(fun(Y) -> emit(F, ", ~p", [Y]) end, Recs), + emit(F, "}).\n"). + + +rec2(F, Align, Delim, [M1 , M2, M3 | Ms]) -> + emit(F, "~s~s~p, ~p, ~p", [Delim, Align, M1, M2, M3]), + rec2(F, " ", ",\n", Ms); +rec2(F, Align, Delim, [M1 , M2]) -> + emit(F, "~s~s~p, ~p", [Delim, Align, M1, M2]); +rec2(F, Align, Delim, [M]) -> + emit(F, "~s~s~p", [Delim, Align, M]); +rec2(_F, _Align, _Delim, []) -> + ok. + + +%%-------------------------------------------------------------------- +%% Emit export lists for erlang +%%-------------------------------------------------------------------- +export(F, [E1, E2, E3 | Exports]) -> + emit(F, "-export([~s]).\n", [exp_list([E1, E2, E3])]), + export(F, Exports); +export(_F, []) -> ok; +export(F, Exports) -> + emit(F, "-export([~s]).\n", [exp_list(Exports)]). + +exp_list([E1 | L]) -> + exp_to_string(E1) ++ + lists:map(fun(E) -> ", " ++ exp_to_string(E) end, L). + + +exp_to_string({F,N}) -> io_lib:format("~p/~p", [ic_util:to_atom(F), N]). + + +%%-------------------------------------------------------------------- +%% Emit Stub file header +%%-------------------------------------------------------------------- +emit_stub_head(_G, ignore, _Name, _) -> ignore; +emit_stub_head(G, F1, Name, erlang) -> + mcomment(F1, stub_header(G, Name)), + nl(F1), + emit(F1, "-module(~p).\n", [list_to_atom(Name)]), + emit(F1, "-ic_compiled(~p).\n", [compiler_vsn(?COMPILERVSN)]), + emit(F1, "\n\n"), F1; +emit_stub_head(G, F1, Name, erlang_template) -> + ic_erl_template:emit_header(G, F1, Name), + F1; +emit_stub_head(_G, F1, _Name, erlang_template_no_gen) -> + F1; +emit_stub_head(G, F1, Name, c) -> + mcomment(F1, stub_header(G, Name), c), + emit(F1, "int ic_compiled_~s_~s;\n", [compiler_vsn(?COMPILERVSN), Name]), + emit(F1, "\n\n"), F1; +emit_stub_head(G, F1, Name, c_server) -> + CSName = [Name, "__s"], + mcomment(F1, stub_header(G, CSName), c), + emit(F1, "int ic_compiled_~s_~s;\n", [compiler_vsn(?COMPILERVSN), CSName]), + emit(F1, "\n\n"), F1; +emit_stub_head(G, F1, Name, java) -> + mcomment(F1, stub_header(G, Name), java), + emit(F1, "\n\n"), F1. + +stub_header(G, Name) -> + ["Implementation stub file", + "", + io_lib:format("Target: ~s", [Name]), + io_lib:format("Source: ~s", [ic_genobj:idlfile(G)]), + io_lib:format("IC vsn: ~s", [?COMPILERVSN]), + "", + "This file is automatically generated. DO NOT EDIT IT."]. + +compiler_vsn(Vsn) -> + lists:map(fun($.) -> $_; + (C) -> C + end, Vsn). + +%%-------------------------------------------------------------------- +%% Emit include file header +%%-------------------------------------------------------------------- +%% Name is Fully scoped (undescore) name of interface or module +emit_hrl_head(_G, ignore, _Name, _) -> ignore; +emit_hrl_head(G, Fd, Name, erlang) -> + mcomment(Fd, ["Erlang header file" | + hrl_header(G, Name)]), + nl(Fd), + nl(Fd), + IfdefName = ic_util:to_uppercase(Name++"_HRL"), + emit(Fd, "-ifndef(~s).~n", [IfdefName]), + emit(Fd, "-define(~s, true).~n", [IfdefName]), + nl(Fd), + nl(Fd), + Fd; +emit_hrl_head(G, Fd, Name, c) -> + mcomment(Fd, ["C header file" | + hrl_header(G, Name)], c), + nl(Fd), + nl(Fd), + IfdefName = ic_util:to_uppercase(Name++"_H"), + emit(Fd, "#ifndef ~s~n", [IfdefName]), + emit(Fd, "#define ~s ~n", [IfdefName]), + nl(Fd), + nl(Fd), + Fd; +emit_hrl_head(G, Fd, Name, c_server) -> + mcomment(Fd, ["C header file" | + hrl_header(G, [Name, "__s"])], c), + nl(Fd), + nl(Fd), + IfdefName = ic_util:to_uppercase(Name++"__S_H"), + emit(Fd, "#ifndef ~s~n", [IfdefName]), + emit(Fd, "#define ~s ~n", [IfdefName]), + nl(Fd), + nl(Fd), + Fd. + +hrl_header(G, Name) -> + ["", + io_lib:format("Target: ~s", [Name]), + io_lib:format("Source: ~s", [ic_genobj:idlfile(G)]), + io_lib:format("IC vsn: ~s", [?COMPILERVSN]), + "", + "This file is automatically generated. DO NOT EDIT IT."]. + + + + +%%-------------------------------------------------------------------- +%% Emit include file footer +%%-------------------------------------------------------------------- +emit_hrl_foot(_G, erlang_template) -> + ok; +emit_hrl_foot(_G, erlang_template_no_gen) -> + ok; +emit_hrl_foot(G, erlang) -> + case ic_genobj:is_hrlfile_open(G) of + true -> + Fd = ic_genobj:hrlfiled(G), + nl(Fd), + nl(Fd), + emit(Fd, "-endif.\n"), + nl(Fd), + nl(Fd), + Fd; + false -> + ok + end; +emit_hrl_foot(G, erlang_no_stub) -> + case ic_genobj:is_hrlfile_open(G) of + true -> + Fd = ic_genobj:hrlfiled(G), + nl(Fd), + nl(Fd), + emit(Fd, "-endif.\n"), + nl(Fd), + nl(Fd), + Fd; + false -> + ok + end; +emit_hrl_foot(G, c) -> + case ic_genobj:is_hrlfile_open(G) of + true -> + Fd = ic_genobj:hrlfiled(G), + nl(Fd), + nl(Fd), + emit(Fd, "#ifdef __cplusplus\n"), + emit(Fd, "}\n"), + emit(Fd, "#endif\n"), + nl(Fd), + emit(Fd, "#endif\n"), + nl(Fd), + nl(Fd), + Fd; + false -> + ok + end; +emit_hrl_foot(G, c_server) -> + case ic_genobj:is_hrlfile_open(G) of + true -> + Fd = ic_genobj:hrlfiled(G), + nl(Fd), + nl(Fd), + emit(Fd, "#ifdef __cplusplus\n"), + emit(Fd, "}\n"), + emit(Fd, "#endif\n"), + nl(Fd), + emit(Fd, "#endif\n"), + nl(Fd), + nl(Fd), + Fd; + false -> + ok + end; +emit_hrl_foot(G, c_no_stub) -> + case ic_genobj:is_hrlfile_open(G) of + true -> + Fd = ic_genobj:hrlfiled(G), + nl(Fd), + nl(Fd), + emit(Fd, "#ifdef __cplusplus\n"), + emit(Fd, "}\n"), + emit(Fd, "#endif\n"), + nl(Fd), + emit(Fd, "#endif\n"), + nl(Fd), + nl(Fd), + Fd; + false -> + ok + end; +emit_hrl_foot(G, c_server_no_stub) -> + case ic_genobj:is_hrlfile_open(G) of + true -> + Fd = ic_genobj:hrlfiled(G), + nl(Fd), + nl(Fd), + emit(Fd, "#ifdef __cplusplus\n"), + emit(Fd, "}\n"), + emit(Fd, "#endif\n"), + nl(Fd), + emit(Fd, "#endif\n"), + nl(Fd), + nl(Fd), + Fd; + false -> + ok + end. + + + + + + + + + + +%%----------------------------------------------------------------- +%% Internal functions +%%----------------------------------------------------------------- diff --git a/lib/ic/src/ic_constant_java.erl b/lib/ic/src/ic_constant_java.erl new file mode 100644 index 0000000000..0a3172363f --- /dev/null +++ b/lib/ic/src/ic_constant_java.erl @@ -0,0 +1,99 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1999-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_constant_java). + + +-include("icforms.hrl"). +-include("ic.hrl"). +-include("ic_debug.hrl"). +%%----------------------------------------------------------------- +%% External exports +%%----------------------------------------------------------------- +-export([gen/3]). + +%%----------------------------------------------------------------- +%% Internal exports +%%----------------------------------------------------------------- +-export([]). + +%%----------------------------------------------------------------- +%% External functions +%%----------------------------------------------------------------- + +%%----------------------------------------------------------------- +%% Func: gen/3 +%%----------------------------------------------------------------- +gen(G, N, X) when is_record(X, const) -> + ConstantName = ic_forms:get_java_id(X), + case inInterface(G, N) of + true -> + emit_constant(G, N, X, ConstantName); + false -> + emit_constant_interface(G, N, X, ConstantName) + end; +gen(_G, _N, _X) -> + ok. + + +%%----------------------------------------------------------------- +%% Internal functions +%%----------------------------------------------------------------- + +%%----------------------------------------------------------------- +%% Func: emit_constant/4 +%%----------------------------------------------------------------- +emit_constant(G, N, X, ConstantName) -> + Fd = ic_genobj:interfacefiled(G), + %%?PRINTDEBUG2("~p", [Fd]), + Type = ic_java_type:getType(G, N, ic_forms:get_type(X)), + ic_codegen:emit(Fd, " public static final ~s ~s = (~s) ~p;\n", + [Type, ConstantName, Type, X#const.val]), + ic_codegen:nl(Fd). + +%%----------------------------------------------------------------- +%% Func: emit_constant_interface/4 +%%----------------------------------------------------------------- +emit_constant_interface(G, N, X, ConstantName) -> + {Fd, _} = ic_file:open_java_file(G, N, ConstantName), + + ic_codegen:emit(Fd, "final public class ~s {\n",[ConstantName]), + + Type = ic_java_type:getType(G, N, ic_forms:get_type(X)), + ic_codegen:emit(Fd, " public static final ~s value = (~s) ~p;\n", + [Type, Type, X#const.val]), + ic_codegen:emit(Fd, "}\n", []), + file:close(Fd). + +%%----------------------------------------------------------------- +%% Func: emit_constant_interface/4 +%%----------------------------------------------------------------- +inInterface(_G, []) -> % Global constant + false; +inInterface(G, N) -> + [N1 |Ns] = N, + {_FullScopedName, T, _TK, _} = + ic_symtab:get_full_scoped_name(G, Ns, ic_symtab:scoped_id_new(N1)), + case T of + interface -> % Constant declare in an interface + true; + _ -> % Constant declared in a module + false + end. + diff --git a/lib/ic/src/ic_cserver.erl b/lib/ic/src/ic_cserver.erl new file mode 100644 index 0000000000..52d98c5795 --- /dev/null +++ b/lib/ic/src/ic_cserver.erl @@ -0,0 +1,2419 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1998-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_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 \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 \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 \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 \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(_, [], []) -> + []. + + diff --git a/lib/ic/src/ic_debug.hrl b/lib/ic/src/ic_debug.hrl new file mode 100644 index 0000000000..c0490b4c13 --- /dev/null +++ b/lib/ic/src/ic_debug.hrl @@ -0,0 +1,37 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1999-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% +%% +%% + +%%---------------------------------------------------------------------- +%% Debug macro +%%---------------------------------------------------------------------- +-ifndef(ic_debug_hrl). +-define(ic_debug_hrl, true). + +-ifdef(debug). + -define(PRINTDEBUG(Msg), + io:format("~p :~p ~p~n", [Msg, ?FILE, ?LINE])). + -define(PRINTDEBUG2(F, A), + io:format(F ++ ":~p ~p~n", A ++ [?FILE, ?LINE])). +-else. + -define(PRINTDEBUG(Msg), ok). + -define(PRINTDEBUG2(F, A), ok). +-endif. + +-endif. diff --git a/lib/ic/src/ic_enum_java.erl b/lib/ic/src/ic_enum_java.erl new file mode 100644 index 0000000000..5978c3468e --- /dev/null +++ b/lib/ic/src/ic_enum_java.erl @@ -0,0 +1,312 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1999-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_enum_java). + +-include("icforms.hrl"). +-include("ic.hrl"). +-include("ic_debug.hrl"). +%%----------------------------------------------------------------- +%% External exports +%%----------------------------------------------------------------- +-export([gen/3]). + +%%----------------------------------------------------------------- +%% Internal exports +%%----------------------------------------------------------------- +-export([]). + +%%----------------------------------------------------------------- +%% External functions +%%----------------------------------------------------------------- + +%%----------------------------------------------------------------- +%% Func: gen/3 +%%----------------------------------------------------------------- +gen(G, N, X) when is_record(X, enum) -> + %%?PRINTDEBUG2("enum: ~p", [X]), + EnumName = ic_forms:get_java_id(X), + N2 = ["_" ++ EnumName |N], + ic_jbe:gen(G, N2, ic_forms:get_body(X)), + + emit_enum_class(G, N, X, EnumName), + emit_holder_class(G, N, X, EnumName), + emit_helper_class(G, N, X, EnumName); +gen(_G, _N, _X) -> + ok. + + +%%----------------------------------------------------------------- +%% Internal functions +%%----------------------------------------------------------------- + +%%----------------------------------------------------------------- +%% Func: emit_enum_class/4 +%%----------------------------------------------------------------- +emit_enum_class(G, N, X, EnumName) -> + {Fd, _} = ic_file:open_java_file(G, N, EnumName), + + EList = enum_member_name_list(G, N, X), + %%?PRINTDEBUG2("EList: ~p", [EList]), + ic_codegen:emit(Fd, ["final public class ",EnumName," {\n\n" + + " // instance variables\n"]), + + emit_enum_member_int_values_initialization(G, N, X, Fd, EList), + emit_enum_public_instance_variables(G, N, X, Fd, EnumName, EList), + + ic_codegen:emit(Fd, [" private int _value;\n\n" + + " // constructors\n" + " private ",EnumName,"(int __value) {\n" + " _value = __value;\n" + " }\n\n" + + " // methods\n" + " public int value() {\n" + " return _value;\n" + " }\n"]), + + emit_enum_from_int_function(G, N, X, Fd, EnumName, EList), + + ic_codegen:emit(Fd, "\n}\n"), + file:close(Fd). + +%%----------------------------------------------------------------- +%% Func: emit_holder_class/4 +%%----------------------------------------------------------------- +emit_holder_class(G, N, _X, EnumName) -> + EName = string:concat(EnumName, "Holder"), + {Fd, _} = ic_file:open_java_file(G, N, EName), + + ic_codegen:emit(Fd, ["final public class ",EnumName,"Holder {\n\n" + + " // instance variables\n" + " public ",EnumName," value;\n\n" + + " // constructors\n" + " public ",EnumName,"Holder() {}\n\n" + + " public ",EnumName,"Holder(",EnumName," initial) {\n" + " value = initial;\n" + " }\n\n" + + " // methods\n" + " public void _marshal(",?ERLANGPACKAGE,"OtpOutputStream out) throws java.lang.Exception {\n" + " ",EnumName,"Helper.marshal(out, value);\n" + " }\n\n" + + " public void _unmarshal(",?ERLANGPACKAGE,"OtpInputStream in) throws java.lang.Exception {\n" + " value = ",EnumName,"Helper.unmarshal(in);\n" + " }\n\n" + "}\n"]), + file:close(Fd). + + +%%----------------------------------------------------------------- +%% Func: emit_helper_class/4 +%%----------------------------------------------------------------- +emit_helper_class(G, N, X, EnumName) -> + EName = string:concat(EnumName, "Helper"), + WEList = enum_member_atom_list(G, N, X), + {Fd, _} = ic_file:open_java_file(G, N, EName), + + ic_codegen:emit(Fd, ["public class ",EnumName,"Helper {\n\n" + + " // constructors\n" + " private ",EnumName,"Helper() {}\n\n" + + " // methods\n" + + " public static void marshal(",?ERLANGPACKAGE,"OtpOutputStream _out, ",EnumName," _value)\n" + " throws java.lang.Exception {\n\n"]), + + emit_enum_write_function(G, N, X, Fd, EnumName), + + ic_codegen:emit(Fd, [" }\n\n" + + " public static ",EnumName," unmarshal(",?ERLANGPACKAGE,"OtpInputStream _in)\n" + " throws java.lang.Exception {\n\n"]), + + emit_enum_read_function(G, N, X, Fd, EnumName), + + ic_codegen:emit(Fd, "\n }\n\n"), + + emit_enum_private_member_variables(Fd, WEList), + + ic_codegen:emit(Fd, ["\n // Get integer value of enum from string\n" + " private static int _getIntFromName(String name) throws java.lang.Exception {\n" + " for(int i = 0; i < _memberCount; i++) {\n" + " if (name.equals(_members[i]))\n" + " return i;\n" + " }\n" + " throw new java.lang.Exception(\"\");\n" + " }\n\n" + + " public static String id() {\n" + " return \"",ictk:get_IR_ID(G, N, X),"\";\n" + " }\n\n" + + " public static String name() {\n" + " return \"",EnumName,"\";\n" + " }\n\n"]), + + ic_jbe:emit_type_function(G, N, X, Fd), + + ic_codegen:emit(Fd, [" public static void insert(",?ICPACKAGE,"Any _any, ",EnumName," _this)\n" + " throws java.lang.Exception {\n\n" + + " ",?ERLANGPACKAGE,"OtpOutputStream _os = \n" + " new ",?ERLANGPACKAGE,"OtpOutputStream();\n\n" + + " _any.type(type());\n" + " marshal(_os, _this);\n" + " _any.insert_Streamable(_os);\n" + " }\n\n" + + " public static ",EnumName," extract(",?ICPACKAGE,"Any _any)\n" + " throws java.lang.Exception {\n\n" + + " return unmarshal(_any.extract_Streamable());\n" + " }\n\n" + + "}\n"]), + file:close(Fd). + +%%----------------------------------------------------------------- +%% Func: emit_enum_public_instance_variables/6 +%%----------------------------------------------------------------- +emit_enum_public_instance_variables(_G, _N, _X, _Fd, _EnumName, []) -> + ok; +emit_enum_public_instance_variables(G, N, X, Fd, EnumName, [Enumerator |EList]) -> + ic_codegen:emit(Fd, [" public static final ",EnumName," ",Enumerator," = new ",EnumName,"(_",Enumerator,");\n"]), + emit_enum_public_instance_variables(G, N, X, Fd, EnumName, EList). + +%%----------------------------------------------------------------- +%% Func: emit_enum_member_int_values_initialization/5 +%%----------------------------------------------------------------- +emit_enum_member_int_values_initialization(G, N, X, Fd, EList) -> + InitString = emit_enum_member_int_values_initialization_1(G, N, X, Fd, EList, 0), + ic_codegen:emit(Fd, [" public static final int ",InitString,";\n"]). + + +%%----------------------------------------------------------------- +%% Func: emit_enum_member_int_values_initialization_1/6 +%%----------------------------------------------------------------- +emit_enum_member_int_values_initialization_1(_G, _N, _X, _Fd, [Enumerator], Num) -> + " _" ++ Enumerator ++ " = " ++ ic_util:to_list(Num); +emit_enum_member_int_values_initialization_1(G, N, X, Fd, [Enumerator |EList], Num) -> + Spaces = if + Num == 0 -> + ""; + true -> + " " + end, + Spaces ++ "_" ++ Enumerator ++ " = " ++ ic_util:to_list(Num) ++ ",\n" ++ + emit_enum_member_int_values_initialization_1(G, N, X, Fd, EList, Num + 1). + +%%----------------------------------------------------------------- +%% Func: emit_enum_from_int_function/6 +%%----------------------------------------------------------------- +emit_enum_from_int_function(_G, _N, _X, Fd, EnumName, EList) -> + ic_codegen:emit(Fd, + [" public static final ",EnumName," from_int(int __value) throws java.lang.Exception {\n" + " switch (__value) {\n"]), + emit_enum_from_int_function_switchbody(Fd, EList), + ic_codegen:emit(Fd, [" }\n" + " }\n"]). + +%%----------------------------------------------------------------- +%% Func: emit_enum_from_int_function_switchbody/2 +%%----------------------------------------------------------------- +emit_enum_from_int_function_switchbody(Fd, []) -> + ic_codegen:emit(Fd, [" default:\n" + " throw new java.lang.Exception(\"\");\n"]); +emit_enum_from_int_function_switchbody(Fd, [Enumerator |EList]) -> + ic_codegen:emit(Fd, [" case _",Enumerator,":\n" + " return ",Enumerator,";\n"]), + emit_enum_from_int_function_switchbody(Fd, EList). + +%%----------------------------------------------------------------- +%% Func: emit_enum_private_member_variables/2 +%%----------------------------------------------------------------- +emit_enum_private_member_variables(Fd, EList) -> + ic_codegen:emit(Fd, [" private static final int _memberCount = ",integer_to_list(length(EList)),";\n" + " private static String[] _members = {\n"]), + emit_enum_private_member_variables_1(Fd, EList), + ic_codegen:emit(Fd, " };\n"). + +%%----------------------------------------------------------------- +%% Func: emit_enum_private_member_variables_1/2 +%%----------------------------------------------------------------- +emit_enum_private_member_variables_1(Fd, [Enumerator]) -> + ic_codegen:emit(Fd, [" \"",Enumerator,"\"\n"]); +emit_enum_private_member_variables_1(Fd, [Enumerator |EList]) -> + ic_codegen:emit(Fd, [" \"",Enumerator,"\",\n"]), + emit_enum_private_member_variables_1(Fd, EList). + +%%----------------------------------------------------------------- +%% Func: emit_enum_read_function/5 +%%----------------------------------------------------------------- +emit_enum_read_function(_G, _N, _X, Fd, EnumName) -> + ic_codegen:emit(Fd, [" return ",EnumName,".from_int(_getIntFromName(_in.read_atom()));"]). + +%%----------------------------------------------------------------- +%% Func: emit_enum_write_function/5 +%%----------------------------------------------------------------- +emit_enum_write_function(_G, _N, _X, Fd, _EnumName) -> + ic_codegen:emit(Fd, " _out.write_atom(_members[_value.value()]);\n"). + + +%%----------------------------------------------------------------- +%% Func: enum_member_name_list/3 +%% +%% Note: The names generated are checked for name coalition +%% with java keywords. If so the name is always prefixed +%% by "_" +%%----------------------------------------------------------------- +enum_member_name_list(_G, _N, X) -> + lists:map( + fun(Enumerator) -> + ic_forms:get_java_id(Enumerator) + end, + ic_forms:get_body(X)). + +%%----------------------------------------------------------------- +%% Func: enum_member_atom_list/3 +%% +%% Note : Similar to the emit_member_list/3 but does not +%% solves name coalitions with java keywords. +%% Used for wire encoding only +%%----------------------------------------------------------------- +enum_member_atom_list(_G, _N, X) -> + lists:map( + fun(Enumerator) -> + ic_forms:get_id2(Enumerator) + end, + ic_forms:get_body(X)). + + + + + + + + diff --git a/lib/ic/src/ic_erl_template.erl b/lib/ic/src/ic_erl_template.erl new file mode 100644 index 0000000000..f5983a53bd --- /dev/null +++ b/lib/ic/src/ic_erl_template.erl @@ -0,0 +1,639 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2004-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_erl_template). + + +-export([do_gen/3, emit_header/3]). + +-import(ic_codegen, [emit/2, emit/3, nl/1]). + +-include("icforms.hrl"). +-include("ic.hrl"). + +-include_lib("stdlib/include/erl_compile.hrl"). + +-define(TAB, " "). +-define(TAB2, "% "). + +-define(TEMPLATE_1_A, + "%%----------------------------------------------------------------------\n" + "%% \n" + "%% \n" + "%% $Id$\n" + "%%\n" + "%%----------------------------------------------------------------------\n" + "%% Module : ~s.erl\n" + "%% \n" + "%% Source : ~s\n" + "%% \n" + "%% Description : \n" + "%% \n" + "%% Creation date: ~s\n" + "%%\n" + "%%----------------------------------------------------------------------\n" + "-module(~p).\n\n"). + +-define(TEMPLATE_1_B, + "%%----------------------------------------------------------------------\n" + "%% Internal Exports\n" + "%%----------------------------------------------------------------------\n" + "-export([init/1,\n" + " terminate/2,\n" + " code_change/3,\n" + " handle_info/2]).\n\n" + "%%----------------------------------------------------------------------\n" + "%% Include Files\n" + "%%----------------------------------------------------------------------\n" + "\n\n" + "%%----------------------------------------------------------------------\n" + "%% Macros\n" + "%%----------------------------------------------------------------------\n" + "\n\n" + "%%----------------------------------------------------------------------\n" + "%% Records\n" + "%%----------------------------------------------------------------------\n" + "-record(state, {}).\n\n" + "%%======================================================================\n" + "%% API Functions\n" + "%%======================================================================\n"). + +-define(TEMPLATE_1_C, + "%%======================================================================\n" + "%% Internal Functions\n" + "%%======================================================================\n" + "%%----------------------------------------------------------------------\n" + "%% Function : init/1\n" + "%% Arguments : Env = term()\n" + "%% Returns : {ok, State} |\n" + "%% {ok, State, Timeout} |\n" + "%% ignore |\n" + "%% {stop, Reason}\n" + "%% Raises : -\n" + "%% Description: Initiates the server\n" + "%%----------------------------------------------------------------------\n" + "init(_Env) ->\n" + "\t{ok, #state{}}.\n\n\n" + "%%----------------------------------------------------------------------\n" + "%% Function : terminate/2\n" + "%% Arguments : Reason = normal | shutdown | term()\n" + "%% State = term()\n" + "%% Returns : ok\n" + "%% Raises : -\n" + "%% Description: Invoked when the object is terminating.\n" + "%%----------------------------------------------------------------------\n" + "terminate(_Reason, _State) ->\n" + "\tok.\n\n\n" + "%%----------------------------------------------------------------------\n" + "%% Function : code_change/3\n" + "%% Arguments : OldVsn = undefined | term()\n" + "%% State = NewState = term()\n" + "%% Extra = term()\n" + "%% Returns : {ok, NewState}\n" + "%% Raises : -\n" + "%% Description: Invoked when the object should update its internal state\n" + "%% due to code replacement.\n" + "%%----------------------------------------------------------------------\n" + "code_change(_OldVsn, State, _Extra) ->\n" + "\t{ok, State}.\n\n\n" + "%%----------------------------------------------------------------------\n" + "%% Function : handle_info/2\n" + "%% Arguments : Info = normal | shutdown | term()\n" + "%% State = NewState = term()\n" + "%% Returns : {noreply, NewState} |\n" + "%% {noreply, NewState, Timeout} |\n" + "%% {stop, Reason, NewState}\n" + "%% Raises : -\n" + "%% Description: Invoked when, for example, the server traps exits.\n" + "%%----------------------------------------------------------------------\n" + "handle_info(_Info, State) ->\n" + "\t{noreply, State}.\n\n\n"). + +-define(TEMPLATE_2_A, + "%%% #0. BASIC INFORMATION\n" + "%%% ----------------------------------------------------------------------\n" + "%%% %CCaseFile : ~s.erl %\n" + "%%% Author : \n" + "%%% Description : \n" + "%%%\n" + "%%% Modules used: \n" + "%%%\n" + "%%%\n" + "%%% ----------------------------------------------------------------------\n" + "-module(~p).\n" + "-author('unknown').\n" + "-id('').\n" + "-vsn('').\n" + "-date('~s').\n\n" + "%%% ----------------------------------------------------------------------\n" + "%%% Template Id: \n" + "%%%\n" + "%%% #Copyright (C) 2004\n" + "%%% by \n" + "%%%
\n" + "%%% \n" + "%%% \n" + "%%% \n" + "%%% \n" + "%%% \n" + "%%% ----------------------------------------------------------------------\n" + "%%% #1. REVISION LOG\n" + "%%% ----------------------------------------------------------------------\n" + "%%% Rev Date Name What\n" + "%%% ----- ------- -------- --------------------------\n" + "%%% \n" + "%%% ----------------------------------------------------------------------\n" + "%%%\n" + "%%% \n" + "%%% #2. EXPORT LISTS\n" + "%%% ----------------------------------------------------------------------\n" + "%%% #2.1 EXPORTED INTERFACE FUNCTIONS\n" + "%%% ----------------------------------------------------------------------\n"). + +-define(TEMPLATE_2_B, + "%%% ----------------------------------------------------------------------\n" + "%%% #2.2 EXPORTED INTERNAL FUNCTIONS\n" + "%%% ----------------------------------------------------------------------\n" + "-export([init/1,\n" + " terminate/2,\n" + " code_change/3,\n" + " handle_info/2]).\n\n" + "%%% ----------------------------------------------------------------------\n" + "%%% #2.3 INCLUDE FILES\n" + "%%% ----------------------------------------------------------------------\n" + "\n\n" + "%%% ----------------------------------------------------------------------\n" + "%%% #2.4 MACROS\n" + "%%% ----------------------------------------------------------------------\n" + "\n\n" + "%%% ----------------------------------------------------------------------\n" + "%%% #2.5 RECORDS\n" + "%%% ----------------------------------------------------------------------\n" + "-record(state, {}).\n\n" + "%%% ----------------------------------------------------------------------\n" + "%%% #3. CODE\n" + "%%% #---------------------------------------------------------------------\n" + "%%% #3.1 CODE FOR EXPORTED INTERFACE FUNCTIONS\n" + "%%% #---------------------------------------------------------------------\n"). + +-define(TEMPLATE_2_C, + "%%% ----------------------------------------------------------------------\n" + "%%% #3.3 CODE FOR INTERNAL FUNCTIONS\n" + "%%% ----------------------------------------------------------------------\n" + "%%% ----------------------------------------------------------------------\n" + "%%% # init/1\n" + "%%% Input : Env = term()\n" + "%%% Output : {ok, State} |\n" + "%%% {ok, State, Timeout} |\n" + "%%% ignore |\n" + "%%% {stop, Reason}\n" + "%%% Exceptions : -\n" + "%%% Description: Initiates the server\n" + "%%% ----------------------------------------------------------------------\n" + "init(_Env) ->\n" + "\t{ok, #state{}}.\n\n\n" + "%%% ----------------------------------------------------------------------\n" + "%%% # terminate/2\n" + "%%% Input : Reason = normal | shutdown | term()\n" + "%%% State = term()\n" + "%%% Output : ok\n" + "%%% Exceptions : -\n" + "%%% Description: Invoked when the object is terminating.\n" + "%%% ----------------------------------------------------------------------\n" + "terminate(_Reason, _State) ->\n" + "\tok.\n\n\n" + "%%% ----------------------------------------------------------------------\n" + "%%% # code_change/3\n" + "%%% Input : OldVsn = undefined | term()\n" + "%%% State = NewState = term()\n" + "%%% Extra = term()\n" + "%%% Output : {ok, NewState}\n" + "%%% Exceptions : -\n" + "%%% Description: Invoked when the object should update its internal state\n" + "%%% due to code replacement.\n" + "%%% ----------------------------------------------------------------------\n" + "code_change(_OldVsn, State, _Extra) ->\n" + "\t{ok, State}.\n\n\n" + "%%% ----------------------------------------------------------------------\n" + "%%% # handle_info/2\n" + "%%% Input : Info = normal | shutdown | term()\n" + "%%% State = NewState = term()\n" + "%%% Output : {noreply, NewState} |\n" + "%%% {noreply, NewState, Timeout} |\n" + "%%% {stop, Reason, NewState}\n" + "%%% Exceptions : -\n" + "%%% Description: Invoked when, for example, the server traps exits.\n" + "%%% ----------------------------------------------------------------------\n" + "handle_info(_Info, State) ->\n" + "\t{noreply, State}.\n\n\n" + "%%% ----------------------------------------------------------------------\n" + "%%% #4 CODE FOR TEMPORARY CORRECTIONS\n" + "%%% ----------------------------------------------------------------------\n\n"). + + +%%------------------------------------------------------------ +%% +%% Generate the client side Erlang stubs. +%% +%% Each module is generated to a separate file. +%% +%% Export declarations for all interface functions must be +%% generated. Each function then needs to generate a function head and +%% a body. IDL parameters must be converted into Erlang parameters +%% (variables, capitalised) and a type signature list must be +%% generated (for later encode/decode). +%% +%%------------------------------------------------------------ +do_gen(G, _File, Form) -> + gen_head(G, [], Form), + gen(G, [], Form). + + +gen(G, N, [X|Xs]) when is_record(X, preproc) -> + NewG = ic:handle_preproc(G, N, X#preproc.cat, X), + gen(NewG, N, Xs); +gen(G, N, [X|Xs]) when is_record(X, module) -> + G2 = ic_file:filename_push(G, N, X, erlang_template_no_gen), + N2 = [ic_forms:get_id2(X) | N], + gen_head(G2, N2, X), + gen(G2, N2, ic_forms:get_body(X)), + G3 = ic_file:filename_pop(G2, erlang_template_no_gen), + gen(G3, N, Xs); +gen(G, N, [X|Xs]) when is_record(X, interface) -> + G2 = ic_file:filename_push(G, N, X, erlang_template), + N2 = [ic_forms:get_id2(X) | N], + gen_head(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), + Fd = ic_genobj:stubfiled(G2), + case get_template_version(G2) of + ?IC_FLAG_TEMPLATE_2 -> + emit(Fd, ?TEMPLATE_2_C, []); + _ -> + emit(Fd, ?TEMPLATE_1_C, []) + end, + G3 = ic_file:filename_pop(G2, erlang_template), + gen(G3, N, Xs); +gen(G, N, [X|Xs]) when is_record(X, op) -> + {Name, InArgNames, OutArgNames, Reply} = extract_info(X), + emit_function(G, N, X, ic_genobj:is_stubfile_open(G), + ic_forms:is_oneway(X), Name, InArgNames, OutArgNames, Reply), + gen(G, N, Xs); +gen(G, N, [X|Xs]) when is_record(X, attr) -> + emit_attr(G, N, X, ic_genobj:is_stubfile_open(G), fun emit_function/9), + gen(G, N, Xs); +gen(G, N, [_X|Xs]) -> + gen(G, N, Xs); +gen(_G, _N, []) -> + ok. + +%% Module Header +emit_header(G, Fd, Name) -> + Date = get_date(), + case get_template_version(G) of + ?IC_FLAG_TEMPLATE_2 -> + emit(Fd, ?TEMPLATE_2_A, [Name, list_to_atom(Name), Date]); + _ -> + IDLFile = ic_genobj:idlfile(G), + emit(Fd, ?TEMPLATE_1_A, [Name, IDLFile, Date, list_to_atom(Name)]) + end. + + +emit_attr(G, N, X, Open, F) -> + XX = #id_of{type=X}, + lists:foreach(fun(Id) -> + X2 = XX#id_of{id=Id}, + IsOneWay = ic_forms:is_oneway(X2), + {Get, Set} = mk_attr_func_names(N, ic_forms:get_id(Id)), + F(G, N, X2, Open, IsOneWay, Get, [], [], + [{ic_util:mk_var(ic_forms:get_id(Id)), + ic_forms:get_tk(X)}]), + case X#attr.readonly of + {readonly, _} -> + ok; + _ -> + F(G, N, X2, Open, IsOneWay, Set, + [{ic_util:mk_var(ic_forms:get_id(Id)), + ic_forms:get_tk(X)}], [], ["ok"]) + end + end, ic_forms:get_idlist(X)). + + +%% The automaticly generated get and set operation names for an +%% attribute. +mk_attr_func_names(_Scope, Name) -> + {"_get_" ++ Name, "_set_" ++ Name}. + + +extract_info(X) when is_record(X, op) -> + Name = ic_forms:get_id2(X), + InArgs = ic:filter_params([in,inout], X#op.params), + OutArgs = ic:filter_params([out,inout], X#op.params), + Reply = case ic_forms:get_tk(X) of + tk_void -> + ["ok"]; + Type -> + [{"OE_Reply", Type}] + end, + InArgsTypeList = + [{ic_util:mk_var(ic_forms:get_id(InArg#param.id)), + ic_forms:get_tk(InArg)} || InArg <- InArgs ], + OutArgsTypeList = + [{ic_util:mk_var(ic_forms:get_id(OutArg#param.id)), + ic_forms:get_tk(OutArg)} || OutArg <- OutArgs ], + {Name, InArgsTypeList, OutArgsTypeList, Reply}. + +get_template_version(G) -> + case ic_options:get_opt(G, flags) of + Flags when is_integer(Flags) -> + case ?IC_FLAG_TEST(Flags, ?IC_FLAG_TEMPLATE_2) of + true -> + ?IC_FLAG_TEMPLATE_2; + false -> + ?IC_FLAG_TEMPLATE_1 + end; + _ -> + ?IC_FLAG_TEMPLATE_1 + end. + + +get_date() -> + {{Y,M,D}, _} = calendar:now_to_datetime(now()), + if + M < 10, D < 10 -> + lists:concat([Y, "-0", M, "-0",D]); + M < 10 -> + lists:concat([Y, "-0", M, "-", D]); + D < 10 -> + lists:concat([Y, "-", M, "-0", D]); + true -> + lists:concat([Y, "-", M, "-", D]) + end. + + +%%------------------------------------------------------------ +%% +%% Export stuff +%% +%% Gathering of all names that should be exported from a stub +%% file. +%% + + +gen_head_special(G, N, X) when is_record(X, interface) -> + Fd = ic_genobj:stubfiled(G), + lists:foreach(fun({_Name, Body}) -> + ic_codegen:export(Fd, exp_top(G, N, Body, [])) + end, X#interface.inherit_body), + nl(Fd), + ok; +gen_head_special(_G, _N, _X) -> + ok. + + +%% Generate all export declarations +gen_head(G, N, X) -> + case ic_genobj:is_stubfile_open(G) of + true -> + Fd = ic_genobj:stubfiled(G), + ic_codegen:export(Fd, exp_top(G, N, X, [])), + gen_head_special(G, N, X), + case get_template_version(G) of + ?IC_FLAG_TEMPLATE_2 -> + emit(Fd, ?TEMPLATE_2_B, []); + _ -> + emit(Fd, ?TEMPLATE_1_B, []) + end; + false -> + ok + end. + +exp_top(_G, _N, X, Acc) when element(1, X) == preproc -> + Acc; +exp_top(G, N, L, Acc) when is_list(L) -> + exp_list(G, N, L, Acc); +exp_top(G, N, M, Acc) when is_record(M, module) -> + exp_list(G, N, ic_forms:get_body(M), Acc); +exp_top(G, N, I, Acc) when is_record(I, interface) -> + exp_list(G, N, ic_forms:get_body(I), Acc); +exp_top(G, N, X, Acc) -> + exp3(G, N, X, Acc). + +exp3(G, N, Op, Acc) when is_record(Op, op) -> + FuncName = ic_forms:get_id(Op#op.id), + Arity = length(ic:filter_params([in, inout], Op#op.params)) + 1 + + count_extras(G, N, Op), + [{FuncName, Arity} | Acc]; +exp3(G, N, A, Acc) when is_record(A, attr) -> + Extra = count_extras(G, N, A), + lists:foldr(fun(Id, Acc2) -> + {Get, Set} = mk_attr_func_names([], ic_forms:get_id(Id)), + case A#attr.readonly of + {readonly, _} -> + [{Get, 1 + Extra} | Acc2]; + _ -> + [{Get, 1 + Extra}, {Set, 2 + Extra} | Acc2] + end + end, Acc, ic_forms:get_idlist(A)); +exp3(_G, _N, _X, Acc) -> + Acc. + +exp_list(G, N, L, OrigAcc) -> + lists:foldr(fun(X, Acc) -> + exp3(G, N, X, Acc) + end, OrigAcc, L). + +count_extras(G, N, Op) -> + case {use_this(G, N, Op), use_from(G, N, Op)} of + {[], []} -> + 0; + {[], _} -> + 1; + {_, []} -> + 1; + _ -> + 2 + end. + +%%------------------------------------------------------------ +%% +%% Emit stuff +%% +%% Low level generation primitives +%% + +emit_function(_G, _N, _X, false, _, _, _, _, _) -> + ok; +emit_function(G, N, X, true, false, Name, InArgs, OutArgs, Reply) -> + Fd = ic_genobj:stubfiled(G), + This = use_this(G, N, Name), + From = use_from(G, N, Name), + State = ["State"], + Vers = get_template_version(G), + case OutArgs of + [] -> + ReplyString = create_string(Reply), + emit_function_header(G, Fd, X, N, Name, create_extra(This, From, Vers), + InArgs, length(InArgs), OutArgs, Reply, + ReplyString, Vers), + emit(Fd, "~p(~s) ->\n\t{reply, ~s, State}.\n\n", + [ic_util:to_atom(Name), create_string(This ++ From ++ State ++ InArgs), + ReplyString]); + _ -> + ReplyString = "{" ++ create_string(Reply ++ OutArgs) ++ "}", + emit_function_header(G, Fd, X, N, Name, create_extra(This, From, Vers), + InArgs, length(InArgs), OutArgs, Reply, + ReplyString, Vers), + emit(Fd, "~p(~s) ->\n\t{reply, ~s, State}.\n\n", + [ic_util:to_atom(Name), create_string(This ++ From ++ State ++ InArgs), + ReplyString]) + end; +emit_function(G, N, X, true, true, Name, InArgs, _OutArgs, _Reply) -> + Fd = ic_genobj:stubfiled(G), + This = use_this(G, N, Name), + State = ["State"], + Vers = get_template_version(G), + emit_function_header(G, Fd, X, N, Name, create_extra(This, [], Vers), + InArgs, length(InArgs), "", "", "", Vers), + emit(Fd, "~p(~s) ->\n\t{noreply, State}.\n\n", + [ic_util:to_atom(Name), create_string(This ++ State ++ InArgs)]). + +create_string([]) -> + ""; +create_string([{Name, _Type}|T]) -> + Name ++ create_string2(T); +create_string([Name|T]) -> + Name ++ create_string2(T). + +create_string2([{Name, _Type}|T]) -> + ", " ++ Name ++ create_string2(T); +create_string2([Name|T]) -> + ", " ++ Name ++ create_string2(T); +create_string2([]) -> + "". + +create_extra([], [], _Vers) -> + {"State - term()", 1}; +create_extra([], _From, ?IC_FLAG_TEMPLATE_2) -> + {"OE_From - term()\n%%% " ++ ?TAB ++ "State - term()", 2}; +create_extra([], _From, _Vers) -> + {"OE_From - term()\n%% " ++ ?TAB ++ "State - term()", 2}; +create_extra(_This, [], ?IC_FLAG_TEMPLATE_2) -> + {"OE_This - #objref{} (i.e., self())\n%%% " ++ ?TAB ++ "State - term()", 2}; +create_extra(_This, [], _Vers) -> + {"OE_This - #objref{} (i.e., self())\n%% " ++ ?TAB ++ "State - term()", 2}; +create_extra(_This, _From, ?IC_FLAG_TEMPLATE_2) -> + {"OE_This - #objref{} (i.e., self())\n%%% " ++ ?TAB ++ + "OE_From - term()\n%%% " ++ ?TAB ++ "State - term()", 3}; +create_extra(_This, _From, _Vers) -> + {"OE_This - #objref{} (i.e., self())\n%% " ++ ?TAB ++ + "OE_From - term()\n%% " ++ ?TAB ++ "State - term()", 3}. + +use_this(G, N, OpName) -> + FullOp = ic_util:to_colon([OpName|N]), + FullIntf = ic_util:to_colon(N), + case {ic_options:get_opt(G, {this, FullIntf}), + ic_options:get_opt(G, {this, FullOp}), + ic_options:get_opt(G, {this, true})} of + {_, force_false, _} -> + []; + {force_false, false, _} -> + []; + {false, false, false} -> + []; + _ -> + ["OE_This"] + end. + +use_from(G, N, OpName) -> + FullOp = ic_util:to_colon([OpName|N]), + FullIntf = ic_util:to_colon(N), + case {ic_options:get_opt(G, {from, FullIntf}), + ic_options:get_opt(G, {from, FullOp}), + ic_options:get_opt(G, {from, true})} of + {_, force_false, _} -> + []; + {force_false, false, _} -> + []; + {false, false, false} -> + []; + _ -> + ["OE_From"] + end. + + +emit_function_header(G, Fd, X, N, Name, {Extra, ExtraNo}, InP, Arity, OutP, + Reply, ReplyString, ?IC_FLAG_TEMPLATE_2) -> + emit(Fd, + "%%% ----------------------------------------------------------------------\n" + "%%% # ~p/~p\n" + "%%% Input : ~s\n", + [ic_util:to_atom(Name), (ExtraNo+Arity), Extra]), + ic_code:type_expand_all(G, N, X, Fd, ?TAB2, InP), + case Reply of + ["ok"] -> + emit(Fd, "%%% Output : ReturnValue = ~s\n", [ReplyString]); + _ -> + emit(Fd, "%%% Output : ReturnValue = ~s\n", [ReplyString]), + ic_code:type_expand_all(G, N, X, Fd, "% ", Reply) + end, + ic_code:type_expand_all(G, N, X, Fd, ?TAB2, OutP), + emit(Fd, + "%%% Exceptions : ~s\n" + "%%% Description: \n" + "%%% ----------------------------------------------------------------------\n", + [get_raises(X, ?IC_FLAG_TEMPLATE_2)]); +emit_function_header(G, Fd, X, N, Name, {Extra, ExtraNo}, InP, Arity, OutP, + Reply, ReplyString, Vers) -> + emit(Fd, + "%%----------------------------------------------------------------------\n" + "%% Function : ~p/~p\n" + "%% Arguments : ~s\n", + [ic_util:to_atom(Name), (ExtraNo+Arity), Extra]), + ic_code:type_expand_all(G, N, X, Fd, ?TAB, InP), + case Reply of + ["ok"] -> + emit(Fd, "%% Returns : ReturnValue = ~s\n", [ReplyString]); + _ -> + emit(Fd, "%% Returns : ReturnValue = ~s\n", [ReplyString]), + ic_code:type_expand_all(G, N, X, Fd, " ", Reply) + end, + ic_code:type_expand_all(G, N, X, Fd, ?TAB, OutP), + emit(Fd, + "%% Raises : ~s\n" + "%% Description: \n" + "%%----------------------------------------------------------------------\n", + [get_raises(X, Vers)]). + +get_raises(#op{raises = []}, _Vers) -> + ""; +get_raises(#op{raises = ExcList}, Vers) -> + get_raises2(ExcList, [], Vers); +get_raises(_X, _Vers) -> + []. + +get_raises2([H], Acc, _Vers) -> + lists:flatten(lists:reverse([ic_util:to_colon(H)|Acc])); +get_raises2([H|T], Acc, ?IC_FLAG_TEMPLATE_2) -> + get_raises2(T, ["\n%%% ", ic_util:to_colon(H) |Acc], + ?IC_FLAG_TEMPLATE_2); +get_raises2([H|T], Acc, _Vers) -> + get_raises2(T, ["\n%% ", ic_util:to_colon(H) |Acc], _Vers). + diff --git a/lib/ic/src/ic_erlbe.erl b/lib/ic/src/ic_erlbe.erl new file mode 100644 index 0000000000..75c87929db --- /dev/null +++ b/lib/ic/src/ic_erlbe.erl @@ -0,0 +1,1141 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1998-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_erlbe). + + +-export([do_gen/3]). +%%------------------------------------------------------------ +%% +%% Internal stuff +%% +%%------------------------------------------------------------ + +-export([unfold/1, mk_attr_func_names/2]). + + +-import(ic_util, [mk_name/2, mk_var/1, mk_oe_name/2, to_atom/1, to_list/1]). +-import(ic_forms, [get_id/1, get_id2/1, get_body/1, is_oneway/1]). +-import(ic_codegen, [emit/2, emit/3, nl/1]). +-import(ic_options, [get_opt/2]). + +-import(lists, [foreach/2, foldr/3, map/2]). + + +-include("icforms.hrl"). +-include("ic.hrl"). + +-include_lib("stdlib/include/erl_compile.hrl"). + + +%%------------------------------------------------------------ +%% +%% Generate the client side Erlang stubs. +%% +%% Each module is generated to a separate file. +%% +%% Export declarations for all interface functions must be +%% generated. Each function then needs to generate a function head and +%% a body. IDL parameters must be converted into Erlang parameters +%% (variables, capitalised) and a type signature list must be +%% generated (for later encode/decode). +%% +%%------------------------------------------------------------ +do_gen(G, File, Form) -> + GT = get_opt(G, be), + G2 = ic_file:filename_push(G, [], mk_oe_name(G, + ic_file:remove_ext(to_list(File))), + erlang), + Light = ic_options:get_opt(G, light_ifr), + R = if + GT == erl_corba, Light == false -> + case ic_genobj:is_stubfile_open(G2) of + true -> + emit(ic_genobj:stubfiled(G2), "-include_lib(\"~s/include/~s\").\n\n", + [?ORBNAME, ?IFRTYPESHRL]); + false -> ok + end, + gen_head(G2, [], Form), + ic_codegen:export(ic_genobj:stubfiled(G2), + [{ictk:register_name(G2), 0}, + {ictk:unregister_name(G2), 0}, + {oe_get_module,5}, + {oe_dependency,0}]), + R0= gen(G2, [], Form), + ictk:reg_gen(G2, [], Form), + ictk:unreg_gen(G2, [], Form), % "new" unreg_gen/3 + genDependency(G2), % creates code for dependency list + R0; + GT == erl_corba, Light == true -> + case ic_genobj:is_stubfile_open(G2) of + true -> + emit(ic_genobj:stubfiled(G2), "-include_lib(\"~s/include/~s\").\n\n", + [?ORBNAME, ?IFRTYPESHRL]); + false -> ok + end, + gen_head(G2, [], Form), + ic_codegen:export(ic_genobj:stubfiled(G2), + [{ictk:register_name(G2), 0}, + {ictk:register_name(G2), 1}, + {ictk:unregister_name(G2), 0}, + {ictk:unregister_name(G2), 1}]), + R0= gen(G2, [], Form), + ictk:reg_gen(G2, [], Form), + ictk:unreg_gen(G2, [], Form), % "new" unreg_gen/3 + R0; + true -> + gen_head(G2, [], Form), + gen(G2, [], Form) + end, + ic_file:filename_pop(G2, erlang), + R. + + +gen(G, N, [X|Xs]) when is_record(X, preproc) -> + NewG = ic:handle_preproc(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 = [get_id2(X) | N], + gen_head(G2, N2, X), + gen(G2, N2, 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, erlang), + N2 = [get_id2(X) | N], + gen_head(G2, N2, X), + gen(G2, N2, get_body(X)), + foreach(fun({_Name, Body}) -> gen(G2, N2, Body) end, + X#interface.inherit_body), + gen_serv(G2, N, X), + G3 = ic_file:filename_pop(G2, erlang), + gen(G3, N, Xs); + +gen(G, N, [X|Xs]) when is_record(X, const) -> +% N2 = [get_id2(X) | N], + emit_constant_func(G, X#const.id, X#const.val), + gen(G, N, Xs); %% N2 or N? + +gen(G, N, [X|Xs]) when is_record(X, op) -> + {Name, ArgNames, TypeList, OutArgs} = extract_info(G, N, X), + emit_stub_func(G, N, X, Name, ArgNames, TypeList, OutArgs, + is_oneway(X), get_opt(G, be)), + gen(G, N, Xs); + +gen(G, N, [X|Xs]) when is_record(X, attr) -> + emit_attr(G, N, X, fun emit_stub_func/9), + gen(G, N, Xs); + +gen(G, N, [X|Xs]) when is_record(X, except) -> + icstruct:except_gen(G, N, X, erlang), + gen(G, N, Xs); + +gen(G, N, [X|Xs]) -> + case may_contain_structs(X) of + true -> icstruct:struct_gen(G, N, X, erlang); + false -> ok + end, + gen(G, N, Xs); + +gen(_G, _N, []) -> ok. + + +may_contain_structs(X) when is_record(X, typedef) -> true; +may_contain_structs(X) when is_record(X, struct) -> true; +may_contain_structs(X) when is_record(X, union) -> true; +may_contain_structs(_X) -> false. + + + +%%-------------------------------------------------------------------- +%% +%% Generate the server side (handle_call and handle_cast) +%% + +gen_serv(G, N, X) -> + case ic_genobj:is_stubfile_open(G) of + true -> + GT = get_opt(G, be), + gen_oe_is_a(G, N, X, GT), + N2 = [get_id2(X) | N], + gen_oe_tc(G, N2, X, GT), + + emit_serv_std(GT, G, N, X), + + gen_calls(G, N2, get_body(X)), + lists:foreach(fun({_Name, Body}) -> + gen_calls(G, N2, Body) end, + X#interface.inherit_body), + gen_end_of_call(GT, G), + + gen_casts(G, N2, get_body(X)), + lists:foreach(fun({_Name, Body}) -> + gen_casts(G, N2, Body) end, + X#interface.inherit_body), + gen_end_of_cast(GT, G), + emit_skel_footer(GT, G, N, X); % Note N instead of N2 + false -> + ok + end. + +gen_oe_is_a(G, N, X, erl_corba) when is_record(X, interface) -> + Fd = ic_genobj:stubfiled(G), + ic_codegen:mcomment(Fd, ["Inherited Interfaces"]), + emit(Fd, "oe_is_a(~p) -> true;\n", [ictk:get_IR_ID(G, N, X)]), + lists:foreach(fun(ScopedName) -> + emit(Fd, "oe_is_a(~p) -> true;\n", + [ic_pragma:scope2id(G, ScopedName)]) + end, X#interface.inherit), + emit(Fd, "oe_is_a(_) -> false.\n"), + nl(Fd), + ok; +gen_oe_is_a(_G, _N, _X, _BE) -> ok. + + +%% Generates the oe_tc function +gen_oe_tc(G, N, X, erl_corba) -> + Fd = ic_genobj:stubfiled(G), + ic_codegen:mcomment(Fd, ["Interface TypeCode"]), + LocalInterface = gen_oe_tc2(G, N, get_body(X), Fd, []), + CompleteInterface = + lists:foldl(fun({Name, Body}, FunAcc) -> + AName = ic_util:to_atom(ic_util:to_undersc(Name)), + gen_oe_tc3(G, AName, Body, Fd, FunAcc) + end, LocalInterface, X#interface.inherit_body), + emit(Fd, "oe_tc(_) -> undefined.\n"), + nl(Fd), + emit(Fd, "oe_get_interface() -> \n\t["), + emit_oe_get_interface(Fd, CompleteInterface), + nl(Fd), + ok; +gen_oe_tc(_, _, _, _) -> + ok. + +emit_oe_get_interface(Fd, []) -> + emit(Fd, "].\n"); +emit_oe_get_interface(Fd, [Item]) -> + emit(Fd, "~s].\n", [lists:flatten(Item)]); +emit_oe_get_interface(Fd, [H|T]) -> + emit(Fd, "~s,\n\t", [lists:flatten(H)]), + emit_oe_get_interface(Fd, T). + +gen_oe_tc2(_,_,[],_, Acc) -> + Acc; +gen_oe_tc2(G, N, [X|Rest], Fd, Acc) when is_record(X, op) -> + R = ic_forms:get_tk(X), + IN = lists:map(fun(P) -> ic_forms:get_tk(P) end, + ic:filter_params([in, inout], X#op.params)), + OUT = lists:map(fun(P) -> ic_forms:get_tk(P) end, + ic:filter_params([out, inout], X#op.params)), + Function = get_id2(X), + FunctionAtom = ic_util:to_atom(Function), + emit(Fd, "oe_tc(~p) -> \n\t~p;\n",[FunctionAtom, {R, IN, OUT}]), + GI = io_lib:format("{~p, oe_tc(~p)}",[Function, FunctionAtom]), + gen_oe_tc2(G, N, Rest, Fd, [GI|Acc]); + +gen_oe_tc2(G, N, [X|Rest], Fd, Acc) when is_record(X, attr) -> + {GetT, SetT} = mk_attr_func_types([], X), + NewAcc = + lists:foldl(fun(Id, FunAcc) -> + {Get, Set} = mk_attr_func_names([], get_id(Id)), + GetAttrAtom = ic_util:to_atom(Get), + emit(Fd, "oe_tc(~p) -> \n\t~p;\n", + [GetAttrAtom, GetT]), + case X#attr.readonly of + {readonly, _} -> + GI = io_lib:format("{~p, oe_tc(~p)}", + [Get, GetAttrAtom]), + [GI|FunAcc]; + _ -> + SetAttrAtom = ic_util:to_atom(Set), + + emit(Fd, "oe_tc(~p) -> \n\t~p;\n", + [SetAttrAtom, SetT]), + GetGI = io_lib:format("{~p, oe_tc(~p)}", + [Get, GetAttrAtom]), + SetGI = io_lib:format("{~p, oe_tc(~p)}", + [Set, SetAttrAtom]), + [GetGI, SetGI|FunAcc] + end + end, Acc, ic_forms:get_idlist(X)), + gen_oe_tc2(G, N, Rest, Fd, NewAcc); + +gen_oe_tc2(G,N,[_X|Rest], Fd, Acc) -> + gen_oe_tc2(G,N,Rest, Fd, Acc). + + +gen_oe_tc3(_,_,[],_, Acc) -> + Acc; +gen_oe_tc3(G, N, [X|Rest], Fd, Acc) when is_record(X, op) -> + Function = get_id2(X), + FunctionAtom = ic_util:to_atom(get_id2(X)), + GI = io_lib:format("{~p, ~p:oe_tc(~p)}",[Function, N, FunctionAtom]), + emit(Fd, "oe_tc(~p) -> ~p:oe_tc(~p);\n", + [FunctionAtom, N, FunctionAtom]), + gen_oe_tc3(G, N, Rest, Fd, [GI|Acc]); + +gen_oe_tc3(G, N, [X|Rest], Fd, Acc) when is_record(X, attr) -> + NewAcc = lists:foldl(fun(Id, FunAcc) -> + {Get, Set} = mk_attr_func_names([], get_id(Id)), + GetAttrAtom = ic_util:to_atom(Get), + emit(Fd, "oe_tc(~p) -> ~p:oe_tc(~p);\n", + [GetAttrAtom, N, GetAttrAtom]), + case X#attr.readonly of + {readonly, _} -> + [io_lib:format("{~p, ~p:oe_tc(~p)}", + [Get, N, GetAttrAtom])|FunAcc]; + _ -> + SetAttrAtom = ic_util:to_atom(Set), + emit(Fd, "oe_tc(~p) -> ~p:oe_tc(~p);\n", + [SetAttrAtom, N, SetAttrAtom]), + [io_lib:format("{~p, ~p:oe_tc(~p)}", + [Get, N, GetAttrAtom]), + io_lib:format("{~p, ~p:oe_tc(~p)}", + [Set, N, SetAttrAtom])|FunAcc] + end + end, Acc, ic_forms:get_idlist(X)), + gen_oe_tc3(G, N, Rest, Fd, NewAcc); + +gen_oe_tc3(G,N,[_X|Rest], Fd, Acc) -> + gen_oe_tc3(G,N,Rest, Fd, Acc). + +gen_calls(G, N, [X|Xs]) when is_record(X, op) -> + case is_oneway(X) of + false -> + {Name, ArgNames, TypeList, OutArgs} = extract_info(G, N, X), + emit_skel_func(G, N, X, Name, ArgNames, TypeList, OutArgs, false, + get_opt(G, be)), + gen_calls(G, N, Xs); + true -> + gen_calls(G, N, Xs) + end; + +gen_calls(G, N, [X|Xs]) when is_record(X, attr) -> + emit_attr(G, N, X, fun emit_skel_func/9), + gen_calls(G, N, Xs); + +gen_calls(G, N, [_X|Xs]) -> gen_calls(G, N, Xs); +gen_calls(_G, _N, []) -> ok. + +gen_casts(G, N, [X|Xs]) when is_record(X, op) -> + case is_oneway(X) of + true -> + {Name, ArgNames, TypeList, OutArgs} = extract_info(G, N, X), + emit_skel_func(G, N, X, Name, ArgNames, TypeList, OutArgs, true, + get_opt(G, be)), + gen_casts(G, N, Xs); + false -> + gen_casts(G, N, Xs) + end; + +gen_casts(G, N, [_X|Xs]) -> gen_casts(G, N, Xs); +gen_casts(_G, _N, []) -> ok. + +emit_attr(G, N, X, F) -> + XX = #id_of{type=X}, + BE = get_opt(G, be), + {GetType, SetType} = mk_attr_func_types(N, X), + lists:foreach(fun(Id) -> + X2 = XX#id_of{id=Id}, + {Get, Set} = mk_attr_func_names(N, get_id(Id)), + F(G, N, X2, Get, [], GetType, [], + is_oneway(X2), BE), + case X#attr.readonly of + {readonly, _} -> ok; + _ -> + F(G, N, X2, Set, [mk_name(G, "Value")], + SetType, [], + is_oneway(X2), BE) + end end, ic_forms:get_idlist(X)). + + +extract_info(G, _N, X) when is_record(X, op) -> + Name = get_id2(X), + InArgs = ic:filter_params([in,inout], X#op.params), + OutArgs = ic:filter_params([out,inout], X#op.params), + ArgNames = mk_erl_vars(G, InArgs), + TypeList = {ic_forms:get_tk(X), + map(fun(Y) -> ic_forms:get_tk(Y) end, InArgs), + map(fun(Y) -> ic_forms:get_tk(Y) end, OutArgs) + }, + {Name, ArgNames, TypeList, OutArgs}. + + + +%% This function generates the standard functions of an object +%% gen_server +emit_serv_std(erl_corba, G, N, X) -> + Fd = ic_genobj:stubfiled(G), + Impl = ic_genobj:impl(G), + TypeID = ictk:get_IR_ID(G, N, X), + + nl(Fd), nl(Fd), nl(Fd), + ic_codegen:mcomment(Fd, ["Object server implementation."]), + nl(Fd), nl(Fd), + ic_codegen:mcomment(Fd, ["Function for fetching the interface type ID."]), + nl(Fd), + emit(Fd, "typeID() ->\n"), + emit(Fd, " \"~s\".\n", [TypeID]), + nl(Fd), nl(Fd), + ic_codegen:mcomment(Fd, ["Object creation functions."]), + nl(Fd), + emit(Fd, "oe_create() ->\n"), + emit(Fd, " corba:create(?MODULE, \"~s\").\n", [TypeID]), + nl(Fd), + emit(Fd, "oe_create_link() ->\n"), + emit(Fd, " corba:create_link(?MODULE, \"~s\").\n", [TypeID]), + nl(Fd), + emit(Fd, "oe_create(Env) ->\n"), + emit(Fd, " corba:create(?MODULE, \"~s\", Env).\n", [TypeID]), + nl(Fd), + emit(Fd, "oe_create_link(Env) ->\n"), + emit(Fd, " corba:create_link(?MODULE, \"~s\", Env).\n", [TypeID]), + nl(Fd), + emit(Fd, "oe_create(Env, RegName) ->\n"), + emit(Fd, " corba:create(?MODULE, \"~s\", Env, RegName).\n", [TypeID]), + nl(Fd), + emit(Fd, "oe_create_link(Env, RegName) ->\n"), + emit(Fd, " corba:create_link(?MODULE, \"~s\", Env, RegName).\n", [TypeID]), + nl(Fd), + ic_codegen:mcomment(Fd, ["Init & terminate functions."]), + nl(Fd), + emit(Fd, "init(Env) ->\n"), + ic_codegen:comment(Fd, "Call to implementation init"), + emit(Fd, " corba:handle_init(~p, Env).\n", [to_atom(Impl)]), + nl(Fd), + emit(Fd, "terminate(Reason, State) ->\n"), + emit(Fd, " corba:handle_terminate(~p, Reason, State).\n", + [to_atom(Impl)]), + nl(Fd), nl(Fd), + Fd; +emit_serv_std(erl_genserv, G, N, X) -> + Fd = ic_genobj:stubfiled(G), + Impl = ic_genobj:impl(G), + TypeID = ictk:get_IR_ID(G, N, X), + + nl(Fd), nl(Fd), nl(Fd), + ic_codegen:mcomment(Fd, ["Server implementation."]), + nl(Fd), nl(Fd), + ic_codegen:mcomment(Fd, ["Function for fetching the interface type ID."]), + nl(Fd), + emit(Fd, "typeID() ->\n"), + emit(Fd, " \"~s\".\n", [TypeID]), + nl(Fd), nl(Fd), + ic_codegen:mcomment(Fd, ["Server creation functions."]), + nl(Fd), + emit(Fd, "oe_create() ->\n"), + emit(Fd, " start([], []).\n", []), + nl(Fd), + emit(Fd, "oe_create_link() ->\n"), + emit(Fd, " start_link([], []).\n", []), + nl(Fd), + emit(Fd, "oe_create(Env) ->\n"), + emit(Fd, " start(Env, []).\n", []), + nl(Fd), + emit(Fd, "oe_create_link(Env) ->\n"), + emit(Fd, " start_link(Env, []).\n", []), + nl(Fd), + emit(Fd, "oe_create(Env, RegName) ->\n"), + emit(Fd, " start(RegName, Env, []).\n", []), + nl(Fd), + emit(Fd, "oe_create_link(Env, RegName) ->\n"), + emit(Fd, " start_link(RegName, Env, []).\n", []), + nl(Fd), + ic_codegen:mcomment(Fd, ["Start functions."]), + nl(Fd), + emit(Fd, "start(Env, Opt) ->\n"), + emit(Fd, " gen_server:start(?MODULE, Env, Opt).\n"), + nl(Fd), + emit(Fd, "start_link(Env, Opt) ->\n"), + emit(Fd, " gen_server:start_link(?MODULE, Env, Opt).\n"), + nl(Fd), + emit(Fd, "start(RegName, Env, Opt) ->\n"), + emit(Fd, " gen_server:start(RegName, ?MODULE, Env, Opt).\n"), + nl(Fd), + emit(Fd, "start_link(RegName, Env, Opt) ->\n"), + emit(Fd, " gen_server:start_link(RegName, ?MODULE, Env, Opt).\n"), + nl(Fd), + ic_codegen:comment(Fd, "Standard gen_server termination"), + emit(Fd, "stop(OE_THIS) ->\n"), + emit(Fd, " gen_server:cast(OE_THIS,stop).\n"), + nl(Fd), + ic_codegen:comment(Fd, "Call to implementation init"), + emit(Fd, "init(Env) ->\n"), + emit(Fd, " ~p:~p(Env).\n", [to_atom(Impl), init]), + nl(Fd), + emit(Fd, "terminate(Reason, State) ->\n"), + emit(Fd, " ~p:~p(Reason, State).\n", + [to_atom(Impl), terminate]), + nl(Fd), nl(Fd), + Fd. + +gen_end_of_call(erl_corba, G) -> + Fd = ic_genobj:stubfiled(G), + nl(Fd), nl(Fd), + ic_codegen:mcomment_light(Fd, ["Standard gen_server call handle"]), + emit(Fd, "handle_call(stop, _, State) ->\n"), + emit(Fd, " {stop, normal, ok, State}"), + case get_opt(G, serv_last_call) of + exception -> + emit(Fd, ";\n"), + nl(Fd), + emit(Fd, "handle_call(_, _, State) ->\n"), + emit(Fd, " {reply, catch corba:raise(#'BAD_OPERATION'{minor=1163001857, completion_status='COMPLETED_NO'}), State}.\n"); + exit -> + emit(Fd, ".\n"), + nl(Fd), + nl(Fd) + end, + ok; +gen_end_of_call(erl_genserv, G) -> + Fd = ic_genobj:stubfiled(G), + nl(Fd), nl(Fd), + ic_codegen:mcomment_light(Fd, ["Standard gen_server call handle"]), + emit(Fd, "handle_call(stop, _, State) ->\n"), + emit(Fd, " {stop, normal, ok, State}"), + emit(Fd, ".\n"), + nl(Fd), nl(Fd), + ok. + +gen_end_of_cast(erl_corba, G) -> + Fd = ic_genobj:stubfiled(G), + nl(Fd), nl(Fd), + ic_codegen:mcomment_light(Fd, ["Standard gen_server cast handle"]), + emit(Fd, "handle_cast(stop, State) ->\n"), + emit(Fd, " {stop, normal, State}"), + case get_opt(G, serv_last_call) of + exception -> + emit(Fd, ";\n"), + nl(Fd), + emit(Fd, "handle_cast(_, State) ->\n"), + emit(Fd, " {noreply, State}.\n"); + exit -> + emit(Fd, ".\n"), + nl(Fd), nl(Fd) + end, + ok; +gen_end_of_cast(erl_genserv, G) -> + Fd = ic_genobj:stubfiled(G), + nl(Fd), nl(Fd), + ic_codegen:mcomment_light(Fd, ["Standard gen_server cast handle"]), + emit(Fd, "handle_cast(stop, State) ->\n"), + emit(Fd, " {stop, normal, State}"), + emit(Fd, ".\n"), + nl(Fd), nl(Fd), + ok. + +emit_skel_footer(erl_corba, G, N, X) -> + Fd = ic_genobj:stubfiled(G), + nl(Fd), nl(Fd), + ic_codegen:mcomment_light(Fd, ["Standard gen_server handles"]), + case use_impl_handle_info(G, N, X) of + true -> + emit(Fd, "handle_info(Info, State) ->\n"), + emit(Fd, " corba:handle_info(~p, Info, State).\n\n", + [list_to_atom(ic_genobj:impl(G))]); + false -> + emit(Fd, "handle_info(_, State) ->\n"), + emit(Fd, " {noreply, State}.\n\n") + end, + nl(Fd), + case get_opt(G, no_codechange) of + false -> + emit(Fd, "code_change(OldVsn, State, Extra) ->\n"), + emit(Fd, " corba:handle_code_change(~p, OldVsn, State, Extra).\n\n", + [list_to_atom(ic_genobj:impl(G))]); + true -> + emit(Fd, "code_change(_, State, _) ->\n"), + emit(Fd, " {ok, State}.\n\n") + end, + ok; +emit_skel_footer(erl_genserv, G, N, X) -> + Fd = ic_genobj:stubfiled(G), + nl(Fd), nl(Fd), + ic_codegen:mcomment_light(Fd, ["Standard gen_server handles"]), + case use_impl_handle_info(G, N, X) of + true -> + emit(Fd, "handle_info(Info, State) ->\n"), + emit(Fd, " ~p:handle_info(Info, State).\n\n", + [list_to_atom(ic_genobj:impl(G))]); + false -> + emit(Fd, "handle_info(_, State) ->\n"), + emit(Fd, " {noreply, State}.\n\n") + end, + nl(Fd), nl(Fd), + case get_opt(G, no_codechange) of + false -> + emit(Fd, "code_change(OldVsn, State, Extra) ->\n"), + emit(Fd, " ~p:code_change(OldVsn, State, Extra).\n\n", + [list_to_atom(ic_genobj:impl(G))]); + true -> + emit(Fd, "code_change(_, State, _) ->\n"), + emit(Fd, " {ok, State}.\n\n") + end, + ok. + + +use_impl_handle_info(G, N, X) -> + FullName = ic_util:to_colon([get_id2(X) | N]), + case {get_opt(G, {handle_info, true}), get_opt(G, {handle_info, FullName})} of + {_, force_false} -> false; + {false, false} -> false; + _ -> true + end. + +use_timeout(G, N, _X) -> + FullName = ic_util:to_colon(N), + case {get_opt(G, {timeout, true}), get_opt(G, {timeout, FullName})} of + {_, force_false} -> false; + {false, false} -> false; + _ -> true + end. + +use_precond(G, N, X) -> + FullName = ic_util:to_colon([get_id2(X) | N]), + case get_opt(G, {precond, FullName}) of + false -> + InterfaceName = ic_util:to_colon(N), + case get_opt(G, {precond, InterfaceName}) of + false -> + case get_opt(G, precond) of + false -> false; + V2 -> V2 + end; + V2 -> V2 + end; + V1 -> V1 + end. + +use_postcond(G, N, X) -> + FullName = ic_util:to_colon([get_id2(X) | N]), + case get_opt(G, {postcond, FullName}) of + false -> + InterfaceName = ic_util:to_colon(N), + case get_opt(G, {postcond, InterfaceName}) of + false -> + case get_opt(G, postcond) of + false -> false; + V3 -> V3 + end; + V2 -> V2 + end; + V1 -> V1 + end. + + +%%------------------------------------------------------------ +%% +%% Export stuff +%% +%% Gathering of all names that should be exported from a stub +%% file. +%% + + +gen_head_special(G, N, X) when is_record(X, interface) -> + Fd = ic_genobj:stubfiled(G), + + foreach(fun({Name, Body}) -> + ic_codegen:comment(Fd, "Exports from ~p", + [ic_util:to_colon(Name)]), + ic_codegen:export(Fd, exp_top(G, N, Body, [], get_opt(G, be))), + nl(Fd) + end, X#interface.inherit_body), + + ic_codegen:comment(Fd, "Type identification function"), + ic_codegen:export(Fd, [{typeID, 0}]), + nl(Fd), + ic_codegen:comment(Fd, "Used to start server"), + ic_codegen:export(Fd, [{oe_create, 0}, {oe_create_link, 0}, {oe_create, 1}, {oe_create_link, 1}, + {oe_create, 2}, {oe_create_link, 2}]), + nl(Fd), + case get_opt(G, be) of + erl_corba -> + ic_codegen:comment(Fd, "TypeCode Functions and inheritance"), + ic_codegen:export(Fd, [{oe_tc, 1}, {oe_is_a, 1}, {oe_get_interface, 0}]); + _ -> + ic_codegen:export(Fd, [{start, 2}, {start_link, 3}]) + end, + nl(Fd), + ic_codegen:comment(Fd, "gen server export stuff"), + emit(Fd, "-behaviour(gen_server).\n"), + + case get_opt(G, be) of + erl_genserv -> %% stop/1 is only for erl_genserv backend + ic_codegen:export(Fd, [{stop, 1}, {init, 1}, {terminate, 2}, {handle_call, 3}, + {handle_cast, 2}, {handle_info, 2}, {code_change, 3}]); + _ -> + ic_codegen:export(Fd, [{init, 1}, {terminate, 2}, {handle_call, 3}, + {handle_cast, 2}, {handle_info, 2}, {code_change, 3}]) + end, + + case get_opt(G, be) of + erl_corba -> + nl(Fd), + emit(Fd, "-include_lib(\"~s/include/~s\").\n", [?ORBNAME, ?CORBAHRL]); + _ -> + ok + end, + nl(Fd), nl(Fd), + ic_codegen:mcomment(Fd, ["Object interface functions."]), + nl(Fd), nl(Fd), nl(Fd), + Fd; +gen_head_special(_G, _N, _X) -> ok. + + + +%% Shall generate all export declarations +gen_head(G, N, X) -> + case ic_genobj:is_stubfile_open(G) of + true -> + F = ic_genobj:stubfiled(G), + ic_codegen:comment(F, "Interface functions"), + ic_codegen:export(F, exp_top(G, N, X, [], get_opt(G, be))), + nl(F), + gen_head_special(G, N, X); + false -> ok + end. + +exp_top(_G, _N, X, Acc, _) when element(1, X) == preproc -> + Acc; +exp_top(G, N, L, Acc, BE) when is_list(L) -> + exp_list(G, N, L, Acc, BE); +exp_top(G, N, M, Acc, BE) when is_record(M, module) -> + exp_list(G, N, get_body(M), Acc, BE); +exp_top(G, N, I, Acc, BE) when is_record(I, interface) -> + exp_list(G, N, get_body(I), Acc, BE); +exp_top(G, N, X, Acc, BE) -> + exp3(G, N, X, Acc, BE). + +exp3(_G, _N, C, Acc, _BE) when is_record(C, const) -> + [{get_id(C#const.id), 0} | Acc]; +exp3(_G, _N, Op, Acc, erl_corba) when is_record(Op, op) -> + FuncName = get_id(Op#op.id), + Arity = length(ic:filter_params([in, inout], Op#op.params)) + 1, + [{FuncName, Arity}, {FuncName, Arity+1} | Acc]; +exp3(G, N, Op, Acc, _BE) when is_record(Op, op) -> + FuncName = get_id(Op#op.id), + Arity = + case use_timeout(G,N,Op) of + true -> + %% NO TimeOut on ONEWAYS here !!!! + case is_oneway(Op) of + true -> + length(ic:filter_params([in, inout], Op#op.params)) + 1; + false -> + length(ic:filter_params([in, inout], Op#op.params)) + 2 + end; + false -> + length(ic:filter_params([in, inout], Op#op.params)) + 1 + end, + [{FuncName, Arity} | Acc]; + +exp3(_G, _N, A, Acc, erl_corba) when is_record(A, attr) -> + lists:foldr(fun(Id, Acc2) -> + {Get, Set} = mk_attr_func_names([], get_id(Id)), + case A#attr.readonly of + {readonly, _} -> [{Get, 1}, {Get, 2} | Acc2]; + _ -> [{Get, 1}, {Get, 2}, + {Set, 2}, {Set, 3} | Acc2] + end end, Acc, ic_forms:get_idlist(A)); +exp3(_G, _N, A, Acc, _BE) when is_record(A, attr) -> + lists:foldr(fun(Id, Acc2) -> + {Get, Set} = mk_attr_func_names([], get_id(Id)), + case A#attr.readonly of + {readonly, _} -> [{Get, 1} | Acc2]; + _ -> [{Get, 1}, {Set, 2} | Acc2] + end end, Acc, ic_forms:get_idlist(A)); + +exp3(_G, _N, _X, Acc, _BE) -> Acc. + +exp_list(G, N, L, OrigAcc, BE) -> + lists:foldr(fun(X, Acc) -> exp3(G, N, X, Acc, BE) end, OrigAcc, L). + + + + +%%------------------------------------------------------------ +%% +%% Emit stuff +%% +%% Low level generation primitives +%% + +emit_stub_func(G, N, X, Name, ArgNames, _TypeList, OutArgs, Oneway, Backend) -> + case ic_genobj:is_stubfile_open(G) of + false -> + ok; + true -> + Fd = ic_genobj:stubfiled(G), + StubName = list_to_atom(Name), + UsingTimeout = use_timeout(G, N, X), + Timeout = case UsingTimeout of + true -> + mk_name(G, "Timeout"); + false -> + "infinity" + end, + Options = mk_name(G, "Options"), + This = mk_name(G, "THIS"), + CallOrCast = + case is_oneway(X) of + true -> ?CAST; + _ -> ?CALL + end, + emit_op_comment(G, Fd, X, StubName, ArgNames, OutArgs), + case Backend of + erl_corba -> + emit(Fd, "~p(~s) ->\n", + [StubName, mk_list([This | ArgNames])]), + emit(Fd, " ~s:~s(~s, ~p, [~s], ?MODULE).\n\n", + [?CORBAMOD, CallOrCast, This, StubName, mk_list(ArgNames)]), + emit(Fd, "~p(~s) ->\n", + [StubName, mk_list([This, Options| ArgNames])]), + emit(Fd, " ~s:~s(~s, ~p, [~s], ?MODULE, ~s).\n\n", + [?CORBAMOD, CallOrCast, This, StubName, mk_list(ArgNames), + Options]); + _ -> + FunName = case ic_options:get_opt(G, scoped_op_calls) of + true -> + list_to_atom(ic_util:to_undersc([Name | N])); + false -> + StubName + end, + %% NO TimeOut on ONEWAYS here !!!! + case Oneway of + true -> + emit(Fd, "~p(~s) ->\n", + [StubName, mk_list([This | ArgNames])]); + false -> + case UsingTimeout of + true -> + emit(Fd, "~p(~s) ->\n", + [StubName, mk_list([This, Timeout| ArgNames])]); + false -> + emit(Fd, "~p(~s) ->\n", + [StubName, mk_list([This | ArgNames])]) + end + end, + + %% NO TimeOut on ONEWAYS here !!!! + if + length(ArgNames) == 0 -> + case is_oneway(X) of + true -> + emit(Fd, " ~s:~s(~s, ~p).\n\n", + [?GENSERVMOD, CallOrCast, This, FunName]); + false -> + emit(Fd, " ~s:~s(~s, ~p, ~s).\n\n", + [?GENSERVMOD, CallOrCast, This, FunName, Timeout]) + end; + true -> + case is_oneway(X) of + true -> + emit(Fd, " ~s:~s(~s, {~p, ~s}).\n\n", + [?GENSERVMOD, CallOrCast, This, FunName, + mk_list(ArgNames)]); + false -> + emit(Fd, " ~s:~s(~s, {~p, ~s}, ~s).\n\n", + [?GENSERVMOD, CallOrCast, This, FunName, + mk_list(ArgNames), Timeout]) + end + end + end + end. + +emit_skel_func(G, N, X, OpName, ArgNames, TypeList, OutArgs, Oneway, Backend) -> + case ic_genobj:is_stubfile_open(G) of + false -> + ok; + true -> + emit_skel_func_helper(G, N, X, OpName, ArgNames, TypeList, OutArgs, + Oneway, Backend) + end. + +emit_skel_func_helper(G, N, X, OpName, ArgNames, _TypeList, OutArgs, Oneway, + erl_corba) -> + Fd = ic_genobj:stubfiled(G), + Name = list_to_atom(OpName), + ImplF = Name, + ImplM = list_to_atom(ic_genobj:impl(G)), + ThisStr = mk_name(G, "THIS"), + FromStr = mk_name(G, "From"), + State = mk_name(G, "State"), + Context = mk_name(G, "Context"), + + {UseFrom, From} = + case Oneway of + false -> + case use_from(G, N, OpName) of + true -> + {FromStr, FromStr}; + false -> + {"false", "_"} + end; + true -> + {"false", "_"} + end, + {UseThis, This} = + case use_this(G, N, OpName) of + true -> + {ThisStr, ThisStr}; + false -> + {"false", "_"} + end, + %% Create argument list string + CallArgs = mk_list(ArgNames), + emit_op_comment(G, Fd, X, Name, ArgNames, OutArgs), + + %% Check if pre and post conditions are specified for this operation + Precond = use_precond(G, N, X), + Postcond = use_postcond(G, N, X), + + case Oneway of + true -> + emit(Fd, "handle_cast({~s, ~s, ~p, [~s]}, ~s) ->\n", + [This, Context, Name, CallArgs, State]), + case {Precond, Postcond} of + {false, false} -> + emit(Fd, " corba:handle_cast(~p, ~p, [~s], ~s, ~s, ~s);\n\n", + [ImplM, ImplF, CallArgs, State, Context, UseThis]); + _ -> + emit(Fd, " corba:handle_cast(~p, ~p, [~s], ~s, ~s, ~s, ~p, ~p, ?MODULE);\n\n", + [ImplM, ImplF, CallArgs, State, Context, UseThis, + Precond, Precond]) + end; + false -> + emit(Fd, "handle_call({~s, ~s, ~p, [~s]}, ~s, ~s) ->\n", + [This, Context, Name, CallArgs, From, State]), + case {Precond, Postcond} of + {false, false} -> + emit(Fd, " corba:handle_call(~p, ~p, [~s], ~s, ~s, ~s, ~s);\n\n", + [ImplM, ImplF, CallArgs, State, Context, UseThis, UseFrom]); + _-> + emit(Fd, " corba:handle_call(~p, ~p, [~s], ~s, ~s, ~s, ~s, ~p, ~p, ?MODULE);\n\n", + [ImplM, ImplF, CallArgs, State, Context, UseThis, UseFrom, + Precond, Postcond]) + end + end; +emit_skel_func_helper(G, N, X, OpName, ArgNames, _TypeList, OutArgs, Oneway, + _Backend) -> + Fd = ic_genobj:stubfiled(G), + Name = list_to_atom(OpName), + ImplF = Name, + ImplM = list_to_atom(ic_genobj:impl(G)), + FromStr = mk_name(G, "From"), + State = mk_name(G, "State"), + + %% Create argument list + CallArgs1 = [State | ArgNames], + {CallArgs2, From} = + case is_oneway(X) of + false -> + case use_from(G, N, OpName) of + true -> + {[FromStr | CallArgs1], FromStr}; + false -> + {CallArgs1, "_"} + end; + true -> + {CallArgs1, "_"} + end, + %% Create argument list string + CallArgs = mk_list(CallArgs2), + emit_op_comment(G, Fd, X, Name, ArgNames, OutArgs), + FunName = case ic_options:get_opt(G, scoped_op_calls) of + true -> + list_to_atom(ic_util:to_undersc([OpName | N])); + false -> + list_to_atom(OpName) + end, + case Oneway of + true -> + if + length(ArgNames) == 0 -> + emit(Fd, "handle_cast(~p, ~s) ->\n", [FunName, State]); + true -> + emit(Fd, "handle_cast({~p, ~s}, ~s) ->\n", + [FunName, mk_list(ArgNames), State]) + end, + emit(Fd, " ~p:~p(~s);\n\n", [ImplM, ImplF, CallArgs]); + false -> + if + length(ArgNames) == 0 -> + emit(Fd, "handle_call(~p, ~s, ~s) ->\n", + [FunName, From, State]); + true -> + emit(Fd, "handle_call({~p, ~s}, ~s, ~s) ->\n", + [FunName, mk_list(ArgNames), From, State]) + end, + emit(Fd, " ~p:~p(~s);\n\n", [ImplM, ImplF, CallArgs]) + end. + +use_this(G, N, OpName) -> + FullOp = ic_util:to_colon([OpName|N]), + FullIntf = ic_util:to_colon(N), + case {get_opt(G, {this, FullIntf}), get_opt(G, {this, FullOp}), + get_opt(G, {this, true})} of + {_, force_false, _} -> false; + {force_false, false, _} -> false; + {false, false, false} -> false; + _ -> true + end. + +use_from(G, N, OpName) -> + FullOp = ic_util:to_colon([OpName|N]), + FullIntf = ic_util:to_colon(N), + case {get_opt(G, {from, FullIntf}), get_opt(G, {from, FullOp}), + get_opt(G, {from, true})} of + {_, force_false, _} -> false; + {force_false, false, _} -> false; + {false, false, false} -> false; + _ -> true + end. + + +emit_constant_func(G, Id, Val) -> + case ic_genobj:is_stubfile_open(G) of + false -> ok; + true -> + Fd = ic_genobj:stubfiled(G), + N = list_to_atom(get_id(Id)), + emit_const_comment(G, Fd, Id, N), + emit(Fd, "~p() -> ~p.\n\n", [N, Val]) + end. + + + +emit_const_comment(_G, F, _X, Name) -> + ic_codegen:mcomment_light(F, + [io_lib:format("Constant: ~p", [Name])]). + + +emit_op_comment(G, F, X, Name, InP, OutP) -> + ic_codegen:mcomment_light(F, + [io_lib:format("~s: ~p", [get_title(X), Name]), + "", + get_returns(G, X, InP, OutP) | + get_raises(X)]). + +get_title(X) when is_record(X, attr) -> "Attribute Operation"; +get_title(_X) -> "Operation". + +get_raises(X) when is_record(X, op) -> + if X#op.raises == [] -> []; + true -> + [" Raises: " ++ + mk_list(lists:map(fun(E) -> ic_util:to_colon(E) end, + X#op.raises))] + end; +get_raises(_X) -> []. + +get_returns(_G, _X, _InP, []) -> + " Returns: RetVal"; +get_returns(G, _X, _InP, OutP) -> + " Returns: "++mk_list(["RetVal" | mk_erl_vars(G, OutP)]). + + + + +%%------------------------------------------------------------ +%% +%% Utilities +%% +%% Convenient little go-get functions +%% +%%------------------------------------------------------------ + +%% The automaticly generated get and set operation names for an +%% attribute. +mk_attr_func_names(_Scope, Name) -> + {"_get_" ++ Name, "_set_" ++ Name}. +%% {scoped_name(Scope, "_get_"++Name), scoped_name(Scope, "_set_"++Name)}. + +%% Returns TK of the Get and Set attribute functions. +mk_attr_func_types(_N, X) -> + TK = ic_forms:get_tk(X), + {{TK, [], []}, {tk_void, [TK], []}}. + + + +%%------------------------------------------------------------ +%% +%% Generation utilities and common stuff +%% +%% Convenient stuff for generation +%% +%%------------------------------------------------------------ + + +%% Input is a list of parameters (in parse form) and output is a list +%% of capitalised variable names. mk_var is in icgen +mk_erl_vars(_G, Params) -> + map(fun(P) -> mk_var(get_id(P#param.id)) end, Params). + + +%% mk_list produces a nice comma separated string of variable names +mk_list([]) -> []; +mk_list([Arg | Args]) -> + Arg ++ mk_list2(Args). +mk_list2([Arg | Args]) -> + ", " ++ Arg ++ mk_list2(Args); +mk_list2([]) -> []. + + +%%------------------------------------------------------------ +%% +%% Parser utilities +%% +%% Called from the yecc parser. Expands the identifier list of an +%% attribute so that the attribute generator never has to handle +%% lists. +%% +%%------------------------------------------------------------ + + +%% Unfold identifier lists or nested lists. Note that many records +%% contain an entry named id that is a list before unfold and a single +%% id afterwards. +unfold(L) when is_list(L) -> + lists:flatten(map(fun(X) -> unfold2(X) end, L)); +unfold(X) -> unfold2(X). + +unfold2(A) when is_record(A, attr) -> + map(fun(Id) -> A#attr{id=Id} end, A#attr.id); +unfold2(M) when is_record(M, member) -> + map(fun(Id) -> M#member{id=Id} end, M#member.id); +unfold2(M) when is_record(M, case_dcl) -> + map(fun(Id) -> M#case_dcl{label=Id} end, M#case_dcl.label); +unfold2(T) when is_record(T, typedef) -> + map(fun(Id) -> T#typedef{id=Id} end, T#typedef.id). + + + + +%% Code produce for dependency function +genDependency(G) -> + Fd = ic_genobj:stubfiled(G), + nl(Fd),nl(Fd), + ic_codegen:comment(Fd, "Idl file dependency list function"), + emit(Fd, "oe_dependency() ->\n\n", []), + emit(Fd, " ~p.\n\n", [ic_pragma:get_dependencies(G)]). diff --git a/lib/ic/src/ic_error.erl b/lib/ic/src/ic_error.erl new file mode 100644 index 0000000000..f41e78a8be --- /dev/null +++ b/lib/ic/src/ic_error.erl @@ -0,0 +1,375 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1998-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_error). + +-include_lib("ic/src/ic.hrl"). +-include_lib("ic/src/ic_debug.hrl"). + +%%----------------------------------------------------------------- +%% External exports +%%----------------------------------------------------------------- +-export([error/2, + fatal_error/2, + init_errors/1, + return/1, + warn/2, + get_error_count/1]). + +%%----------------------------------------------------------------- +%% Internal exports +%%----------------------------------------------------------------- +-export([]). + +%%----------------------------------------------------------------- +%% External functions +%%----------------------------------------------------------------- + +%%-------------------------------------------------------------------- +%% +%% Error and warning utilities. +%% +%% Note that errors are somewhat brutal and that warnings are kept in +%% a list for the user to extract at a later stage. The handling of +%% warnings is entirely up to the user while handling of errors is +%% never left to the user. +%% +%%-------------------------------------------------------------------- + +return(G) -> + case ic_options:get_opt(G, silent2) of + true -> + case get_error_count(G) of + 0 -> {ok, get_list(G, warn_list)}; + _X -> {error, get_list(G, warn_list), get_list(G, error_list)} + end; + false -> + case get_error_count(G) of + 0 -> ok; + X -> print_error(G, {error, g, ic_genobj:idlfile(G), {error_count, X}}), + error + end + end. + + +get_list(G, ListName) -> + ?lookup(G#genobj.options, ListName). + + +%% Public function for reporting an error +error(G, Err) -> + Error = {error, g, ic_genobj:idlfile(G), Err}, + case insert_in_list(G, Error, error_list) of + new -> + print_error(G, Error), + MaxErrs = ic_options:get_opt(G, maxerrs), + case incr_counter(G, error_count) of + X when X >= MaxErrs -> + fatal_error(G, {error_count_exceeded, X}); + _ -> Error + end; + old -> + Error + end. + +%% Public function for reporting an error. NOTE: also stops execution +fatal_error(G, Err) -> + Error = {error, g, ic_genobj:idlfile(G), Err}, + insert_in_list(G, Error, error_list), + incr_counter(G, error_count), + print_error(G, Error), + throw(Error). + + +%% Public function for reporting a warning +warn(G, Warn) -> + Warning = {warn, g, ic_genobj:idlfile(G), Warn}, + case insert_in_list(G, Warning, warn_list) of + new -> + print_warn(G, Warning), + MaxErrs = ic_options:get_opt(G, maxwarns), + case incr_counter(G, warn_count) of + X when X >= MaxErrs -> + fatal_error(G, {warn_count_exceeded, X}); + _ -> ok + end; + old -> ok +end. + + +%% Initialisation of all counters and lists associated with errors and +%% warnings. +init_errors(G) -> + reset_counter(G, error_count), + reset_counter(G, warn_count), + reset_list(G, error_list), + reset_list(G, warn_list), + ok. + + + +%%-------------------------------------------------------------------- +%% Counter and list (warn and error) handling +%% + +incr_counter(G, Counter) -> + Num = ?lookup(G#genobj.options, Counter) + 1, + ?insert(G#genobj.options, Counter, Num), + Num. + +reset_counter(G, Counter) -> + ?insert(G#genobj.options, Counter, 0). + +get_error_count(G) -> + ?lookup(G#genobj.options, error_count). + +reset_list(G, ListName) -> + ?insert(G#genobj.options, ListName, []). + +insert_in_list(G, Item, ListName) -> + List = ?lookup(G#genobj.options, ListName), + case lists:member(Item, List) of + true -> old; + false -> + ?insert(G#genobj.options, ListName, [Item| List]), + new + end. + + +%%-------------------------------------------------------------------- +%% +%% Nice printouts of errors and warnings +%% + + +%% Errors + +print_error(G, Error) -> + case {ic_options:get_opt(G, silent), ic_options:get_opt(G, silent2)} of + {true, _} -> ok; + {_, true} -> ok; + _ -> format_error(Error) + end, + error. + +format_error({error, _, File, {parse_error, Line, Args}}) -> + Fmt = lists:foldl(fun(_, Acc) -> [$~, $s | Acc] end, [], Args), + display(File, Line, Fmt, Args); +format_error({error, _, File, {error_count, X}}) -> + display(File, "~p errors found", [X]); +format_error({error, _, File, {error_count_exceeded, X}}) -> + display(File, "too many errors found (~p)", [X]); +format_error({error, _, File, {warn_count_exceeded, X}}) -> + display(File, "too many warnings found (~p)", [X]); +format_error({error, _, File, {inherit_name_collision, + {Orig, Item}, {Base, NewItem}}}) -> + display(File, ic_forms:get_line(Item), "~s collides with ~s", + [pp([ic_forms:get_id2(Item) | Orig]), pp([ic_forms:get_id2(NewItem) | Base])]); +format_error({error, _, File, {unsupported_op, {'~', Line}}}) -> + display(File, Line, "unsupported unary operation ~~", []); +format_error({error, _, File, {multiply_defined, X}}) -> + display(File, ic_forms:get_line(X), "multiple defined identifier ~p", [ic_forms:get_id2(X)]); +format_error({error, _, File, {illegal_spelling, X}}) -> + display(File, ic_forms:get_line(X), +% "illegal spelling of identifier ~s (capitalisation?)", + "identifier ~p multiply declared - differs in case only", + [ic_forms:get_id2(X)]); +format_error({error, _, File, {illegal_enumerant_value, X}}) -> + display(File, ic_forms:get_line(X), + "Enumerant ~s's value collide by name with other type", + [ic_forms:get_id2(X)]); +format_error({error, _, File, {illegal_forward, X}}) -> + display(File, ic_forms:get_line(X), + "cannot inherit from forwarded interface ~s", [ic_forms:get_id2(X)]); +format_error({error, _, File, {illegal_const_t, X, Type}}) -> + display(File, ic_forms:get_line(X), + "Illegal constant type ~s of ~s", [pp(Type), ic_forms:get_id2(X)]); +format_error({error, _, File, {multiple_cases, X}}) -> + display(File, ic_forms:get_line(X), "multiple case values ~s", [pp(X)]); +format_error({error, _, File, {symtab_not_found, X}}) -> + display(File, ic_forms:get_line(X), "undeclared identifier ~s", [ic_forms:get_id2(X)]); +format_error({error, _, File, {preproc, Lines}}) -> + display(File, "preprocessor error: ~s", [hd(Lines)]); +format_error({error, _, File, {ic_pp_error, Lines}}) -> + display(File, "preprocessor error: ~s", [Lines]); +format_error({error, _, File, {illegal_float, Line}}) -> + display(File, Line, "illegal floating point number", []); +format_error({error, _, File, {bad_type_combination, E, V1, V2}}) -> + display(File, ic_forms:get_line(E), "incompatible types, ~p and ~p", [V1, V2]); +format_error({error, _, File, {bad_oneway_type, X, _TK}}) -> + display(File, ic_forms:get_line(X), "oneway operations must be declared void", []); +format_error({error, _, File, {inout_spec_for_c, X, Arg}}) -> + display(File, ic_forms:get_line(X), "inout parameter ~s specified in native c mode", + [Arg]); +format_error({error, _, File, {sequence_not_defined, X, Arg}}) -> + display(File, ic_forms:get_line(X), "sequence ~s not defined", [Arg]); +format_error({error, _, File, {illegal_typecode_for_c, Arg}}) -> + display(File, not_specified, "illegal typecode ~s used in native c mode", + [Arg]); +format_error({error, _, File, {name_not_found, N}}) -> + display(File, not_specified, "name ~s not found", [N]); +format_error({error, _, File, {illegal_typecode_for_c, Arg, N}}) -> + display(File, not_specified, "illegal typecode ~p used for ~p in native c mode", [Arg, N]); +format_error({error, _, File, {oneway_outparams, X}}) -> + display(File, ic_forms:get_line(X), + "oneway operations may not have out or inout parameters", []); +format_error({error, _, File, {oneway_raises, X}}) -> + display(File, ic_forms:get_line(X), "oneway operations may not raise exceptions", + []); +format_error({error, _, File, {bad_tk_match, T, TK, V}}) -> + display(File, ic_forms:get_line(T), + "value ~p does not match declared type ~s", [V, pp(TK)]); +format_error({error, _, File, {bad_scope_enum_case, ScopedId}}) -> + display(File, ic_forms:get_line(ScopedId), + "scoped enum identifiers not allowed as case (~s)", + [pp(ScopedId)]); +format_error({error, _, File, {bad_type, Expr, Op, _TypeList, V}}) -> + display(File, ic_forms:get_line(Expr), + "parameter value ~p to ~s is of illegal type", [V, pp(Op)]); +format_error({error, _, File, {bad_case_type, TK, X, Val}}) -> + display(File, ic_forms:get_line(X), + "case value ~s does not match discriminator type ~s", + [case_pp(X, Val), pp(TK)]); +format_error({error, _, File, {tk_not_found, X}}) -> + display(File, ic_forms:get_line(X), "undeclared identifier ~s", [pp(X)]); +%%% New format_errors +format_error({error, _, File, {bad_fixed, Format, Args, Line}}) -> + display(File, Line, Format, Args); +format_error({error, _, File, {illegal_switch_t, Arg, _N}}) -> + display(File, ic_forms:get_line(Arg), "illegal switch", []); +format_error({error, _, File, {inherit_resolve, Arg, N}}) -> + display(File, ic_forms:get_line(Arg), "cannot resolve ~s", [N]); +format_error({error, _, File, {bad_escape_character, Line, Char}}) -> + display(File, Line, "bad escape character \"~c\"", [Char]); +format_error({error, _, File, {pragma_code_opt_bad_option_list, Line}}) -> + display(File, Line, "bad option list on pragma \"CODEOPT\"", []); +format_error({error, _, File, {bad_string, Line}}) -> + display(File, Line, "bad string", []); +format_error({error, _, File, {create_dir, Path, Reason}}) -> + display(File, not_specified, "couldn't create directory ~p due to ~p", [Path, Reason]); +format_error({error, _, File, {open_file, Path, Reason}}) -> + display(File, not_specified, "couldn't open ~p due to ~p", [Path, Reason]); +format_error({error, _, File, {plain_error_string, ErrString}}) -> + display(File, not_specified, "~s", [ErrString]); +format_error({error, _, File, {plain_error_string, T, ErrString}}) -> + display(File, ic_forms:get_line(T), "~s", [ErrString]); +format_error({error, _, File, {ErrString, Line}}) -> + display(File, Line, ErrString, []). + + +%% Warnings +print_warn(G, Warn) -> + case {ic_options:get_opt(G, silent), ic_options:get_opt(G, silent2)} of + {true, _} -> ok; + {_, true} -> ok; + _ -> format_warn(Warn) + end. + +format_warn({warn, _, File, {ic_pp_warning, Lines}}) -> + display(File, "preprocessor warning: ~s", [Lines]); +format_warn({warn, _, _File, {cfg_open, _Reason, File}}) -> + display(File, "warning: could not open file: ~p", [File]); +format_warn({warn, _, _File, {cfg_read, File}}) -> + display(File, "warning: syntax error in configuration file", []); +format_warn({warn, _, File, {multi_modules, Id}}) -> + display(File, ic_forms:get_line(Id), "warning: multiple modules in file", []); +format_warn({warn, _, File, {illegal_opt, Opt}}) -> + display(File, "warning: unrecognised option: ~p", [Opt]); +format_warn({warn, _, File, {nested_mod, Id}}) -> + display(File, ic_forms:get_line(Id), "warning: nested module: ~s", [ic_forms:get_id(Id)]); +format_warn({warn, _, File, {inherit_name_shadow, {Orig, Item}, + {Base, NewItem}}}) -> + display(File, ic_forms:get_line(Item), + "warning: ~s shadows ~s", [pp([ic_forms:get_id2(Item) | Orig]), + pp([ic_forms:get_id2(NewItem) | Base])]); +format_warn({warn, _, File, {internal_307, X, Y}}) -> + %% If global Scope variable is not [] at top level constant + display(File, ic_forms:get_line(X), "warning: internal 307: ~p ~p", [X, Y]); +format_warn({warn, _, File, {WarnString, Line}}) -> + display(File, Line, WarnString, []). + +%% Display an error or warning +display(File, not_specified, F, A) -> + io:format("~p : ~s~n", [File, io_lib:format(F, A)]); +display(File, Line, F, A) -> + io:format("~p on line ~p: ~s~n", [File, Line, io_lib:format(F, A)]). +display(File, F, A) -> + io:format("~p: ~s~n", [File, io_lib:format(F, A)]). + + + +%%format_warn2(G, WarnStr) -> +%% case {ic_options:get_opt(G, silent), ic_options:get_opt(G, silent2), +%% ic_options:get_opt(G, nowarn)} of +%% {false, false, false} -> +%% io:format("~p: warning: ~s~n", [ic_genobj:idlfile(G), WarnStr]); +%% _ -> ok +%% end. + +%%format_warn2(G, Line, WarnStr) -> +%% case {ic_options:get_opt(G, silent), ic_options:get_opt(G, silent2), +%% ic_options:get_opt(G, nowarn)} of +%% {false, false, false} -> +%% io:format("~p on line ~p: warning: ~s~n", +%% [ic_genobj:idlfile(G), Line, WarnStr]); +%% _ -> ok +%% end. + + + + +%% pretty print various stuff + +pp({tk_string, _}) -> "string"; +pp({tk_wstring, _}) -> "wstring"; +pp(tk_long) -> "long"; +pp(tk_short) -> "short"; +pp(tk_ushort) -> "unsigned short"; +pp(tk_ulong) -> "unsigned long"; +pp(tk_float) -> "float"; +pp(tk_double) -> "double"; +pp(tk_boolean) -> "boolean"; +pp(tk_char) -> "char"; +pp(tk_wchar) -> "wchar"; +pp(tk_octet) -> "octet"; +pp(tk_null) -> "null"; +pp(tk_void) -> "void"; +pp(tk_any) -> "any"; +pp({tk_fixed, _, _}) -> "fixed"; +pp({tk_objref, _, _}) -> "object reference"; +pp(rshift) -> ">>"; +pp(lshift) -> "<<"; +pp(X) when element(1, X) == tk_enum -> "enum"; +pp(X) when is_record(X, scoped_id) -> ic_util:to_colon(X); +pp(X) when element(1, X) == '' -> ic_forms:get_id(X); +pp(X) when is_list(X) andalso is_list(hd(X)) -> ic_util:to_colon(X); +pp({_, Num, Beef}) when is_integer(Num) -> Beef; +pp({Beef, Num}) when is_integer(Num) -> ic_util:to_list(Beef); +pp(X) -> ic_util:to_list(X). + +%% special treatment of case label names +case_pp(X, _Val) when is_record(X, scoped_id) -> pp(X); +case_pp(_X, Val) -> pp(Val). + + + +%%----------------------------------------------------------------- +%% Internal functions +%%----------------------------------------------------------------- diff --git a/lib/ic/src/ic_fetch.erl b/lib/ic/src/ic_fetch.erl new file mode 100644 index 0000000000..c1b140ef11 --- /dev/null +++ b/lib/ic/src/ic_fetch.erl @@ -0,0 +1,388 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1998-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_fetch). + +-include("icforms.hrl"). + +-export([member2type/3]). + +-export([fetchTk/3, isArray/3, isBasicType/1, isBasicType/2, + isBasicType/3, isBasicTypeOrEterm/3, isEterm/3, isString/3, + isStruct/3, isUnion/3, name2type/2, searchIncludedTk/2, + searchInsideTks/2, searchTk/2, searchTk/3]). + +name2type(G, Name) -> + S = ic_genobj:tktab(G), + ScopedName = lists:reverse(string:tokens(Name,"_")), + InfoList = ets:lookup( S, ScopedName ), + filter( InfoList ). + + + +%% This is en overloaded function, +%% differs in input on unions +member2type(_G, X, I) when is_record(X, union)-> + Name = ic_forms:get_id2(I), + case lists:keysearch(Name,2,element(6,X#union.tk)) of + false -> + error; + {value,Rec} -> + fetchType(element(3,Rec)) + end; +member2type( G, SName, MName ) -> + + S = ic_genobj:tktab( G ), + SNList = lists:reverse(string:tokens(SName,"_")), + ScopedName = [MName | SNList], + InfoList = ets:lookup( S, ScopedName ), + + case filter( InfoList ) of + error -> + %% Try a little harder, seeking inside tktab + case lookup_member_type_in_tktab(S, ScopedName, MName) of + error -> + %% Check if this is the "return to return1" case + case MName of + "return1" -> + %% Do it all over again ! + ScopedName2 = ["return" | SNList], + InfoList2 = ets:lookup( S, ScopedName2 ), + case filter( InfoList2 ) of + error -> + %% Last resort: seek in pragma table + lookup_type_in_pragmatab(G, SName); + + Other -> + Other + end; + _ -> + %% Last resort: seek in pragma table + lookup_type_in_pragmatab(G, SName) + end; + Other -> + Other + end; + Other -> + Other + end. + + +lookup_member_type_in_tktab(S, ScopedName, MName) -> + case ets:match_object(S, {'_',member,{MName,'_'},nil}) of + [] -> + error; + [{_FullScopedName,member,{MName,TKInfo},nil}]-> + fetchType( TKInfo ); + List -> + lookup_member_type_in_tktab(List,ScopedName) + end. + +lookup_member_type_in_tktab([],_ScopedName) -> + error; +lookup_member_type_in_tktab([{FullScopedName,_,{_,TKInfo},_}|Rest],ScopedName) -> + case lists:reverse(string:tokens(ic_util:to_undersc(FullScopedName),"_")) of + ScopedName -> + fetchType(TKInfo); + _ -> + lookup_member_type_in_tktab(Rest,ScopedName) + end. + + +lookup_type_in_pragmatab(G, SName) -> + S = ic_genobj:pragmatab(G), + + %% Look locally first + case ets:match(S,{file_data_local,'_','_','$2','_','_',SName,'_','_'}) of + [] -> + %% No match, seek included + case ets:match(S,{file_data_included,'_','_','$2','_','_',SName,'_','_'}) of + + [] -> + error; + [[Type]] -> + io:format("1 Found(~p) : ~p~n",[SName,Type]), + Type + end; + + [[Type]] -> + io:format("2 Found(~p) : ~p~n",[SName,Type]), + Type + end. + + + + +filter( [] ) -> + error; +filter( [I | Is ] ) -> + case I of + { _, member, { _, TKINFO }, _ } -> + fetchType( TKINFO ); + + { _, struct, _, _ } -> + struct; + + { _, typedef, TKINFO, _ } -> + fetchType( TKINFO ); + + { _, module, _, _ } -> + module; + + { _, interface, _, _ } -> + interface; + + { _, op, _, _ } -> + op; + + { _,enum, _, _ } -> + enum; + + { _, spellcheck } -> + filter( Is ); + + _ -> + error + end. + + +fetchType( { tk_sequence, _, _ } ) -> + sequence; +fetchType( { tk_array, _, _ } ) -> + array; +fetchType( { tk_struct, _, _, _} ) -> + struct; +fetchType( { tk_string, _} ) -> + string; +fetchType( tk_short ) -> + short; +fetchType( tk_long ) -> + long; +fetchType( tk_ushort ) -> + ushort; +fetchType( tk_ulong ) -> + ulong; +fetchType( tk_float ) -> + float; +fetchType( tk_double ) -> + double; +fetchType( tk_boolean ) -> + boolean; +fetchType( tk_char ) -> + char; +fetchType( tk_octet ) -> + octet; +fetchType( { tk_enum, _, _, _ } ) -> + enum; +fetchType( { tk_union, _, _, _, _, _ } ) -> + union; +fetchType( tk_any ) -> + any; +fetchType( _ ) -> + error. + +isBasicTypeOrEterm(G, N, S) -> + case isBasicType(G, N, S) of + true -> + true; + false -> + isEterm(G, N, S) + end. + + +isEterm(G, N, S) when element(1, S) == scoped_id -> + {FullScopedName, _, _TK, _} = ic_symtab:get_full_scoped_name(G, N, S), + case ic_code:get_basetype(G, ic_util:to_undersc(FullScopedName)) of + "erlang_term" -> + true; + "ETERM*" -> + true; + _X -> + false + end; +isEterm(_G, _Ni, _X) -> + false. + +isBasicType(G, N, S) when element(1, S) == scoped_id -> + {_, _, TK, _} = ic_symtab:get_full_scoped_name(G, N, S), + isBasicType(fetchType(TK)); +isBasicType(_G, _N, {string, _} ) -> + false; +isBasicType(_G, _N, {Type, _} ) -> + isBasicType(Type). + + +isBasicType(G, Name) -> + isBasicType(name2type(G, Name )). + + +isBasicType(Type) -> + lists:member(Type, + [tk_short,short, + tk_long,long, + tk_ushort,ushort, + tk_ulong,ulong, + tk_float,float, + tk_double,double, + tk_boolean,boolean, + tk_char,char, + tk_octet,octet]). + + + +isString(G, N, T) when element(1, T) == scoped_id -> + case ic_symtab:get_full_scoped_name(G, N, T) of + {_FullScopedName, _, {'tk_string',_}, _} -> + true; + _ -> + false + end; +isString(_G, _N, T) when is_record(T, string) -> + true; +isString(_G, _N, _Other) -> + false. + + +isArray(G, N, T) when element(1, T) == scoped_id -> + case ic_symtab:get_full_scoped_name(G, N, T) of + {_FullScopedName, _, {'tk_array', _, _}, _} -> + true; + _ -> + false + end; +isArray(_G, _N, T) when is_record(T, array) -> + true; +isArray(_G, _N, _Other) -> + false. + + + +isStruct(G, N, T) when element(1, T) == scoped_id -> + case ic_symtab:get_full_scoped_name(G, N, T) of + {_FullScopedName, _, {'tk_struct', _, _, _}, _} -> + true; + _ -> + false + end; +isStruct(_G, _N, T) when is_record(T, struct) -> + true; +isStruct(_G, _N, _Other) -> + false. + + + +isUnion(G, N, T) when element(1, T) == scoped_id -> + case ic_symtab:get_full_scoped_name(G, N, T) of + {_FullScopedName, _, {'tk_union', _, _, _,_,_}, _} -> + true; + _Other -> + false + end; +isUnion(_G, _N, T) when is_record(T, union) -> + true; +isUnion(_G, _N, _Other) -> + false. + + + +%%------------------------------------------------------------ +%% +%% Always fetchs TK of a record. +%% +%%------------------------------------------------------------ +fetchTk(G,N,X) -> + case ic_forms:get_tk(X) of + undefined -> + searchTk(G,ictk:get_IR_ID(G, N, X)); + TK -> + TK + end. + + +%%------------------------------------------------------------ +%% +%% seek type code when not accessible by get_tk/1 +%% +%%------------------------------------------------------------ +searchTk(G,IR_ID) -> + S = ic_genobj:tktab(G), + case catch searchTk(S,IR_ID,typedef) of + {value,TK} -> + TK; + _ -> %% false / exit + case catch searchTk(S,IR_ID,struct) of + {value,TK} -> + TK; + _ -> %% false / exit + case catch searchTk(S,IR_ID,union) of + {value,TK} -> + TK; + _ -> + undefined + end + end + end. + + +searchTk(S,IR_ID,Type) -> + L = lists:flatten(ets:match(S,{'_',Type,'$1','_'})), + case lists:keysearch(IR_ID,2,L) of + {value,TK} -> + {value,TK}; + false -> + searchInsideTks(L,IR_ID) + end. + + +searchInsideTks([],_IR_ID) -> + false; +searchInsideTks([{tk_array,TK,_}|Xs],IR_ID) -> + case searchIncludedTk(TK,IR_ID) of + {value,TK} -> + {value,TK}; + false -> + searchInsideTks(Xs,IR_ID) + end. + + +searchIncludedTk({tk_array,TK,_},IR_ID) -> + searchIncludedTk(TK,IR_ID); +searchIncludedTk({tk_sequence,TK,_},IR_ID) -> + searchIncludedTk(TK,IR_ID); +searchIncludedTk(TK,_IR_ID) when is_atom(TK) -> + false; +searchIncludedTk(TK,IR_ID) -> + case element(2,TK) == IR_ID of + true -> + {value,TK}; + false -> + false + end. + + + + + + + + + + + diff --git a/lib/ic/src/ic_file.erl b/lib/ic/src/ic_file.erl new file mode 100644 index 0000000000..6a99d6cfde --- /dev/null +++ b/lib/ic/src/ic_file.erl @@ -0,0 +1,447 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1999-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_file). + +-include_lib("ic/src/ic.hrl"). + +%%----------------------------------------------------------------- +%% External exports +%%----------------------------------------------------------------- +-export([filename_push/4, filename_pop/2, open/2, close/1, remove_ext/1, join/2, + add_dot_erl/1, add_dot_hrl/1, add_dot_c/1, add_dot_h/1, add_dot_java/1, + add_dot_idl/1, javaInterfaceFilePush/3, javaInterfaceFilePop/1, + createDirectory/2, createJavaDirectory/2, open_java_file/3]). + +%%----------------------------------------------------------------- +%% Internal exports +%%----------------------------------------------------------------- +-export([]). + +%%----------------------------------------------------------------- +%% External functions +%%----------------------------------------------------------------- + +%%----------------------------------------------------------------- +%% Func: filename_push +%% +%% Pushes a file name, can also push ignore in which case means that +%% no files should ever be opened at this scope. Note that empty in +%% the file descriptor entries means that the file just isn't open +%% yet. +%%----------------------------------------------------------------- +filename_push(G, _N, ignore, _) -> + G#genobj{stubfile=[ignore | G#genobj.stubfile], + stubfiled=[ignore | G#genobj.stubfiled], + skelfile=[ignore | G#genobj.skelfile], + skelfiled=[ignore | G#genobj.skelfiled], + includefile=[ignore | G#genobj.includefile], + includefiled=[ignore | G#genobj.includefiled]}; + +filename_push(G, N, X, Lang) -> + Fullname = [ic_forms:get_id2(X) | N], + EName0 = ic_util:to_undersc(Fullname), + + DoGen = ic_genobj:do_gen(G), + + ImplName = find_impl_name(G, Fullname), + + {StubName, EName} = + case Lang of + erlang -> + {join(ic_options:get_opt(G, stubdir), add_dot_erl(EName0)), + EName0}; + erlang_template -> + {join(ic_options:get_opt(G, stubdir), add_dot_erl(ImplName)), + ImplName}; + c -> + {join(ic_options:get_opt(G, stubdir), add_dot_c(EName0)), + EName0}; + c_server -> + {join(ic_options:get_opt(G, stubdir), add_dot_c(EName0++"__s")), + EName0}; + erlang_template_no_gen -> + {undefined, EName0}; + erlang_no_stub -> + {undefined, EName0}; + c_no_stub -> + {undefined, EName0}; + c_server_no_stub -> + {undefined, EName0} + end, + Stub = if DoGen==true -> + case StubName of + undefined -> + ignore; + _ -> + ic_codegen:emit_stub_head(G, open(empty, StubName), EName, Lang) + end; + true -> ignore end, + + HrlName = case Lang of + erlang_template -> + ignore; + erlang_template_no_gen -> + ignore; + erlang -> + ?ifopt2(G, gen_hrl, + join(ic_options:get_opt(G, stubdir), add_dot_hrl(EName)), + ignore); + c -> + ?ifopt2(G, gen_hrl, + join(ic_options:get_opt(G, stubdir), add_dot_h(EName)), + ignore); + c_server -> + ?ifopt2(G, gen_hrl, + join(ic_options:get_opt(G, stubdir), + add_dot_h(EName++"__s")), + ignore); + erlang_no_stub -> + ?ifopt2(G, gen_hrl, + join(ic_options:get_opt(G, stubdir), add_dot_hrl(EName)), + ignore); + c_no_stub -> + ?ifopt2(G, gen_hrl, + join(ic_options:get_opt(G, stubdir), add_dot_h(EName)), + ignore); + c_server_no_stub -> + ?ifopt2(G, gen_hrl, + join(ic_options:get_opt(G, stubdir), + add_dot_h(EName++"__s")), + ignore) + end, + Hrl = if DoGen==true -> + case Lang of + erlang_template -> + ignore; + erlang_template_no_gen -> + ignore; + erlang_no_stub -> + ic_codegen:emit_hrl_head(G, open(empty, HrlName), + EName, erlang); + c_no_stub -> + ic_codegen:emit_hrl_head(G, open(empty, HrlName), + EName, c); + c_server_no_stub -> + ic_codegen:emit_hrl_head(G, open(empty, HrlName), + EName, c_server); + _ -> + ic_codegen:emit_hrl_head(G, open(empty, HrlName), + EName, Lang) + end; + true -> ignore end, + + G#genobj{impl=ImplName, + stubfile=[StubName | G#genobj.stubfile], + stubfiled=[Stub | G#genobj.stubfiled], + includefile=[HrlName | G#genobj.includefile], + includefiled=[Hrl | G#genobj.includefiled]}. + +%%----------------------------------------------------------------- +%% Func: join/2 +%% +%% Special version of filename join. +%%----------------------------------------------------------------- +join([], File) -> + File; +join(Path, File) -> + filename:join(Path, File). + + +%%----------------------------------------------------------------- +%% Func: filename_pop/2 +%%----------------------------------------------------------------- +filename_pop(G, Lang) -> +%% io:format("Popped file names: ~p~n", [hd(G#genobj.stubfile)]), +%% case is_skelfile_open(G) of +%% true -> emit_skel_footer(G); +%% false -> ok end, +%% close(hd(G#genobj.skelfiled)), + close(hd(G#genobj.stubfiled)), + ic_codegen:emit_hrl_foot(G, Lang), + close(hd(G#genobj.includefiled)), + G#genobj{stubfile=tl(G#genobj.stubfile), + stubfiled=tl(G#genobj.stubfiled), +%% skelfile=tl(G#genobj.skelfile), +%% skelfiled=tl(G#genobj.skelfiled), + includefile=tl(G#genobj.includefile), + includefiled=tl(G#genobj.includefiled)}. + + + +%%----------------------------------------------------------------- +%% Func: javaInterfaceFilePush/3 +%%----------------------------------------------------------------- +javaInterfaceFilePush(G, N, X) -> + Name = ic_forms:get_java_id(X), + {InterfaceFd, InterfaceFileName} = open_java_file(G, N, Name), + + StubClassName = "_" ++ Name ++ "Stub", + {StubFd, StubFileName} = open_java_file(G, N, StubClassName), + + SkelClassName = "_" ++ Name ++ "ImplBase", + {SkelFd, SkelFileName} = open_java_file(G, N, SkelClassName), + + HelperClassName = Name ++ "Helper", + {HelperFd, HelperFileName} = open_java_file(G, N, HelperClassName), + + HolderClassName = Name ++ "Holder", + {HolderFd, HolderFileName} = open_java_file(G, N, HolderClassName), + + G#genobj{ + interfacefile=[InterfaceFileName | G#genobj.interfacefile], + interfacefiled=[InterfaceFd | G#genobj.interfacefiled], + stubfile=[StubFileName | G#genobj.stubfile], + stubfiled=[StubFd | G#genobj.stubfiled], + skelfile=[SkelFileName | G#genobj.skelfile], + skelfiled=[SkelFd | G#genobj.skelfiled], + helperfile=[HelperFileName | G#genobj.helperfile], + helperfiled=[HelperFd | G#genobj.helperfiled], + holderfile=[HolderFileName | G#genobj.holderfile], + holderfiled=[HolderFd | G#genobj.holderfiled]}. + + + + + +%%----------------------------------------------------------------- +%% Func: javaInterfaceFilePop/1 +%%----------------------------------------------------------------- +javaInterfaceFilePop(G) -> + close(hd(G#genobj.interfacefiled)), + close(hd(G#genobj.stubfiled)), + close(hd(G#genobj.skelfiled)), + close(hd(G#genobj.helperfiled)), + close(hd(G#genobj.holderfiled)), + G#genobj{ + interfacefile=tl(G#genobj.interfacefile), + interfacefiled=tl(G#genobj.interfacefiled), + stubfile=tl(G#genobj.stubfile), + stubfiled=tl(G#genobj.stubfiled), + skelfile=tl(G#genobj.skelfile), + skelfiled=tl(G#genobj.skelfiled), + helperfile=tl(G#genobj.helperfile), + helperfiled=tl(G#genobj.helperfiled), + holderfile=tl(G#genobj.holderfile), + holderfiled=tl(G#genobj.holderfiled)}. + +%%----------------------------------------------------------------- +%% Func: createDirectory/2 +%%----------------------------------------------------------------- +createDirectory(_G, []) -> + ok; +createDirectory(G, Scope) -> + Path = ic_file:join(ic_options:get_opt(G, stubdir), ic_pragma:slashify(Scope)), + case file:make_dir(Path) of + ok -> + ok; + {error, eexist} -> + ok; + {error, Reason} -> + ic_error:fatal_error(G, {create_dir, Path, Reason}) + end. + + +%%----------------------------------------------------------------- +%% Func: createJavaDirectory/2 +%%----------------------------------------------------------------- +createJavaDirectory(_G, []) -> + ok; +createJavaDirectory(G, Scope) -> + JavaScope = ic_util:adjustScopeToJava(G,Scope), + Path = ic_file:join(ic_options:get_opt(G, stubdir), ic_pragma:slashify(JavaScope)), + case file:make_dir(Path) of + ok -> + ok; + {error, eexist} -> + ok; + {error, Reason} -> + ic_error:fatal_error(G, {create_dir, Path, Reason}) + end. + + + + +%%----------------------------------------------------------------- +%% Func: createJavaFileName/3 +%%----------------------------------------------------------------- +createJavaFileName(G, Scope, FName) -> + JavaScope = ic_util:adjustScopeToJava(G,Scope), + join(ic_options:get_opt(G, stubdir), + ic_pragma:slashify([FName++".java"|JavaScope])). + +%%----------------------------------------------------------------- +%% Func: close/2 (used to be file_close) +%%----------------------------------------------------------------- +close(empty) -> ok; +close(ignore) -> ok; +close(Fd) -> + file:close(Fd). + +%%----------------------------------------------------------------- +%% Func: remove_ext/1 +%%----------------------------------------------------------------- +remove_ext(File) -> + filename:rootname(filename:basename(File)). + +%%----------------------------------------------------------------- +%% Func: open/2 (used to be file_open) +%%----------------------------------------------------------------- +open(_, ignore) -> ignore; +open(empty, Name) -> + case file:open(Name, [raw, binary, write]) of + {ok, Fd} -> + Fd; + {error, Reason} -> + exit({error, Reason}) +%% ic_error:fatal_error(G, {open_file, Name, Reason}) + end. + +%%----------------------------------------------------------------- +%% Func: open_java_file/3 +%%----------------------------------------------------------------- +open_java_file(G, N, Name) -> + createJavaDirectory(G, N), + FName = createJavaFileName(G, N, Name), + case file:open(FName, [raw, binary, write]) of + {ok, Fd} -> + ic_codegen:emit_stub_head(G, Fd, Name, java), + emit_package(G, N, Fd), + {Fd, FName}; + {error, Reason} -> + ic_error:fatal_error(G, {open_file, FName, Reason}) + end. + +%%----------------------------------------------------------------- +%% Func: emit_package/3 +%%----------------------------------------------------------------- +emit_package(_G, [], _Fd) -> + ok; +emit_package(G, N, Fd) -> + ic_codegen:emit(Fd, "package ~s;\n", [ic_util:to_dot(G,N)]), + ic_codegen:nl(Fd). + +%%----------------------------------------------------------------- +%% Func: add_dot_erl/1 +%%----------------------------------------------------------------- +add_dot_erl(F) -> + File = ic_util:to_list(F), + F2 = lists:reverse(File), + case F2 of + [$l, $r, $e, $. | _Rest] -> + File; + _ -> + File ++ ".erl" + end. + +%%----------------------------------------------------------------- +%% Func: add_dot_hrl/1 +%%----------------------------------------------------------------- +add_dot_hrl(F) -> + File = ic_util:to_list(F), + F2 = lists:reverse(File), + case F2 of + [$l, $r, $h, $. | _Rest] -> + File; + _ -> + File ++ ".hrl" + end. + +%%----------------------------------------------------------------- +%% Func: add_dot_c/1 +%%----------------------------------------------------------------- +add_dot_c(F) -> + File = ic_util:to_list(F), + F2 = lists:reverse(File), + case F2 of + [$c, $. | _Rest] -> + File; + _ -> + File ++ ".c" + end. + +%%----------------------------------------------------------------- +%% Func: add_dot_h/1 +%%----------------------------------------------------------------- +add_dot_h(F) -> + File = ic_util:to_list(F), + F2 = lists:reverse(File), + case F2 of + [$h, $. | _Rest] -> + File; + _ -> + File ++ ".h" + end. + +%%----------------------------------------------------------------- +%% Func: add_dot_java/1 +%%----------------------------------------------------------------- +add_dot_java(F) -> + File = ic_util:to_list(F), + F2 = lists:reverse(File), + case F2 of + [$a, $v, $a, $j, $. | _Rest] -> + File; + _ -> + File ++ ".java" + end. + +%%----------------------------------------------------------------- +%% Func: add_dot_idl/1 +%%----------------------------------------------------------------- +add_dot_idl(F) -> + File = ic_util:to_list(F), + F2 = lists:reverse(File), + case F2 of + [$l, $d, $i, $. | _Rest] -> + File; + _ -> + File ++ ".idl" + end. + + +%%----------------------------------------------------------------- +%% Internal functions +%%----------------------------------------------------------------- + +%%-------------------------------------------------------------------- +%% +%% File handling stuff +%% +%% +%% Shall open a file for writing. Also sets up the generator with +%% usefull bits of information +%% +%%-------------------------------------------------------------------- +find_impl_name(G, Name) -> + N1 = ic_util:to_colon(Name), + N2 = ic_util:to_undersc(Name), + case {ic_options:get_opt(G, {impl, N1}), + ic_options:get_opt(G, {impl, N2})} of + {false, false} -> + case {ic_options:get_opt(G, {impl, "::"++N1}), + ic_options:get_opt(G, {impl, N2})} of + {false, false} -> N2 ++ "_impl"; + {X, _Y} when X /= false -> ic_util:to_list(X); + {_X, Y} when Y /= false -> ic_util:to_list(Y) + end; + {X, _Y} when X /= false -> ic_util:to_list(X); + {_X, Y} when Y /= false -> ic_util:to_list(Y) + end. diff --git a/lib/ic/src/ic_forms.erl b/lib/ic/src/ic_forms.erl new file mode 100644 index 0000000000..7409ddeb7b --- /dev/null +++ b/lib/ic/src/ic_forms.erl @@ -0,0 +1,437 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1998-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_forms). + +-include_lib("ic/src/ic.hrl"). +-include_lib("ic/src/icforms.hrl"). + +%%----------------------------------------------------------------- +%% External exports +%%----------------------------------------------------------------- +-export([get_id/1, get_id2/1, get_java_id/1, get_line/1]). +-export([get_type_code/3, search_tk/2, clean_up_scope/1]). +-export([get_body/1, get_dimension/1, get_idlist/1, get_type/1, get_tk/1, is_oneway/1]). + +%%----------------------------------------------------------------- +%% Internal exports +%%----------------------------------------------------------------- +-export([]). + +%%----------------------------------------------------------------- +%% External functions +%%----------------------------------------------------------------- + +%%-------------------------------------------------------------------- +%% +%% Generation go-get utilities +%% +%% Feeble attempt at virtual funtions. +%% +%%-------------------------------------------------------------------- + +get_dimension(X) when is_record(X, array) -> + [element(3, L) || L <- X#array.size]. + +%% Should find the name hidden in constructs +get_id( [{'', _LineNo, Id}] ) -> Id; +get_id( {'', _LineNo, Id} ) -> Id; +get_id(Id) when is_list(Id) andalso is_integer(hd(Id)) -> Id; +get_id(X) when is_record(X, scoped_id) -> X#scoped_id.id; +get_id(X) when is_record(X, array) -> get_id(X#array.id); +get_id( {'', _LineNo, Id} ) -> Id; +get_id( {'', _LineNo, Id} ) -> Id. + +get_line([{'', LineNo, _Id}]) -> LineNo; +get_line({'', LineNo, _Id}) -> LineNo; +get_line(X) when is_record(X, scoped_id) -> X#scoped_id.line; +get_line(X) when is_record(X, module) -> get_line(X#module.id); +get_line(X) when is_record(X, interface) -> get_line(X#interface.id); +get_line(X) when is_record(X, forward) -> get_line(X#forward.id); +get_line(X) when is_record(X, const) -> get_line(X#const.id); +get_line(X) when is_record(X, typedef) -> get_line(X#typedef.id); +get_line(X) when is_record(X, struct) -> get_line(X#struct.id); +get_line(X) when is_record(X, member) -> get_line(X#member.id); +get_line(X) when is_record(X, union) -> get_line(X#union.id); +get_line(X) when is_record(X, case_dcl) -> get_line(X#case_dcl.id); +get_line(X) when is_record(X, enum) -> get_line(X#enum.id); +get_line(X) when is_record(X, enumerator) -> get_line(X#enumerator.id); +get_line(X) when is_record(X, array) -> get_line(X#array.id); +get_line(X) when is_record(X, attr) -> get_line(X#attr.id); +get_line(X) when is_record(X, except) -> get_line(X#except.id); +get_line(X) when is_record(X, op) -> get_line(X#op.id); +get_line(X) when is_record(X, param) -> get_line(X#param.id); +get_line(X) when is_record(X, id_of) -> get_line(X#id_of.id); + +get_line({'or', T1, _T2}) -> get_line(T1); +get_line({'xor', T1, _T2}) -> get_line(T1); +get_line({'and', T1, _T2}) -> get_line(T1); +get_line({'rshift', T1, _T2}) ->get_line(T1); +get_line({'lshift', T1, _T2}) ->get_line(T1); +get_line({'+', T1, _T2}) -> get_line(T1); +get_line({'-', T1, _T2}) -> get_line(T1); +get_line({'*', T1, _T2}) -> get_line(T1); +get_line({'/', T1, _T2}) -> get_line(T1); +get_line({'%', T1, _T2}) -> get_line(T1); +get_line({{'-', _Line}, T}) -> get_line(T); +get_line({{'+', _Line}, T}) -> get_line(T); +get_line({{'~', _Line}, T}) -> get_line(T); +get_line({_, X, _}) when is_integer(X) -> X; +get_line({_A, N}) when is_integer(N) -> N; +get_line(_) -> -1. + + +%%-------------------------------------------------------------------- +%% +%% High level get functions. +%% +%% These are highly polymorphic functions that will get the id, +%% body and type of a record (those records output from the +%% parser). +%% +%% NOTE: The typedef node (the alias) is special, because the type +%% field is a type definition and therefore considered a body, +%% and the type of a typedef is its name. +%% + +get_id2(X) when is_record(X, module) -> get_id(X#module.id); +get_id2(X) when is_record(X, interface) -> get_id(X#interface.id); +get_id2(X) when is_record(X, forward) -> get_id(X#forward.id); +get_id2(X) when is_record(X, const) -> get_id(X#const.id); +get_id2(X) when is_record(X, typedef) -> get_id(hd(X#typedef.id)); +get_id2(X) when is_record(X, struct) -> get_id(X#struct.id); +get_id2(X) when is_record(X, member) -> get_id(hd(X#member.id)); +get_id2(X) when is_record(X, union) -> get_id(X#union.id); +get_id2(X) when is_record(X, case_dcl) -> get_id(X#case_dcl.id); +get_id2(X) when is_record(X, enum) -> get_id(X#enum.id); +get_id2(X) when is_record(X, enumerator) -> get_id(X#enumerator.id); +get_id2(X) when is_record(X, array) -> get_id(X#array.id); +get_id2(X) when is_record(X, attr) -> get_id(X#attr.id); +get_id2(X) when is_record(X, except) -> get_id(X#except.id); +get_id2(X) when is_record(X, op) -> get_id(X#op.id); +get_id2(X) when is_record(X, param) -> get_id(X#param.id); +get_id2(X) when is_record(X, type_dcl) -> get_id2(X#type_dcl.type); +get_id2(X) when is_record(X, scoped_id) -> ic_symtab:scoped_id_strip(X); +get_id2(X) when is_record(X, preproc) -> get_id(X#preproc.id); +get_id2(X) when is_record(X, id_of) -> get_id2(X#id_of.id); +get_id2(X) -> get_id(X). + +get_body(X) when is_record(X, module) -> X#module.body; +get_body(X) when is_record(X, interface) -> X#interface.body; +get_body(X) when is_record(X, struct) -> X#struct.body; +get_body(X) when is_record(X, union) -> X#union.body; +get_body(X) when is_record(X, enum) -> X#enum.body; +get_body(X) when is_record(X, typedef) -> X#typedef.type; % See Note +get_body(X) when is_record(X, except) -> X#except.body. + +get_type(X) when is_record(X, const) -> X#const.type; +get_type(X) when is_record(X, type_dcl) -> X#type_dcl.type; +get_type(X) when is_record(X, typedef) -> X#typedef.id; % See Note +get_type(X) when is_record(X, member) -> X#member.type; +get_type(X) when is_record(X, union) -> X#union.type; +get_type(X) when is_record(X, case_dcl) -> X#case_dcl.type; +get_type(X) when is_record(X, sequence) -> X#sequence.type; +get_type(X) when is_record(X, attr) -> X#attr.type; +get_type(X) when is_record(X, op) -> X#op.type; +get_type(X) when is_record(X, param) -> X#param.type. +%%get_type(X) when record(X, id_of) -> get_type(X#id_of.type). + +%% Temporary place +get_tk(X) when is_record(X, interface) -> X#interface.tk; +get_tk(X) when is_record(X, forward) -> X#forward.tk; +get_tk(X) when is_record(X, const) -> X#const.tk; +get_tk(X) when is_record(X, type_dcl) -> X#type_dcl.tk; +get_tk(X) when is_record(X, typedef) -> X#typedef.tk; +get_tk(X) when is_record(X, struct) -> X#struct.tk; +get_tk(X) when is_record(X, union) -> X#union.tk; +get_tk(X) when is_record(X, enum) -> X#enum.tk; +get_tk(X) when is_record(X, attr) -> X#attr.tk; +get_tk(X) when is_record(X, except) -> X#except.tk; +get_tk(X) when is_record(X, op) -> X#op.tk; +get_tk(X) when is_record(X, id_of) -> X#id_of.tk; +get_tk(X) when is_record(X, param) -> X#param.tk. + + +%% Get idlist returns the list of identifiers found in typedefs, case +%% dcls etc. +get_idlist(X) when is_record(X, typedef) -> X#typedef.id; +get_idlist(X) when is_record(X, member) -> X#member.id; +get_idlist(X) when is_record(X, case_dcl) -> X#case_dcl.label; +get_idlist(X) when is_record(X, attr) -> X#attr.id. + + +is_oneway(X) when is_record(X, op) -> + case X#op.oneway of + {oneway, _} -> true; + _ -> false + end; +is_oneway(_X) -> false. + + + + + +%%------------------------------------------------------------ +%% +%% Analyze the record and seek the correct type code. +%% +%% NOT equal to get_tk, this will always succed ! +%% +%%------------------------------------------------------------ +get_type_code(G, N, X) -> + case get_type_code2(G, N, X) of + undefined -> + %% Remove "Package" suffix from scope + N2 = clean_up_scope(N), + search_tk(G,ictk:get_IR_ID(G, N2, X)); + TC -> + TC + end. + +clean_up_scope(N) -> + clean_up_scope(N,[]). + +clean_up_scope([],N) -> + lists:reverse(N); +clean_up_scope([N|Ns],Found) -> + case lists:suffix("Package",N) of + true -> + Len = length(N), + case Len > 7 of + true -> + N2 = string:substr(N,1,Len-7), + clean_up_scope(Ns,[N2|Found]); + false -> + clean_up_scope(Ns,[N|Found]) + end; + false -> + clean_up_scope(Ns,[N|Found]) + end. + + +get_type_code2(_, _, X) when is_record(X, interface) -> X#interface.tk; +get_type_code2(_, _, X) when is_record(X, forward) -> X#forward.tk; +get_type_code2(_, _, X) when is_record(X, const) -> X#const.tk; +get_type_code2(_, _, X) when is_record(X, type_dcl) -> X#type_dcl.tk; +get_type_code2(_, _, X) when is_record(X, typedef) -> + Id = X#typedef.id, + ET = X#typedef.tk, + if is_list(Id) -> + Head = hd(Id), + if is_tuple(Head) -> + case element(1,Head) of + array -> + get_array_tc(ET, element(3,Head)); + _ -> + ET + end; + true -> + ET + end; + true -> + ET + end; + +get_type_code2(_, _, X) when is_record(X, struct) -> X#struct.tk; +get_type_code2(_, _, X) when is_record(X, union) -> X#union.tk; +get_type_code2(_, _, X) when is_record(X, enum) -> X#enum.tk; +get_type_code2(_, _, X) when is_record(X, attr) -> X#attr.tk; +get_type_code2(_, _, X) when is_record(X, except) -> X#except.tk; +get_type_code2(_, _, X) when is_record(X, op) -> X#op.tk; +get_type_code2(_, _, X) when is_record(X, id_of) -> X#id_of.tk; +get_type_code2(_, _, X) when is_record(X, param) -> X#param.tk; + +get_type_code2(G, N, X) when is_record(X, member) -> + ET = get_type_code(G, N, element(2,X)), + Id = element(3,X), + + if is_list(Id) -> + Head = hd(Id), + if is_tuple(Head) -> + case element(1,Head) of + array -> + get_array_tc(ET, element(3,Head)); + _ -> + ET + end; + true -> + ET + end; + true -> + ET + end; + +get_type_code2(G, N, X) when is_record(X, scoped_id) -> + element(3,ic_symtab:get_full_scoped_name(G, N, X)); + +get_type_code2(G, N, X) when is_record(X, sequence) -> + if is_tuple(X#sequence.length) -> + {tk_sequence, + get_type_code(G, N, X#sequence.type), + list_to_integer(element(3,X#sequence.length))}; + true -> + {tk_sequence, + get_type_code(G, N, X#sequence.type), + X#sequence.length} + end; + +get_type_code2(_G, _N, {unsigned,{short,_}}) -> tk_ushort; + +get_type_code2(_G, _N, {unsigned,{long,_}}) -> tk_ulong; + +get_type_code2(_G, _N, {unsigned,{'long long',_}}) -> tk_ulonglong; + +get_type_code2(_G, _N, X) when is_record(X, fixed) -> + {tk_fixed, X#fixed.digits, X#fixed.scale}; + +get_type_code2(G, N, {X,_}) -> + get_type_code2(G, N, X); + +get_type_code2(_, _, short) -> tk_short; +get_type_code2(_, _, long) -> tk_long; +get_type_code2(_, _, 'long long') -> tk_longlong; +get_type_code2(_, _, float) -> tk_float; +get_type_code2(_, _, double) -> tk_double; +get_type_code2(_, _, boolean) -> tk_boolean; +get_type_code2(_, _, char) -> tk_char; +get_type_code2(_, _, wchar) -> tk_wchar; +get_type_code2(_, _, octet) -> tk_octet; +get_type_code2(_, _, string) -> tk_string; +get_type_code2(_, _, wstring) -> tk_wstring; +get_type_code2(_, _, any) -> tk_any. + + +get_array_tc(ET, []) -> + ET; +get_array_tc(ET, [L|Ls]) -> + {tk_array, + get_array_tc(ET,Ls), + list_to_integer(element(3,L))}. + + + + +%%------------------------------------------------------------ +%% +%% seek type code when not accessible by ic_forms:get_tk/1 ( should be +%% a part of "do_gen" related functions later ) +%% +%%------------------------------------------------------------ +search_tk(G, IR_ID) -> + S = ic_genobj:tktab(G), + case catch search_tk(S,IR_ID,typedef) of + {value,TK} -> + TK; + _ -> %% false / exit + case catch search_tk(S,IR_ID,struct) of + {value,TK} -> + TK; + _ -> %% false / exit + case catch search_tk(S,IR_ID,union) of + {value,TK} -> + TK; + _ -> + undefined + end + end + end. + + +search_tk(S, IR_ID, Type) -> + L = lists:flatten(ets:match(S,{'_',Type,'$1','_'})), + case lists:keysearch(IR_ID,2,L) of + {value,TK} -> + {value,TK}; + false -> + search_inside_tks(L,IR_ID) + end. + + +search_inside_tks([],_IR_ID) -> + false; +search_inside_tks([{tk_array,TK,_}|Xs],IR_ID) -> + case search_included_tk(TK,IR_ID) of + {value,TK} -> + {value,TK}; + false -> + search_inside_tks(Xs,IR_ID) + end. + + +search_included_tk({tk_array,TK,_}, IR_ID) -> + search_included_tk(TK,IR_ID); +search_included_tk({tk_sequence,TK,_}, IR_ID) -> + search_included_tk(TK,IR_ID); +search_included_tk(TK, _IR_ID) when is_atom(TK) -> + false; +search_included_tk(TK, IR_ID) -> + case element(2,TK) == IR_ID of + true -> + {value,TK}; + false -> + false + end. + + + + +%% This is similar to get_id2 but in everything else +%% than a module it will generate an id prefixed +get_java_id(Id) when is_list(Id) -> + case java_keyword_coalition(Id) of + true -> + "_" ++ Id; + false -> + Id + end; +get_java_id(Id_atom) when is_atom(Id_atom) -> + Id = atom_to_list(Id_atom), + case java_keyword_coalition(Id) of + true -> + "_" ++ Id; + false -> + Id + end; +get_java_id(X) -> + Id = get_id2(X), + case java_keyword_coalition(Id) of + true -> + "_" ++ Id; + false -> + Id + end. + +java_keyword_coalition(Id) -> + lists:member(list_to_atom(Id), + [abstract, default, 'if', private, throw, boolean, + do, implements, protected, throws, break, + double, import, public, transient, byte, + else, instanceof, return, 'try', 'case', extends, + int, short, void, 'catch', final, interface, static, + volatile, char, finally, long, super, while, class, + float, native, switch, const, for, new, synchronized, + continue, goto, package, this, true, false]). + + + + +%%----------------------------------------------------------------- +%% Internal functions +%%----------------------------------------------------------------- diff --git a/lib/ic/src/ic_genobj.erl b/lib/ic/src/ic_genobj.erl new file mode 100644 index 0000000000..afb00eeb19 --- /dev/null +++ b/lib/ic/src/ic_genobj.erl @@ -0,0 +1,244 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1998-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_genobj). + + +-include_lib("ic/src/ic.hrl"). + +%%----------------------------------------------------------------- +%% External exports +%%----------------------------------------------------------------- +-export([new/1, free_table_space/1, process_space/0]). +-export([skelfiled/1, stubfiled/1, hrlfiled/1, includefiled/1]). +-export([interfacefiled/1, helperfiled/1, holderfiled/1]). +-export([is_skelfile_open/1, is_stubfile_open/1, is_hrlfile_open/1]). +-export([include_file/1, include_file_stack/1]). +-export([push_file/2, pop_file/2, sys_file/2]). + +-export([skelscope/1, stubscope/1, impl/1, do_gen/1]). +-export([symtab/1, auxtab/1, tktab/1, pragmatab/1, optiontab/1, typedeftab/1]). +-export([idlfile/1, module/1, set_idlfile/2, set_module/2]). + + +%%----------------------------------------------------------------- +%% Internal exports +%%----------------------------------------------------------------- +-export([]). + +%%----------------------------------------------------------------- +%% External functions +%%----------------------------------------------------------------- + +%%-------------------------------------------------------------------- +%% +%% Initialisation stuff +%% +%% +%% +%%-------------------------------------------------------------------- + + +new(Opts) -> + OptDB = ets:new(options, [set, public]), + Warns = ets:new(warnings, [set, public]), + Aux = ets:new(aux, [set, public]), + Tk = ets:new(tktab, [set, public]), + PragmaTab = ets:new(pragmatab, [bag, public]), + TypeDefTab = ets:new(c_typedeftab, [set, public]), + G = #genobj{options=OptDB, + warnings=Warns, + symtab=ic_symtab:new(), + auxtab=Aux, + tktab=Tk, + pragmatab=PragmaTab, + c_typedeftab=TypeDefTab}, + ic_error:init_errors(G), + ic_options:add_opt(G, default_opts, true), + ic_options:read_cfg(G, Opts), % Read any config files + ic_options:add_opt(G, Opts, true), + ic_symtab:symtab_add_faked_included_types(G), % Add CORBA:: that as if they + % were defined in an included file + case ic_options:get_opt(G, be) of + false -> + DefBE = ic_options:defaultBe(), + case ic_options:get_opt(G, multiple_be) of + false -> + ic_options:add_opt(G, be, DefBE), + G; + List -> + case lists:member(DefBE, List) of + true -> + %% Delete the default be from the list to avoid + %% generating it twice. + NewList = lists:delete(DefBE, List), + ic_options:add_opt(G, multiple_be, NewList), + ic_options:add_opt(G, be, DefBE), + G; + false -> + G + end + end; + _ -> + G + end. + + +%%-------------------------------------------------------------------- +%% +%% Table removal +%% +%% +%% +%%-------------------------------------------------------------------- + + +free_table_space(G) -> + %% Free ets tables + ets:delete(G#genobj.options), + ets:delete(G#genobj.symtab), + ets:delete(G#genobj.warnings), + ets:delete(G#genobj.auxtab), + ets:delete(G#genobj.tktab), + ets:delete(G#genobj.pragmatab), + ets:delete(G#genobj.c_typedeftab), + %% Close file descriptors + close_fd(G#genobj.skelfiled), + close_fd(G#genobj.stubfiled), + close_fd(G#genobj.interfacefiled), + close_fd(G#genobj.helperfiled), + close_fd(G#genobj.holderfiled), + close_fd(G#genobj.includefiled). + +close_fd([]) -> + ok; +close_fd([Fd|Fds]) -> + file_close(Fd), + close_fd(Fds). + +file_close(empty) -> ok; +file_close(ignore) -> ok; +file_close(Fd) -> + file:close(Fd). + + +%%-------------------------------------------------------------------- +%% +%% Process memory usage +%% +%% +%% +%%-------------------------------------------------------------------- + +process_space() -> + Pheap=4*element(2,element(2,lists:keysearch(heap_size,1,process_info(self())))), + Pstack=4*element(2,element(2,lists:keysearch(stack_size,1,process_info(self())))), + io:format("Process current heap = ~p bytes\n",[Pheap]), + io:format("Symbol current stack = ~p bytes\n",[Pstack]), + io:format("-----------------------------------------------\n"), + io:format("Totally used ~p bytes\n\n",[Pheap+Pstack]). + + + + + + +skelfiled(G) -> hd(G#genobj.skelfiled). +stubfiled(G) -> hd(G#genobj.stubfiled). +includefiled(G) -> hd(G#genobj.includefiled). +hrlfiled(G) -> hd(G#genobj.includefiled). +interfacefiled(G) -> hd(G#genobj.interfacefiled). +helperfiled(G) -> hd(G#genobj.helperfiled). +holderfiled(G) -> hd(G#genobj.holderfiled). + +include_file(G) -> hd(G#genobj.includefile). +include_file_stack(G) -> G#genobj.includefile. + +is_skelfile_open(G) -> + if hd(G#genobj.skelfiled) /= empty, hd(G#genobj.skelfiled) /= ignore + -> true; + true -> false + end. +is_stubfile_open(G) -> + if hd(G#genobj.stubfiled) /= empty, hd(G#genobj.stubfiled) /= ignore + -> true; + true -> false + end. + +is_hrlfile_open(G) -> + if hd(G#genobj.includefiled) /= empty, hd(G#genobj.includefiled) /= ignore + -> true; + true -> false + end. + +%%-------------------------------------------------------------------- +%% +%% Handling of pre processor file commands +%% +%%-------------------------------------------------------------------- + +push_file(G, Id) -> + New = G#genobj.filestack+1, + set_idlfile(G, Id), + G#genobj{filestack=New, do_gen=true_or_not(New)}. +pop_file(G, Id) -> + New = G#genobj.filestack-1, + set_idlfile(G, Id), + G#genobj{filestack=New, do_gen=true_or_not(New)}. +sys_file(G, _Id) -> G#genobj{sysfile=true}. + + +do_gen(G) -> G#genobj.do_gen. + +%%-------------------------------------------------------------------- +%% +%% Storage routines +%%i +%% The generator object G is used to store many usefull bits of +%% information so that the information doesn't need to get passed +%% around everywhere. +%% +%%-------------------------------------------------------------------- + + +skelscope(G) -> G#genobj.skelscope. +stubscope(G) -> G#genobj.stubscope. +symtab(G) -> G#genobj.symtab. +auxtab(G) -> G#genobj.auxtab. +tktab(G) -> G#genobj.tktab. +impl(G) -> G#genobj.impl. +pragmatab(G) -> G#genobj.pragmatab. +optiontab(G) -> G#genobj.options. +typedeftab(G) -> G#genobj.c_typedeftab. + +idlfile(G) -> ?lookup(G#genobj.options, idlfile). +module(G) -> ?lookup(G#genobj.options, module). + +set_idlfile(G, X) -> ?insert(G#genobj.options, idlfile, X). +set_module(G, X) -> ?insert(G#genobj.options, module, ic_forms:get_id(X)). + + +%%----------------------------------------------------------------- +%% Internal functions +%%----------------------------------------------------------------- +true_or_not(X) when X < 2 -> + true; +true_or_not(_) -> + false. diff --git a/lib/ic/src/ic_java_type.erl b/lib/ic/src/ic_java_type.erl new file mode 100644 index 0000000000..b8979b6dbe --- /dev/null +++ b/lib/ic/src/ic_java_type.erl @@ -0,0 +1,1213 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1999-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_java_type). + + +-include("icforms.hrl"). +-include("ic.hrl"). +-include("ic_debug.hrl"). +%%----------------------------------------------------------------- +%% External exports +%%----------------------------------------------------------------- +-export([getType/3, getHolderType/3, + getParamType/4, inlinedTypes/2, + marshalFun/4, unMarshalFun/4, getFullType/4, + getFullType/3, getMarshalType/4, getUnmarshalType/4, + getdim/1]). +-export([isBasicType/3, isBasicType/1]). +-export([isIntegerType/3, isIntegerType/1]). +-export([isTermType/3]). + +%%----------------------------------------------------------------- +%% Internal exports +%%----------------------------------------------------------------- +-export([]). + +%%----------------------------------------------------------------- +%% External functions +%%----------------------------------------------------------------- +%%----------------------------------------------------------------- +%% Func: getType/3 +%%----------------------------------------------------------------- +getType(G, N, T) when is_record(T, scoped_id) -> + {FullScopedName, _, TK, _} = ic_symtab:get_full_scoped_name(G, N, T), + BT = ic_code:get_basetype(G, ic_util:to_dot(G,FullScopedName)), + case BT of + "erlang.pid" -> + ?ICPACKAGE ++ "Pid"; + "erlang.port" -> + ?ICPACKAGE ++ "Port"; + "erlang.ref" -> + ?ICPACKAGE ++ "Ref"; + "erlang.term" -> + ?ICPACKAGE ++ "Term"; + {enum, Type} -> + getType(G, N, Type); + Type -> + case TK of + {tk_array,_,_} -> + tk2type(G,N,T,TK); + {tk_sequence,_,_} -> + tk2type(G,N,T,TK); + tk_any -> + ?ICPACKAGE ++ "Any"; + _ -> + case isBasicType(G,N,TK) of + true -> + tk2type(G,N,T,TK); + false -> + Type %% Other types + end + end + end; + +getType(_G, _N, S) when is_list(S) -> + S; + +getType(_G, _N, T) when is_record(T, string) -> + "java.lang.String"; + +getType(_G, _N, T) when is_record(T, wstring) -> %% WSTRING + "java.lang.String"; + +getType(G, N, T) when is_record(T, struct) -> + ic_util:to_dot(G,[ic_forms:get_id2(T)|N]); + +getType(G, N, T) when is_record(T, union) -> + ic_util:to_dot(G,[ic_forms:get_id2(T)|N]); + +getType(G, N, T) when is_record(T, sequence) -> + getType(G, N, ic_forms:get_type(T)) ++ "[]"; + +getType(G, N, T) when is_record(T, enum) -> + ic_util:to_dot(G,[ic_forms:get_id2(T)|N]); + +%% NOTE i am using the new isJavaElementaryType +%% to avoid members declared as keywords (except +%% all java elementary types) to be used as a +%% class +getType(G, N, T) when is_record(T, member) -> + Type = tk2type(G,N,T,ic_forms:get_type_code(G, N, T)), + case isJavaElementaryType(list_to_atom(Type)) of + true -> + Type; + false -> + Prefix = list_to_atom(lists:flatten(string:tokens(Type,"[]"))), + case isJavaElementaryType(Prefix) of %% Checks if Type is an array + %% of elementary java types + true -> + Type; + false -> + ic_forms:get_java_id(getType(G,N,ic_forms:get_type(T))) ++ + if is_record(hd(T#member.id),array) -> + arrayEmptyDim(hd(T#member.id)); + true -> + "" + end + end + end; + +getType(_G, _N, {boolean, _}) -> + "boolean"; + +getType(_G, _N, {octet, _}) -> + "byte"; + +getType(_G, _N, {void, _}) -> + "void"; + +getType(_G, _N, {unsigned, U}) -> + case U of + {short,_} -> + "short"; + {long,_} -> + "int"; + {'long long',_} -> + "long" + end; + +getType(_G, _N, {char, _}) -> + "char"; + +getType(_G, _N, {wchar, _}) -> %% WCHAR + "char"; + +getType(_G, _N, {short, _}) -> + "short"; + +getType(_G, _N, {long, _}) -> + "int"; + +getType(_G, _N, {'long long', _}) -> + "long"; + +getType(_G, _N, {float, _}) -> + "float"; + +getType(_G, _N, {double, _}) -> + "double"; + +getType(_G, _N, {any, _}) -> + ?ICPACKAGE ++ "Any". + + + + + + +%%----------------------------------------------------------------- +%% Func: getHolderType/3 +%%----------------------------------------------------------------- +getHolderType(G, N, T) when element(1, T) == scoped_id -> + {FullScopedName, _, TK, _} = ic_symtab:get_full_scoped_name(G, N, T), + BT = ic_code:get_basetype(G, ic_util:to_dot(G,FullScopedName)), + case BT of + "erlang.pid" -> + ?ICPACKAGE ++ "PidHolder"; + "erlang.port" -> + ?ICPACKAGE ++ "PortHolder"; + "erlang.ref" -> + ?ICPACKAGE ++ "RefHolder"; + "erlang.term" -> + ?ICPACKAGE ++ "TermHolder"; + {enum, Type} -> + getHolderType(G, N, Type); + + Type -> + case TK of + {'tk_struct', _, _, _} -> + Type ++ "Holder"; + + {'tk_union', _, _, _, _, _} -> + Type ++ "Holder"; + + {'tk_array', _ , _} -> + Type ++ "Holder"; + + {'tk_sequence', _ , _} -> + Type ++ "Holder"; + + {'tk_string', _} -> + ?ICPACKAGE ++ "StringHolder"; + + {'tk_wstring', _} -> %% WSTRING + ?ICPACKAGE ++ "StringHolder"; + + {'tk_enum', _, _, _} -> + Type ++ "Holder"; + + 'tk_boolean' -> + ?ICPACKAGE ++ "BooleanHolder"; + + 'tk_octet' -> + ?ICPACKAGE ++ "ByteHolder"; + + 'tk_ushort' -> + ?ICPACKAGE ++ "ShortHolder"; + + 'tk_ulong' -> + ?ICPACKAGE ++ "IntHolder"; + + 'tk_ulonglong' -> %% ULLONG + ?ICPACKAGE ++ "LongHolder"; + + 'tk_short' -> + ?ICPACKAGE ++ "ShortHolder"; + + 'tk_long' -> + ?ICPACKAGE ++ "IntHolder"; + + 'tk_longlong' -> + ?ICPACKAGE ++ "LongHolder"; %% LLONG + + 'tk_float' -> + ?ICPACKAGE ++ "FloatHolder"; + + 'tk_double' -> + ?ICPACKAGE ++ "DoubleHolder"; + + 'tk_char' -> + ?ICPACKAGE ++ "CharHolder"; + + 'tk_wchar' -> %% WCHAR + ?ICPACKAGE ++ "CharHolder"; + + 'tk_any' -> + ?ICPACKAGE ++ "AnyHolder"; + + _ -> + case isBasicType(G,N,TK) of + true -> + %% Faked the type ! + getHolderType(G, N, {list_to_atom(tk2type(G,N,T,TK)), -1}); + false -> + %%io:format("TK = ~p, Type = ~p\n",[TK,Type]), + ic_util:to_dot(G,FullScopedName) ++ "Holder" + end + end + end; + +getHolderType(G, N, S) when is_list(S) -> + ic_util:to_dot(G,[S|N]) ++ "Holder"; + +getHolderType(_G, _N, T) when is_record(T, string) -> + ?ICPACKAGE ++"StringHolder"; + +getHolderType(_G, _N, T) when is_record(T, wstring) -> %% WSTRING + ?ICPACKAGE ++"StringHolder"; + +getHolderType(G, N, T) when is_record(T, struct) -> + ic_util:to_dot(G,[ic_forms:get_id2(T)|N]) ++ "Holder"; + +getHolderType(G, N, T) when is_record(T, union) -> + ic_util:to_dot(G,[ic_forms:get_id2(T)|N]) ++ "Holder"; + +getHolderType(G, N, T) when is_record(T, array) -> + ic_util:to_dot(G,[ic_forms:get_id2(T)|N]) ++ "Holder"; + +getHolderType(G, N, T) when is_record(T, sequence) -> + getType(G, N, ic_forms:get_type(T)) ++ "Holder[]"; + +getHolderType(G, N, T) when is_record(T, enum) -> + ic_util:to_dot(G,[ic_forms:get_id2(T)|N]) ++ "Holder"; + +getHolderType(_G, _N, {boolean, _}) -> + ?ICPACKAGE ++"BooleanHolder"; + +getHolderType(_G, _N, {octet, _}) -> + ?ICPACKAGE ++"ByteHolder"; + +getHolderType(_G, _N, {void, _}) -> + "void"; + +getHolderType(_G, _N, {unsigned, U}) -> + case U of + {short,_} -> + ?ICPACKAGE ++"ShortHolder"; + {long,_} -> + ?ICPACKAGE ++"IntHolder"; + {'long long',_} -> + ?ICPACKAGE ++"LongHolder" + end; + +getHolderType(_G, _N, {char, _}) -> + ?ICPACKAGE ++"CharHolder"; + +getHolderType(_G, _N, {wchar, _}) -> %% WCHAR + ?ICPACKAGE ++"CharHolder"; + +getHolderType(_G, _N, {short, _}) -> + ?ICPACKAGE ++"ShortHolder"; + +getHolderType(_G, _N, {long, _}) -> + ?ICPACKAGE ++"IntHolder"; + +getHolderType(_G, _N, {'long long', _}) -> + ?ICPACKAGE ++"LongHolder"; + +getHolderType(_G, _N, {float, _}) -> + ?ICPACKAGE ++"FloatHolder"; + +getHolderType(_G, _N, {double, _}) -> + ?ICPACKAGE ++"DoubleHolder"; + +getHolderType(_G, _N, {any,_}) -> + ?ICPACKAGE ++ "AnyHolder". + + +%%----------------------------------------------------------------- +%% Func: getParamType/4 +%%----------------------------------------------------------------- +getParamType(G, N, S, in) -> + getType(G, N, S); +getParamType(G, N, S, ret) -> + getType(G, N, S); +getParamType(G, N, S, out) -> + getHolderType(G, N, S); +getParamType(G, N, S, inout) -> + getHolderType(G, N, S). + + +%%----------------------------------------------------------------- +%% Func: getUnmarshalType/4 +%%----------------------------------------------------------------- +getUnmarshalType(G, N, X, T) when element(1, T) == scoped_id -> + {FullScopedName, _, TK, _} = ic_symtab:get_full_scoped_name(G, N, T), + BT = ic_code:get_basetype(G, ic_util:to_dot(G,FullScopedName)), + case BT of + "erlang.pid" -> + ?ICPACKAGE ++ "PidHelper"; + "erlang.port" -> + ?ICPACKAGE ++ "PortHelper"; + "erlang.ref" -> + ?ICPACKAGE ++ "RefHelper"; + "erlang.term" -> + ?ICPACKAGE ++ "TermHelper"; + {enum, Type} -> + getUnmarshalType(G, N, X, Type); + Type -> + case TK of + {'tk_struct', _, _, _} -> + Type ++ "Helper"; + + {'tk_union', _, _, _, _, _} -> + Type ++ "Helper"; + + {'tk_sequence', _ , _} -> + Type ++ "Helper"; + + {'tk_array', _ , _} -> + Type ++ "Helper"; + + {'tk_enum', _, _, _} -> + Type ++ "Helper"; + + {'tk_string',_} -> + ?ERLANGPACKAGE ++ "OtpErlangString"; + + {'tk_wstring',_} -> %% WSTRING + ?ERLANGPACKAGE ++ "OtpErlangString"; + + 'tk_char' -> + ?ERLANGPACKAGE ++ "OtpErlangLong"; + + 'tk_wchar' -> %% WCHAR + ?ERLANGPACKAGE ++ "OtpErlangLong"; + + 'tk_octet' -> + ?ERLANGPACKAGE ++ "OtpErlangLong"; + + 'tk_ushort' -> + ?ERLANGPACKAGE ++ "OtpErlangLong"; + + 'tk_ulong' -> + ?ERLANGPACKAGE ++ "OtpErlangLong"; + + 'tk_ulonglong' -> %% ULLONG + ?ERLANGPACKAGE ++ "OtpErlangLong"; + + 'tk_short' -> + ?ERLANGPACKAGE ++ "OtpErlangLong"; + + 'tk_long' -> + ?ERLANGPACKAGE ++ "OtpErlangLong"; + + 'tk_longlong' -> %% LLONG + ?ERLANGPACKAGE ++ "OtpErlangLong"; + + 'tk_float' -> + ?ERLANGPACKAGE ++ "OtpErlangDouble"; + + 'tk_double' -> + ?ERLANGPACKAGE ++ "OtpErlangDouble"; + + 'tk_boolean' -> + ?ERLANGPACKAGE ++ "OtpErlangAtom"; + + 'tk_void' -> + ?ERLANGPACKAGE ++ "OtpErlangAtom"; + + 'tk_any' -> + ?ICPACKAGE ++ "AnyHelper"; + + _ -> + case isBasicType(G,N,TK) of + true -> + %% Faked the type ! + getUnmarshalType(G, N, X, {list_to_atom(tk2type(G,N,T,TK)), -1}); + false -> + ic_util:to_dot(G,FullScopedName) ++ "Helper" + end + end + end; + +getUnmarshalType(_G, _N, _X, S) when is_list(S) -> + S ++ "Helper"; + +getUnmarshalType(_G, _N, _X, T) when is_record(T, string) -> + ?ERLANGPACKAGE ++ "OtpErlangString"; + +getUnmarshalType(_G, _N, _X, T) when is_record(T, wstring) -> %% WSTRING + ?ERLANGPACKAGE ++ "OtpErlangString"; + +getUnmarshalType(G, N, _X, T) when is_record(T, struct) -> + ic_util:to_dot(G,[ic_forms:get_id2(T)|N]) ++ "Helper"; + +getUnmarshalType(G, N, _X, T) when is_record(T, union) -> + ic_util:to_dot(G,[ic_forms:get_id2(T)|N]) ++ "Helper"; + +getUnmarshalType(G, N, X, T) when is_record(T, sequence) andalso + is_record(X, member) -> + ic_util:to_dot(G,[ic_forms:get_id2(X)|N]) ++ "Helper"; + +getUnmarshalType(G, N, X, T) when is_record(T, sequence) andalso + is_record(X, case_dcl) -> + ic_util:to_dot(G,[ic_forms:get_id2(X)|N]) ++ "Helper"; + +getUnmarshalType(G, N, X, T) when is_record(T, sequence) -> + getUnmarshalType(G, N, X, ic_forms:get_type(T)) ++ "Helper"; + +getUnmarshalType(G, N, X, T) when is_record(T, array) andalso + is_record(X, case_dcl) -> + ic_util:to_dot(G,[ic_forms:get_id2(T)|N]) ++ "Helper"; + +getUnmarshalType(G, N, _X, T) when is_record(T, enum) -> + ic_util:to_dot(G,[ic_forms:get_id2(T)|N]) ++ + "Helper"; + +getUnmarshalType(_G, _N, _X, {boolean, _}) -> + ?ERLANGPACKAGE ++ "OtpErlangAtom"; + +getUnmarshalType(_G, _N, _X, {octet, _}) -> + ?ERLANGPACKAGE ++ "OtpErlangLong"; + +getUnmarshalType(_G, _N, _X, {void, _}) -> + ?ERLANGPACKAGE ++ "OtpErlangAtom"; + +getUnmarshalType(_G, _N, _X, {unsigned, U}) -> + case U of + {short,_} -> + ?ERLANGPACKAGE ++ "OtpErlangLong"; + {long,_} -> + ?ERLANGPACKAGE ++ "OtpErlangLong"; + {'long long',_} -> + ?ERLANGPACKAGE ++ "OtpErlangLong" + end; + +getUnmarshalType(_G, _N, _X, {char, _}) -> + ?ERLANGPACKAGE ++ "OtpErlangLong"; + +getUnmarshalType(_G, _N, _X, {wchar, _}) -> %% WCHAR + ?ERLANGPACKAGE ++ "OtpErlangLong"; + +getUnmarshalType(_G, _N, _X, {short, _}) -> + ?ERLANGPACKAGE ++ "OtpErlangLong"; + +getUnmarshalType(_G, _N, _X, {long, _}) -> + ?ERLANGPACKAGE ++ "OtpErlangLong"; + +getUnmarshalType(_G, _N, _X, {'long long', _}) -> + ?ERLANGPACKAGE ++ "OtpErlangLong"; + +getUnmarshalType(_G, _N, _X, {float, _}) -> + ?ERLANGPACKAGE ++ "OtpErlangDouble"; + +getUnmarshalType(_G, _N, _X, {double, _}) -> + ?ERLANGPACKAGE ++ "OtpErlangDouble"; + +getUnmarshalType(_G, _N, _X, {any, _}) -> + ?ICPACKAGE ++ "AnyHelper". + +%%----------------------------------------------------------------- +%% Func: getMarshalType/4 +%%----------------------------------------------------------------- +getMarshalType(G, N, X, T) when element(1, T) == scoped_id -> + {FullScopedName, _, TK, _} = ic_symtab:get_full_scoped_name(G, N, T), + BT = ic_code:get_basetype(G, ic_util:to_dot(G,FullScopedName)), + case BT of + "erlang.pid" -> + ?ICPACKAGE ++ "PidHelper"; + "erlang.port" -> + ?ICPACKAGE ++ "PortHelper"; + "erlang.ref" -> + ?ICPACKAGE ++ "RefHelper"; + "erlang.term" -> + ?ICPACKAGE ++ "TermHelper"; + {enum, Type} -> + getMarshalType(G, N, X, Type); + Type -> + case TK of + {'tk_struct', _, _, _} -> + Type ++ "Helper"; + + {'tk_union', _, _, _, _, _} -> + Type ++ "Helper"; + + {'tk_array', _ , _} -> + Type ++ "Helper"; + + {'tk_sequence', _ , _} -> + Type ++ "Helper"; + + {'tk_enum', _, _, _} -> + Type ++ "Helper"; + + {'tk_string',_} -> + "string"; + + {'tk_wstring',_} -> %% WSTRING + "string"; + + 'tk_char' -> + "char"; + + 'tk_wchar' -> %% WCHAR + "char"; + + 'tk_octet' -> + "byte"; + + 'tk_ushort' -> + "ushort"; + + 'tk_ulong' -> + "uint"; + + 'tk_ulonglong' -> %% ULLONG + "ulong"; + + 'tk_short' -> + "short"; + + 'tk_long' -> + "int"; + + 'tk_longlong' -> %% LLONG + "long"; + + 'tk_float' -> + "float"; + + 'tk_double' -> + "double"; + + 'tk_boolean' -> + "boolean"; + + 'tk_void' -> + "atom"; + + 'tk_any' -> + ?ICPACKAGE ++ "AnyHelper"; + + _ -> + case isBasicType(G,N,TK) of + true -> + %% Faked the type ! + getMarshalType(G, N, X, {list_to_atom(tk2type(G,N,T,TK)), -1}); + false -> + ic_util:to_dot(G,FullScopedName) ++ "Helper" + end + end + end; + +getMarshalType(_G, _N, _X, S) when is_list(S) -> + S ++ "Helper"; + +getMarshalType(_G, _N, _X, T) when is_record(T, string) -> + "string"; + +getMarshalType(_G, _N, _X, T) when is_record(T, wstring) -> %% WSTRING + "string"; + +getMarshalType(G, N, _X, T) when is_record(T, struct) -> + ic_util:to_dot(G,[ic_forms:get_id2(T)|N]) ++ + "Helper"; + +getMarshalType(G, N, _X, T) when is_record(T, union) -> + ic_util:to_dot(G,[ic_forms:get_id2(T)|N]) ++ + "Helper"; + +getMarshalType(G, N, X, T) when is_record(T, array) andalso + is_record(X, case_dcl) -> + ic_util:to_dot(G,[ic_forms:get_id2(T)|N]) ++ + "Helper"; + +getMarshalType(G, N, X, T) when is_record(T, sequence) andalso + is_record(X, member) -> + ic_util:to_dot(G,[ic_forms:get_id2(X)|N]) ++ + "Helper"; + +getMarshalType(G, N, _X, T) when is_record(T, sequence) -> + getType(G, N, ic_forms:get_type(T)) ++ + "Helper"; + +getMarshalType(G, N, _X, T) when is_record(T, enum) -> + ic_util:to_dot(G,[ic_forms:get_id2(T)|N]) ++ + "Helper"; + +getMarshalType(_G, _N, _X, {boolean, _}) -> + "boolean"; + +getMarshalType(_G, _N, _X, {octet, _}) -> + "byte"; + +getMarshalType(_G, _N, _X, {void, _}) -> + ""; % <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + +getMarshalType(_G, _N, _X, {unsigned, U}) -> + case U of + {short,_} -> + "ushort"; + {long,_} -> + "uint"; + {'long long',_} -> + "ulong" + end; + +getMarshalType(_G, _N, _X, {short, _}) -> + "short"; +getMarshalType(_G, _N, _X, {long, _}) -> + "int"; +getMarshalType(_G, _N, _X, {'long long', _}) -> + "long"; +getMarshalType(_G, _N, _X, {float, _}) -> + "float"; +getMarshalType(_G, _N, _X, {double, _}) -> + "double"; +getMarshalType(_G, _N, _X, {char, _}) -> + "char"; +getMarshalType(_G, _N, _X, {wchar, _}) -> %% WCHAR + "char"; +getMarshalType(_G, _N, _X, {any, _}) -> + ?ICPACKAGE ++ "AnyHelper". + + + + +%%----------------------------------------------------------------- +%% Func: unMarshalFun/4 +%%----------------------------------------------------------------- +unMarshalFun(G, N, X, T) when element(1, T) == scoped_id -> + {FullScopedName, _, TK, _} = ic_symtab:get_full_scoped_name(G, N, T), + BT = ic_code:get_basetype(G, ic_util:to_dot(G,FullScopedName)), + case BT of + "erlang.pid" -> + ".read_pid()"; + "erlang.port" -> + ".read_port()"; + "erlang.ref" -> + ".read_ref()"; + "erlang.term" -> + ".read_term()"; + {enum, Type} -> + unMarshalFun(G, N, X, Type); + _Type -> + case isBasicType(G,N,TK) of + true -> + case TK of + {'tk_string',_} -> + ".read_string()"; + + {'tk_wstring',_} -> %% WSTRING + ".read_string()"; + + 'tk_boolean' -> + ".read_boolean()"; + + 'tk_octet' -> + ".read_byte()"; + + 'tk_ushort' -> + ".read_ushort()"; + + 'tk_ulong' -> + ".read_uint()"; + + 'tk_ulonglong' -> %% ULLONG + ".read_ulong()"; + + 'tk_short' -> + ".read_short()"; + + 'tk_long' -> + ".read_int()"; + + 'tk_longlong' -> %% LLONG + ".read_long()"; + + 'tk_float' -> + ".read_float()"; + + 'tk_double' -> + ".read_double()"; + + 'tk_char' -> + ".read_char()"; + + 'tk_wchar' -> %% WCHAR + ".read_char()"; + + _ -> + %% Faked the type ! + unMarshalFun(G, N, X, {list_to_atom(tk2type(G,N,X,TK)), -1}) + end; + false -> + ".unmarshal()" + end + end; + +unMarshalFun(_G, _N, _X, S) when is_list(S) -> + ".unmarshal()"; + +unMarshalFun(_G, _N, _X, T) when is_record(T, string) -> + ".read_string()"; + +unMarshalFun(_G, _N, _X, T) when is_record(T, wstring) -> %% WSTRING + ".read_string()"; + +unMarshalFun(_G, _N, _X, T) when is_record(T, struct) -> + ".unmarshal((" ++ ?ERLANGPACKAGE ++ "OtpErlangTuple)"; + +unMarshalFun(_G, _N, _X, T) when is_record(T, union) -> + ".unmarshal((" ++ ?ERLANGPACKAGE ++ "OtpErlangTuple)"; + +unMarshalFun(_G, _N, _X, T) when is_record(T, sequence) -> + ".unmarshal((" ++ ?ERLANGPACKAGE ++ "OtpErlanglist)"; + +unMarshalFun(_G, _N, _X, T) when is_record(T, enum) -> + ".unmarshal((" ++ ?ERLANGPACKAGE ++ "OtpErlangAtom)"; + +unMarshalFun(_G, _N, _X, {boolean, _}) -> + ".read_boolean()"; + +unMarshalFun(_G, _N, _X, {octet, _}) -> + ".read_byte()"; + +unMarshalFun(_G, _N, _X, {void, _}) -> + ""; + +unMarshalFun(_G, _N, _X, {unsigned, U}) -> + case U of + {short,_} -> + ".read_ushort()"; + {long,_} -> + ".read_uint()"; + {'long long',_} -> + ".read_ulong()" + end; + +unMarshalFun(_G, _N, _X, {short, _}) -> + ".read_short()"; +unMarshalFun(_G, _N, _X, {long, _}) -> + ".read_int()"; +unMarshalFun(_G, _N, _X, {'long long', _}) -> + ".read_long()"; +unMarshalFun(_G, _N, _X, {float, _}) -> + ".read_float()"; +unMarshalFun(_G, _N, _X, {double, _}) -> + ".read_double()"; +unMarshalFun(_G, _N, _X, {char, _}) -> + ".read_char()"; +unMarshalFun(_G, _N, _X, {wchar, _}) -> %% WCHAR + ".read_char()". + + + + + +%%----------------------------------------------------------------- +%% Func: getFullType/4 - /3 +%% +%% Note : Similar to the getType/3 with the major difference +%% thet on arrays and sequences it will also declare +%% their sizes. Used for "new" declarations +%% +%%----------------------------------------------------------------- + + +getFullType(G, N, X, T) when is_record(X, typedef) andalso is_record(T, array) -> + FullDim = + tk2FullType(G,N,X,ic_forms:get_tk(X)) ++ + getFullDim(G,N,T#array.size), + fixArrayDims(FullDim); + +getFullType(G, N, X, T) when is_record(X, member) andalso is_record(T, array) -> + FullDim = + getFullType(G, N, ic_forms:get_type(X)) ++ + getFullDim(G,N,T#array.size), + fixArrayDims(FullDim); + +getFullType(G, N, X, T) when is_record(X, case_dcl) andalso is_record(T, array) -> + FullDim = + getFullType(G, N, ic_forms:get_type(X)) ++ + getFullDim(G,N,T#array.size), + fixArrayDims(FullDim); + +getFullType(G, N, _X, T) -> + getFullType(G, N, T). + + + +getFullType(G, N, T) when is_record(T, scoped_id) -> + {FullScopedName, _, TK, _} = ic_symtab:get_full_scoped_name(G, N, T), + case TK of + {tk_array,_,_} -> + tk2FullType(G,N,T,TK); + {tk_sequence,_,_} -> + tk2FullType(G,N,T,TK); + _ -> + case isBasicType(G,N,TK) of + true -> + tk2FullType(G,N,T,TK); + false -> + %% Other types + ic_code:get_basetype(G, ic_util:to_dot(G,FullScopedName)) + end + end; + +getFullType(G, N, T) when is_record(T, sequence) -> + fixSeqDims(getType(G,N,T),"_length"); + +getFullType(G, N, T) -> + getType(G, N, T). + + + +%% In order to make a legal declaration +%% of an assignable array, the dimensions +%% of empty array sequences are swifted to +%% the end of the type +fixArrayDims(Cs) -> + fixArrayDims(Cs,[],[]). + +fixArrayDims([],Fulls,Emptys) -> + lists:reverse(Fulls) ++ Emptys; +fixArrayDims([91,93|Rest],Fulls,Emptys) -> + fixArrayDims(Rest,Fulls,[91,93|Emptys]); +fixArrayDims([C|Rest],Fulls,Emptys) -> + fixArrayDims(Rest,[C|Fulls],Emptys). + + +%% In order to make a legal declaration +%% of an assignable array, the dimensions +%% of empty array of sequences are swifted +%% to the end of the type +fixSeqDims(Cs,Length) -> + fixSeqDims(Cs,Length,[]). + +fixSeqDims([],_Length,Found) -> + lists:reverse(Found); +fixSeqDims([91,93|Rest],Length,Found) when is_list(Length) -> + lists:reverse([93|lists:reverse(Length)] ++ + [91|Found]) ++ Rest; +fixSeqDims([C|Rest],Length,Found) -> + fixSeqDims(Rest,Length,[C|Found]). + + + +%%----------------------------------------------------------------- +%% Func: inlinedTypes/2 +%%----------------------------------------------------------------- +inlinedTypes(PkgName, Type) when is_record(Type, struct) -> + "_" ++ PkgName ++ "."; +inlinedTypes(PkgName, Type) when is_record(Type, union) -> + "_" ++ PkgName ++ "."; +inlinedTypes(PkgName, Type) when is_record(Type, enum) -> + "_" ++ PkgName ++ "."; +inlinedTypes(_, _) -> + "". + +%%----------------------------------------------------------------- +%% Func: marshalFun/4 +%%----------------------------------------------------------------- +marshalFun(G, N, X, Type) -> + case isBasicType(G, N, Type) of + true -> + ".write_" ++ getMarshalType(G, N, X, Type); + _ -> + getMarshalType(G, N, X, Type) ++ ".marshal" + end. + + +%%----------------------------------------------------------------- +%% Func: isBasicType/3 +%%----------------------------------------------------------------- +isBasicType(G, N, S) when element(1, S) == scoped_id -> + {_, _, TK, _} = ic_symtab:get_full_scoped_name(G, N, S), + isBasicType(ictype:fetchType(TK)); + +isBasicType(G, N, X) when is_record(X, member) -> + if is_record(hd(element(3,X)), array) -> + false; + true -> + isBasicType(G, N, element(2,X)) + end; + +isBasicType(_G, _N, {unsigned, {long, _}} ) -> + true; + +isBasicType(_G, _N, {unsigned, {short, _}} ) -> + true; + +isBasicType(_G, _N, {unsigned, {'long long', _}} ) -> + true; + +isBasicType(_G, _N, {'long long', _} ) -> + true; + +isBasicType(_G, _N, {Type, _} ) -> + isBasicType(Type); + +isBasicType(_G, _N, Type) -> + isBasicType(Type). + + +%%----------------------------------------------------------------- +%% Func: isBasicType/1 +%%----------------------------------------------------------------- + +isBasicType( Type ) -> + lists:member(Type, + [tk_short,short, + tk_long,long, + tk_longlong,longlong, %% LLONG + tk_ushort,ushort, + tk_ulong,ulong, + tk_ulonglong,ulonglong, %% ULLONG + tk_float,float, + tk_double,double, + tk_boolean,boolean, + tk_char,char, + tk_wchar,wchar, %% WCHAR + tk_octet,octet, + tk_wstring,wstring, %% WSTRING + tk_string,string]). + +%% returns true if the Type is a java elementary type +isJavaElementaryType( Type ) -> + lists:member(Type, + [byte, char, wchar, boolean, + int, short, long, 'long long', float, double]). + +%%----------------------------------------------------------------- +%% Func: isIntegerType/3 +%%----------------------------------------------------------------- +isIntegerType(G, N, S) when element(1, S) == scoped_id -> + {_, _, TK, _} = ic_symtab:get_full_scoped_name(G, N, S), + isIntegerType(ictype:fetchType(TK)); +isIntegerType(_G, _N, {unsigned, {long, _}} ) -> + true; +isIntegerType(_G, _N, {unsigned, {short, _}} ) -> + true; +isIntegerType(_G, _N, {unsigned, {'long long', _}} ) -> + true; +isIntegerType(_G, _N, {'long long', _} ) -> + true; +isIntegerType(_G, _N, {Type, _} ) -> + isIntegerType(Type); +isIntegerType(_G, _N, Type) -> + isIntegerType(Type). + +%%----------------------------------------------------------------- +%% Func: isIntegerType/1 +%%----------------------------------------------------------------- + +isIntegerType( Type ) -> + lists:member(Type, + [tk_short,short, + tk_long,long, + tk_longlong,longlong, %% LLONG + tk_ushort,ushort, + tk_ulong,ulong, + tk_ulonglong,ulonglong, %% ULLONG + tk_char,char, + tk_wchar,wchar, %% WCHAR + tk_octet,octet]). + + + +%%----------------------------------------------------------------- +%% Func: isTerm/3 +%%----------------------------------------------------------------- +isTermType(G, N, T) -> + case getType(G,N,T) of + "com.ericsson.otp.ic.Term" -> + true; + _ -> + false + end. + + + + +%%----------------------------------------------------------------- +%% Internal functions +%%----------------------------------------------------------------- + + +%% Changes the typecode to the +%% corresponding "basic" type +tk2type(_G,_N,_X,{'tk_struct', _IFRId, "port", _ElementList}) -> + ?ICPACKAGE ++ "Port"; +tk2type(_G,_N,_X,{'tk_struct', _IFRId, "pid", _ElementList}) -> + ?ICPACKAGE ++ "Pid"; +tk2type(_G,_N,_X,{'tk_struct', _IFRId, "ref", _ElementList}) -> + ?ICPACKAGE ++ "Ref"; +tk2type(_G,_N,_X,{'tk_struct', _IFRId, "term", _ElementList}) -> + ?ICPACKAGE ++ "Term"; +tk2type(_G,_N,_X,{'tk_string', _}) -> + "java.lang.String"; +tk2type(_G,_N,_X,{'tk_wstring', _}) -> %% WSTRING + "java.lang.String"; +tk2type(G,N,X,{'tk_array', ElemTC, Dim}) -> + tkarr2decl(G,N,X,{'tk_array', ElemTC, Dim}); +tk2type(G,N,X,{'tk_sequence', ElemTC, MaxLsextractength}) -> + tkseq2decl(G,N,X,{'tk_sequence', ElemTC, MaxLsextractength}); +tk2type(G,N,_X,{'tk_struct', IFRId, Name, _ElementList}) -> + ScopedId= + lists:reverse(string:tokens(lists:nth(2,string:tokens(IFRId,":")),"/")), + + case ic_forms:clean_up_scope([Name|N]) of + ScopedId -> + %% Right path, use N instead + ic_util:to_dot(G,[Name|N]); + _ -> + %% Ugly work arround + ic_util:to_dot(G,ScopedId) + end; +tk2type(G,N,_X,{'tk_union', IFRId, Name, _, _, _ElementList}) -> + ScopedId= + lists:reverse(string:tokens(lists:nth(2,string:tokens(IFRId,":")),"/")), + + case ic_forms:clean_up_scope([Name|N]) of + ScopedId -> + %% Right path, use N instead + ic_util:to_dot(G,[Name|N]); + _ -> + %% Ugly work arround + ic_util:to_dot(G,ScopedId) + end; +tk2type(_G,_N,_X,{'tk_enum', _Id, Name, _ElementList}) -> + Name; +tk2type(_G,_N,_X,tk_void) -> + "void"; +tk2type(_G,_N,_X,tk_long) -> + "int"; +tk2type(_G,_N,_X,tk_longlong) -> %% LLONG + "long"; +tk2type(_G,_N,_X,tk_short) -> + "short"; +tk2type(_G,_N,_X,tk_ulong) -> + "int"; +tk2type(_G,_N,_X,tk_ulonglong) -> %% ULLONG + "long"; +tk2type(_G,_N,_X,tk_ushort) -> + "short"; +tk2type(_G,_N,_X,tk_float) -> + "float"; +tk2type(_G,_N,_X,tk_double) -> + "double"; +tk2type(_G,_N,_X,tk_boolean) -> + "boolean"; +tk2type(_G,_N,_X,tk_char) -> + "char"; +tk2type(_G,_N,_X,tk_wchar) -> %% WCHAR + "char"; +tk2type(_G,_N,_X,tk_octet) -> + "byte"; +tk2type(_G,_N,_X,tk_string) -> + "java.lang.String"; +tk2type(_G,_N,_X,tk_wstring) -> %% WSTRING + "java.lang.String"; +tk2type(_G,_N,_X,tk_any) -> + ?ICPACKAGE ++ "Any"; +tk2type(_G,_N,_X,tk_term) -> %% Term + ?ICPACKAGE ++ "Term". + +%% Changes the sequence typecode to the +%% corresponding "basic" structure +tkseq2decl(G,N,X,TKSeq) -> + tkseq2decl2(G,N,X,TKSeq,[],[]). + +tkseq2decl2(G,N,X,{tk_sequence,E,D},[],Ds) -> + tkseq2decl2(G,N,X,E,[],[D|Ds]); +tkseq2decl2(G,N,X,TkEl,[],Ds) -> + ElName = tk2type(G,N,X,TkEl), + ElName ++ getdim(Ds). + +%% Changes the array typecode to the +%% corresponding "basic" structure +tkarr2decl(G,N,X,TKArr) -> + tkarr2decl2(G,N,X,TKArr,[],[]). + +tkarr2decl2(G,N,X,{tk_array,E,D},[],Ds) -> + tkarr2decl2(G,N,X,E,[],[D|Ds]); +tkarr2decl2(G,N,X,TkEl,[],Ds) -> + ElName = tk2type(G,N,X,TkEl), + ElName ++ getdim(Ds). + +getdim([]) -> + ""; +getdim([_D|Ds]) -> + getdim(Ds) ++ "[]". + + + +%% Changes the typecode to the corresponding "basic" type +%% used for variable declarations where arrays and sequences +%% are declared with there full dimensions +tk2FullType(G,N,X,{'tk_array', ElemTC, Dim}) -> + tkarr2FullDecl(G,N,X,{'tk_array', ElemTC, Dim}); +tk2FullType(G,N,X,{'tk_sequence', ElemTC, MaxLsextractength}) -> + tkseq2FullDecl(G,N,X,{'tk_sequence', ElemTC, MaxLsextractength}); +tk2FullType(G,N,X,TK) -> + tk2type(G,N,X,TK). + + +%% Changes the sequence typecode to the +%% corresponding "basic" structure here +%% arrays and sequences are declared with +%% their full dimensions +tkseq2FullDecl(G,N,X,TKSeq) -> + tkseq2FullDecl2(G,N,X,TKSeq,[],[]). + +tkseq2FullDecl2(G,N,X,{tk_sequence,E,D},[],Ds) -> + tkseq2FullDecl2(G,N,X,E,[],[D|Ds]); +tkseq2FullDecl2(G,N,X,TkEl,[],Ds) -> + ElName = tk2FullType(G,N,X,TkEl), + ElName ++ getdim(Ds). + +%% Changes the array typecode to the +%% corresponding "basic" structure +tkarr2FullDecl(G,N,X,TKArr) -> + tkarr2FullDecl2(G,N,X,TKArr,[],[]). + +tkarr2FullDecl2(G,N,X,{tk_array,E,D},[],Ds) -> + tkarr2FullDecl2(G,N,X,E,[],[D|Ds]); +tkarr2FullDecl2(G,N,X,TkEl,[],Ds) -> + ElName = tk2FullType(G,N,X,TkEl), + ElName ++ getFullDim(G,N,Ds). + +getFullDim(_G,_N,[]) -> + ""; +getFullDim(G,N,[D|Ds]) when is_record(D,scoped_id) -> + {FSN, _, _, _} = ic_symtab:get_full_scoped_name(G, N, D), + "[" ++ ic_util:to_dot(G,FSN) ++ "]" ++ getFullDim(G,N,Ds); +getFullDim(G,N,[D|Ds]) when is_integer(D) -> + "[" ++ integer_to_list(D) ++ "]" ++ getFullDim(G,N,Ds); +getFullDim(G,N,[D|Ds]) when is_tuple(D) -> + "[" ++ ic_util:eval_java(G,N,D) ++ "]" ++ getFullDim(G,N,Ds). + + + +%% Constructs an array empty dimension string +%% used for array variable declaration +arrayEmptyDim(X) -> + arrayEmptyDim2(X#array.size). + +arrayEmptyDim2([_D]) -> + "[]"; +arrayEmptyDim2([_D |Ds]) -> + "[]" ++ arrayEmptyDim2(Ds). + + + diff --git a/lib/ic/src/ic_jbe.erl b/lib/ic/src/ic_jbe.erl new file mode 100644 index 0000000000..81798d0429 --- /dev/null +++ b/lib/ic/src/ic_jbe.erl @@ -0,0 +1,1487 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1999-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_jbe). + + +-export([do_gen/3, gen/3, emit_type_function/4]). + + + +-include("icforms.hrl"). +-include("ic.hrl"). +-include("ic_debug.hrl"). +-include_lib("stdlib/include/erl_compile.hrl"). + + + +%%------------------------------------------------------------ +%% +%% Entry point +%% +%%------------------------------------------------------------ + +do_gen(G, _File, Form) -> + gen(G, [], Form). + + +%%------------------------------------------------------------ +%% +%% Generate the client side C stubs. +%% +%% Each module is generated to a separate file. +%% +%% Each function needs to generate a function head and +%% a body. IDL parameters must be converted into C parameters. +%% +%%------------------------------------------------------------ + +gen(G, N, [X|Xs]) when is_record(X, preproc) -> + NewG = handle_preproc(G, N, X#preproc.cat, X), + gen(NewG, N, Xs); + +gen(G, N, [X|Xs]) when is_record(X, module) -> + gen_module(G, N, X), + gen(G, N, Xs); + +gen(G, N, [X|Xs]) when is_record(X, interface) -> + gen_interface(G, N, X), + gen(G, N, Xs); + +gen(G, N, [X|Xs]) when is_record(X, const) -> + ic_constant_java:gen(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) -> + gen_exception(G, N, X), + gen(G, N, Xs); + +gen(G, N, [X|Xs]) when is_record(X, enum) -> + ic_enum_java:gen(G, N, X), + gen(G, N, Xs); + +gen(G, N, [X|Xs]) when is_record(X, struct) -> + ic_struct_java:gen(G, N, X), + gen(G, N, Xs); + +gen(G, N, [X|Xs]) when is_record(X, union) -> + ic_union_java:gen(G, N, X), + gen(G, N, Xs); + +gen(G, N, [X|Xs]) when is_record(X, typedef) -> + gen_typedef(G, N, X), + gen(G, N, Xs); + +gen(G, N, [X|Xs]) when is_record(X, member) -> + %%?PRINTDEBUG2("gen member: ~p\n",[ic_forms:get_type(X)]), + gen_member(G, N, X), + gen(G, N, Xs); + +gen(G, N, [X|Xs]) when is_record(X, case_dcl) -> + %%?PRINTDEBUG2("gen case decl: ~p\n",[ic_forms:get_type(X)]), + gen(G, N, [ic_forms:get_type(X)]), + gen(G, N, Xs); + +gen(G, N, [_|Xs]) -> + gen(G, N, Xs); + +gen(_G, _N, []) -> + ok. + + +%%%-------------------------------------------- +%%% +%%% Just generates the directory to host +%%% the module files +%%% +%%%-------------------------------------------- + +gen_module(G, N, X) -> + case ic_genobj:do_gen(G) of + + true -> %% Generate & register + N1 = [ic_forms:get_id2(X) | N], + %% Create directory + ic_file:createJavaDirectory(G, N1), + gen(G, N1, ic_forms:get_body(X)); + + false -> %% Register only + N1 = [ic_forms:get_id2(X) | N], + reg(G, N1, ic_forms:get_body(X)) + end. + +reg(G, N, [X|_Xs]) when is_record(X, module) -> + reg(G, [ic_forms:get_id2(X) | N], ic_forms:get_body(X)); + +reg(G, N, [X|_Xs]) when is_record(X, interface) -> + reg(G, [ic_forms:get_id2(X) | N], ic_forms:get_body(X)); + +reg(G, N, [X|Xs]) when is_record(X, typedef) -> + Name = ic_util:to_dot(G,[ic_forms:get_java_id(X) | N]), + case X#typedef.type of + {scoped_id,_,_,_} -> + {FullScopedName, _, _, _} = + ic_symtab:get_full_scoped_name(G, N, X#typedef.type), + Type = ic_code:get_basetype(G, ic_util:to_dot(G,FullScopedName)), + ic_code:insert_typedef(G, Name, Type); + _ -> + ok + end, + reg(G, N, Xs); + +reg(G, N, [_|Xs]) -> + reg(G, N, Xs); + +reg(_G, _N, []) -> + ok. + + + + +%%%---------------------------------------------- +%%% +%%% Generates the interface code +%%% +%%%---------------------------------------------- + +gen_interface(G, N, X) -> + case ic_genobj:do_gen(G) of + true -> + G1 = ic_file:javaInterfaceFilePush(G, N, X), + + %% Generate Interface file + InterfaceFd = ic_genobj:interfacefiled(G1), + emit_interface(G1, N, X, InterfaceFd), + + %% Generate Helper file + HelperFd = ic_genobj:helperfiled(G1), + emit_helper(G1, N, X, HelperFd), + + %% Generate Holder file + HolderFd = ic_genobj:holderfiled(G1), + emit_holder(G1, N, X, HolderFd), + + %% Generate Stub file + StubFd = ic_genobj:stubfiled(G1), + emit_stub(G1,N,X,StubFd), %<--------------------------------------------------- 1 + + %% Generate Skeleton file + SkelFd = ic_genobj:skelfiled(G1), + emit_skel(G1, N, X, SkelFd), + + ic_file:javaInterfaceFilePop(G1); + false -> + ok + end. + + + + +%%%-------------------------------------------- +%%% +%%% Typedef redirection +%%% +%%%-------------------------------------------- + +gen_typedef(G, N, X) -> + Name = ic_util:to_dot(G,[ic_forms:get_java_id(X) | N]), + case X#typedef.type of + {scoped_id,_,_,_} -> + {FullScopedName, _, _, _} = + ic_symtab:get_full_scoped_name(G, N, X#typedef.type), + Type = ic_code:get_basetype(G, ic_util:to_dot(G,FullScopedName)), + ic_code:insert_typedef(G, Name, Type); + _ -> + ok + end, + gen_typedef_1(G, N, X, ic_forms:get_body(X)). + +gen_typedef_1(G, N, X, Type) when is_record(Type, sequence) -> + ic_sequence_java:gen(G, N, Type, ic_forms:get_java_id(X)); +gen_typedef_1(G, N, X, Type) when is_record(Type, array) -> + ic_array_java:gen(G, N, X, Type); +gen_typedef_1(G, N, X, _Type) -> + gen_typedef_2(G, N, X, X#typedef.id), + ok. + +gen_typedef_2(G, N, X, Type) when is_record(Type, array) -> + gen_typedef_1(G, N, X, Type); +gen_typedef_2(G, N, X, Type) when is_list(Type) -> + case Type of + [] -> + ok; + _ -> + gen_typedef_2(G, N, X, hd(Type)), + gen_typedef_2(G, N, X, tl(Type)) + end; +%gen_typedef_2(G, N, X, Type) -> %% Generating Helpers for typedef +% %% Stoped due to compatibility problems +% %% with erl_genserv backend +% case ic_java_type:isBasicType(G,N,X#typedef.type) of +% true -> +% ok; +% false -> +% case ic_forms:get_type_code(G,N,X#typedef.type) of +% {'tk_struct', _, _, _} -> +% ic_struct_java:gen(G, N, X); +% {'tk_sequence',_,_} -> +% ic_sequence_java:gen(G, N, X, ic_forms:get_java_id(X)), +% ok; +% _ -> +% ok +% end +% end; +gen_typedef_2(_G, _N, _X, _Type) -> + ok. + + + +%%%-------------------------------------------- +%%% +%%% Member redirection +%%% +%%%-------------------------------------------- + +gen_member(G, N, X) -> + gen_member_1(G, N, X, [X#member.type]), + gen_member_2(G, N, X, X#member.id). + + +gen_member_1(_G, _N, _X, []) -> + ok; + +gen_member_1(G, N, X, [T|Ts]) when is_record(T, sequence) -> + ic_sequence_java:gen(G, N, T, ic_forms:get_java_id(X)), + gen_member_1(G, N, X, Ts); + +gen_member_1(G, N, X, [T|Ts]) -> + gen(G,N,[T]), + gen_member_1(G,N,X,Ts). + + +gen_member_2(_G, _N, _X, []) -> + ok; + +gen_member_2(G, N, X, [T|Ts]) when is_record(T, array) -> %% BUG ! + ic_array_java:gen(G, N, X, T), + gen_member_2(G, N, X, Ts); + +gen_member_2(G, N, X, [_T|Ts]) -> + gen_member_2(G, N, X, Ts). + + + +gen_exception(_G, N, X) -> + io:format("Warning : Exceptions not supported for java mapping, ~p ignored\n", + [ic_util:to_colon([ic_forms:get_java_id(X)|N])]), + ok. + + + +%%%----------------------------------------------------- +%%% +%%% Interface file generation +%%% +%%%----------------------------------------------------- + +emit_interface(G, N, X, Fd) -> + Interface = ic_forms:get_java_id(X), %% Java Interface Name + IFCName = ic_forms:get_id2(X), %% Internal Interface Name + + ic_codegen:emit(Fd, "public interface ~s {\n\n",[Interface]), + Body = ic_forms:get_body(X), + + %% Generate type declarations inside interface + gen(G, [IFCName |N], Body), + + lists:foreach(fun({_Name, Body1}) -> + emit_interface_prototypes(G, [IFCName|N], Body1, Fd) end, + [{x, Body} | X#interface.inherit_body]), + + ic_codegen:emit(Fd, "}\n\n"). + + +emit_interface_prototypes(G, N, [X |Xs], Fd) when is_record(X, op) -> + + {_, ArgNames, TypeList} = extract_info(G, N, X), + {R, ParameterTypes, _} = TypeList, + + OpName = ic_forms:get_java_id(X), + RT = ic_java_type:getParamType(G,N,R,ret), + PL = ic_util:mk_list(gen_par_list(G, N, X, ParameterTypes,ArgNames)), + + ic_codegen:emit(Fd, "/*\n"), + ic_codegen:emit(Fd, " * Operation ~p interface functions \n", [ic_util:to_colon([OpName|N])]), + ic_codegen:emit(Fd, " */\n\n"), + + ic_codegen:emit(Fd, "~s ~s(~s)\n",[RT, OpName, PL]), + ic_codegen:emit(Fd, " throws java.lang.Exception;\n\n\n"), + + emit_interface_prototypes(G, N, Xs, Fd); +emit_interface_prototypes(G, N, [X |Xs], Fd) when is_record(X, attr) -> + ic_attribute_java:emit_attribute_prototype(G, N, X, Fd), + emit_interface_prototypes(G, N, Xs, Fd); +emit_interface_prototypes(G, N, [_X|Xs], Fd) -> + emit_interface_prototypes(G, N, Xs, Fd); +emit_interface_prototypes(_G, _N, [], _Fd) -> ok. + + + + +%%%----------------------------------------------------- +%%% +%%% Holder file generation +%%% +%%%----------------------------------------------------- + +emit_holder(_G, N, X, Fd) -> + InterfaceName = ic_forms:get_java_id(X), + FullInterfaceName = ic_util:to_dot([InterfaceName|N]), + + ic_codegen:emit(Fd, "public final class ~sHolder {\n\n",[InterfaceName]), + + ic_codegen:emit(Fd, " // Instance variable\n"), + ic_codegen:emit(Fd, " public ~s value;\n\n",[FullInterfaceName]), + + ic_codegen:emit(Fd, " // Constructors\n"), + ic_codegen:emit(Fd, " public ~sHolder() {\n",[InterfaceName]), + ic_codegen:emit(Fd, " this(null);\n"), + ic_codegen:emit(Fd, " }\n\n"), + + ic_codegen:emit(Fd, " public ~sHolder(~s _arg) {\n",[InterfaceName, FullInterfaceName]), + ic_codegen:emit(Fd, " value = _arg;\n"), + ic_codegen:emit(Fd, " }\n\n"), + + ic_codegen:emit(Fd, " public void _marshal() {\n"), + ic_codegen:emit(Fd, " }\n\n"), + + ic_codegen:emit(Fd, " public void _unmarshal() {\n"), + ic_codegen:emit(Fd, " }\n\n"), + + ic_codegen:emit(Fd, "}\n\n"). + + + + +%%%----------------------------------------------------- +%%% +%%% Helper file generation +%%% +%%%----------------------------------------------------- +emit_helper(G, N, X, Fd) -> + InterfaceName = ic_forms:get_java_id(X), + FullInterfaceName = ic_util:to_dot([InterfaceName|N]), + + ic_codegen:emit(Fd, "public final class ~sHelper {\n\n",[InterfaceName]), + + ic_codegen:emit(Fd, " // Constructor\n"), + ic_codegen:emit(Fd, " public ~sHelper() {\n",[InterfaceName]), + ic_codegen:emit(Fd, " }\n\n"), + + ic_codegen:emit(Fd, " public static void _marshal() {\n"), + ic_codegen:emit(Fd, " // Writing the object to the message\n"), + ic_codegen:emit(Fd, " }\n\n"), + + ic_codegen:emit(Fd, " public static ~s _unmarshal() {\n",[FullInterfaceName]), + ic_codegen:emit(Fd, " // Reading the object from the message\n"), + ic_codegen:emit(Fd, " return null;\n"), + ic_codegen:emit(Fd, " }\n\n"), + + ic_codegen:emit(Fd, " public static java.lang.String id() {\n"), + ic_codegen:emit(Fd, " return ~p;\n",[ictk:get_IR_ID(G, N, X)]), + ic_codegen:emit(Fd, " }\n\n"), + + ic_codegen:emit(Fd, "}\n\n"). + + + + +%%%----------------------------------------------------- +%%% +%%% Stub file generation +%%% +%%%----------------------------------------------------- + +emit_stub(G, N, X, Fd) -> + InterfaceName = ic_forms:get_java_id(X), %% Java Interface Name + IFCName = ic_forms:get_id2(X), %% Internal Interface Name + + FullInterfaceName = ic_util:to_dot([InterfaceName|N]), + Body = ic_forms:get_body(X), + + ic_codegen:emit(Fd, "public class _~sStub implements ~s {\n\n", + [InterfaceName,FullInterfaceName]), + + ic_codegen:emit(Fd, " // Client data\n"), + ic_codegen:emit(Fd, " public ~sEnvironment _env;\n\n",[?ICPACKAGE]), + + ic_codegen:emit(Fd, " // Constructors\n"), + ic_codegen:emit(Fd, " public _~sStub(~sOtpSelf _self,\n",[InterfaceName,?ERLANGPACKAGE]), + ic_codegen:emit(Fd, " ~sOtpPeer _peer,\n",[?ERLANGPACKAGE]), + ic_codegen:emit(Fd, " java.lang.Object _server) throws java.lang.Exception {\n\n"), + + ic_codegen:emit(Fd, " _env =\n"), + ic_codegen:emit(Fd, " new ~sEnvironment(_self, _peer, _server);\n",[?ICPACKAGE]), + ic_codegen:emit(Fd, " _env.connect();\n"), + ic_codegen:emit(Fd, " }\n\n"), + + ic_codegen:emit(Fd, " public _~sStub(java.lang.String _selfN,\n",[InterfaceName]), + ic_codegen:emit(Fd, " java.lang.String _peerN,\n"), + ic_codegen:emit(Fd, " java.lang.String _cookie,\n"), + ic_codegen:emit(Fd, " java.lang.Object _server) throws java.lang.Exception {\n\n"), + ic_codegen:emit(Fd, " _env =\n"), + ic_codegen:emit(Fd, " new ~sEnvironment(_selfN, _peerN, _cookie, _server);\n",[?ICPACKAGE]), + ic_codegen:emit(Fd, " _env.connect();\n"), + ic_codegen:emit(Fd, " }\n\n"), + + ic_codegen:emit(Fd, " public _~sStub(~sOtpConnection _connection,\n",[InterfaceName, ?ERLANGPACKAGE]), + ic_codegen:emit(Fd, " java.lang.Object _server) throws java.lang.Exception {\n\n"), + ic_codegen:emit(Fd, " _env =\n"), + ic_codegen:emit(Fd, " new ~sEnvironment(_connection, _server);\n",[?ICPACKAGE]), + ic_codegen:emit(Fd, " _env.connect();\n"), + ic_codegen:emit(Fd, " }\n\n"), + + emit_message_reference_extraction(Fd), + + emit_servers_object_access(Fd), + + emit_client_connection_close(Fd), + + emit_client_connection_reconnect(Fd), + + emit_client_destroy(Fd), + + lists:foreach(fun({_Name, Body1}) -> + emit_op_implementation(G, [IFCName|N], Body1, Fd) end, + [{x, Body} | X#interface.inherit_body]), + + ic_codegen:emit(Fd, "}\n\n"). + + +emit_op_implementation(G, N, [X |Xs], Fd) when is_record(X, op) -> + + WireOpName = ic_forms:get_id2(X), + OpName = ic_forms:get_java_id(WireOpName), + {_, ArgNames, TypeList} = extract_info(G, N, X), + {R, ParamTypes, _} = TypeList, + + RT = ic_java_type:getParamType(G,N,R,ret), + PL = ic_util:mk_list(gen_par_list(G, N, X, ParamTypes, ArgNames)), + CMCPL = ic_util:mk_list(gen_client_marshal_call_par_list(ArgNames)), + + ic_codegen:emit(Fd, " // Operation ~p implementation\n", [ic_util:to_colon([WireOpName|N])]), + ic_codegen:emit(Fd, " public ~s ~s(~s)\n", [RT, OpName, PL]), + ic_codegen:emit(Fd, " throws java.lang.Exception {\n\n"), + + %% Function marshal call + ic_codegen:emit(Fd, " // Calling the marshal function\n"), + + case CMCPL of + "" -> + ic_codegen:emit(Fd, " _~s_marshal(_env);\n\n",[OpName]); + _ -> + ic_codegen:emit(Fd, " _~s_marshal(_env, ~s);\n\n",[OpName, CMCPL]) + end, + + %% Sending call + ic_codegen:emit(Fd, " // Message send\n"), + ic_codegen:emit(Fd, " _env.send();\n\n"), + + case ic_forms:is_oneway(X) of + true -> + ok; + false -> + %% Receiving return values + ic_codegen:emit(Fd, " // Message receive\n"), + ic_codegen:emit(Fd, " _env.receive();\n\n"), + + %% Function unmarshal call + case RT of + "void" -> + case ic_util:mk_list(gen_client_unmarshal_call_par_list(ArgNames)) of + "" -> + ic_codegen:emit(Fd, " // Calling the unmarshal function\n"), + ic_codegen:emit(Fd, " _~s_unmarshal(_env);\n", + [OpName]); + UMCPL -> + ic_codegen:emit(Fd, " // Calling the unmarshal function\n"), + ic_codegen:emit(Fd, " _~s_unmarshal(_env, ~s);\n", + [OpName,UMCPL]) + end; + _ -> + ic_codegen:emit(Fd, " // Calling the unmarshal function\n"), + case ic_util:mk_list(gen_client_unmarshal_call_par_list(ArgNames)) of + "" -> + ic_codegen:emit(Fd, " return _~s_unmarshal(_env);\n", + [OpName]); + UMCPL -> + ic_codegen:emit(Fd, " return _~s_unmarshal(_env, ~s);\n", + [OpName,UMCPL]) + end + end + end, + ic_codegen:emit(Fd, " }\n\n"), + + %% Marshalling + emit_op_marshal(G, N, X, Fd), + + %% UnMarshalling + emit_op_unmarshal(G, N, X, Fd), + ic_codegen:emit(Fd, "\n"), + + emit_op_implementation(G, N, Xs, Fd); +emit_op_implementation(G, N, [X |Xs], Fd) when is_record(X, attr) -> + ic_attribute_java:emit_attribute_stub_code(G, N, X, Fd), + emit_op_implementation(G, N, Xs, Fd); +emit_op_implementation(G, N, [_X|Xs], Fd) -> + emit_op_implementation(G, N, Xs, Fd); +emit_op_implementation(_G, _N, [], _Fd) -> ok. + + + + + +%%--------------------------------------- +%% +%% Marshal operation generation +%% +%%--------------------------------------- + +emit_op_marshal(G, N, X, Fd) -> + WireOpName = ic_forms:get_id2(X), + OpName = ic_forms:get_java_id(WireOpName), + {_, ArgNames, TypeList} = extract_info(G, N, X), + {_R, ParamTypes, _} = TypeList, + + PL = ic_util:mk_list(gen_marshal_par_list(G, N, X, ParamTypes, ArgNames)), + + ic_codegen:emit(Fd, " // Marshal operation for ~p\n", [OpName]), + case PL of + "" -> + ic_codegen:emit(Fd, " public static void _~s_marshal(~sEnvironment __env)\n", + [OpName, ?ICPACKAGE]), + ic_codegen:emit(Fd, " throws java.lang.Exception {\n\n"); + _ -> + ic_codegen:emit(Fd, " public static void _~s_marshal(~sEnvironment __env, ~s)\n", + [OpName, ?ICPACKAGE, PL]), + ic_codegen:emit(Fd, " throws java.lang.Exception {\n\n") + end, + %% Message encoding + emit_op_encode(G, N, X, OpName, WireOpName, ParamTypes, ArgNames, Fd), + + ic_codegen:emit(Fd, " }\n\n"). + + +emit_op_encode(G, N, X, _OpN, WOpN, ParamTypes, ArgNames, Fd) -> + + OpCallName = case ic_options:get_opt(G, scoped_op_calls) of + true -> + ic_util:to_undersc([WOpN|N]); + false -> + WOpN + end, + + SendParamNr = count_client_send(ArgNames), + + ic_codegen:emit(Fd, " ~sOtpOutputStream __os = __env.getOs();\n\n", + [?ERLANGPACKAGE]), + + case ic_forms:is_oneway(X) of + true -> + %% Initiating call tuple + ic_codegen:emit(Fd, " // Message header assembly\n"), + ic_codegen:emit(Fd, " __os.reset();\n"), + ic_codegen:emit(Fd, " __os.write_tuple_head(2);\n"), + ic_codegen:emit(Fd, " __os.write_atom(\"$gen_cast\");\n\n"); + false -> + %% Initiating call tuple + ic_codegen:emit(Fd, " // Message header assembly\n"), + ic_codegen:emit(Fd, " __os.reset();\n"), + ic_codegen:emit(Fd, " __os.write_tuple_head(3);\n"), + ic_codegen:emit(Fd, " __os.write_atom(\"$gen_call\");\n\n"), + + %% Initiating call identity tuple + ic_codegen:emit(Fd, " // Message identity part creation\n"), + ic_codegen:emit(Fd, " __os.write_tuple_head(2);\n"), + ic_codegen:emit(Fd, " __env.write_client_pid();\n"), + ic_codegen:emit(Fd, " __env.write_client_ref();\n\n") + end, + + %% Operation part initializations + case SendParamNr > 0 of + true -> + ic_codegen:emit(Fd, " // Operation attribute creation\n"), + ic_codegen:emit(Fd, " __os.write_tuple_head(~p);\n", [SendParamNr+1]), + ic_codegen:emit(Fd, " __os.write_atom(~p);\n", [OpCallName]), + emit_op_encode_loop(G, N, X, ParamTypes, ArgNames, 1, Fd); + false -> %% No in/inout paramaters + ic_codegen:emit(Fd, " __os.write_atom(~p);\n", [OpCallName]) + end. + + + +emit_op_encode_loop(_,_,_,_,[],_,_Fd) -> + ok; +emit_op_encode_loop(G, N, X, [_Type|Types],[{out, _Arg}|Args], Counter, Fd) -> + emit_op_encode_loop(G, N, X, Types, Args, Counter, Fd); +emit_op_encode_loop(G, N, X, [Type|Types], [{inout, Arg}|Args], Counter, Fd) -> + case ic_java_type:isBasicType(G, N, Type) of + true -> + ic_codegen:emit(Fd, " __os~s(~s.value);\n", + [ic_java_type:marshalFun(G, N, X, Type),Arg]); + false -> + ic_codegen:emit(Fd, " ~s(__os, ~s.value);\n", + [ic_java_type:marshalFun(G, N, X, Type),Arg]) + end, + emit_op_encode_loop(G, N, X, Types, Args, Counter+1, Fd); +emit_op_encode_loop(G, N, X, [Type|Types], [{in, Arg}|Args], Counter, Fd) -> + case ic_java_type:isBasicType(G, N, Type) of + true -> + ic_codegen:emit(Fd, " __os~s(~s);\n", + [ic_java_type:marshalFun(G, N, X, Type),Arg]); + false -> + ic_codegen:emit(Fd, " ~s(__os, ~s);\n", + [ic_java_type:marshalFun(G, N, X, Type),Arg]) + end, + emit_op_encode_loop(G, N, X, Types, Args, Counter+1, Fd). + + + + + + +%%------------------------------------- +%% +%% UnMarshal operation generation +%% +%%------------------------------------- + +emit_op_unmarshal(G, N, X, Fd) -> + case ic_forms:is_oneway(X) of + true -> + ok; + false -> + OpName = ic_forms:get_java_id(X), + {_, ArgNames, TypeList} = extract_info(G, N, X), + {R, ParamTypes, _} = TypeList, + + RT = ic_java_type:getParamType(G,N,R,ret), + PL = ic_util:mk_list(gen_unmarshal_par_list(G, N, X, ParamTypes, ArgNames)), + + case PL of + "" -> + case RT of + "void" -> + ic_codegen:emit(Fd, " // Unmarshal operation for ~p\n", [OpName]), + ic_codegen:emit(Fd, " public static void _~s_unmarshal(~sEnvironment __env)\n", + [OpName, ?ICPACKAGE]), + ic_codegen:emit(Fd, " throws java.lang.Exception {\n\n"), + ic_codegen:emit(Fd, " __env.getIs().read_atom();\n"), + ic_codegen:emit(Fd, " }\n\n"); + _ -> + ic_codegen:emit(Fd, " // Unmarshal operation for ~p\n", [OpName]), + ic_codegen:emit(Fd, " public static ~s _~s_unmarshal(~sEnvironment __env)\n", + [RT, OpName, ?ICPACKAGE]), + ic_codegen:emit(Fd, " throws java.lang.Exception {\n\n"), + + ic_codegen:emit(Fd, " // Get input stream\n"), + ic_codegen:emit(Fd, " ~sOtpInputStream __is = __env.getIs();\n\n", + [?ERLANGPACKAGE]), + + emit_op_decode(G, N, X, R, RT, ParamTypes, ArgNames, Fd), + ic_codegen:emit(Fd, " }\n\n") + end; + _ -> + ic_codegen:emit(Fd, " // Unmarshal operation for ~p\n", [OpName]), + ic_codegen:emit(Fd, " public static ~s _~s_unmarshal(~sEnvironment __env, ~s)\n", + [RT, OpName, ?ICPACKAGE, PL]), + ic_codegen:emit(Fd, " throws java.lang.Exception {\n\n"), + + ic_codegen:emit(Fd, " // Get input stream\n"), + ic_codegen:emit(Fd, " ~sOtpInputStream __is = __env.getIs();\n\n", + [?ERLANGPACKAGE]), + + emit_op_decode(G, N, X, R, RT, ParamTypes, ArgNames, Fd), + ic_codegen:emit(Fd, " }\n\n") + end + end. + + +emit_op_decode(G, N, X, R, RT, ParamTypes, ArgNames, Fd) -> + ReceiveNr = count_client_receive(ArgNames), + + case RT of + "void" -> + case ReceiveNr > 0 of + true -> + ic_codegen:emit(Fd, " // Extracting output values\n"), + ic_codegen:emit(Fd, " __is.read_tuple_head();\n"), + ic_codegen:emit(Fd, " __is.read_atom();\n"), + emit_op_decode_loop(G, N, X, ParamTypes, ArgNames, 1, Fd); + false -> + ic_codegen:emit(Fd, " __is.read_atom();\n") + end; + _ -> + case ReceiveNr > 0 of + true -> + ic_codegen:emit(Fd, " // Extracting return/output values\n"), + ic_codegen:emit(Fd, " __is.read_tuple_head();\n"), + case ic_java_type:isBasicType(G,N,R) of + true -> + ic_codegen:emit(Fd, " ~s _result = __is~s;\n", + [RT,ic_java_type:unMarshalFun(G, N, X, R)]); + false -> + ic_codegen:emit(Fd, " ~s _result = ~s.unmarshal(__is);\n", + [RT, ic_java_type:getUnmarshalType(G,N,X,R)]) + end, + emit_op_decode_loop(G, N, X, ParamTypes, ArgNames, 1, Fd), + + ic_codegen:nl(Fd), + ic_codegen:emit(Fd, " return _result;\n"); + false -> + ic_codegen:emit(Fd, " // Extracting return value\n"), + case ic_java_type:isBasicType(G,N,R) of + true -> + ic_codegen:emit(Fd, " return __is~s;\n", + [ic_java_type:unMarshalFun(G, N, X, R)]); + false -> + ic_codegen:emit(Fd, " return ~s.unmarshal(__is);\n", + [ic_java_type:getUnmarshalType(G,N,X,R)]) + end + end + end. + +emit_op_decode_loop(_,_,_,_,[],_,_Fd) -> + ok; +emit_op_decode_loop(G, N, X, [_Type|Types], [{in, _Arg}|Args], Counter, Fd) -> + emit_op_decode_loop(G, N, X, Types, Args, Counter, Fd); +emit_op_decode_loop(G, N, X, [Type|Types], [{_, Arg}|Args], Counter, Fd) -> + case ic_java_type:isBasicType(G,N,Type) of + true -> + ic_codegen:emit(Fd, " ~s.value = __is~s;\n", + [Arg, + ic_java_type:unMarshalFun(G, N, X, Type)]); + false -> + ic_codegen:emit(Fd, " ~s.value = ~s.unmarshal(__is);\n", + [Arg, + ic_java_type:getUnmarshalType(G, N, X, Type)]) + end, + emit_op_decode_loop(G, N, X, Types, Args, Counter+1, Fd). + + + +emit_message_reference_extraction(Fd) -> + ic_codegen:emit(Fd, " // Returns call reference\n"), + ic_codegen:emit(Fd, " public ~sOtpErlangRef __getRef()\n", + [?ERLANGPACKAGE]), + ic_codegen:emit(Fd, " throws java.lang.Exception {\n"), + ic_codegen:emit(Fd, " return _env.received_ref();\n"), + ic_codegen:emit(Fd, " }\n\n"). + +emit_servers_object_access(Fd) -> + ic_codegen:emit(Fd, " // Returns the server\n"), + ic_codegen:emit(Fd, " public java.lang.Object __server() {\n"), + ic_codegen:emit(Fd, " return _env.server();\n"), + ic_codegen:emit(Fd, " }\n\n"). + +emit_client_connection_close(Fd) -> + ic_codegen:emit(Fd, " // Closes connection\n"), + ic_codegen:emit(Fd, " public void __disconnect() {\n"), + ic_codegen:emit(Fd, " _env.disconnect();\n"), + ic_codegen:emit(Fd, " }\n\n"). + +emit_client_connection_reconnect(Fd) -> + ic_codegen:emit(Fd, " // Reconnects client\n"), + ic_codegen:emit(Fd, " public void __reconnect()\n"), + ic_codegen:emit(Fd, " throws java.lang.Exception {\n"), + ic_codegen:emit(Fd, " _env.reconnect();\n"), + ic_codegen:emit(Fd, " }\n\n"). + +emit_client_destroy(Fd) -> + ic_codegen:emit(Fd, " // Destroy server\n"), + ic_codegen:emit(Fd, " public void __stop()\n"), + ic_codegen:emit(Fd, " throws java.lang.Exception {\n"), + ic_codegen:emit(Fd, " _env.client_stop_server();\n"), + ic_codegen:emit(Fd, " }\n\n"). + + + +%%%---------------------------------------------------- +%%% +%%% Generates the server code +%%% +%%%---------------------------------------------------- + +emit_skel(G, N, X, Fd) -> + InterfaceName = ic_forms:get_java_id(X), + FullInterfaceName = ic_util:to_dot([InterfaceName|N]), + + ic_codegen:emit(Fd, "public abstract class _~sImplBase implements ~s {\n\n", + [InterfaceName,FullInterfaceName]), + + ic_codegen:emit(Fd, " // Server data\n"), + ic_codegen:emit(Fd, " protected ~sEnvironment _env = null;\n\n",[?ICPACKAGE]), + + ic_codegen:emit(Fd, " // Constructors\n"), + ic_codegen:emit(Fd, " public _~sImplBase() {\n",[InterfaceName]), + ic_codegen:emit(Fd, " }\n\n"), + + emit_caller_pid(G, N, X, Fd), + + %% Emit operation dictionary + emit_dictionary(G, N, X, Fd), + + %% Emit server switch + emit_server_switch(G, N, X, Fd), + + ic_codegen:emit(Fd, "}\n"). + + +emit_server_switch(G, N, X, Fd) -> + + IFCName = ic_forms:get_id2(X), %% Internal Interface Name + Body = ic_forms:get_body(X), + Counter = 0, + + ic_codegen:emit(Fd, " // Operation invokation\n"), + ic_codegen:emit(Fd, " public ~sOtpOutputStream invoke(~sOtpInputStream _in)\n", + [?ERLANGPACKAGE,?ERLANGPACKAGE]), + ic_codegen:emit(Fd, " throws java.lang.Exception {\n\n"), + + ic_codegen:emit(Fd, " // Create a new environment if needed\n"), + ic_codegen:emit(Fd, " if (_env == null)\n"), + ic_codegen:emit(Fd, " _env = new com.ericsson.otp.ic.Environment();\n\n"), + + ic_codegen:emit(Fd, " // Unmarshal head\n"), + ic_codegen:emit(Fd, " _env.uHead(_in);\n\n"), + + ic_codegen:emit(Fd, " // Switch over operation\n"), + ic_codegen:emit(Fd, " return __switch(_env);\n"), + + ic_codegen:emit(Fd, " }\n\n"), + + + ic_codegen:emit(Fd, " // Operation switch\n"), + ic_codegen:emit(Fd, " public ~sOtpOutputStream __switch(~sEnvironment __env)\n", [?ERLANGPACKAGE,?ICPACKAGE]), + ic_codegen:emit(Fd, " throws java.lang.Exception {\n\n"), + + ic_codegen:emit(Fd, " // Setup streams and operation label\n"), + ic_codegen:emit(Fd, " ~sOtpOutputStream __os = __env.getOs();\n",[?ERLANGPACKAGE]), + ic_codegen:emit(Fd, " __os.reset();\n"), + ic_codegen:emit(Fd, " int __label = __env.uLabel(__operations);\n\n"), + + ic_codegen:emit(Fd, " // Switch over operation\n"), + ic_codegen:emit(Fd, " switch(__label) {\n\n"), + + OpNr = emit_server_op_switch_loop(G, + [IFCName|N], + [{x, Body} | X#interface.inherit_body], + Counter, + Fd), + + ic_codegen:emit(Fd, " case ~p: { // Standard stop operation\n\n",[OpNr]), + ic_codegen:emit(Fd, " __env.server_stop_server();\n\n"), + ic_codegen:emit(Fd, " } break;\n\n"), + + ic_codegen:emit(Fd, " default: // It will never come down here \n"), + ic_codegen:emit(Fd, " throw new java.lang.Exception(\"BAD OPERATION\");\n\n", []), + + ic_codegen:emit(Fd, " }\n\n"), + + ic_codegen:emit(Fd, " if(__os.count() > 0)\n"), + ic_codegen:emit(Fd, " return __os;\n\n"), + + ic_codegen:emit(Fd, " return null;\n"), + ic_codegen:emit(Fd, " }\n\n"). + + + +emit_server_op_switch_loop(_G, _N, [], C, _Fd) -> + C; +emit_server_op_switch_loop(G, N, [{_,X}|Xs], C, Fd) -> + C1 = emit_server_op_switch(G, N, X, C, Fd), + emit_server_op_switch_loop(G, N, Xs, C1, Fd). + + +emit_server_op_switch(G, N, [X|Xs], C, Fd) when is_record(X, op) -> + + OpName = ic_forms:get_java_id(X), + + ic_codegen:emit(Fd, " case ~p: { // Operation ~s\n\n",[C,ic_util:to_dot([OpName|N])]), + + emit_invoke(G, N, X, Fd), + + ic_codegen:emit(Fd, " } break;\n\n"), + + emit_server_op_switch(G, N, Xs, C+1, Fd); +emit_server_op_switch(G, N, [X |Xs], C, Fd) when is_record(X, attr) -> + C1 = ic_attribute_java:emit_attribute_switch_case(G,N,X,Fd,C), + emit_server_op_switch(G, N, Xs, C1, Fd); +emit_server_op_switch(G, N, [_X|Xs], C, Fd) -> + emit_server_op_switch(G, N, Xs, C, Fd); +emit_server_op_switch(_G, _N, [], C, _Fd) -> + C. + + +emit_caller_pid(_G, _N, _X, Fd) -> + ic_codegen:emit(Fd, " // Extracts caller identity\n"), + ic_codegen:emit(Fd, " public ~sOtpErlangPid __getCallerPid() {\n", [?ERLANGPACKAGE]), + ic_codegen:emit(Fd, " return _env.getScaller();\n"), + ic_codegen:emit(Fd, " }\n\n"), + + ic_codegen:emit(Fd, " public ~sOtpErlangPid __getCallerPid(~sEnvironment __env) {\n", + [?ERLANGPACKAGE, ?ICPACKAGE]), + ic_codegen:emit(Fd, " return __env.getScaller();\n"), + ic_codegen:emit(Fd, " }\n\n"), + + ic_codegen:emit(Fd, " public boolean __isStopped() {\n"), + ic_codegen:emit(Fd, " return _env.isStopped();\n"), + ic_codegen:emit(Fd, " }\n\n"), + + ic_codegen:emit(Fd, " public boolean __isStopped(~sEnvironment __env) {\n", + [?ICPACKAGE]), + ic_codegen:emit(Fd, " return __env.isStopped();\n"), + ic_codegen:emit(Fd, " }\n\n"). + + + +%% Creates an operation dictionary +emit_dictionary(G, N, X, Fd) -> + + Counter = 0, + Body = ic_forms:get_body(X), + + ic_codegen:emit(Fd, " // Operation dictionary\n"), + ic_codegen:emit(Fd, " private static java.util.Dictionary __operations = new java.util.Hashtable();\n"), + ic_codegen:emit(Fd, " static {\n"), + + emit_dictionary_loop(G, + [ic_forms:get_id2(X)|N], + [{x, Body} | X#interface.inherit_body], + Counter, + Fd), + + ic_codegen:emit(Fd, " }\n\n"), + + ic_codegen:emit(Fd, " // Operation dictionary access\n"), + ic_codegen:emit(Fd, " public static java.util.Dictionary __operations() {\n"), + ic_codegen:emit(Fd, " return __operations;\n"), + ic_codegen:emit(Fd, " }\n\n"). + + + + +emit_dictionary_loop(_G, _N, [], C, Fd) -> + ic_codegen:emit(Fd, " __operations.put(~p, new java.lang.Integer(~p));\n", + ["stop",C]); +emit_dictionary_loop(G, N, [{_,X}|Xs], C, Fd) -> + C1 = emit_dictionary(G, N, X, C, Fd), + emit_dictionary_loop(G, N, Xs, C1, Fd). + + +emit_dictionary(G, N, [X|Xs], C, Fd) when is_record(X, op) -> + + OpName = case ic_options:get_opt(G, scoped_op_calls) of + true -> + ic_util:to_undersc([ic_forms:get_id2(X)|N]); + false -> + ic_forms:get_id2(X) + end, + + ic_codegen:emit(Fd, " __operations.put(~p, new java.lang.Integer(~p));\n", + [OpName,C]), + emit_dictionary(G, N, Xs, C+1, Fd); + +emit_dictionary(G, N, [X |Xs], C, Fd) when is_record(X, attr) -> + C1 = ic_attribute_java:emit_atrribute_on_dictionary(G, N, X, Fd, C), + emit_dictionary(G, N, Xs, C1, Fd); + +emit_dictionary(G, N, [_X|Xs], C, Fd) -> + emit_dictionary(G, N, Xs, C, Fd); + +emit_dictionary(_G, _N, [], C, _Fd) -> + C. + + + +emit_invoke(G, N, X, Fd) -> + + {_, ArgNames, TypeList} = extract_info(G, N, X), + {R, ParamTypes, _} = TypeList, + OpName = ic_forms:get_java_id(X), + RT = ic_java_type:getParamType(G,N,R,ret), + PL = ic_util:mk_list(gen_cb_arg_list(ArgNames)), + OutParamNr = count_server_send(ArgNames), + + case count_server_receive(ArgNames) of + 0 -> + ok; + _C -> + ic_codegen:emit(Fd, " // Preparing input\n"), + ic_codegen:emit(Fd, " ~sOtpInputStream __is = __env.getIs();\n", + [?ERLANGPACKAGE]), + emit_server_unmarshal_loop(G, N, X, ParamTypes, ArgNames, 1, Fd) + end, + + ic_codegen:emit(Fd, " // Calling implementation function\n"), + case RT of + "void" -> + ic_codegen:emit(Fd, " this.~s(~s);\n\n", + [OpName,PL]); + _ -> + ic_codegen:emit(Fd, " ~s _result = this.~s(~s);\n\n", + [RT, OpName, PL]) + end, + + case ic_forms:is_oneway(X) of + true -> + ok; + false -> + ic_codegen:emit(Fd, " // Marshaling output\n"), + ic_codegen:emit(Fd, " ~sOtpErlangRef __ref = __env.getSref();\n",[?ERLANGPACKAGE]), + + case RT of + "void" -> + case OutParamNr > 0 of + true -> + ic_codegen:emit(Fd, " __os.write_tuple_head(2);\n"), + ic_codegen:emit(Fd, " __os.write_ref(__ref.node(),__ref.ids(),__ref.creation()); // Call reference\n"), + ic_codegen:emit(Fd, " __os.write_tuple_head(~p);\n",[OutParamNr+1]), + ic_codegen:emit(Fd, " __os.write_atom(\"ok\");\n"), + emit_server_marshal_loop(G, N, X, ParamTypes,ArgNames,1,Fd); + false -> + ic_codegen:emit(Fd, " __os.write_tuple_head(2);\n"), + ic_codegen:emit(Fd, " __os.write_ref(__ref.node(),__ref.ids(),__ref.creation()); // Call reference\n"), + ic_codegen:emit(Fd, " __os.write_atom(\"ok\");\n\n") + end; + _ -> + case OutParamNr > 0 of + true -> + ic_codegen:emit(Fd, " __os.write_tuple_head(2);\n"), + ic_codegen:emit(Fd, " __os.write_ref(__ref.node(),__ref.ids(),__ref.creation()); // Call reference\n"), + ic_codegen:emit(Fd, " __os.write_tuple_head(~p);\n",[OutParamNr+1]), + + case ic_java_type:isBasicType(G,N,R) of + true -> + ic_codegen:emit(Fd, " __os~s(_result); // Return value\n", + [ic_java_type:marshalFun(G,N,X,R)]); + false -> + ic_codegen:emit(Fd, " ~s(__os,_result); // Return value\n", + [ic_java_type:marshalFun(G,N,X,R)]) + end, + emit_server_marshal_loop(G, N, X, ParamTypes,ArgNames,1,Fd); + false -> + ic_codegen:emit(Fd, " __os.write_tuple_head(2);\n"), + ic_codegen:emit(Fd, " __os.write_ref(__ref.node(),__ref.ids(),__ref.creation()); // Call reference\n"), + + case ic_java_type:isBasicType(G,N,R) of + true -> + ic_codegen:emit(Fd, " __os~s(_result); // Return value\n\n", + [ic_java_type:marshalFun(G,N,X,R)]); + false -> + ic_codegen:emit(Fd, " ~s(__os,_result); // Return value\n\n", + [ic_java_type:marshalFun(G,N,X,R)]) + end + end + end, + ic_codegen:nl(Fd) + end. + + +emit_server_unmarshal_loop(_,_,_,_,[],_,Fd) -> + ic_codegen:nl(Fd); +emit_server_unmarshal_loop(G, N, X, [Type|Types], [{in, Arg}|Args], Counter, Fd) -> + case ic_java_type:isBasicType(G,N,Type) of + true -> + ic_codegen:emit(Fd, " ~s ~s = __is~s; // In value\n", + [ic_java_type:getType(G,N,Type), + Arg, + ic_java_type:unMarshalFun(G,N,X,Type)]); + false -> + ic_codegen:emit(Fd, " ~s ~s = ~s.unmarshal(__is); // In value\n", + [ic_java_type:getType(G,N,Type), + Arg, + ic_java_type:getUnmarshalType(G,N,X,Type)]) + end, + emit_server_unmarshal_loop(G, N, X, Types, Args, Counter+1, Fd); +emit_server_unmarshal_loop(G, N, X, [Type|Types],[{inout, Arg}|Args], Counter, Fd) -> + Holder = ic_java_type:getHolderType(G,N,Type), + case ic_java_type:isBasicType(G,N,Type) of + true -> +% OtpEncVar = ic_java_type:getUnmarshalType(G,N,X,Type), + ic_codegen:emit(Fd, " ~s _~s = __is~s;\n", + [ic_java_type:getType(G,N,Type), + Arg, + ic_java_type:unMarshalFun(G,N,X,Type)]), + ic_codegen:emit(Fd, " ~s ~s = new ~s(_~s); // InOut value\n", + [Holder, + Arg, + Holder, + Arg]); + false -> + ic_codegen:emit(Fd, " ~s ~s = new ~s(); // InOut value\n", + [Holder, + Arg, + Holder]), + ic_codegen:emit(Fd, " ~s._unmarshal(__is);\n", + [Arg]) + end, + emit_server_unmarshal_loop(G, N, X, Types, Args, Counter+1, Fd); +emit_server_unmarshal_loop(G, N, X, [Type|Types],[{out, Arg}|Args], Counter, Fd) -> + Holder = ic_java_type:getHolderType(G,N,Type), + ic_codegen:emit(Fd, " ~s ~s = new ~s(); // Out value\n", [Holder, Arg, Holder]), + emit_server_unmarshal_loop(G, N, X, Types, Args, Counter, Fd). + + +emit_server_marshal_loop(_,_,_,_,[],_,_Fd) -> + ok; +emit_server_marshal_loop(G, N, X, [_Type|Types],[{in, _Arg}|Args], Counter, Fd) -> + emit_server_marshal_loop(G, N, X, Types, Args, Counter, Fd); +emit_server_marshal_loop(G, N, X, [Type|Types],[{_, Arg}|Args], Counter, Fd) -> +% Holder = ic_java_type:getHolderType(G,N,Type), + case ic_java_type:isBasicType(G,N,Type) of + true -> + ic_codegen:emit(Fd, " __os~s(~s.value); // Out/InOut value\n", + [ic_java_type:marshalFun(G,N,X,Type),Arg]); + false -> + ic_codegen:emit(Fd, " ~s._marshal(__os); // Out/InOut value\n", + [Arg]) + end, + emit_server_marshal_loop(G, N, X, Types, Args, Counter+1, Fd). + + + + + +%%%---------------------------------------------------- +%%% +%%% Utilities +%%% +%%%---------------------------------------------------- + +extract_info(_G, N, X) when is_record(X, op) -> + Name = ic_util:to_undersc([ic_forms:get_id2(X) | N]), + Args = X#op.params, + ArgNames = mk_c_vars(Args), + TypeList = {ic_forms:get_type(X), + lists:map(fun(Y) -> ic_forms:get_type(Y) end, Args), + [] + }, + {Name, ArgNames, TypeList}; +extract_info(_G, N, X) -> + Name = ic_util:to_undersc([ic_forms:get_id2(X) | N]), + {Name, [], []}. + +%% Input is a list of parameters (in parse form) and output is a list +%% of parameter attribute and variable names. +mk_c_vars(Params) -> + lists:map(fun(P) -> {A, _} = P#param.inout, + {A, ic_forms:get_id(P#param.id)} + end, + Params). + +%% +handle_preproc(G, _N, line_nr, X) -> + Id = ic_forms:get_java_id(X), + Flags = X#preproc.aux, + case Flags of + [] -> ic_genobj:push_file(G, Id); + _ -> + lists:foldr(fun({_, _, "1"}, Gprim) -> ic_genobj:push_file(Gprim, Id); + ({_, _, "2"}, Gprim) -> ic_genobj:pop_file(Gprim, Id); + ({_, _, "3"}, Gprim) -> ic_genobj:sys_file(Gprim, Id) end, + G, Flags) + end; +handle_preproc(G, _N, _Other, _X) -> + G. + + +%% +gen_par_list(_, _, _, [], []) -> + []; +gen_par_list(G, N, X, [Type |Types], [{Attr, Arg}|Args]) -> + JType = ic_java_type:getParamType(G, N, Type, Attr), + [JType ++ " " ++ Arg | + gen_par_list(G, N, X, Types, Args)]. + + +gen_marshal_par_list(_, _, _, [], []) -> + []; +gen_marshal_par_list(G, N, X, [_Type |Types], [{out, _Arg}|Args]) -> + gen_marshal_par_list(G, N, X, Types, Args); +gen_marshal_par_list(G, N, X, [Type |Types], [{Attr, Arg}|Args]) -> + JType = ic_java_type:getParamType(G, N, Type, Attr), + [JType ++ " " ++ Arg | + gen_marshal_par_list(G, N, X, Types, Args)]. + + +gen_unmarshal_par_list(_, _, _, [], []) -> + []; +gen_unmarshal_par_list(G, N, X, [_Type |Types], [{in, _Arg}|Args]) -> + gen_unmarshal_par_list(G, N, X, Types, Args); +gen_unmarshal_par_list(G, N, X, [Type |Types], [{Attr, Arg}|Args]) -> + JType = ic_java_type:getParamType(G, N, Type, Attr), + [JType ++ " " ++ Arg | + gen_unmarshal_par_list(G, N, X, Types, Args)]. + + +%% +gen_client_marshal_call_par_list([]) -> + []; +gen_client_marshal_call_par_list([{out, _Arg}|Args]) -> + gen_client_marshal_call_par_list(Args); +gen_client_marshal_call_par_list([{_Attr, Arg}|Args]) -> + [Arg | gen_client_marshal_call_par_list(Args)]. + + +gen_client_unmarshal_call_par_list([]) -> + []; +gen_client_unmarshal_call_par_list([{in, _Arg}|Args]) -> + gen_client_unmarshal_call_par_list(Args); +gen_client_unmarshal_call_par_list([{_Attr, Arg}|Args]) -> + [Arg | gen_client_unmarshal_call_par_list(Args)]. + + + +count_client_receive(ArgNames) -> + count_client_receive(ArgNames,0). + +count_client_receive([],C) -> + C; +count_client_receive([{in, _Arg}|Args],C) -> + count_client_receive(Args,C); +count_client_receive([_|Args],C) -> + count_client_receive(Args,C+1). + + + +count_client_send(ArgNames) -> + count_client_send(ArgNames,0). + +count_client_send([],C) -> + C; +count_client_send([{out, _Arg}|Args],C) -> + count_client_send(Args,C); +count_client_send([_|Args],C) -> + count_client_send(Args,C+1). + + +gen_cb_arg_list([]) -> + []; +gen_cb_arg_list([{_Attr, Arg}|Args]) -> + [Arg | gen_cb_arg_list(Args)]. + + +count_server_receive(ArgNames) -> + count_server_receive(ArgNames,0). + +count_server_receive([],C) -> + C; +count_server_receive([_|Args],C) -> + count_server_receive(Args,C+1). + + +count_server_send(ArgNames) -> + count_server_send(ArgNames,0). + +count_server_send([],C) -> + C; +count_server_send([{in, _Arg}|Args],C) -> + count_server_send(Args,C); +count_server_send([_|Args],C) -> + count_server_send(Args,C+1). + + + + + +%%%------------------------------------------------------- + + +emit_type_function(G, N, X, Fd) -> + + TC = ic_forms:get_type_code(G, N, X), + + %%io:format("X = ~p\nTC = ~p\n",[X,TC]), + + ic_codegen:emit(Fd, " private static ~sTypeCode _tc;\n",[?ICPACKAGE]), + ic_codegen:emit(Fd, " synchronized public static ~sTypeCode type() {\n\n",[?ICPACKAGE]), + + ic_codegen:emit(Fd, " if (_tc != null)\n"), + ic_codegen:emit(Fd, " return _tc;\n\n"), + + emit_type_function(TC, 0, Fd), + + ic_codegen:emit(Fd, "\n _tc = _tc0;\n"), + + ic_codegen:emit(Fd, "\n return _tc0;\n"), + ic_codegen:emit(Fd, " }\n\n"). + + + +emit_type_function({tk_struct, ID, Name, ML}, C, Fd) -> %% struct + ic_codegen:emit(Fd, " ~sTypeCode _tc~p =\n",[?ICPACKAGE,C]), + ic_codegen:emit(Fd, " new ~sTypeCode();\n", [?ICPACKAGE]), + ic_codegen:emit(Fd, " _tc~p.kind(~sTCKind.tk_struct);\n", [C,?ICPACKAGE]), + ic_codegen:emit(Fd, " _tc~p.id(~p);\n", [C,ID]), + ic_codegen:emit(Fd, " _tc~p.name(~p);\n", [C,Name]), + ic_codegen:emit(Fd, " _tc~p.member_count(~p);\n", [C,length(ML)]), + emit_struct_members(ML, C, C+1, 0, Fd); + +emit_type_function({tk_enum, ID, Name, MNames}, C, Fd) -> %% enum + ic_codegen:emit(Fd, " ~sTypeCode _tc~p =\n",[?ICPACKAGE,C]), + ic_codegen:emit(Fd, " new ~sTypeCode();\n", [?ICPACKAGE]), + ic_codegen:emit(Fd, " _tc~p.kind(~sTCKind.tk_enum);\n", [C,?ICPACKAGE]), + ic_codegen:emit(Fd, " _tc~p.id(~p);\n", [C,ID]), + ic_codegen:emit(Fd, " _tc~p.name(~p);\n", [C,Name]), + ic_codegen:emit(Fd, " _tc~p.member_count(~p);\n", [C,length(MNames)]), + emit_enum_members(MNames, C, 0, Fd), + C+1; + +emit_type_function({tk_array, ET, L}, C, Fd) -> %% array + ic_codegen:emit(Fd, " ~sTypeCode _tc~p =\n",[?ICPACKAGE,C]), + ic_codegen:emit(Fd, " new ~sTypeCode();\n", [?ICPACKAGE]), + ic_codegen:emit(Fd, " _tc~p.kind(~sTCKind.tk_array);\n", [C,?ICPACKAGE]), + ic_codegen:emit(Fd, " _tc~p.id(id());\n",[C]), + ic_codegen:emit(Fd, " _tc~p.length(~p);\n", [C,L]), + C1 = C+1, + C2 = emit_type_function(ET, C1, Fd), + ic_codegen:emit(Fd, " _tc~p.content_type(_tc~p);\n", [C,C1]), + C2; + +emit_type_function({tk_sequence, ET, L}, C, Fd) -> %% sequence + ic_codegen:emit(Fd, " ~sTypeCode _tc~p =\n",[?ICPACKAGE,C]), + ic_codegen:emit(Fd, " new ~sTypeCode();\n", [?ICPACKAGE]), + ic_codegen:emit(Fd, " _tc~p.kind(~sTCKind.tk_sequence);\n", [C,?ICPACKAGE]), + ic_codegen:emit(Fd, " _tc~p.id(id());\n",[C]), + ic_codegen:emit(Fd, " _tc~p.length(~p);\n", [C,L]), + C1 = C+1, + C2 = emit_type_function(ET, C1, Fd), + ic_codegen:emit(Fd, " _tc~p.content_type(_tc~p);\n", [C,C1]), + C2; + +emit_type_function({tk_string, L}, C, Fd) -> %% string + ic_codegen:emit(Fd, " ~sTypeCode _tc~p =\n",[?ICPACKAGE,C]), + ic_codegen:emit(Fd, " new ~sTypeCode();\n", [?ICPACKAGE]), + ic_codegen:emit(Fd, " _tc~p.kind(~sTCKind.tk_string);\n", [C,?ICPACKAGE]), + ic_codegen:emit(Fd, " _tc~p.length(~p);\n", [C,L]), + C+1; + +emit_type_function({tk_union, ID, Name, DT, DI, LL}, C, Fd) -> %% union + + ic_codegen:emit(Fd, " ~sTypeCode _tc~p =\n",[?ICPACKAGE,C]), + ic_codegen:emit(Fd, " new ~sTypeCode();\n", [?ICPACKAGE]), + ic_codegen:emit(Fd, " _tc~p.kind(~sTCKind.tk_union);\n", [C,?ICPACKAGE]), + ic_codegen:emit(Fd, " _tc~p.id(~p);\n", [C,ID]), + ic_codegen:emit(Fd, " _tc~p.name(~p);\n", [C,Name]), + + C1 = C+1, + C2 = emit_type_function(DT, C1, Fd), + + ic_codegen:emit(Fd, " _tc~p.discriminator_type(_tc~p);\n", [C,C1]), + ic_codegen:emit(Fd, " _tc~p.default_index(~p);\n", [C,DI]), + ic_codegen:emit(Fd, " _tc~p.member_count(~p);\n", [C,length(LL)]), + + emit_union_labels(LL, C, DT, C2, 0, Fd); + +emit_type_function(tk_term, C, Fd) -> %% term, must change it to tk_any + ic_codegen:emit(Fd, " ~sTypeCode _tc~p =\n",[?ICPACKAGE,C]), + ic_codegen:emit(Fd, " new ~sTypeCode();\n", [?ICPACKAGE]), + ic_codegen:emit(Fd, " _tc~p.kind(~sTCKind.tk_any);\n", [C,?ICPACKAGE]), + C+1; + +emit_type_function(TC, C, Fd) -> %% other + ic_codegen:emit(Fd, " ~sTypeCode _tc~p =\n",[?ICPACKAGE,C]), + ic_codegen:emit(Fd, " new ~sTypeCode();\n", [?ICPACKAGE]), + ic_codegen:emit(Fd, " _tc~p.kind(~sTCKind.~p);\n", [C,?ICPACKAGE,TC]), + C+1. + + + +emit_struct_members([], _, TCtr, _, _Fd) -> + TCtr; +emit_struct_members([{Name,MT}|Rest], BTCtr, TCtr, I, Fd) -> + ic_codegen:emit(Fd, " _tc~p.member_name(~p,~p);\n", [BTCtr,I,Name]), + TCtr2 = emit_type_function(MT, TCtr, Fd), + ic_codegen:emit(Fd, " _tc~p.member_type(~p,_tc~p);\n", [BTCtr,I,TCtr]), + emit_struct_members(Rest, BTCtr, TCtr2, I+1, Fd). + +emit_enum_members([], _, _, _Fd) -> + ok; +emit_enum_members([Name|Names], BTCtr, I, Fd) -> + ic_codegen:emit(Fd, " _tc~p.member_name(~p,~p);\n", [BTCtr,I,Name]), + emit_enum_members(Names, BTCtr, I+1, Fd). + + +emit_union_labels([], _, _, TCtr, _, _) -> + TCtr; +emit_union_labels([{L, LN, LT}|Rest], BTCtr, DT, TCtr, I, Fd) -> + ic_codegen:emit(Fd, " ~sAny _any~p =\n",[?ICPACKAGE,TCtr]), + ic_codegen:emit(Fd, " new ~sAny();\n", [?ICPACKAGE]), + TCtr1 = TCtr+1, + TCtr2 = emit_type_function(LT, TCtr1,Fd), + ic_codegen:emit(Fd, " _any~p.type(_tc~p);\n",[TCtr,TCtr1]), + + case L of + default -> + ic_codegen:emit(Fd, " _any~p.insert_atom(\"default\");\n", [TCtr]); + _ -> + case DT of + tk_boolean -> + ic_codegen:emit(Fd, " _any~p.insert_boolean(~p);\n",[TCtr,L]); + tk_char -> + Default = if is_integer(L) -> + [L]; + true -> + L + end, + ic_codegen:emit(Fd, " _any~p.insert_char('~s');\n",[TCtr,Default]); + tk_ushort -> + ic_codegen:emit(Fd, " _any~p.insert_ushort(~p);\n",[TCtr,L]); + tk_ulong -> + ic_codegen:emit(Fd, " _any~p.insert_ulong(~p);\n",[TCtr,L]); + tk_short -> + ic_codegen:emit(Fd, " _any~p.insert_short(~p);\n",[TCtr,L]); + tk_long -> + ic_codegen:emit(Fd, " _any~p.insert_long(~p);\n",[TCtr,L]); + _ -> + ic_codegen:emit(Fd, " _any~p.insert_string(~p);\n", [TCtr,L]) + end + end, + ic_codegen:emit(Fd, " _tc~p.member_label(~p,_any~p);\n", [BTCtr,I,TCtr]), + ic_codegen:emit(Fd, " _tc~p.member_name(~p,~p);\n", [BTCtr,I,LN]), + TCtr3 = emit_type_function(LT, TCtr2, Fd), + ic_codegen:emit(Fd, " _tc~p.member_type(~p,_tc~p);\n", [BTCtr,I,TCtr2]), + emit_union_labels(Rest, BTCtr, DT, TCtr3, I+1, Fd). + + + + + + + + diff --git a/lib/ic/src/ic_noc.erl b/lib/ic/src/ic_noc.erl new file mode 100644 index 0000000000..d43d550a52 --- /dev/null +++ b/lib/ic/src/ic_noc.erl @@ -0,0 +1,1113 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1998-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_noc). + + +-export([do_gen/3]). +%%------------------------------------------------------------ +%% +%% Internal stuff +%% +%%------------------------------------------------------------ + +-export([unfold/1, mk_attr_func_names/2]). + + +-import(ic_util, [mk_name/2, mk_var/1, mk_oe_name/2, to_atom/1, to_list/1]). +-import(ic_forms, [get_id/1, get_id2/1, get_body/1, is_oneway/1]). +-import(ic_codegen, [emit/2, emit/3, nl/1]). +-import(ic_options, [get_opt/2]). + + +-import(lists, [foreach/2, foldr/3, map/2]). + + +-include("icforms.hrl"). +-include("ic.hrl"). + + + + +%%------------------------------------------------------------ +%% +%% Generate the client side Erlang stubs. +%% +%% Each module is generated to a separate file. +%% +%% Export declarations for all interface functions must be +%% generated. Each function then needs to generate a function head and +%% a body. IDL parameters must be converted into Erlang parameters +%% (variables, capitalised) and a type signature list must be +%% generated (for later encode/decode). +%% +%%------------------------------------------------------------ + + +do_gen(G, File, Form) -> + G2 = ic_file:filename_push(G, [], mk_oe_name(G, + ic_file:remove_ext(to_list(File))), + erlang), + gen_head(G2, [], Form), + exportDependency(G2), + %% Loop through form and adds inheritence data + ic_pragma:preproc(G2, [], Form), + gen(G2, [], Form), + genDependency(G2), + ic_file:filename_pop(G2, erlang), + ok. + + +gen(G, N, [X|Xs]) when is_record(X, preproc) -> + NewG = ic:handle_preproc(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 = [get_id2(X) | N], + gen_head(G2, N2, X), + gen(G2, N2, 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, erlang), + N2 = [get_id2(X) | N], + gen_head(G2, N2, X), + gen(G2, N2, get_body(X)), + foreach(fun({_Name, Body}) -> gen(G2, N2, Body) end, + X#interface.inherit_body), + gen_serv(G2, N, X), + G3 = ic_file:filename_pop(G2, erlang), + gen(G3, N, Xs); + +gen(G, N, [X|Xs]) when is_record(X, const) -> +% N2 = [get_id2(X) | N], + emit_constant_func(G, X#const.id, X#const.val), + gen(G, N, Xs); %% N2 or N? + +gen(G, N, [X|Xs]) when is_record(X, op) -> + {Name, ArgNames, TypeList, OutArgs} = extract_info(G, N, X), + + case getNocType(G,X,N) of + transparent -> + emit_transparent_func(G, N, X, Name, ArgNames, TypeList, OutArgs); + multiple -> + mark_not_transparent(G,N), + emit_transparent_func(G, N, X, Name, ArgNames, TypeList, OutArgs); + _XTuple -> + mark_not_transparent(G,N), + emit_stub_func(G, N, X, Name, ArgNames, TypeList, OutArgs) + end, + + gen(G, N, Xs); + + +gen(G, N, [X|Xs]) when is_record(X, attr) -> + emit_attr(G, N, X, fun emit_stub_func/7), + gen(G, N, Xs); + +gen(G, N, [X|Xs]) when is_record(X, except) -> + icstruct:except_gen(G, N, X, erlang), + gen(G, N, Xs); + +gen(G, N, [X|Xs]) -> + case may_contain_structs(X) of + true -> icstruct:struct_gen(G, N, X, erlang); + false -> ok + end, + gen(G, N, Xs); + +gen(_G, _N, []) -> ok. + + +may_contain_structs(X) when is_record(X, typedef) -> true; +may_contain_structs(X) when is_record(X, struct) -> true; +may_contain_structs(X) when is_record(X, union) -> true; +may_contain_structs(_X) -> false. + + + +%%-------------------------------------------------------------------- +%% +%% Generate the server side (handle_call and handle_cast) +%% + +gen_serv(G, N, X) -> + case ic_genobj:is_stubfile_open(G) of + true -> + emit_serv_std(G, N, X), + N2 = [get_id2(X) | N], + gen_calls(G, N2, get_body(X)), + lists:foreach(fun({_Name, Body}) -> + gen_calls(G, N2, Body) end, + X#interface.inherit_body), + get_if_gen(G, N2, X), + gen_end_of_call(G, N, X), % Note N instead of N2 + + gen_casts(G, N2, get_body(X)), + lists:foreach(fun({_Name, Body}) -> + gen_casts(G, N2, Body) end, + X#interface.inherit_body), + gen_end_of_cast(G, N, X), % Note N instead of N2 + emit_skel_footer(G, N, X); % Note N instead of N2 + false -> + ok + end. + +gen_calls(G, N, [X|Xs]) when is_record(X, op) -> + case is_oneway(X) of + false -> + {Name, ArgNames, TypeList, OutArgs} = extract_info(G, N, X), + emit_skel_func(G, N, X, Name, ArgNames, TypeList, OutArgs), + gen_calls(G, N, Xs); + true -> + gen_calls(G, N, Xs) + end; + +gen_calls(G, N, [X|Xs]) when is_record(X, attr) -> + emit_attr(G, N, X, fun emit_skel_func/7), + gen_calls(G, N, Xs); + +gen_calls(G, N, [_X|Xs]) -> gen_calls(G, N, Xs); +gen_calls(_G, _N, []) -> ok. + +gen_casts(G, N, [X|Xs]) when is_record(X, op) -> + case is_oneway(X) of + true -> + {Name, ArgNames, TypeList, OutArgs} = extract_info(G, N, X), + emit_skel_func(G, N, X, Name, ArgNames, TypeList, OutArgs), + gen_casts(G, N, Xs); + false -> + gen_casts(G, N, Xs) + end; + +gen_casts(G, N, [_X|Xs]) -> gen_casts(G, N, Xs); +gen_casts(_G, _N, []) -> ok. + +emit_attr(G, N, X, F) -> + XX = #id_of{type=X}, + {GetType, SetType} = mk_attr_func_types(N, X), + lists:foreach(fun(Id) -> + X2 = XX#id_of{id=Id}, + {Get, Set} = mk_attr_func_names(N, get_id(Id)), + F(G, N, X2, Get, [], GetType, []), + case X#attr.readonly of + {readonly, _} -> ok; + _ -> + F(G, N, X2, Set, [mk_name(G, "Value")], + SetType, []) + end end, ic_forms:get_idlist(X)). + + +extract_info(G, _N, X) when is_record(X, op) -> + Name = get_id2(X), + InArgs = ic:filter_params([in,inout], X#op.params), + OutArgs = ic:filter_params([out,inout], X#op.params), + ArgNames = mk_erl_vars(G, InArgs), + TypeList = {ic_forms:get_tk(X), + map(fun(Y) -> ic_forms:get_tk(Y) end, InArgs), + map(fun(Y) -> ic_forms:get_tk(Y) end, OutArgs) + }, + {Name, ArgNames, TypeList, OutArgs}. + + + + +emit_serv_std(G, N, X) -> + Fd = ic_genobj:stubfiled(G), + case transparent(G) of + true -> + true; + _XTupleORMultiple -> + Impl = getImplMod(G,X,[get_id2(X)|N]), + TypeID = ictk:get_IR_ID(G, N, X), + + nl(Fd), nl(Fd), nl(Fd), + ic_codegen:mcomment(Fd, ["Server implementation."]), + nl(Fd), nl(Fd), + ic_codegen:mcomment(Fd, ["Function for fetching the interface type ID."]), + nl(Fd), + emit(Fd, "typeID() ->\n"), + emit(Fd, " \"~s\".\n", [TypeID]), + nl(Fd), nl(Fd), + ic_codegen:mcomment(Fd, ["Server creation functions."]), + nl(Fd), + emit(Fd, "oe_create() ->\n"), + emit(Fd, " start([], []).\n", []), + nl(Fd), + emit(Fd, "oe_create_link() ->\n"), + emit(Fd, " start_link([], []).\n", []), + nl(Fd), + emit(Fd, "oe_create(Env) ->\n"), + emit(Fd, " start(Env, []).\n", []), + nl(Fd), + emit(Fd, "oe_create_link(Env) ->\n"), + emit(Fd, " start_link(Env, []).\n", []), + nl(Fd), + emit(Fd, "oe_create(Env, RegName) ->\n"), + emit(Fd, " start(RegName, Env, []).\n", []), + nl(Fd), + emit(Fd, "oe_create_link(Env, RegName) ->\n"), + emit(Fd, " start_link(RegName, Env, []).\n", []), + nl(Fd), + ic_codegen:mcomment(Fd, ["Start functions."]), + nl(Fd), + emit(Fd, "start(Env, Opt) ->\n"), + emit(Fd, " gen_server:start(?MODULE, Env, Opt).\n"), + nl(Fd), + emit(Fd, "start_link(Env, Opt) ->\n"), + emit(Fd, " gen_server:start_link(?MODULE, Env, Opt).\n"), + nl(Fd), + emit(Fd, "start(RegName, Env, Opt) ->\n"), + emit(Fd, " gen_server:start(RegName, ?MODULE, Env, Opt).\n"), + nl(Fd), + emit(Fd, "start_link(RegName, Env, Opt) ->\n"), + emit(Fd, " gen_server:start_link(RegName, ?MODULE, Env, Opt).\n"), + nl(Fd), + ic_codegen:comment(Fd, "Call to implementation init"), + emit(Fd, "init(Env) ->\n"), + emit(Fd, " ~p:~p(Env).\n", [Impl, init]), + nl(Fd), + emit(Fd, "terminate(Reason, State) ->\n"), + emit(Fd, " ~p:~p(Reason, State).\n", + [Impl, terminate]), + nl(Fd), nl(Fd) + end, + Fd. + + + + +gen_end_of_call(G, _N, _X) -> + case transparent(G) of + true -> + true; + _XTuple -> + Fd = ic_genobj:stubfiled(G), + nl(Fd), nl(Fd), + ic_codegen:mcomment_light(Fd, ["Standard gen_server call handle"]), + emit(Fd, "handle_call(stop, From, State) ->\n"), + emit(Fd, " {stop, normal, ok, State}"), + case get_opt(G, serv_last_call) of + exception -> + emit(Fd, ";\n"), + nl(Fd), + emit(Fd, "handle_call(Req, From, State) ->\n"), + emit(Fd, " {reply, ~p, State}.\n",[getCallErr()]); + exit -> + emit(Fd, ".\n"), + nl(Fd), + nl(Fd) + end + end, + ok. + + +gen_end_of_cast(G, _N, _X) -> + case transparent(G) of + true -> + true; + _XTuple -> + Fd = ic_genobj:stubfiled(G), + nl(Fd), nl(Fd), + ic_codegen:mcomment_light(Fd, ["Standard gen_server cast handle"]), + emit(Fd, "handle_cast(stop, State) ->\n"), + emit(Fd, " {stop, normal, State}"), + case get_opt(G, serv_last_call) of + exception -> + emit(Fd, ";\n"), + nl(Fd), + emit(Fd, "handle_cast(Req, State) ->\n"), + emit(Fd, " {reply, ~p, State}.\n",[getCastErr()]); + exit -> + emit(Fd, ".\n"), + nl(Fd), nl(Fd) + end + end, + ok. + + +emit_skel_footer(G, N, X) -> + case transparent(G) of + true -> + true; + _XTuple -> + Fd = ic_genobj:stubfiled(G), + nl(Fd), nl(Fd), + ic_codegen:mcomment_light(Fd, ["Standard gen_server handles"]), + emit(Fd, "handle_info(X, State) ->\n"), + case use_impl_handle_info(G, N, X) of + true -> + emit(Fd, " ~p:handle_info(X, State).\n\n", + [list_to_atom(ic_genobj:impl(G))]); + false -> + emit(Fd, " {reply, ~p, State}.\n\n",[getInfoErr()]) + end + end, + ok. + + +use_impl_handle_info(G, N, X) -> + FullName = ic_util:to_colon([get_id2(X) | N]), + case {get_opt(G, {handle_info, true}), get_opt(G, {handle_info, FullName})} of + {_, force_false} -> false; + {false, false} -> false; + _ -> true + end. + + +use_timeout(G, N, _X) -> + FullName = ic_util:to_colon(N), + case {get_opt(G, {timeout, true}), get_opt(G, {timeout, FullName})} of + {_, force_false} -> false; + {false, false} -> false; + _ -> true + end. + + +get_if_name(G) -> mk_oe_name(G, "get_interface"). + + +%% Generates the get_interface function (for Lars) +get_if_gen(G, N, X) -> + case transparent(G) of + true -> + ok; + _XTuple -> + case ic_genobj:is_stubfile_open(G) of + true -> + IFC_TKS = tk_interface_data(G,N,X), + Fd = ic_genobj:stubfiled(G), + Name = to_atom(get_if_name(G)), + + ic_codegen:mcomment_light(Fd, + [io_lib:format("Standard Operation: ~p", + [Name])]), + + emit(Fd, "handle_call({~s, ~p, []}, From, State) ->~n", + [mk_name(G, "Ref"), Name]), + + emit(Fd, " {reply, ~p, State};~n", [IFC_TKS]), + nl(Fd), + ok; + + false -> ok + end + end. + + +get_if(G,N,[X|Rest]) when is_record(X, op) -> + R = ic_forms:get_tk(X), + IN = lists:map(fun(P) -> ic_forms:get_tk(P) end, + ic:filter_params([in, inout], X#op.params)), + OUT = lists:map(fun(P) -> ic_forms:get_tk(P) end, + ic:filter_params([out, inout], X#op.params)), + case print_tk(G,N,X) of + true -> + [{get_id2(X), {R, IN, OUT}} | get_if(G,N,Rest)]; + false -> + get_if(G,N,Rest) + end; + +get_if(G,N,[X|Rest]) when is_record(X, attr) -> %% Attributes not handled so far <<<<<<<<<<<<<<<<<<<<<<<< + {GetT, SetT} = mk_attr_func_types([], X), + AList = lists:map(fun(Id) -> + {Get, Set} = mk_attr_func_names([], get_id(Id)), + case X#attr.readonly of + {readonly, _} -> + {Get, GetT}; + _ -> + [{Set, SetT}, {Get, GetT}] + end end, ic_forms:get_idlist(X)), + lists:flatten(AList) ++ get_if(G,N,Rest); + +get_if(G,N,[_X|Rest]) -> get_if(G,N,Rest); +get_if(_,_,[]) -> []. + + + + +%%------------------------------------------------------------ +%% +%% Export stuff +%% +%% Gathering of all names that should be exported from a stub +%% file. +%% + + +gen_head_special(G, N, X) when is_record(X, interface) -> + Fd = ic_genobj:stubfiled(G), + NocType = getNocType(G,X,N), + + foreach(fun({Name, Body}) -> + ic_codegen:comment(Fd, "Exports from ~p", + [ic_util:to_colon(Name)]), + ic_codegen:export(Fd, exp_top(G, N, Body, NocType, [])), + nl(Fd) + end, X#interface.inherit_body), + + case transparent(G) of + true -> + nl(Fd), nl(Fd); + _XTuple -> + ic_codegen:comment(Fd, "Type identification function"), + ic_codegen:export(Fd, [{typeID, 0}]), + nl(Fd), + ic_codegen:comment(Fd, "Used to start server"), + ic_codegen:export(Fd, [{start, 2},{start_link, 3}]), + ic_codegen:export(Fd, [{oe_create, 0}, {oe_create_link, 0}, {oe_create, 1}, + {oe_create_link, 1},{oe_create, 2}, {oe_create_link, 2}]), + nl(Fd), + ic_codegen:comment(Fd, "gen server export stuff"), + emit(Fd, "-behaviour(gen_server).\n"), + ic_codegen:export(Fd, [{init, 1}, {terminate, 2}, {handle_call, 3}, + {handle_cast, 2}, {handle_info, 2}]), + nl(Fd), nl(Fd), + ic_codegen:mcomment(Fd, ["Object interface functions."]), + nl(Fd), nl(Fd), nl(Fd) + end, + Fd; + + +gen_head_special(_G, _N, _X) -> ok. + + + +%% Shall generate all export declarations +gen_head(G, N, X) -> + case ic_genobj:is_stubfile_open(G) of + true -> + F = ic_genobj:stubfiled(G), + ic_codegen:comment(F, "Interface functions"), + ic_codegen:export(F, exp_top(G, N, X, getNocType(G,X,N), [])), + nl(F), + gen_head_special(G, N, X); + false -> ok + end. + +exp_top(_G, _N, X, _NT, Acc) when element(1, X) == preproc -> + Acc; +exp_top(G, N, L, NT, Acc) when is_list(L) -> + exp_list(G, N, L, NT, Acc); +exp_top(G, N, M, NT, Acc) when is_record(M, module) -> + exp_list(G, N, get_body(M), NT, Acc); +exp_top(G, N, I, NT, Acc) when is_record(I, interface) -> + exp_list(G, N, get_body(I), NT, Acc); +exp_top(G, N, X, NT, Acc) -> + exp3(G, N, X, NT, Acc). + +exp3(_G, _N, C, _NT, Acc) when is_record(C, const) -> + [{get_id(C#const.id), 0} | Acc]; + +exp3(G, N, Op, NocType, Acc) when is_record(Op, op) -> + FuncName = get_id(Op#op.id), + + TA = case use_timeout(G,N,Op) of + true -> + 1; + false -> + 0 + end, + + case NocType of + transparent -> + Arity = length(ic:filter_params([in, inout], Op#op.params)) + TA + 1, + [{FuncName, Arity} | Acc]; + multiple -> + case getModType(G, Op, N) of + dt -> + Arity = length(ic:filter_params([in, inout], Op#op.params)) + TA + 1, + [{FuncName, Arity} | Acc]; + do -> + Arity = length(ic:filter_params([in, inout], Op#op.params)) + TA + 1, + [{FuncName, Arity} | Acc]; + spt -> + Arity = length(ic:filter_params([in, inout], Op#op.params)) + TA + 1, + [{FuncName, Arity} | Acc]; + spo -> + Arity = length(ic:filter_params([in, inout], Op#op.params)) + TA + 1, + [{FuncName, Arity} | Acc] + end; + _ -> + Arity = length(ic:filter_params([in, inout], Op#op.params)) + TA + 1, + [{FuncName, Arity} | Acc] + end; +exp3(_G, _N, A, _NT, Acc) when is_record(A, attr) -> + lists:foldr(fun(Id, Acc2) -> + {Get, Set} = mk_attr_func_names([], get_id(Id)), + case A#attr.readonly of + {readonly, _} -> [{Get, 1} | Acc2]; + _ -> [{Get, 1}, {Set, 2} | Acc2] + end end, Acc, ic_forms:get_idlist(A)); + +exp3(_G, _N, _X, _NT, Acc) -> Acc. + +exp_list(G, N, L, NT, OrigAcc) -> + lists:foldr(fun(X, Acc) -> exp3(G, N, X, NT, Acc) end, OrigAcc, L). + + + + +%%------------------------------------------------------------ +%% +%% Emit stuff +%% +%% Low level generation primitives +%% + +emit_stub_func(G, N, X, Name, ArgNames, TypeList, _OutArgs) -> + case ic_genobj:is_stubfile_open(G) of + false -> ok; + true -> + Fd = ic_genobj:stubfiled(G), + StubName = list_to_atom(Name), + This = mk_name(G, "Ref"), + XTuple = getNocType(G,X,N), + CallOrCast = + case is_oneway(X) of + true -> ?CAST; + _ -> ?CALL + end, + + %% Type expand operation on comments + ic_code:type_expand_op(G,N,X,Fd), + + case use_timeout(G,N,X) of + true -> + Timeout = mk_name(G,"Timeout"), + emit(Fd, "~p(~s) ->\n", + [StubName, mk_list([This, Timeout| ArgNames])]), + emit(Fd, " ~p:~s(~s, ~s, ?MODULE, ~p, ~p, [~s], ~p).\n\n", + [getImplMod(G,X,N), + CallOrCast, + This, + Timeout, + XTuple, + StubName, + mk_list(ArgNames), + tk_operation_data(G, N, X, TypeList)]); + false -> + emit(Fd, "~p(~s) ->\n", + [StubName, mk_list([This | ArgNames])]), + + emit(Fd, " ~p:~s(~s, ~p, ?MODULE, ~p, [~s], ~p).\n\n", + [getImplMod(G,X,N), + CallOrCast, + This, + XTuple, + StubName, + mk_list(ArgNames), + tk_operation_data(G, N, X, TypeList)]) + end + end. + + +emit_transparent_func(G, N, X, Name, ArgNames, _TypeList, _OutArgs) -> + case ic_genobj:is_stubfile_open(G) of + false -> ok; + true -> + Fd = ic_genobj:stubfiled(G), + OpName = list_to_atom(Name), + + ArgList = case use_timeout(G,N,X) of + true -> + mk_list([mk_name(G,"Ref"),mk_name(G,"Timeout")|ArgNames]); + false -> + mk_list([mk_name(G,"Ref")|ArgNames]) + end, + + %% Type expand operation on comments + ic_code:type_expand_op(G,N,X,Fd), + + emit(Fd, "~p(~s) ->\n", [OpName,ArgList]), + emit(Fd, " ~p:~s(~s).\n\n", [getImplMod(G,X,N), OpName, ArgList]) + end. + + + + + + +emit_skel_func(G, N, X, OpName, ArgNames, _TypeList, _OutArgs) -> + case getNocType(G,X,N) of + transparent -> + true; + multiple -> + true; + XTuple -> + case ic_genobj:is_stubfile_open(G) of + false -> ok; + true -> + Fd = ic_genobj:stubfiled(G), + Name = list_to_atom(OpName), + This = mk_name(G, "Ref"), + From = mk_name(G, "From"), + State = mk_name(G, "State"), + + %% Type expand handle operation on comments + ic_code:type_expand_handle_op(G,N,X,Fd), + + case is_oneway(X) of + true -> + emit(Fd, "handle_cast({~s, ~p, OE_Module, ~p, [~s]}, ~s) ->\n", + [This, XTuple, Name, mk_list(ArgNames), State]), + emit(Fd, " ~p:handle_cast({~s, ~p, OE_Module, ~p, [~s]}, ~s);\n\n", + [getImplMod(G,X,N), This, XTuple, Name, mk_list(ArgNames), State]); + false -> + emit(Fd, "handle_call({~s, ~p, OE_Module, ~p, [~s]}, ~s, ~s) ->\n", + [This, XTuple, Name, mk_list(ArgNames), From, State]), + emit(Fd, " ~p:handle_call({~s, ~p, OE_Module, ~p, [~s]}, ~s, ~s);\n\n", + [getImplMod(G,X,N), This, XTuple, Name, mk_list(ArgNames), From, State]) + end + end + end. + + + +emit_constant_func(G, Id, Val) -> + case ic_genobj:is_stubfile_open(G) of + false -> ok; + true -> + Fd = ic_genobj:stubfiled(G), + N = list_to_atom(get_id(Id)), + emit_const_comment(G, Fd, Id, N), + emit(Fd, "~p() -> ~p.\n\n", [N, Val]) + end. + + +emit_const_comment(_G, F, _X, Name) -> + ic_codegen:mcomment_light(F, + [io_lib:format("Constant: ~p", [Name])]). + +%%------------------------------------------------------------ +%% +%% Utilities +%% +%% Convenient little go-get functions +%% +%%------------------------------------------------------------ + +%% The automaticly generated get and set operation names for an +%% attribute. +mk_attr_func_names(_Scope, Name) -> + {"_get_" ++ Name, "_set_" ++ Name}. + +%% Returns TK of the Get and Set attribute functions. +mk_attr_func_types(_N, X) -> + TK = ic_forms:get_tk(X), + {{TK, [], []}, {tk_void, [TK], []}}. + + + +%%------------------------------------------------------------ +%% +%% Generation utilities and common stuff +%% +%% Convenient stuff for generation +%% +%%------------------------------------------------------------ + + +%% Input is a list of parameters (in parse form) and output is a list +%% of capitalised variable names. mk_var is in icgen +mk_erl_vars(_G, Params) -> + map(fun(P) -> mk_var(get_id(P#param.id)) end, Params). + + +%% mk_list produces a nice comma separated string of variable names +mk_list([]) -> []; +mk_list([Arg | Args]) -> + Arg ++ mk_list2(Args). +mk_list2([Arg | Args]) -> + ", " ++ Arg ++ mk_list2(Args); +mk_list2([]) -> []. + + +%%------------------------------------------------------------ +%% +%% Parser utilities +%% +%% Called from the yecc parser. Expands the identifier list of an +%% attribute so that the attribute generator never has to handle +%% lists. +%% +%%------------------------------------------------------------ + + +%% Unfold identifier lists or nested lists. Note that many records +%% contain an entry named id that is a list before unfold and a single +%% id afterwards. +unfold(L) when is_list(L) -> + lists:flatten(map(fun(X) -> unfold2(X) end, L)); +unfold(X) -> unfold2(X). + +unfold2(A) when is_record(A, attr) -> + map(fun(Id) -> A#attr{id=Id} end, A#attr.id); +unfold2(M) when is_record(M, member) -> + map(fun(Id) -> M#member{id=Id} end, M#member.id); +unfold2(M) when is_record(M, case_dcl) -> + map(fun(Id) -> M#case_dcl{label=Id} end, M#case_dcl.label); +unfold2(T) when is_record(T, typedef) -> + map(fun(Id) -> T#typedef{id=Id} end, T#typedef.id ). + + + + + + +%% Export code produce for dependency function +exportDependency(G) -> + Fd = ic_genobj:stubfiled(G), + ic_codegen:export(Fd, [{oe_dependency, 0}]), + nl(Fd). + +%% Code produce for dependency function +genDependency(G) -> + Fd = ic_genobj:stubfiled(G), + nl(Fd),nl(Fd), + ic_codegen:comment(Fd, "Idl file dependency list function"), + emit(Fd, "oe_dependency() ->\n", []), + emit(Fd, " ~p.\n\n", [ic_pragma:get_dependencies(G)]). + + + + + +%%%%%% + + +getImplMod(G,X,Scope) -> %% to_atom(ic_genobj:impl(G)) | ChoicedModuleName + + %% Get actual pragma appliance scope + SpecScope = getActualScope(G,X,Scope), + + %% The "broker" option is passed + %% only by pragmas, seek for module. + case ic_pragma:getBrokerData(G,X,SpecScope) of + {Module,_Type} -> + Module; + _List -> + element(1,ic_pragma:defaultBrokerData(G)) + end. + + +getNocType(G,X,Scope) when is_record(X, interface) -> %% default | specified + OpList = getAllOperationScopes(G,Scope), + getNocType2(G,X,OpList); +getNocType(G,X,Scope) -> %% transparent | {extraarg1,....,extraargN} + getNocType3(G,X,Scope). + +getNocType2(G,X,List) -> + getNocType2(G,X,List,[]). + +getNocType2(_,_,[],Found) -> + selectTypeFromList(Found); +getNocType2(G,X,[OpScope|OpScopes],Found) -> + getNocType2(G,X,OpScopes,[getNocType3(G,X,OpScope)|Found]). + +getNocType3(G,X,Scope) -> %% transparent | {extraarg1,....,extraargN} + + %% Get actual pragma appliance scope + SpecScope = getActualScope(G,X,Scope), + + %% The "broker" option is passed + %% only by pragmas, seek for type. + case ic_pragma:getBrokerData(G,X,SpecScope) of + {_Module,Type} -> + Type; + List -> + selectTypeFromList(List) %%transparent/multiple + end. + + +getModType(G,X,Scope) -> %% default | specified + + %% Get actual pragma appliance scope + SpecScope = getActualScope(G,X,Scope), + + %% The "broker" option is passed + %% only by pragmas, seek for brokerdata. + case ic_pragma:getBrokerData(G,X,SpecScope) of + {Module,Type} -> + case Module == ic_genobj:impl(G) of + true -> + case Type of + transparent -> + dt; %% default + transparent + _ -> + do %% default + opaque + end; + false -> + case Type of + transparent -> + spt; %% specified + transparent + _ -> + spo %% specified + opaque + end + end; + _List -> + dt + end. + + + +%%%% +%% +%% Returns a list of ALL operation full +%% scoped names local and inherited +%% from other interfaces +%% + +getAllOperationScopes(G,Scope) -> + getOperationScopes(G,Scope) ++ + getInhOperationScopes(G,Scope). + + +getOperationScopes(G,Scope) -> + getOpScopes(G, + Scope, + ets:match(ic_genobj:pragmatab(G),{op,'$0',Scope,'_','_'}), + []). + +getOpScopes(_,_,[],OpScopes) -> + OpScopes; +getOpScopes(G,Scope,[[Name]|Names],Found) -> + getOpScopes(G,Scope,Names,[[Name|Scope]|Found]). + + +getInhOperationScopes(G,Scope) -> + getInhOpScopes1(G, + Scope, + ets:match(ic_genobj:pragmatab(G),{inherits,Scope,'$1'}), + []). + +getInhOpScopes1(G,_Scope,[],OpScopes) -> + getInhOpScopes2(G,OpScopes); +getInhOpScopes1(G,Scope,[[SC]|SCs],Found) -> + getInhOpScopes1(G,Scope,SCs,[SC|Found]). + + +getInhOpScopes2(G,Scopes) -> + getInhOpScopes2(G,Scopes,[]). + +getInhOpScopes2(_G,[],Found) -> + Found; +getInhOpScopes2(G,[SC|SCs],Found) -> + getOperationScopes(G,SC) ++ getInhOpScopes2(G,SCs,Found). + +%% +%% +%%%% + + + +%%%% +%% +%% +%% Seek the actual operation scope : +%% +%% * if the operation is inherited, get the real scope for it +%% +%% * if the operation has a specific pragma, apply the real +%% scope, otherwise return the including scope +%% +getActualScope(G, X, Scope) when is_record(X, op) -> + OpScope = getRealOpScope(G,X,Scope), + case ets:match(ic_genobj:pragmatab(G),{codeopt_specific,OpScope}) of + [[]] -> + OpScope; + _ -> + Scope + end; +getActualScope(_G, _X, N) -> + N. + +%% +%% Just seek and return the scope for the operation +%% where it were originaly defined +%% +getRealOpScope(G,X,N) when is_record(X, op) -> + Ptab = ic_genobj:pragmatab(G), + Id = get_id2(X), + + case ets:match(Ptab,{op,Id,N,'_','_'}) of + [[]] -> + [Id|N]; + _ -> + getRealOpScope(G, Ptab, X, N, Id, ets:match(Ptab,{inherits,N,'$1'})) + end; +getRealOpScope(_G,_X,N) -> + N. + +getRealOpScope(_G, _S, _X, N, Id, []) -> + [Id|N]; +getRealOpScope(G, S, X, N, Id, [[OS]|OSs]) -> + case ets:match(S,{op,Id,OS,'_','_'}) of + [[]] -> + [Id|OS]; + _ -> + getRealOpScope(G, S, X, N, Id, OSs) + end. + +selectTypeFromList([]) -> + transparent; +selectTypeFromList([{_,transparent}|Rest]) -> + selectTypeFromList(Rest); +selectTypeFromList([transparent|Rest]) -> + selectTypeFromList(Rest); +selectTypeFromList([_|_Rest]) -> + multiple. + + + +getCallErr() -> + {'ERROR' ,"Bad Operation -- handle call"}. + +getCastErr() -> + {'ERROR' ,"Bad Operation -- handle cast"}. + +getInfoErr() -> + {'ERROR' ,"Bad Operation -- handle info"}. + + + + + + +%% +%% Type code access utilities +%% + +tk_operation_data(G, N, X, TL) -> + case print_tk(G,N,X) of + true -> + TL; + false -> + no_tk + end. + +tk_interface_data(G, N, X) -> + InfoList = + foldr(fun({_Name, Body}, Acc) -> + get_if(G,N,Body)++Acc end, + get_if(G,N,get_body(X)), + X#interface.inherit_body), + case InfoList of + [] -> + no_tk; %%%%%%%% Should be changed to [] <<<<<<<<<<<<<<<<<<<<<<<<<<< Warning ! + _ -> + InfoList + end. + + +print_tk(G, N, X) when is_record(X, op)-> %% operation + case getNocType(G,X,N) of + transparent -> + false; + multiple -> + false; + _XTuple -> %%check if there are any USETK pragmas + operation_usetk(G,N,X) + end; +print_tk(_G, _N, _X) -> %% error + false. + + +operation_usetk(G,N,X) -> + PTab = ic_genobj:pragmatab(G), + OTab = ic_genobj:optiontab(G), + OpName = get_id2(X), +% SID = ic_util:to_colon(N), + Res = case use_tk(OTab,[N]) of + {ok,N} -> + true; + false -> + %% Look if there is an operation with that name + %% which can be found in an included file. + case ets:match(PTab,{file_data_included,'_','_',op,'$3',OpName,'_','_','_'}) of + [] -> + false; + ScopeList -> + case use_tk(OTab,ScopeList) of + %% There is an operation with that name, + %% look if it is inherited by interface "N" + {ok,FoundScope} -> + ic_pragma:is_inherited_by(FoundScope,N,PTab); + false -> + false + end + end + end, + Res. + + +use_tk(_,[]) -> + false; +use_tk(OTab,[[Scope]|Scopes]) -> + SID = ic_util:to_colon(Scope), + case ets:match(OTab,{{option,{use_tk,SID}},true}) of + [] -> + case ets:match(OTab,{{option,{use_tk,"::"++SID}},true}) of + [] -> + use_tk(OTab,Scopes); + _ -> + {ok,Scope} + end; + _ -> + {ok,Scope} + end; +use_tk(OTab,[Scope|Scopes]) -> + SID = ic_util:to_colon(Scope), + case ets:match(OTab,{{option,{use_tk,SID}},true}) of + [] -> + case ets:match(OTab,{{option,{use_tk,"::"++SID}},true}) of + [] -> + use_tk(OTab,Scopes); + _ -> + {ok,Scope} + end; + _ -> + {ok,Scope} + end. + + + + + +mark_not_transparent(G,N) -> + + %% Mark that there are multiple + %% functions in interface + S = ic_genobj:pragmatab(G), + ets:insert(S,{no_transparent,N}). + + +transparent(G) -> + + S = ic_genobj:pragmatab(G), + case ets:match_object(S,{no_transparent,'$0'}) of + [] -> + true; + _ -> + false + end. + diff --git a/lib/ic/src/ic_options.erl b/lib/ic/src/ic_options.erl new file mode 100644 index 0000000000..8d17fc1753 --- /dev/null +++ b/lib/ic/src/ic_options.erl @@ -0,0 +1,363 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1998-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_options). + +-include_lib("ic/src/ic.hrl"). +-include_lib("kernel/include/file.hrl"). + +%%----------------------------------------------------------------- +%% External exports +%%----------------------------------------------------------------- +-export([defaultBe/0, float_to_version/1, get_opt/2, add_opt/3, + read_cfg/2, which_opts/1, allowed_opt/2]). + +%%----------------------------------------------------------------- +%% Internal exports +%%----------------------------------------------------------------- +-export([]). + +%%----------------------------------------------------------------- +%% External functions +%%----------------------------------------------------------------- + +%%-------------------------------------------------------------------- +%% +%% Option handling +%% +%% Valid options are: (those with * is NotYetImpl) +%% +%% pedantic - makes the compiler really nitty-gritty about its input +%% +%% Wall - those warning options that we feel an IDL programmer should +%% care about. Not as picky as pedantic +%% +%% warn_multi_mod - warn if several modules are declared in the same +%% IDL file +%% +%% warn_nested_mod - warn if there are nested modules. This is not a +%% problem but it breakes the rule that modules are put into one file +%% each. +%% +%% warn_name_shadow - warn if identifiers are shadow through inherited +%% interfaces. Default is true. +%% +%% warn_quoted_atom - warn if atoms needs quote, this makes Erlang +%% code less nice but is certainly no error. +%% +%% nowarn - suppress all warning messages. Will still output warnings +%% if silent2 option is used +%% +%% always_outargs - force object server implementation return the +%% tuple {RetVal, OutArgs, NewState} even if there are no OutArgs. If +%% this option is not set then such an operation implementation is +%% assumed to return {RetVal, NewState} +%% +%% use_proc_dict - use the process dictionary in the client +%% stubs. This means that client stubs return RetVal instead of {ok, +%% RetVal, OutArgs} and that corba:get_outargs() returns OutArgs. The +%% out arguments are stored with the key '$corba_outargs'. +%% +%% module_group - use the top module as file name for both skeletons +%% and stubs. Default value is false which means that each interface +%% is put in a separate file. +%% +%% skel_module_group - group all interfaces in a module in one +%% skeleton file as opposed to one skeleton file for each +%% interface. Defaults to false. +%% +%% stub_module_group - group all interface stubs from a module in one +%% stub file as opposed to one stub file for each interface. Default +%% is false. +%% +%% *help - prints a small summary of the compiler usage +%% +%% silent - suppresses all messages from the compiler +%% +%% silent2 - suppresses all messages from the compiler and returns all +%% warnings or errors as lists. Returns {ok, WarnList} or {error, +%% WarnList, ErrList} +%% +%% *noexec - runs the compiler but does not open files or write to +%% files. +%% +%% {serv, } - sets the name of the implementation skeleton +%% file. This defaults to ModName_skel. +%% +%% {impl, } - sets the name of the interface server +%% implementation module name. This defaults to InterfaceName_impl +%% +%% {outdir, Dir} - use Dir as the directory to put all generated +%% files. +%% +%% {servdir, Dir} - put all generated skel files in the directory Dir. +%% +%% {stubdir, Dir} - put all generated stub files in the directory Dir. +%% +%% {this, InterfaceOrOpName} - puts the OE_THIS parameter into the +%% impl. call. This option can be used both on whole interfaces an on +%% distinct operations. Fullscoped names must be used (as in {this, +%% "M1::I1::Op"}). The option can be given in 3 ways: {this, Name} +%% means this will be added to all matching Name or as {{this, Name}, +%% true} or this can explicitly be asked to be left out as in {{this, +%% Name}, false} which enables OE_THIS to be passed to all ops of an +%% interface except those set by the false flag. +%% +%% cfgfile - sets the name of the config file that is read at +%% startup. The order of the different ways to set options is: default +%% setting, configuration file, options given when generator is +%% called. Default name for this file is .ic_config +%% +%% serv_last_call - tells what the last handle_call clause should +%% do. It can have the values exception, which makes the last clause +%% return a CORBA exception and exit which does not generate a last clause +%% (which will make the server crash on an unknown call) +%% +%% +%% -- UNDOCUMENTED -- +%% +%% debug - prints debug information +%% +%% tokens - prints the tokens from the tokenizer and then exit +%% +%% form - prints the form from the parser and then exit +%% +%% tform - form returned from type check +%% +%% time - if true then time is measured during compilation +%% +%% +%%-------------------------------------------------------------------- +allowed_opt(default_opts, _V) -> true; +allowed_opt(debug, V) -> is_bool(V); +allowed_opt(tokens, V) -> is_bool(V); +allowed_opt(form, V) -> is_bool(V); +allowed_opt(tform, V) -> is_bool(V); +allowed_opt(time, V) -> is_bool(V); +allowed_opt(maxerrs, V) -> is_intorinfinity(V); +allowed_opt(maxwarns, V) -> is_intorinfinity(V); +allowed_opt(nowarn, V) -> is_bool(V); +allowed_opt(show_opts, V) -> is_bool(V); + +allowed_opt(help, V) -> is_bool(V); +allowed_opt('Wall', V) -> is_bool(V); +allowed_opt(warn_multi_mod, V) -> is_bool(V); +allowed_opt(warn_quoted_atom, V) -> is_bool(V); +allowed_opt(warn_nested_mod, V) -> is_bool(V); +allowed_opt(warn_name_shadow, V) -> is_bool(V); +allowed_opt(module_group, V) -> is_bool(V); +allowed_opt(skel_module_group, V) -> is_bool(V); +allowed_opt(stub_module_group, V) -> is_bool(V); +allowed_opt(always_outargs, V) -> is_bool(V); +allowed_opt(pedantic, V) -> is_bool(V); +%%allowed_opt(gen_serv, V) -> is_bool(V); +%%allowed_opt(gen_stub, V) -> is_bool(V); +allowed_opt(gen_hrl, V) -> is_bool(V); +allowed_opt(serv_last_call, exception) -> true; +allowed_opt(serv_last_call, exit) -> true; +allowed_opt(silent, V) -> is_bool(V); +allowed_opt(silent2, V) -> is_bool(V); +allowed_opt({serv, _}, _V) -> true; +allowed_opt({impl, _}, _V) -> true; +allowed_opt(outdir, _V) -> true; +allowed_opt(servdir, _V) -> true; +allowed_opt(stubdir, _V) -> true; +allowed_opt(cfgfile, _V) -> true; +allowed_opt(use_preproc, V) -> is_bool(V); +allowed_opt(preproc_cmd, _V) -> true; +allowed_opt(preproc_flags, _V) -> true; +allowed_opt(this, _V) -> true; +allowed_opt({this, _}, V) -> is_bool(V); +allowed_opt(from, _V) -> true; +allowed_opt({from, _}, V) -> is_bool(V); +allowed_opt(handle_info, _V) -> true; +allowed_opt({handle_info, _}, V) -> is_bool(V); +allowed_opt(timeout, _V) -> true; +allowed_opt({timeout, _}, V) -> is_bool(V); +allowed_opt(c_timeout, {V1, V2}) -> is_int(V1) and is_int(V2); +allowed_opt(c_timeout, V) -> is_int(V); +allowed_opt(c_report, V) -> is_bool(V); +allowed_opt(scoped_op_calls, V) -> is_bool(V); +% Compatibility option (semantic check limitation) +allowed_opt(scl, V) -> is_bool(V); +% Added switches for non corba generation +allowed_opt(flags, V) -> is_int(V); +allowed_opt(be, erl_corba) -> true; +allowed_opt(be, erl_template) -> true; +allowed_opt(be, erl_genserv) -> true; +allowed_opt(be, c_genserv) -> true; +allowed_opt(be, erl_plain) -> true; +allowed_opt(be, c_server) -> true; +allowed_opt(be, c_client) -> true; +allowed_opt(be, java) -> true; +% Noc backend +allowed_opt(be, noc) -> true; +allowed_opt({broker,_},{_,transparent}) -> true; +allowed_opt({broker,_},{_,Term}) -> is_term(Term); +allowed_opt({use_tk,_},V) -> is_bool(V); +% +% Multiple be +allowed_opt(multiple_be, _List) -> true; +% +allowed_opt(precond, {_M, _F}) -> true; +allowed_opt({precond, _}, {_M, _F}) -> true; +allowed_opt(postcond, {_M, _F}) -> true; +allowed_opt({postcond, _}, {_M, _F}) -> true; +allowed_opt(no_codechange, V) -> is_bool(V); +allowed_opt(user_protocol, _V) -> true; +allowed_opt(light_ifr, V) -> is_bool(V); +allowed_opt(_, _) -> false. + + +-define(DEFAULTCFGFILE, ".ic_config"). + +which_opts(G) -> + ets:match(G#genobj.options, {{option, '$1'}, '$2'}). + +add_opt(G, KList, Val) when is_list(KList) -> + lists:foreach(fun({K, V}) -> add_opt(G, K, V); + (K) -> add_opt(G, K, Val) end, + KList); + +add_opt(G, servdir, V) -> + do_add_opt(G, servdir, assure_directory(G, ic_util:to_list(V))); +add_opt(G, stubdir, V) -> + do_add_opt(G, stubdir, assure_directory(G, ic_util:to_list(V))); +add_opt(G, K, V) -> + do_add_opt(G, K, V). + + +assure_directory(_G, Dir) -> + Dirs = filename:split(Dir), + check_dirs(Dirs, [], filename:pathtype(Dir)). + +check_dirs([X | Xs], SoFar, Type) -> + New = if SoFar == [], Type /= absolute -> + X; + true -> + filename:join(SoFar, X) + end, + assert_dir(New), + check_dirs(Xs, New, Type); +check_dirs([], SoFar, _Type) -> + SoFar. + +assert_dir(D) -> + case file:read_file_info(D) of + {ok, X} when X#file_info.type == directory -> ok; + _ -> case file:make_dir(D) of + ok -> ok; + _ -> exit({could_not_create, D}) + end + end. + +do_add_opt(G, handle_info, V) -> + ?insert(G#genobj.options, {option, {handle_info, V}}, true); +do_add_opt(G, {handle_info, V}, false) -> + ?insert(G#genobj.options, {option, {handle_info, V}}, force_false); +do_add_opt(G, timeout, V) -> + ?insert(G#genobj.options, {option, {timeout, V}}, true); +do_add_opt(G, {timeout, V}, false) -> + ?insert(G#genobj.options, {option, {timeout, V}}, force_false); +do_add_opt(G, this, V) -> + ?insert(G#genobj.options, {option, {this, V}}, true); +do_add_opt(G, {this, V}, false) -> + ?insert(G#genobj.options, {option, {this, V}}, force_false); +do_add_opt(G, from, V) -> + ?insert(G#genobj.options, {option, {from, V}}, true); +do_add_opt(G, {from, V}, false) -> + ?insert(G#genobj.options, {option, {from, V}}, force_false); +do_add_opt(G, scoped_op_calls, V) when V /= true, V /= false -> + ?insert(G#genobj.options, {option, {scoped_op_calls, V}}, false); +do_add_opt(G, K, V) -> + case allowed_opt(K, V) of + true -> + case expand_opt(K) of + L when is_list(L) -> + add_opt(G, L, V); + _ -> + %%io:format("Add opt: ~p ~p~n", [K, V]), + ?insert(G#genobj.options, {option, K}, V) + end; + _ -> + ic_error:warn(G, {illegal_opt, K}) + end. + +get_opt(G, K) -> + case ets:lookup(G#genobj.options, {option, K}) of + [] -> false; + [{{_, K}, V}] -> V + end. + +expand_opt(pedantic) -> [warn_multi_mod, warn_quoted_atom, always_outargs]; +expand_opt(module_group) -> [skel_module_group, stub_module_group]; +expand_opt('Wall') -> [warn_multi_mod, warn_nested_mod, warn_name_shadow]; +expand_opt(outdir) -> [servdir, stubdir]; +expand_opt(default_opts) -> + ['Wall', gen_hrl, {serv_last_call, exception}, + {outdir, []}, use_preproc, {preproc_cmd, "erl"}, + {preproc_flags, ""}, {maxerrs, 10}, {maxwarns, infinity}]; +%% gcc preproc command {preproc_cmd, "gcc -x c++ -E"} +expand_opt(Opt) -> Opt. + + +%% Use this if user not provide +%% a backend. +defaultBe() -> erl_corba. + + +%% +%% Read any config file +read_cfg(G, Opts) -> + Name = case lists:keysearch(cfgfile, 1, Opts) of + {value, {_, N}} -> ic_util:to_list(N); + _ -> ?DEFAULTCFGFILE + end, + case file:consult(Name) of + {ok, OptList} -> + add_opt(G, OptList, true); + _X when Name == ?DEFAULTCFGFILE -> ok; +%% {error, X} -> +%% ic_error:warn(G, {cfg_open, X, Name}); + X -> ic_error:warn(G, {cfg_open, X, Name}) + end. + + +float_to_version({_,_,Str}) -> Str. + + +%%----------------------------------------------------------------- +%% Internal functions +%%----------------------------------------------------------------- +is_bool(true) -> true; +is_bool(false) -> true; +is_bool(_) -> false. + +is_int(V) when is_integer(V) -> true; +is_int(_) -> false. + +is_intorinfinity(X) when is_integer(X) -> true; +is_intorinfinity(infinity) -> true; +is_intorinfinity(_X) -> false. + + +is_term(Term) when is_tuple(Term) -> true; +is_term(_NoTerm) -> false. + diff --git a/lib/ic/src/ic_plainbe.erl b/lib/ic/src/ic_plainbe.erl new file mode 100644 index 0000000000..7b3e3dc859 --- /dev/null +++ b/lib/ic/src/ic_plainbe.erl @@ -0,0 +1,355 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1998-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_plainbe). + + +-export([do_gen/3]). +%%------------------------------------------------------------ +%% +%% Internal stuff +%% +%%------------------------------------------------------------ + +-import(ic_util, [mk_var/1, mk_oe_name/2, to_atom/1, to_list/1]). +-import(ic_forms, [get_id/1, get_id2/1, get_body/1]). +-import(ic_codegen, [emit/3, nl/1]). + +-import(lists, [foreach/2, map/2]). + +-include("icforms.hrl"). +-include("ic.hrl"). + +%%------------------------------------------------------------ +%% +%% Generate the client side Erlang stubs. +%% +%% Each module is generated to a separate file. +%% +%% Export declarations for all interface functions must be +%% generated. Each function then needs to generate a function head and +%% a body. IDL parameters must be converted into Erlang parameters +%% (variables, capitalised) and a type signature list must be +%% generated (for later encode/decode). +%% +%%------------------------------------------------------------ + + +do_gen(G, File, Form) -> + G2 = ic_file:filename_push(G, [], mk_oe_name(G, + ic_file:remove_ext(to_list(File))), + erlang), + gen_head(G2, [], Form), + exportDependency(G2), + gen(G2, [], Form), + genDependency(G2), + ic_file:filename_pop(G2, erlang), + ok. + + +gen(G, N, [X|Xs]) when is_record(X, preproc) -> + NewG = ic:handle_preproc(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 = [get_id2(X) | N], + gen_head(G2, N2, X), + gen(G2, N2, get_body(X)), + G3 = ic_file:filename_pop(G2, CD), + gen(G3, N, Xs); + +gen(G, N, [X|Xs]) when is_record(X, interface) -> + %% Add inheritence data to pragmatab + ic_pragma:add_inh_data(G,N,X), + G2 = ic_file:filename_push(G, N, X, erlang), + N2 = [get_id2(X) | N], + gen_head(G2, N2, X), + gen(G2, N2, get_body(X)), + foreach(fun({_Name, Body}) -> gen(G2, N2, Body) end, + X#interface.inherit_body), + G3 = ic_file:filename_pop(G2, erlang), + gen(G3, N, Xs); + +gen(G, N, [X|Xs]) when is_record(X, const) -> +% N2 = [get_id2(X) | N], + emit_constant_func(G, X#const.id, X#const.val), + gen(G, N, Xs); %% N or N2? + +gen(G, N, [X|Xs]) when is_record(X, op) -> + {Name, ArgNames, TypeList, OutArgs} = extract_info(G, N, X), + emit_func(G, N, X, Name, ArgNames, TypeList, OutArgs), + gen(G, N, Xs); + + +gen(G, N, [X|Xs]) when is_record(X, attr) -> + emit_attr(G, N, X, fun emit_func/7), + gen(G, N, Xs); + +gen(G, N, [X|Xs]) when is_record(X, except) -> + icstruct:except_gen(G, N, X, erlang), + gen(G, N, Xs); + +gen(G, N, [X|Xs]) -> + case may_contain_structs(X) of + true -> icstruct:struct_gen(G, N, X, erlang); + false -> ok + end, + gen(G, N, Xs); + +gen(_G, _N, []) -> ok. + + +may_contain_structs(X) when is_record(X, typedef) -> true; +may_contain_structs(X) when is_record(X, struct) -> true; +may_contain_structs(X) when is_record(X, union) -> true; +may_contain_structs(_X) -> false. + + +%%------------------------------------------------------------ +%% +%% Export stuff +%% +%% Gathering of all names that should be exported from a stub +%% file. +%% + + +gen_head_special(G, N, X) when is_record(X, interface) -> + Fd = ic_genobj:stubfiled(G), + + foreach(fun({Name, Body}) -> + ic_codegen:comment(Fd, "Exports from ~p", + [ic_util:to_colon(Name)]), + ic_codegen:export(Fd, exp_top(G, N, Body, [])), + nl(Fd) + end, X#interface.inherit_body), + Fd; +gen_head_special(_G, _N, _X) -> ok. + + + +%% Shall generate all export declarations +gen_head(G, N, X) -> + case ic_genobj:is_stubfile_open(G) of + true -> + F = ic_genobj:stubfiled(G), + ic_codegen:comment(F, "Interface functions"), + ic_codegen:export(F, exp_top(G, N, X, [])), + nl(F), + gen_head_special(G, N, X); + false -> ok + end. + +exp_top(_G, _N, X, Acc) when element(1, X) == preproc -> + Acc; +exp_top(G, N, L, Acc) when is_list(L) -> + exp_list(G, N, L, Acc); +exp_top(G, N, M, Acc) when is_record(M, module) -> + exp_list(G, N, get_body(M), Acc); +exp_top(G, N, I, Acc) when is_record(I, interface) -> + exp_list(G, N, get_body(I), Acc); +exp_top(G, N, X, Acc) -> + exp3(G, N, X, Acc). + +exp3(_G, _N, C, Acc) when is_record(C, const) -> + [{get_id(C#const.id), 0} | Acc]; + +exp3(_G, _N, Op, Acc) when is_record(Op, op) -> + FuncName = get_id(Op#op.id), + Arity = length(ic:filter_params([in, inout], Op#op.params)), + [{FuncName, Arity} | Acc]; + +exp3(_G, _N, A, Acc) when is_record(A, attr) -> + lists:foldr(fun(Id, Acc2) -> + {Get, Set} = mk_attr_func_names([], get_id(Id)), + case A#attr.readonly of + {readonly, _} -> [{Get, 1} | Acc2]; + _ -> [{Get, 1}, {Set, 2} | Acc2] + end end, Acc, ic_forms:get_idlist(A)); + +exp3(_G, _N, _X, Acc) -> Acc. + +exp_list(G, N, L, OrigAcc) -> + lists:foldr(fun(X, Acc) -> exp3(G, N, X, Acc) end, OrigAcc, L). + + + + +%%------------------------------------------------------------ +%% +%% Emit stuff +%% +%% Low level generation primitives +%% + + +emit_func(G, _N, X, Name, ArgNames, _TypeList, OutArgs) -> + case ic_genobj:is_stubfile_open(G) of + false -> ok; + true -> + Fd = ic_genobj:stubfiled(G), + OpName = list_to_atom(Name), + ArgList = mk_list(ArgNames), + emit_op_comment(G, Fd, X, OpName, ArgNames, OutArgs), + emit(Fd, "~p(~s) ->\n", [OpName,ArgList]), + emit(Fd, " ~p:~p(~s).\n\n", [to_atom(ic_genobj:impl(G)), OpName, ArgList]) + end. + +emit_attr(G, N, X, F) -> + XX = #id_of{type=X}, + {GetType, SetType} = mk_attr_func_types(N, X), + lists:foreach(fun(Id) -> + X2 = XX#id_of{id=Id}, + {Get, Set} = mk_attr_func_names(N, get_id(Id)), + F(G, N, X2, Get, [], GetType, []), + case X#attr.readonly of + {readonly, _} -> ok; + _ -> + F(G, N, X2, Set, [ic_util:mk_name(G, "Value")], + SetType, []) + end end, ic_forms:get_idlist(X)). + +emit_constant_func(G, Id, Val) -> + case ic_genobj:is_stubfile_open(G) of + false -> ok; + true -> + Fd = ic_genobj:stubfiled(G), + N = list_to_atom(get_id(Id)), + emit_const_comment(G, Fd, Id, N), + emit(Fd, "~p() -> ~p.\n\n", [N, Val]) + end. + + +emit_const_comment(_G, F, _X, Name) -> + ic_codegen:mcomment_light(F, + [io_lib:format("Constant: ~p", [Name])]). + + +emit_op_comment(G, F, X, Name, InP, OutP) -> + ic_codegen:mcomment_light(F, + [io_lib:format("~s: ~p", [get_title(X), Name]), + "", + get_returns(G, X, InP, OutP) | + get_raises(X)]). + +get_title(X) when is_record(X, attr) -> "Attribute Operation"; +get_title(_X) -> "Operation". + +get_raises(X) when is_record(X, op) -> + if X#op.raises == [] -> []; + true -> + [" Raises: " ++ + mk_list(lists:map(fun(E) -> ic_util:to_colon(E) end, X#op.raises))] + end; +get_raises(_X) -> []. + +get_returns(_G, _X, _InP, []) -> + " Returns: RetVal"; +get_returns(G, _X, _InP, OutP) -> + " Returns: "++mk_list(["RetVal" | mk_erl_vars(G, OutP)]). + + + + +%%------------------------------------------------------------ +%% +%% Utilities +%% +%% Convenient little go-get functions +%% +%%------------------------------------------------------------ + +%% The automaticly generated get and set operation names for an +%% attribute. +mk_attr_func_names(_Scope, Name) -> + {"_get_" ++ Name, "_set_" ++ Name}. + +%% Returns TK of the Get and Set attribute functions. +mk_attr_func_types(_N, X) -> + TK = ic_forms:get_tk(X), + {{TK, [], []}, {tk_void, [TK], []}}. + + + +%%------------------------------------------------------------ +%% +%% Generation utilities and common stuff +%% +%% Convenient stuff for generation +%% +%%------------------------------------------------------------ + + +%% Input is a list of parameters (in parse form) and output is a list +%% of capitalised variable names. mk_var is in icgen +mk_erl_vars(_G, Params) -> + map(fun(P) -> mk_var(get_id(P#param.id)) end, Params). + + +%% mk_list produces a nice comma separated string of variable names +mk_list([]) -> []; +mk_list([Arg | Args]) -> + Arg ++ mk_list2(Args). +mk_list2([Arg | Args]) -> + ", " ++ Arg ++ mk_list2(Args); +mk_list2([]) -> []. + + +%%------------------------------------------------------------ +%% +%% Parser utilities +%% +%% Called from the yecc parser. Expands the identifier list of an +%% attribute so that the attribute generator never has to handle +%% lists. +%% +%%------------------------------------------------------------ + + + + +%% Export code produce for dependency function +exportDependency(G) -> + Fd = ic_genobj:stubfiled(G), + ic_codegen:export(Fd, [{oe_dependency, 0}]), + nl(Fd). + +%% Code produce for dependency function +genDependency(G) -> + Fd = ic_genobj:stubfiled(G), + nl(Fd),nl(Fd), + ic_codegen:comment(Fd, "Idl file dependency list function"), + emit(Fd, "oe_dependency() ->\n", []), + emit(Fd, " ~p.\n\n", [ic_pragma:get_dependencies(G)]). + + + + +extract_info(G, _N, X) when is_record(X, op) -> + Name = get_id2(X), + InArgs = ic:filter_params([in,inout], X#op.params), + OutArgs = ic:filter_params([out,inout], X#op.params), + ArgNames = mk_erl_vars(G, InArgs), + TypeList = {ic_forms:get_tk(X), + map(fun(Y) -> ic_forms:get_tk(Y) end, InArgs), + map(fun(Y) -> ic_forms:get_tk(Y) end, OutArgs) + }, + {Name, ArgNames, TypeList, OutArgs}. diff --git a/lib/ic/src/ic_pp.erl b/lib/ic/src/ic_pp.erl new file mode 100644 index 0000000000..db06118d32 --- /dev/null +++ b/lib/ic/src/ic_pp.erl @@ -0,0 +1,2139 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1997-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_pp). + +-export([run/2]). + +-define(is_number(X), X >= $0, X =< $9). +-define(is_upper(X), X >= $A, X =< $Z). +-define(is_lower(X), X >= $a, X =< $z). +-define(is_underline(X), X == $_). +-define(is_tab(X), X == 9). +-define(is_space(X), X == 32). +-define(tab, 9). +-define(space, 32). + + +%%====================================================================================== +%%====================================================================================== +%%====================================================================================== +%% Preprocessor +%% +%% This preprocessor is equivalent to the gcc-preprocessor. It takes a file name and +%% a list of preprocessor flags as an input and returns a processed text file. +%% +%% The processing is done in two phases. +%% In the first phase the input file is tokenised into a list where all comments are +%% replaced by a space and all "backslash-newline" sequences are removed. +%% +%% In the second phase all macros are expanded. + +%% %% %% NOTE: #if, #else, and #elif are not yet implemented. +%% Only '#if 0' is implemented to be possible to keep old code as a comment for +%% future refence by putting '#if 0' before it and '#endif' after it. +%% +%%====================================================================================== +%%====================================================================================== +%%====================================================================================== + + +%%====================================================================================== +%% Variables which are used throughout the program: +%% ------------------------------------------------ +%% +%% Command A preprocessor command +%% Current Temporary variable used when tokenising the file +%% Defs The currently valid macro definitions +%% Err The current list of errors = [{file, line number, error text}, ...] +%% File The tokenised file (or what remains of it when expanding the macros) +%% Flags The preprocessor flags +%% FN or FileName Tbe name of the current file +%% IfCou Used for ifdef/ifndef/endif values: check_all | {endif, Endif, IfLine} +%% Endif = number of matching endif's yet to be found +%% Ifline = the line number for the the first found ifdef/ifndef +%% IncDir Directories to be searched for included files +%% IncFile Stack of included files +%% IncLine The line numer of an include +%% L The current line number +%% Name Name of a macro +%% Nl Number of encountered newlines +%% No_of_para Numer of parameters of the currently expanded macro +%% Out The result of the second step +%% Parameters The parameters of the currently expanded macro +%% PrevFile The name of the "parent" file which includes the currently expanded file +%% Rem Remaining of the file currently being expanded +%% Removed The tokens removed, used when removing tokens to the end of a line +%% Result The current result of something +%% SelfRef List of variables which shoud not be expanded at the rescan to avoid +%% endless loops due to self referencing +%% Str Temporary string +%% Text A variable used for string handling, e.g at error handling +%% Tokens Temoprary list when tokenising +%% War The current list of warnings = [{file, line number, warning text}, ...] +%% X Temporary variable used when the value is not important +%% Y Temporary variable used when the value is not important +%% +%%====================================================================================== + + + + +%%====================================================================================== +%%====================================================================================== +%%====================================================================================== +%% The main entry for the preprocessor +%% +%% +%% Output {ok, Out, War} | {error, Err} +%%====================================================================================== +%%====================================================================================== +%%====================================================================================== +run(FileName, Flags) when is_atom(FileName) -> + run(atom_to_list(FileName), Flags); + +run(FileName, Flags) -> + IncDir = include_dir(Flags), + + case catch file:read_file(FileName) of + {ok, Bin} -> + FileList = binary_to_list(Bin), + run(FileList, FileName, IncDir, Flags); + {error, _} -> + Text = "No such file or directory", + {error, [FileName ++ ": " ++ Text]} + end. + + +run(FileList, FileName, IncDir, Flags) -> + %%---------------------------------------------------------- + %% Run the first phase, i.e tokenise the file + %%---------------------------------------------------------- + File = tokenise(FileList, FileName), + + %%---------------------------------------------------------- + %% Run the second phase, i.e expand macros + %%---------------------------------------------------------- + {Out, Err, War, _Defs, IfCou} = expand(File, FileName, IncDir, Flags), + + %%---------------------------------------------------------- + %% Check if all #if #ifdef #ifndef have a matching #endif + %%---------------------------------------------------------- + IfError = case IfCou of + {endif, Endif, IfLine} when Endif > 0 -> + [{FileName, IfLine, "unterminated `#if' conditional"}]; + _ -> + [] + end, + + Err2 = Err++IfError, + + case Err2 of + [] -> + {ok, lists:flatten(lists:reverse(Out)), lists:reverse(War)}; + _ -> + {error, lists:reverse(Err2)} + end. + +%%====================================================================================== +%% The entry for all included files +%% +%% +%% Output {Out, Defs, Err, War} +%%====================================================================================== +run_include(FileName, FileList, _Out, Defs, Err, War, IncLine, IncFile, IncDir) -> + + %%---------------------------------------------------------- + %% Run the first phase, i.e tokenise the file + %%---------------------------------------------------------- + [PrevFile | _T] = IncFile, + {File, FileInfoStart, FileInfoEnd} = + tokenise(FileList, FileName, IncLine, PrevFile), + + %%---------------------------------------------------------- + %% Run the second phase, i.e expand macros + %%---------------------------------------------------------- + + %% Try first pass without file info start/end + {OutT, ErrT, WarT, DefsT, IfCouT} = + expand(File, Defs, Err, War, [FileName|IncFile], IncDir), + + {Out2, Err2, War2, Defs2, IfCou2} = + case only_nls(OutT) of + true -> %% The file is defined before + {["\n"], ErrT, WarT, DefsT, IfCouT}; + false -> %% The file is not defined before, try second pass + expand([FileInfoStart|File]++FileInfoEnd, Defs, Err, War, [FileName|IncFile], IncDir) + end, + + %%---------------------------------------------------------- + %% Check if all #if #ifdef #ifndef have a matching #endif + %%---------------------------------------------------------- + IfError = case IfCou2 of + {endif, Endif, IfLine} when Endif > 0 -> + [{FileName, IfLine, "unterminated `#if' conditional"}]; + _ -> + [] + end, + + {Out2, Defs2, Err2++IfError, War2}. + + + +%% Return true if there is no data +%% other than new lines +only_nls([]) -> + true; +only_nls(["\n"|Rem]) -> + only_nls(Rem); +only_nls(["\r","\n"|Rem]) -> + only_nls(Rem); +only_nls([_|_Rem]) -> + false. + + + + + + + + + + +%%=================================================================================== +%%=================================================================================== +%%=================================================================================== +%% Tokenise the file +%% +%% +%% Output: File +%% +%% Description: +%% The input file is tokenised into a list where all comments are replaced +%% by a space and all "backslash-newline" sequences are removed. +%% +%% A file information is added at start and end of an included file to set the +%% current file name and line number. +%% +%% +%% A token consists of: +%% -------------------- +%% +%% {char, Char} special characters like ()[]{},!%& etc +%% {command,Command} a macro command +%% {expanded,Str} an expanded variable, used to prevent infinite loops +%% at self reference +%% {file_info,FI} start and end information of a file +%% FI is a string of the following format: +%% "# Line FileName Int" were Int is +%% 1 if start of an included file, +%% 2 when returning to "parent" file +%% {nl, L} newline +%% {number,Num) variable, a string starting with a number +%% {self_ref,Var} to allow reference to a variable again, used when expanding +%% self refering macros +%% space a space +%% space_exp a space, special notation to prevent not wanted concatination +%% {string, Str} a (tail of a) string constant +%% {string_part, Str} a head of a string constant defined on several consecutive lines +%% {sys_head, Str} (tail of) the file name of included system file +%% {sys_head_part , Str} the file name of included system file +%% {var,Var} variable, a string starting with minuscular or capital letter or +%% an underline +%% +%% Note, comments are not removed within a character or string constant +%% or inside an include-definition where the file name is delimited with < > +%%=================================================================================== +%%=================================================================================== +%%=================================================================================== + +tokenise(File, FileName) -> + {Result, _L} = token(File, 2, [], not_set, 0), + FI_start = lists:reverse(lists:flatten(io_lib:format("# 1 ~p~n",[FileName]))), + FileInfoStart = {file_info, FI_start}, + [FileInfoStart | Result]. + +tokenise(File, FileName, IncLine, PrevFile) -> + {Result, _L} = token(File, 2, [], not_set, 0), + FI_start = lists:reverse(lists:flatten(io_lib:format("# 1 ~p 1~n",[FileName]))), + FileInfoStart = {file_info, FI_start}, + FI_end = lists:reverse(lists:flatten(io_lib:format("# ~p ~p 2~n~n",[IncLine-1,PrevFile]))), + FileInfoEnd = [{file_info, FI_end}], + {Result, FileInfoStart, FileInfoEnd}. +% [FileInfoStart | Result] ++ FileInfoEnd. + + +%%=================================================================================== +%% token(InputFile, L, Result, Gen) +%% Gen information of the first token on the line, default = not_set +%% +%% Output: File +%%=================================================================================== + +%%================================================================== +%% Normal line +%%================================================================== +%%--------------------------------------- +%% All file tokenised +%%--------------------------------------- +token([], L, [{nl,NL}|Result], _Gen, _BsNl) when L == NL+1-> + {lists:reverse([{nl,NL}|Result]), L}; +token([], L, Result, _Gen, _BsNl) -> + {lists:reverse([{nl,L-1}|Result]), L}; + +%%--------------------------------------- +%% String +%%--------------------------------------- +token(File, L, Result, string, BsNl) -> + case token_string(File, []) of + {Rem, Str, nl} -> + Result1 = [{nl, L}, {string,Str} | Result], + token(Rem, L+1, Result1, string, BsNl); + {Rem, Str} -> + token(Rem, L, [{string,Str}|Result], not_set, BsNl) + end; + +token([$"|File], L, Result, Gen, BsNl) -> + case token_string(File, []) of + {Rem, Str, nl} -> + Result1 = [{nl, L}, {string_part,Str} | Result], + token(Rem, L+1, Result1, string, BsNl); + {Rem, Str} -> + token(Rem, L, [{string,Str}|Result], Gen, BsNl) + end; + +%%--------------------------------------- +%% Include with < > +%%--------------------------------------- +token(File, L, Result, include, BsNl) -> + case token_include(File, []) of + {Rem, Str, nl} -> + Result1 = [{nl, L}, {sys_head,Str} | Result], + token(Rem, L+1, Result1, include, BsNl); + {Rem, Str} -> + token(Rem, L, [{sys_head,Str}|Result], not_set, BsNl) + end; + +token([$<|File], L, [space,{command,"include"}|Result], Gen, BsNl) -> + case token_include(File, []) of + {Rem, Str, nl} -> + Result1 = [{nl, L}, {sys_head_part,Str}, space, {command,"include"} |Result], + token(Rem, L+1,Result1, include, BsNl); + {Rem, Str} -> + Result1 = [{sys_head,Str}, space, {command,"include"} |Result], + token(Rem, L, Result1, Gen, BsNl) + end; +token([$<|File], L, [{command,"include"}|Result], Gen, BsNl) -> + case token_include(File, []) of + {Rem, Str, nl} -> + Result1 = [{nl, L}, {sys_head_part,Str}, space, {command,"include"} |Result], + token(Rem, L+1,Result1, include, BsNl); + {Rem, Str} -> + Result1 = [{sys_head,Str}, space, {command,"include"} |Result], + token(Rem, L, Result1, Gen, BsNl) + end; + + + + +%%--------------------------------------- +%% CR (just remove these) +%%--------------------------------------- +token([$\r|File], L, Result, Gen, BsNl) -> +% Bs = lists:duplicate(BsNl+1,{nl,L}), + token(File, L, Result, Gen, BsNl); %% Bs or BsNl? + +%%--------------------------------------- +%% Newline +%%--------------------------------------- +token([$\n|File], L, Result, _Gen, BsNl) -> + Bs = lists:duplicate(BsNl+1,{nl,L}), + token(File, L+1, Bs++Result, not_set, 0); + +token([$\\,$\n|File], L, Result, Gen, BsNl) -> + token(File, L, Result, Gen, BsNl+1); + +%%--------------------------------------- +%% Comments +%%--------------------------------------- +token([$/,$/|File], L, Result, not_set, BsNl) -> + Rem = skip_to_nl(File), + token(Rem, L+1,[{nl, L} | Result], not_set, BsNl); +token([$/,$/|File], L, Result, _Gen, BsNl) -> + Rem = skip_to_nl(File), + token(Rem, L+1,[{nl, L} | Result], not_set, BsNl); + +token([$/,$*|File], L, Result, not_set, BsNl) -> + case token_comment(File) of + {Rem, nl} -> + token(Rem, L+1, [{nl, L} | Result], not_set, BsNl); + Rem -> + token(Rem, L, Result, not_set, BsNl) + end; +token([$/,$*|File], L, Result, Gen, BsNl) -> + case token_comment(File) of + {Rem, nl} -> + token(Rem, L+1, [{nl, L}, space | Result], not_set, BsNl); + Rem -> + token(Rem, L, [space|Result], Gen, BsNl) + end; + +%%--------------------------------------- +%% Variable +%%--------------------------------------- +token([X|File], L, Result, Gen, BsNl) when ?is_upper(X) -> + GenNew = case Gen of not_set -> var; _ -> Gen end, + {Rem, Var} = tok_var(File, [X]), + token(Rem, L, [{var,Var}|Result], GenNew, BsNl); +token([X|File], L, Result, Gen, BsNl) when ?is_lower(X) -> + GenNew = case Gen of not_set -> var; _ -> Gen end, + {Rem, Var} = tok_var(File, [X]), + token(Rem, L, [{var,Var}|Result], GenNew, BsNl); +token([X|File], L, Result, Gen, BsNl) when ?is_underline(X) -> + GenNew = case Gen of not_set -> var; _ -> Gen end, + {Rem, Var} = tok_var(File, [X]), + token(Rem, L, [{var,Var}|Result], GenNew, BsNl); + +%%--------------------------------------- +%% Number +%%--------------------------------------- +token([X|File], L, Result, Gen, BsNl) when ?is_number(X) -> + GenNew = case Gen of not_set -> number; _ -> Gen end, + {Rem, Tokens} = tok_number(File, [X]), + token(Rem, L, [{number,Tokens}|Result], GenNew, BsNl); + +%%--------------------------------------- +%% Space +%%--------------------------------------- +token([X|File], L, [Y|Result], Gen, BsNl) when ?is_space(X) -> + case Y of + space -> + Rem = remove_leading_spaces(File), + token(Rem, L, [Y|Result], Gen, BsNl); + {nl,_,_} -> + Rem = remove_leading_spaces(File), + token(Rem, L, Result, Gen, BsNl); + _ -> + Rem = remove_leading_spaces(File), + token(Rem, L, [space, Y |Result], Gen, BsNl) + end; + +token([X|File], L, [Y|Result], Gen, BsNl) when ?is_tab(X) -> + case Y of + space -> + Rem = remove_leading_spaces(File), + token(Rem, L, [Y|Result], Gen, BsNl); + {nl,_,_} -> + Rem = remove_leading_spaces(File), + token(Rem, L, Result, Gen, BsNl); + _ -> + Rem = remove_leading_spaces(File), + token(Rem, L, [space, Y |Result], Gen, BsNl) + end; + +%%--------------------------------------- +%% Command +%%--------------------------------------- +token([$#|File], L, Result, not_set, BsNl) -> + {Rem, Command} = token_pp_com(File), + case catch list_to_integer(Command) of + {'EXIT', _} -> + token(Rem, L, [{command,Command}|Result], not_set, BsNl); + _Int -> + Result1 = [{number,Command}, {command,"line"}| Result], + token(Rem, L, Result1, not_set, BsNl) + end; + +%%--------------------------------------- +%% Char +%%--------------------------------------- +token([X|File], L, Result, Gen, BsNl) -> + GenNew = case Gen of not_set -> char; _ -> Gen end, + token(File, L, [{char,X}|Result], GenNew, BsNl). + + +%%================================================================== +%% Scan to the end of a token +%%================================================================== +%%--------------------------------------- +%% Number +%%--------------------------------------- +tok_number([], Str) -> + {[], lists:reverse(Str)}; +tok_number([X|File], Str) when ?is_upper(X) -> + tok_number(File, [X|Str]); +tok_number([X|File], Str) when ?is_lower(X) -> + tok_number(File, [X|Str]); +tok_number([X|File], Str) when ?is_underline(X) -> + tok_number(File, [X|Str]); +tok_number([X|File], Str) when ?is_number(X) -> + tok_number(File, [X|Str]); +tok_number(File, Str) -> + {File, lists:reverse(Str)}. + + +%%--------------------------------------- +%% Variable +%%--------------------------------------- +tok_var([], Str) -> + {[], lists:reverse(Str)}; +tok_var([X|File], Str) when ?is_upper(X) -> + tok_var(File, [X|Str]); +tok_var([X|File], Str) when ?is_lower(X) -> + tok_var(File, [X|Str]); +tok_var([X|File], Str) when ?is_underline(X) -> + tok_var(File, [X|Str]); +tok_var([X|File], Str) when ?is_number(X) -> + tok_var(File, [X|Str]); +tok_var(File, Str) -> + {File, lists:reverse(Str)}. + + +%%--------------------------------------- +%% Preprocessor command +%%--------------------------------------- +token_pp_com([X|File]) when ?is_upper(X) -> + tok_var(File, [X]); +token_pp_com([X|File]) when ?is_lower(X) -> + tok_var(File, [X]); +token_pp_com([X|File]) when ?is_underline(X) -> + tok_var(File, [X]); +token_pp_com([X|File]) when ?is_number(X) -> + tok_var(File, [X]); +token_pp_com(File) -> + Rem = remove_leading_spaces(File), + {Rem, "null"}. + + + +%%--------------------------------------- +%% Comment +%%--------------------------------------- +token_comment([]) -> + []; +token_comment([$*,$/|File]) -> + File; +token_comment([$\n|File]) -> + {[$/,$*|File], nl}; +token_comment([$\r,$\n|File]) -> + {[$/,$*|File], nl}; +token_comment([$\\,$\n|File]) -> + {[$/,$*|File], nl}; +%token_comment([$\\,$\n|File]) -> +% token_comment(File); +token_comment([_|File]) -> + token_comment(File). + + +%%--------------------------------------- +%% String +%%--------------------------------------- +token_string([], Str) -> + {[], lists:reverse(Str)}; +token_string([$"|File], Str) -> + {File, lists:reverse(Str)}; +token_string([$\n|File], Str) -> + {File, lists:reverse(Str), nl}; +token_string([$\r,$\n|File], Str) -> + {File, lists:reverse(Str), nl}; +token_string([$\\,$\n|File], Str) -> + token_string(File, Str); +token_string([X|File], Str) -> + token_string(File, [X|Str]). + + +%%--------------------------------------- +%% Include +%%--------------------------------------- +token_include([], Str) -> + {[], lists:reverse(Str)}; +token_include([$>|File], Str) -> + {File, lists:reverse(Str)}; +token_include([$\n|File], Str) -> + {File, lists:reverse(Str), nl}; +token_include([$\r,$\n|File], Str) -> + {File, lists:reverse(Str), nl}; +token_include([$\\,$\n|File], Str) -> + token_include(File, Str); +token_include([X|File], Str) -> + token_include(File, [X|Str]). + + + + +%%=================================================================================== +%% detokenise a list of tokens, until next newline +%% +%% Output: a string +%%=================================================================================== +detokenise(Tokens) -> + detokenise(Tokens, []). + +detokenise([], Result) -> + lists:flatten(Result); +detokenise([space], Result) -> + lists:flatten(Result); +detokenise([space_exp], Result) -> + lists:flatten(Result); +detokenise([space|Rem], Result) -> + detokenise(Rem, Result++[?space]); +detokenise([space_exp|Rem], Result) -> + detokenise(Rem, Result++[?space]); +detokenise([nl|Rem], Result) -> + detokenise(Rem, Result++[$\n]); +detokenise([{_, String}|Rem], Result) -> + detokenise(Rem, Result++[String]). + + +detokenise_pragma(Tokens) -> + detokenise_pragma(Tokens, []). + +detokenise_pragma([], Result) -> + lists:flatten(Result); +detokenise_pragma([space], Result) -> + lists:flatten(Result); +detokenise_pragma([space|Rem], Result) -> + detokenise_pragma(Rem, Result++[?space]); +detokenise_pragma([nl|Rem], Result) -> + detokenise_pragma(Rem, Result++[$\n]); +detokenise_pragma([{string, String}|Rem], Result) -> + detokenise_pragma(Rem, Result++[$"|String]++[$"]); +detokenise_pragma([{_, String}|Rem], Result) -> + detokenise_pragma(Rem, Result++[String]). + + + + + + + +%%====================================================================================== +%%====================================================================================== +%%====================================================================================== +%% Expand macros. +%% +%% +%% Output: A text file +%% +%% Description: Expands all macros. All macro definitions are logged in a list 'Defs' +%% and all found errors and warnings are logged in a list 'Err' and 'War', +%% respectively. +%% +%% When a macro name is found in a source line it is expanded according +%% to the current 'Defs'-list. The macro must agree both to the name +%% and number of parameters, otherwise an error is reported. +%%====================================================================================== +%%====================================================================================== +%%====================================================================================== + + +expand(List, FileName, IncDir, Flags) -> + %% Get all definitions from preprocessor commnads + %% and merge them on top of the file collected. + CLDefs = get_cmd_line_defs(Flags), + expand(List, [], [], CLDefs, [FileName], IncDir, check_all, [], [], 1, FileName). + +expand(List, Defs, Err, War, [FileName|IncFile], IncDir) -> + expand(List, [], [], Defs, [FileName|IncFile], IncDir, check_all, Err, War, 1, FileName). + + +%%======================================================= +%% Main loop for the expansion +%%======================================================= +expand([], Out, _SelfRef, Defs, _IncFile, _IncDir, IfCou, Err, War, _L, _FN) -> +% io:format("~n ===============~n"), +% io:format(" definitions ~p~n",[lists:reverse(Defs)]), +% io:format(" found warnings ~p~n",[lists:reverse(War)]), +% io:format(" found errors ~p~n",[lists:reverse(Err)]), +% io:format(" ===============~n~n~n"), + {Out, Err, War, Defs, IfCou}; + +expand([{file_info, Str} | Rem], Out, SelfRef, Defs, IncFile, IncDir, IfCou, Err, War, L, FN) -> + expand(Rem, Str++Out, SelfRef, Defs, IncFile, IncDir, IfCou, Err, War, L, FN); + +%%--------------------------------------- +%% Searching for endif, +%% i.e skip all source lines until matching +%% end if is encountered +%%--------------------------------------- +expand([{command,Command} | Rem], Out, SelfRef, Defs, IncFile, IncDir, {endif, Endif, IfLine}, Err, War, L, FN) + when Command == "ifdef" -> + {_Removed, Rem2, _Nl} = read_to_nl(Rem), + IfCou2 = {endif, Endif+1, IfLine}, + expand(Rem2, Out, SelfRef, Defs, IncFile, IncDir, IfCou2, Err, War, L, FN); + + +expand([{command,Command} | Rem], Out, SelfRef, Defs, IncFile, IncDir, {endif, Endif, IfLine}, Err, War, L, FN) + when Command == "ifndef" -> + {_Removed, Rem2, _Nl} = read_to_nl(Rem), + IfCou2 = {endif, Endif+1, IfLine}, + expand(Rem2, Out, SelfRef, Defs, IncFile, IncDir, IfCou2, Err, War, L, FN); + + +expand([{command,Command} | Rem], Out, SelfRef, Defs, IncFile, IncDir, {endif, Endif, IfLine}, Err, War, L, FN) + when Command == "if" -> + case pp_command(Command, Rem, Defs, IncDir, Err, War, L, FN) of + {{'if', true}, Rem2, Err2, War2, Nl} -> + IfCou2 = {endif, Endif+1, IfLine}, + expand(Rem2, Out, SelfRef, Defs, IncFile, IncDir, IfCou2, Err2, War2, L+Nl, FN); +%% {{'if', false}, Rem2, Err2, War2, Nl} -> Not implemented yet + {{'if', error}, Rem2, Err2, War2, Nl} -> + IfCou2 = {endif, Endif, IfLine}, + expand(Rem2, Out, SelfRef, Defs, IncFile, IncDir, IfCou2, Err2, War2, L+Nl, FN) + end; + +expand([{command,Command} | Rem], Out, SelfRef, Defs, IncFile, IncDir, {endif, Endif, IfLine}, Err, War, L, FN) + when Command == "endif" -> + {_Removed, Rem2, Nl} = read_to_nl(Rem), + case Endif of + 1 -> + Out2 = [lists:duplicate(Nl,$\n)|Out], + expand(Rem2, Out2, SelfRef, Defs, IncFile, IncDir, check_all, Err, War, L+Nl, FN); + _ -> + IfCou2 = {endif, Endif-1, IfLine}, + expand(Rem2, Out, SelfRef, Defs, IncFile, IncDir, IfCou2, Err, War, L+Nl, FN) + end; + + +expand([{command,_Command} | Rem], Out, SelfRef, Defs, IncFile, IncDir, {endif, Endif, IfLine}, Err, War, L, FN) -> + {_Removed, Rem2, _Nl} = read_to_nl(Rem), + IfCou2 = {endif, Endif, IfLine}, + expand(Rem2, Out, SelfRef, Defs, IncFile, IncDir, IfCou2, Err, War, L, FN); + +%% Solves a bug when spaces in front of hashmark ! +expand([space | Rem], Out, SelfRef, Defs, IncFile, IncDir, {endif, Endif, IfLine}, Err, War, L, FN) -> + expand(Rem, Out, SelfRef, Defs, IncFile, IncDir, {endif, Endif, IfLine}, Err, War, L, FN); + +expand([{nl,_Nl} | Rem], Out, SelfRef, Defs, IncFile, IncDir, {endif, Endif, IfLine}, Err, War, L, FN) -> + expand(Rem, Out, SelfRef, Defs, IncFile, IncDir, {endif, Endif, IfLine}, Err, War, L, FN); + + +expand([_X | Rem], Out, SelfRef, Defs, IncFile, IncDir, {endif, Endif, IfLine}, Err, War, L, FN) -> + {_Removed, Rem2, Nl} = read_to_nl(Rem), + Out2 = [lists:duplicate(Nl,$\n)|Out], + expand(Rem2, Out2, SelfRef, Defs, IncFile, IncDir, {endif, Endif, IfLine}, Err, War, L, FN); + + + + + +%%--------------------------------------- +%% Check all tokens +%%--------------------------------------- +expand([{nl, _N} | Rem], Out, SelfRef, Defs, IncFile, IncDir, IfCou, Err, War, L, FN) -> + expand(Rem, [$\n | Out], SelfRef, Defs, IncFile, IncDir, IfCou, Err, War, L+1, FN); + +expand([space | Rem], Out, SelfRef, Defs, IncFile, IncDir, IfCou, Err, War, L, FN) -> + expand(Rem, [?space | Out], SelfRef, Defs, IncFile, IncDir, IfCou, Err, War, L, FN); + +expand([space_exp | Rem], Out, SelfRef, Defs, IncFile, IncDir, IfCou, Err, War, L, FN) -> + expand(Rem, [?space | Out], SelfRef, Defs, IncFile, IncDir, IfCou, Err, War, L, FN); + +expand([{command,Command} | Rem], Out, SelfRef, Defs, IncFile, IncDir, check_all, Err, War, L, FN) -> + case pp_command(Command, Rem, Defs, IncDir, Err, War, L, FN) of + {define, Rem2, Defs2, Err2, War2, Nl} -> + Out2 = [lists:duplicate(Nl,$\n)|Out], + expand(Rem2, Out2, SelfRef, Defs2, IncFile, IncDir, check_all, Err2, War2, L+Nl, FN); + + {undef, Rem2, Defs2, Err2, War2, Nl} -> + Out2 = [lists:duplicate(Nl,$\n)|Out], + expand(Rem2, Out2, SelfRef, Defs2, IncFile, IncDir, check_all, Err2, War2, L+Nl, FN); + + {{include, ok}, FileName, FileCont, Rem2, Nl, Err2, War2} -> + {Out3, Defs3, Err3, War3} = + run_include(FileName, FileCont, Out, Defs, Err2, War2, L+Nl, IncFile, IncDir), + Nls = [], + Out4 = Out3++Nls++Out, + expand(Rem2, Out4, SelfRef, Defs3, IncFile, IncDir, check_all, Err3, War3, L+Nl, FN); + + {{include, error}, Rem2, Nl, Err2, War2} -> + Out2 = [lists:duplicate(Nl,$\n)|Out], + expand(Rem2, Out2, SelfRef, Defs, IncFile, IncDir, check_all, Err2, War2, L+Nl, FN); + + {{ifdef, true}, Rem2, Err2, War2, Nl} -> + Out2 = [lists:duplicate(Nl,$\n)|Out], + IfCou2 = {endif, 1, L}, + expand(Rem2, Out2, SelfRef, Defs, IncFile, IncDir, IfCou2, Err2, War2, L+Nl, FN); + {{ifdef, false}, Rem2, Err2, War2, Nl} -> + Out2 = [lists:duplicate(Nl,$\n)|Out], + expand(Rem2, Out2, SelfRef, Defs, IncFile, IncDir, check_all, Err2, War2, L+Nl, FN); + + {{ifndef, true}, Rem2, Err2, War2, Nl} -> + Out2 = [lists:duplicate(Nl,$\n)|Out], + IfCou2 = {endif, 1, L}, + expand(Rem2, Out2, SelfRef, Defs, IncFile, IncDir, IfCou2, Err2, War2, L+Nl, FN); + {{ifndef, false}, Rem2, Err2, War2, Nl} -> + Out2 = [lists:duplicate(Nl,$\n)|Out], + expand(Rem2, Out2, SelfRef, Defs, IncFile, IncDir, check_all, Err2, War2, L+Nl, FN); + + {endif, Rem2, Err2, War2, Nl} -> + Out2 = [lists:duplicate(Nl,$\n)|Out], + expand(Rem2, Out2, SelfRef, Defs, IncFile, IncDir, check_all, Err2, War2, L+Nl, FN); + + {{'if', true}, Rem2, Err2, War2, Nl} -> + Out2 = [lists:duplicate(Nl,$\n)|Out], + IfCou2 = {endif, 1, L}, + expand(Rem2, Out2, SelfRef, Defs, IncFile, IncDir, IfCou2, Err2, War2, L+Nl, FN); +%% {{'if', false}, Removed, Rem2, Nl} -> Not implemented at present + {{'if', error}, Rem2, Err2, War2, Nl} -> + Out2 = [lists:duplicate(Nl,$\n)|Out], + expand(Rem2, Out2, SelfRef, Defs, IncFile, IncDir, check_all, Err2, War2, L+Nl, FN); + + {'else', {_Removed, Rem2, Nl}} -> + Out2 = [lists:duplicate(Nl,$\n)|Out], + Err2 = {FN, L, "`else' command is not implemented at present"}, + expand(Rem2, Out2, SelfRef, Defs, IncFile, IncDir, check_all, [Err2|Err], War, L+Nl, FN); + + {'elif', {_Removed, Rem2, Nl}} -> + Out2 = [lists:duplicate(Nl,$\n)|Out], + Err2 = {FN, L, "`elif' command is not implemented at present"}, + expand(Rem2, Out2, SelfRef, Defs, IncFile, IncDir, check_all, [Err2|Err], War, L+Nl, FN); + + {warning, {WarningText, Rem2, Nl}} -> + [FileName|_More] = IncFile, + War2 = {FileName, L, "warning: #warning "++detokenise(WarningText)}, + Out2 = [lists:duplicate(Nl,$\n)|Out], + expand(Rem2, Out2, SelfRef, Defs, IncFile, IncDir, check_all, Err, [War2|War], L+Nl, FN); + + {error, {ErrorText, Rem2, Nl}} -> + [FileName|_More] = IncFile, + Err2 = {FileName, L, detokenise(ErrorText)}, + Out2 = [lists:duplicate(Nl,$\n)|Out], + expand(Rem2, Out2, SelfRef, Defs, IncFile, IncDir, check_all, [Err2|Err], War, L+Nl, FN); + + {{line, ok}, {_Removed, Rem2, Nl}, L2, FN2, LineText} -> + Out2 = lists:duplicate(Nl,$\n)++LineText++Out, + [_X|IF] = IncFile, + IncFile2 = [FN2|IF], + expand(Rem2, Out2, SelfRef, Defs, IncFile2, IncDir, check_all, Err, War, L2, FN2); + {{line, error}, {_Removed, Rem2, Nl}, Err2} -> + Out2 = [lists:duplicate(Nl,$\n)|Out], + expand(Rem2, Out2, SelfRef, Defs, IncFile, IncDir, check_all, [Err2|Err], War, L+Nl, FN); + + hash_mark -> + expand(Rem, Out, SelfRef, Defs, IncFile, IncDir, check_all, Err, War, L, FN); + + {pragma, Rem2, Nl, Text} -> + Out2 = lists:duplicate(Nl,$\n)++Text++Out, + expand(Rem2, Out2, SelfRef, Defs, IncFile, IncDir, check_all, Err, War, L+Nl, FN); + + {ident, Rem2, Nl, Text} -> + Out2 = lists:duplicate(Nl,$\n)++Text++Out, + expand(Rem2, Out2, SelfRef, Defs, IncFile, IncDir, check_all, Err, War, L+Nl, FN); + + {not_recognised, {Removed, Rem2, Nl}} -> + Text = lists:reverse([$#|Command]), + RemovedS = lists:reverse([?space|detokenise(Removed)]), + Out2 = [$\n|RemovedS]++Text++Out, + case Command of + [X|_T] when ?is_upper(X) -> + expand(Rem2, Out2, SelfRef, Defs, IncFile, IncDir, check_all, Err, War, L+Nl, FN); + [X|_T] when ?is_lower(X) -> + expand(Rem2, Out2, SelfRef, Defs, IncFile, IncDir, check_all, Err, War, L+Nl, FN); + [X|_T] when ?is_underline(X) -> + expand(Rem2, Out2, SelfRef, Defs, IncFile, IncDir, check_all, Err, War, L+Nl, FN); + _ -> + Err2 = {FN, L, "invalid preprocessing directive name"}, + expand(Rem2, Out2, SelfRef, Defs, IncFile, IncDir, check_all, [Err2|Err], War, L+Nl, FN) + end; + + Else -> +% io:format(" %%%%Else%%%%%% ~p~n",[Else]), + exit(Else) + end; + + +expand([{var, "__LINE__"}|Rem], Out, SelfRef, Defs, IncFile, IncDir, IfCou, Err, War, L, FN) -> + LL = io_lib:format("~p",[L]), + expand(Rem, [LL | Out], SelfRef, Defs, IncFile, IncDir, IfCou, Err, War, L, FN); + +expand([{var, "__FILE__"}|Rem], Out, SelfRef, Defs, IncFile, IncDir, IfCou, Err, War, L, FN) -> + expand(Rem, [$",FN,$" | Out], SelfRef, Defs, IncFile, IncDir, IfCou, Err, War, L, FN); + +expand([{var, "__DATE__"}|Rem], Out, SelfRef, Defs, IncFile, IncDir, IfCou, Err, War, L, FN) -> + {{Y,M,D},{_H,_Mi,_S}} = calendar:universal_time(), + Date = io_lib:format("\"~s ~p ~p\"",[month(M),D,Y]), + expand(Rem, [Date | Out], SelfRef, Defs, IncFile, IncDir, IfCou, Err, War, L, FN); + +expand([{var, "__TIME__"}|Rem], Out, SelfRef, Defs, IncFile, IncDir, IfCou, Err, War, L, FN) -> + {{_Y,_M,_D},{H,Mi,S}} = calendar:universal_time(), + HS = if H < 10 -> "0"++integer_to_list(H); + true -> integer_to_list(H) + end, + MiS = if Mi < 10 -> "0"++integer_to_list(Mi); + true -> integer_to_list(Mi) + end, + SS = if S < 10 -> "0"++integer_to_list(S); + true -> integer_to_list(S) + end, + Time = io_lib:format("\"~s:~s:~s\"",[HS,MiS,SS]), + expand(Rem, [Time | Out], SelfRef, Defs, IncFile, IncDir, IfCou, Err, War, L, FN); + +expand([{var, "__INCLUDE_LEVEL__"}|Rem], Out, SelfRef, Defs, IncFile, IncDir, IfCou, Err, War, L, FN) -> + IL = io_lib:format("~p",[length(IncFile)-1]), + expand(Rem, [IL | Out], SelfRef, Defs, IncFile, IncDir, IfCou, Err, War, L, FN); + +expand([{var, "__BASE_FILE__"}|Rem], Out, SelfRef, Defs, IncFile, IncDir, IfCou, Err, War, L, FN) -> + [BF|_T] = lists:reverse(IncFile), + expand(Rem, [$",BF,$" | Out], SelfRef, Defs, IncFile, IncDir, IfCou, Err, War, L, FN); + +expand([{var, Var} | Rem], Out, SelfRef, Defs, IncFile, IncDir, IfCou, Err, War, L, FN) -> + {Out2, Err2, War2, Rem2, SelfRef2} = + source_line(Var, Rem, SelfRef, Defs, Err, War, L, FN), + expand(Rem2, [Out2 | Out], SelfRef2, Defs, IncFile, IncDir, IfCou, Err2, War2, L, FN); + +expand([{char, Char} | Rem], Out, SelfRef, Defs, IncFile, IncDir, IfCou, Err, War, L, FN) -> + expand(Rem, [Char | Out], SelfRef, Defs, IncFile, IncDir, IfCou, Err, War, L, FN); + +expand([{number, Number} | Rem], Out, SelfRef, Defs, IncFile, IncDir, IfCou, Err, War, L, FN) -> + expand(Rem, [Number | Out], SelfRef, Defs, IncFile, IncDir, IfCou, Err, War, L, FN); + +expand([{expanded, Str} | Rem], Out, SelfRef, Defs, IncFile, IncDir, IfCou, Err, War, L, FN) -> + expand(Rem, [Str | Out], SelfRef, Defs, IncFile, IncDir, IfCou, Err, War, L, FN); + +expand([{self_ref, Str} | Rem], Out, SelfRef, Defs, IncFile, IncDir, IfCou, Err, War, L, FN) -> + SelfRef2 = lists:delete(Str,SelfRef), + expand(Rem, Out, SelfRef2, Defs, IncFile, IncDir, IfCou, Err, War, L, FN); + +expand([{string, Str} | Rem], Out, SelfRef, Defs, IncFile, IncDir, IfCou, Err, War, L, FN) -> + expand(Rem, [$", Str, $" | Out], SelfRef, Defs, IncFile, IncDir, IfCou, Err, War, L, FN); + +expand([{string_part, Str} | Rem], Out, SelfRef, Defs, IncFile, IncDir, IfCou, Err, War, L, FN) -> + {Str2, Rem2, Nl} = expand_string_part([$"|Str], Rem), + expand(Rem2, [Str2| Out], SelfRef, Defs, IncFile, IncDir, IfCou, Err, War, L+Nl, FN). + + + + + + + + +%%======================================================================== +%% Expand a line starting as a partial string +%%======================================================================== +expand_string_part(Str, File) -> + expand_string_part(File, Str, 0). + +expand_string_part([{string, Str_part} | Rem], Str, Nl) -> + {Str++Str_part++[$"], Rem, Nl}; +expand_string_part([space | Rem], Str, Nl) -> + expand_string_part(Rem, Str, Nl); +expand_string_part([nl| Rem], Str, Nl) -> + expand_string_part(Rem, Str++[$\n], Nl); +expand_string_part([{string_part, Str_part} | Rem], Str, Nl) -> + expand_string_part(Rem, Str++Str_part, Nl). + + + + + +%%======================================================================== +%% Parse and integrate command line macro directives +%% At this momment, only -D and -U are supported (gcc like) +%%======================================================================== + + +%% Collect all command line macro definitions +get_cmd_line_defs(Flags) -> + Adjusted = parse_cmd_line(Flags,[]), + + {_Out, _Err, _War, Defs, _IfCou} = + expand(tokenise(Adjusted,""), + [], + [], + [], + [], + [], + check_all, + [], + [], + 1, + ""), + Defs. + +%% Parse command line macros +parse_cmd_line([],Found) -> + lists:flatten(lists:reverse(Found)); + +parse_cmd_line([45,68|Rest],Found) -> + {Collected,RestCmds} = collect_define(Rest,[]), + parse_cmd_line(RestCmds,[Collected|Found]); + +parse_cmd_line([45,85|Rest],Found) -> + {Collected,RestCmds} = collect_undefine(Rest,[]), + parse_cmd_line(RestCmds,[Collected|Found]); + +parse_cmd_line([_|Rest],Found) -> + parse_cmd_line(Rest,Found). + + +%% Collect defines and translate them +%% into a text format +collect_define([],Found) -> + { "#define "++lists:reverse(Found)++"\n", [] }; +collect_define([32|Rest],Found) -> + { "#define "++lists:reverse(Found)++"\n", Rest }; +collect_define([61|Rest],[]) -> + { "", Rest }; +collect_define([61|Rest],Found) -> + collect_define(Rest,[32|Found]); +collect_define([C|Rest],Found) -> + collect_define(Rest,[C|Found]). + + +%% Collect undefines and translate them +%% into a text format +collect_undefine([],Found) -> + { "#undef "++lists:reverse(Found)++"\n", [] }; +collect_undefine([32|Rest],Found) -> + { "#undef "++lists:reverse(Found)++"\n", Rest }; +collect_undefine([C|Rest],Found) -> + collect_undefine(Rest,[C|Found]). + + + + + + + + + + + + +%%====================================================================================== +%%====================================================================================== +%%====================================================================================== +%% Read a preprocessor command +%% +%% +%% Output: Depending of the command, typically = {Command, Rem, Err, War, Nl} +%% +%%====================================================================================== +%%====================================================================================== +%%====================================================================================== + +pp_command(Command, [space|File], Defs, IncDir, Err, War, L, FN) -> + pp_command(Command, File, Defs, IncDir, Err, War, L, FN); + +pp_command(Command, File, Defs, IncDir, Err, War, L, FN) -> + + case Command of + %%---------------------------------------- + %% #define + %%---------------------------------------- + "define" -> + case define(File, Err, War, L, FN) of + {error, Rem, Err2, War2, Nl} -> + {define, Rem, Defs, Err2, War2, Nl}; + {warning, Rem, Name, No_of_para, Parameters, Macro, Err2, War2, Nl} -> + case is_define_ok(Name, No_of_para, Parameters, Macro, Defs) of + {yes, Defs2} -> + {define, Rem, Defs2, Err2, War2, Nl}; + {no, Defs2} -> + Text = lists:flatten(io_lib:format("`~s' redefined",[Name])), + {define, Rem, Defs2, Err2, [{FN, L, Text}|War2], Nl}; + {error, Text, Defs2} -> + {define, Rem, Defs2, [{FN, L, Text}|Err2], War2, Nl} + end; + {ok, Rem, Name, No_of_para, Parameters, Macro, Err2, War2, Nl} -> + case is_define_ok(Name, No_of_para, Parameters, Macro, Defs) of + {yes, Defs2} -> + {define, Rem, Defs2, Err2, War2, Nl}; + {no, Defs2} -> + Text = lists:flatten(io_lib:format("`~s' redefined",[Name])), + {define, Rem, Defs2, Err2, [{FN, L, Text}|War2], Nl}; + {error, Text, Defs2} -> + {define, Rem, Defs2, [{FN, L, Text}|Err2], War2, Nl} + end + end; + + %%---------------------------------------- + %% #undef + %%---------------------------------------- + "undef" -> + case undef(File, Err, War, L, FN) of + {error, Rem, Err2, War2, Nl} -> + {undef, Rem, Defs, Err2, War2, Nl}; + {ok, Rem, Name, Err2, War2, Nl} -> + Defs2 = lists:keydelete(Name, 1, Defs), + {undef, Rem, Defs2, Err2, War2, Nl} + end; + + %%---------------------------------------- + %% #include + %%---------------------------------------- + "include" -> + case include(File, IncDir) of + {error, Rem, Nl, Err2} -> + {{include, error}, Rem, Nl, [{FN, L, Err2}|Err], War}; + {error, Rem, Nl, Err2, NameNl} -> + {{include, error}, Rem, Nl, [{FN, L+ NameNl, Err2}|Err], War}; + {ok, FileName, FileCont, Rem, Nl} -> + {{include, ok}, FileName, FileCont, Rem, Nl, Err, War} + end; + + %%---------------------------------------- + %% #ifdef + %%---------------------------------------- + "ifdef" -> + case define(File, Err, War, L, FN) of + {error, Rem, Err2, War2, Nl} -> + {{ifdef, false}, Rem, Defs, Err2, War2, Nl}; + {warning, Rem, Name, No_of_para, _Parameters, _Macro, Err2, War2, Nl} -> + case is_defined_before(Name, No_of_para, Defs) of + yes -> + {{ifdef, false}, Rem, Err2, War2, Nl}; + no -> + {{ifdef, true}, Rem, Err2, War2, Nl} + end; + {ok, Rem, Name, No_of_para, _Parameters, _Macro, Err2, War2, Nl} -> + case is_defined_before(Name, No_of_para, Defs) of + yes -> + {{ifdef, false}, Rem, Err2, War2, Nl}; + no -> + {{ifdef, true}, Rem, Err2, War2, Nl} + end + end; + + + + %%---------------------------------------- + %% #ifndef + %%---------------------------------------- + "ifndef" -> + case define(File, Err, War, L, FN) of + {error, Rem, Err2, War2, Nl} -> + {{ifndef, false}, Rem, Defs, Err2, War2, Nl}; + {warning, Rem, Name, No_of_para, _Parameters, _Macro, Err2, War2, Nl} -> + case is_defined_before(Name, No_of_para, Defs) of + yes -> + {{ifndef, true}, Rem, Err2, War2, Nl}; + no -> + {{ifndef, false}, Rem, Err2, War2, Nl} + end; + {ok, Rem, Name, No_of_para, _Parameters, _Macro, Err2, War2, Nl} -> + case is_defined_before(Name, No_of_para, Defs) of + yes -> + {{ifndef, true}, Rem, Err2, War2, Nl}; + no -> + {{ifndef, false}, Rem, Err2, War2, Nl} + end + end; + + + %%---------------------------------------- + %% #endif + %%---------------------------------------- + "endif" -> + {Removed, Rem, Nl} = read_to_nl(File), + case Removed of + [] -> + {endif, Rem, Err, War, 1}; + _ -> + Text = "ignoring the tail of the line", + {ok, Rem, Err, [{FN, L, Text}|War], Nl} + end; + + + %%---------------------------------------- + %% #if + %%---------------------------------------- + "if" -> + case if_zero(File, Err, War, L, FN) of + {error, Rem2, _Removed, Nl} -> + Err2 = {FN, L, "only '#if 0' is implemented at present"}, + {{'if', error}, Rem2, [Err2 | Err], War, Nl}; + {ok, Rem2, 0, _Removed, Nl} -> + {{'if', true}, Rem2, Err, War, Nl}; + {ok, Rem2, _Num, _Removed, Nl} -> + Err2 = {FN, L, "only '#if 0' is implemented at present"}, + {{'if', error}, Rem2, [Err2 | Err], War, Nl} + end; + + %%---------------------------------------- + %% #else + %%---------------------------------------- + "else" -> + {'else', read_to_nl(File)}; + + %%---------------------------------------- + %% #elif + %%---------------------------------------- + "elif" -> + {'elif', read_to_nl(File)}; + + %%---------------------------------------- + %% #pragma + %%---------------------------------------- + "pragma" -> + {Removed, Rem, Nl} = read_to_nl(File), + {pragma, Rem, Nl, lists:reverse("#pragma " ++ detokenise_pragma(Removed))}; + + %%---------------------------------------- + %% #ident + %%---------------------------------------- + "ident" -> + {Removed, Rem, Nl} = read_to_nl(File), + {ident, Rem, Nl, lists:reverse("#ident " ++ detokenise_pragma(Removed))}; + + %%---------------------------------------- + %% #warning + %%---------------------------------------- + "warning" -> + {warning, read_to_nl(File)}; + + %%---------------------------------------- + %% #error + %%---------------------------------------- + "error" -> + {error, read_to_nl(File)}; + + %%---------------------------------------- + %% #line + %%---------------------------------------- + "line" -> + line(File, L, FN); + + %%---------------------------------------- + %% # + %%---------------------------------------- + "null" -> + hash_mark; + + %%---------------------------------------- + %% not recognised preprocessor commands + %%---------------------------------------- + _Else -> + {not_recognised, read_to_nl(File)} + end. + + + + +%%=============================================================== +%%=============================================================== +%%=============================================================== +%% if +%% +%% Only #if 0 is implemented at the time to be able to use if +%% to comment some code parts. +%%=============================================================== +%%=============================================================== +%%=============================================================== + +if_zero(File, _Err, _War, _L, _FN) -> + case if_zero(File) of + {ok, Remain, Num, Removed, Nl} -> + case catch list_to_integer(Num) of + {'EXIT', _} -> + {Removed2, Rem2, Nl2} = read_to_nl(File), + {error, Rem2, Removed2, Nl2}; + Int -> + {ok, Remain, Int, Removed, Nl} + end; + E -> + E + end. + +if_zero([{number,Num}]) -> + {ok, [], Num, [], 0}; +if_zero([{number,Num}, space]) -> + {ok, [], Num, [], 0}; +if_zero([{number,Num} | Rem]) -> + {Removed, Rem2, Nl} = read_to_nl(Rem), + {ok, Rem2, Num, Removed, Nl}; +%if_zero([{number,Num}, {nl,_X} | Rem]) -> +% {ok, Rem, Num, [], 1}; +if_zero(Rem) -> + {Removed, Rem2, Nl} = read_to_nl(Rem), + {error, Rem2, Removed, Nl}. + + + +%%=============================================================== +%%=============================================================== +%%=============================================================== +%% Define macro +%% +%% Check the syntax of the macro, extract the parameters if any. +%% If valid macro it is added to the Defs-list. +%% If a macro is redefined, a warning will be given, the latest +%% definition is always the valid one. +%%=============================================================== +%%=============================================================== +%%=============================================================== + +define(File, Err, War, L, FN) -> + case define_name(File) of + {ok, Rem, Name, No_of_para, Parameters, Macro, Nl} -> + {ok, Rem, Name, No_of_para, Parameters, Macro, Err, War, Nl}; + {{warning,no_space}, Rem, Name, No_of_para, Parameters, Macro, Nl} -> + Text = lists:flatten(io_lib:format("missing white space after `#define ~s'",[Name])), + {warning, Rem, Name, No_of_para, Parameters, Macro, Err, [{FN, L, Text}|War], Nl}; + {error, invalid_name, Nl} -> + Text = "invalid macro name", + {_Removed, Rem, Nl2} = read_to_nl(File), + {error, Rem, [{FN, L, Text}|Err], War, Nl+Nl2}; + {error, invalid_name, Name, Nl} -> + Text = lists:flatten(io_lib:format("invalid macro name `~s'",[Name])), + {_Removed, Rem, Nl2} = read_to_nl(File), + {error, Rem, [{FN, L, Text}|Err], War, Nl+Nl2}; + {error, illegal_arg} -> + {Removed, Rem, Nl} = read_to_nl(File), + RemovedS = detokenise(Removed), + Text = lists:flatten(io_lib:format("Invalid argument list ~s",[RemovedS])), + {error, Rem, [{FN, L, Text}|Err], War, Nl} + end. + + + +%%=========================================================== +%% Check if valid macro +%%=========================================================== +define_name([]) -> + {warning, no_macro}; +define_name([space]) -> + {warning, no_macro}; +%% Macro with parameters +define_name([{var,Name},{char,$(}|Rem]) -> + case read_para([{char,$(}|Rem]) of + {ok, Rem2, Para, NoOfPara} -> + {Removed, Rem3, _Nl} = read_to_nl(Rem2), + {ok, Rem3, Name, NoOfPara, Para, Removed, 1}; + Error -> + Error + end; +%% Macro without parameters +define_name([{var,Name}]) -> + {ok, [], Name, 0, [], [], 0}; +define_name([{var,Name}, space | Rem]) -> + {Removed, Rem2, Nl} = read_to_nl(Rem), + {ok, Rem2, Name, 0, [], Removed, Nl}; +define_name([{var,Name}, {nl,_X} | Rem]) -> + {ok, Rem, Name, 0, [], [], 1}; +define_name([{var,Name} | Rem]) -> + {Removed, Rem2, Nl} = read_to_nl(Rem), + {{warning,no_space}, Rem2, Name, 0, [], Removed, Nl}; +%% Invalid macro name +define_name([{number, Name} | _Rem]) -> + {error, invalid_name, Name, 0}; +define_name(_Rem) -> + {error, invalid_name, 0}. + + + + + + + +%%=============================================================== +%%=============================================================== +%%=============================================================== +%% Undefine macro +%% +%% If it is a valid undef command the macro name will be deleted +%% from the Defs-list +%%=============================================================== +%%=============================================================== +%%=============================================================== + +undef(File, Err, War, L, FN) -> + case undef(File) of + {ok, Rem, Name, Nl} -> + {ok, Rem, Name, Err, War, Nl}; + {warning, Rem, Name, Nl} -> + Text = "ignoring the tail of the line", + {ok, Rem, Name, Err, [{FN, L, Text}|War], Nl}; + {error, invalid_name} -> + Text = "invalid macro name", + {_Removed, Rem, Nl} = read_to_nl(File), + {error, Rem, [{FN, L, Text}|Err], War, Nl}; + {error, invalid_name, Name} -> + Text = lists:flatten(io_lib:format("invalid macro name `~s'",[Name])), + {_Removed, Rem, Nl} = read_to_nl(File), + {error, Rem, [{FN, L, Text}|Err], War, Nl} + end. + +%%------------------------------------------------- +%% Check if valid macro name +%%------------------------------------------------- +undef([]) -> + {error, invalid_name, []}; +%% Valid name +undef([{var,Name}]) -> + {ok, [], Name, 0}; +undef([{var,Name}, {nl,_X} | Rem]) -> + {ok, Rem, Name, 1}; +undef([{var,Name}, space, {nl,_X} | Rem]) -> + {ok, Rem, Name, 1}; +undef([{var,Name} | Rem]) -> + {_Removed, Rem2, Nl} = read_to_nl(Rem), + {warning, Rem2, Name, Nl}; +%% Invalid macro name +undef([{number, Name} | _Rem]) -> + {error, invalid_name, Name}; +undef(_Rem) -> + {error, invalid_name}. + + + + + + +%%=============================================================== +%%=============================================================== +%%=============================================================== +%% Include macro +%% +%% Read the included file +%%=============================================================== +%%=============================================================== +%%=============================================================== + +include(File, IncDir) -> + case include2(File) of + {ok, FileName, Rem, Nl, FileType} -> + %% The error handling is lite strange just to make it compatible to gcc + case {read_inc_file(FileName, IncDir), Nl, FileType} of + {{ok, FileList, FileNamePath}, _, _} -> + {ok, FileNamePath, FileList, Rem, Nl}; + {{error, Text}, _, own_file} -> + NameNl = count_nl(FileName,0), + Error = lists:flatten(io_lib:format("~s: ~s",[FileName,Text])), + {error, Rem, Nl, Error, NameNl}; + {{error, Text}, 1, sys_file} -> + NameNl = count_nl(FileName,0), + Error = lists:flatten(io_lib:format("~s: ~s",[FileName,Text])), + {error, Rem, Nl, Error, NameNl}; + {{error, _Text}, _, sys_file} -> + {error, Rem, Nl, "`#include' expects \"FILENAME\" or "} + end; + + {error, {_Removed, Rem, Nl}} -> + {error, Rem, Nl, "`#include' expects \"FILENAME\" or "} + end. + +count_nl([],Nl) -> + Nl; +count_nl([$\n|T],Nl) -> + count_nl(T,Nl+1); +count_nl([_H|T],Nl) -> + count_nl(T,Nl). + +%%================================================= +%% Extract the file name from the token list +%%================================================= +include2([space|Rem]) -> + include2(Rem); + +include2([{string, FileName}]) -> + {ok, FileName, [], 1, own_file}; +include2([{string, FileName}, space]) -> + {ok, FileName, [], 1, own_file}; +include2([{string, FileName}, {nl, _X} | Rem]) -> + {ok, FileName, Rem, 1, own_file}; +include2([{string, FileName}, space, {nl, _X} | Rem]) -> + {ok, FileName, Rem, 1, own_file}; +include2([{string, _FileName}, _No_nl | Rem]) -> + {error, read_to_nl(Rem)}; +include2([{string_part, File_part}, {nl, _X} | Rem]) -> + case include_read_string_file_name(File_part++[$\n], Rem, 1) of + {ok, FileName, Rem2, Nl} -> + {ok, FileName, Rem2, Nl, own_file}; + error -> + {error, read_to_nl([{string_part,File_part} | Rem])} + end; +include2([{sys_head, FileName}]) -> + {ok, FileName, [], 1, sys_file}; +include2([{sys_head, FileName}, space]) -> + {ok, FileName, [], 1, sys_file}; +include2([{sys_head, FileName}, {nl, _X} | Rem]) -> + {ok, FileName, Rem, 1, sys_file}; +include2([{sys_head, FileName}, space, {nl, _X} | Rem]) -> + {ok, FileName, Rem, 1, sys_file}; +include2([{sys_head, _FileName}, _No_nl | Rem]) -> + {error, read_to_nl(Rem)}; +include2([{sys_head_part ,File_part}, {nl, _X} | Rem]) -> + case include_read_sys_file_name(File_part++[$\n], Rem, 1) of + {ok, FileName, Rem2, Nl} -> + {ok, FileName, Rem2, Nl, sys_file}; + error -> + {error, read_to_nl([{sys_head_part, File_part} | Rem])} + end; +include2(Rem) -> + {error, read_to_nl(Rem)}. + + + +%%------------------------------------------------- +%% File name framed by " " +%%------------------------------------------------- +include_read_string_file_name(File, [{string, File_part}, {nl,_X} | Rem], Nl) -> + {ok, File++File_part, Rem, Nl+1}; +include_read_string_file_name(File, [{string_part, File_part}, {nl,_X} | Rem], Nl) -> + include_read_string_file_name(File++File_part++[$\n], Rem, Nl+1); +include_read_string_file_name(_File, _X, _Nl) -> + error. + +%%------------------------------------------------- +%% File name framed by < > +%%------------------------------------------------- +include_read_sys_file_name(File, [{sys_head, File_part}, {nl,_X} | Rem], Nl) -> + {ok, File++File_part, Rem, Nl+1}; +include_read_sys_file_name(File, [{sys_head_part, File_part}, {nl,_X} | Rem], Nl) -> + include_read_sys_file_name(File++File_part++[$\n], Rem, Nl+1); +include_read_sys_file_name(_File, _X, _Nl) -> + error. + + + + + + + +%%=============================================================== +%%=============================================================== +%%=============================================================== +%% Line macro +%% +%% The line macro may redefine both the current line number and +%% the current file name: #line ' new_line_nr' 'new_file_name' +%%=============================================================== +%%=============================================================== +%%=============================================================== + +line(File, L, FN) -> + line(File, L, FN, not_defined, not_defined). + + + +line([], L, FN, _Line, _File) -> + {{line, error}, {[],[],0}, {FN,L,"invalid format `#line' directive"}}; + +line([space|Rem], L, FN, Line, File) -> + line(Rem, L, FN, Line, File); + +%%------------------------------ +%% Line number expected +%%------------------------------ +line([{number,Number}|Rem], L, FN, not_defined, File) -> + case catch list_to_integer(Number) of + {'EXIT', _} -> + {{line, error}, read_to_nl(Rem), {FN,L,"invalid format `#line' directive"}}; + Int -> + line(Rem, L, FN, Int, File) + end; +line(Rem, L, FN, not_defined, _File) -> + {{line, error}, read_to_nl(Rem), {FN,L,"invalid format `#line' directive"}}; + +%%------------------------------ +%% File name or newline expected +%%------------------------------ +line([{nl, _NL}|Rem], _L, FN, Line, not_defined) -> + {{line, ok}, {[],Rem,1}, Line, FN, io_lib:format("~n~p ~p #",[FN, Line-1])}; +line([{string,NewFN}|Rem], _L, _FN, Line, not_defined) -> + {{line, ok}, read_to_nl(Rem), Line, NewFN, io_lib:format("~n~p ~p #",[NewFN, Line-1])}; +line(Rem, L, FN, _Line, _File) -> + {{line, error}, read_to_nl(Rem), {FN,L,"invalid format `#line' directive"}}. + + + + +%%====================================================================================== +%%====================================================================================== +%%====================================================================================== +%% Source line +%% +%% +%% Output: {Str, Err, War, Rem, SelfRef} +%% +%% Description: The input source line is searched for macros. If a macro is found it +%% is expanded. The result of an expansion is rescanned for more macros. +%% To prevent infinite loops if the macro is self referring +%% an extra token is put into the Rem list. The variable SelfRef +%% contains all the macros which are inhibited to be expanded. +%% A special specae token is also inserted to prevent not wanted +%% concatinations if one of the variables to be concatinated is expanded. +%%====================================================================================== +%%====================================================================================== +%%====================================================================================== + +source_line(Str, Rem, SelfRef, Defs, Err, War, L, FN) -> + {Rem2, Para, No_of_para} = case read_para(Rem) of + {ok, RemT, ParaT, No_of_paraT} -> + {RemT, ParaT, No_of_paraT}; + {error, illegal_arg} -> + {[], [], 0} + end, + + + %%------------------------------------------------- + %% Check if a valid macro + %%------------------------------------------------- + case lists:keysearch(Str, 1, Defs) of + %% a macro without parameters + {value, {Str, 0, _MacroPara, Macro}} -> + case lists:member(Str, SelfRef) of + true -> + {[Str], Err, War, Rem, SelfRef}; + false -> + ExpandedRes2 = sl_mark_expanded(Macro, Str), + {[], Err, War, ExpandedRes2 ++ [{self_ref,Str}|Rem], [Str|SelfRef]} + end; + + %% a macro with parameters + {value, {Str, N, _MacroPara, Macro}} when N == No_of_para -> + case lists:member(Str, SelfRef) of + true -> + {[Str], Err, War, Rem, SelfRef}; + false -> + ExpandedRes = sl_macro_expand(Macro, Para, Defs), + ExpandedRes2 = sl_mark_expanded(ExpandedRes, Str), + {[], Err, War, ExpandedRes2 ++ [{self_ref,Str}|Rem2], [Str|SelfRef]} + end; + + %% a variable, because it doesn't have any parameters + {value, {Str, _N, _MacroPara, _Macro}} when No_of_para == 0 -> + {Str, Err, War, Rem, SelfRef}; + + %% illegal no of parameters + {value, {Str, N, _MacroPara, _Macro}} when No_of_para < N -> + Text = io_lib:format(" macro `~s' used with just ~p arg",[Str,No_of_para]), + Err2 = {FN, L, lists:flatten(Text)}, + {Str, [Err2|Err], War, Rem, SelfRef}; + {value, {Str, _N, _MacroPara, _Macro}} -> + Text = io_lib:format(" macro `~s' used with too many (~p) args",[Str,No_of_para]), + Err2 = {FN, L, lists:flatten(Text)}, + {Str, [Err2|Err], War, Rem, SelfRef}; + + %% no macro + false -> + {Str, Err, War, Rem, SelfRef} + end. + + + + + +%%================================================= +%% Expand a macro +%%================================================= +sl_macro_expand(Macro, Para, Defs) -> + sl_macro_expand(Macro, Para, Defs, []). + + +%%................... +%% End +%%................... +sl_macro_expand([], _Para, _Defs, Res) -> + lists:reverse(Res); + +%%................... +%% Concatination +%%................... +%% para ## para +sl_macro_expand([{para, N}, space, {char,$#}, {char,$#}, space, {para,M} | T], Para, Defs, Res) -> + Exp = sl_para_para({para, N},{para, M}, Para), + sl_macro_expand(Exp++T, Para, Defs, [space |Res]); +%% para## para +sl_macro_expand([{para, N}, {char,$#}, {char,$#}, space, {para,M} | T], Para, Defs, Res) -> + Exp = sl_para_para({para, N},{para, M}, Para), + sl_macro_expand(Exp++T, Para, Defs, [space |Res]); +%% para ##para +sl_macro_expand([{para, N}, space, {char,$#}, {char,$#}, {para,M} | T], Para, Defs, Res) -> + Exp = sl_para_para({para, N},{para, M}, Para), + sl_macro_expand(Exp++T, Para, Defs, [space |Res]); +%% para##para +sl_macro_expand([{para, N}, {char,$#}, {char,$#}, {para,M} | T], Para, Defs, Res) -> + Exp = sl_para_para({para, N},{para, M}, Para), + sl_macro_expand(Exp++T, Para, Defs, [space |Res]); + +%% para ## var +sl_macro_expand([{para, N}, space, {char,$#}, {char,$#}, space, {var, Var}|T], Para, Defs, Res) -> + Exp = sl_para_var({para, N}, {var, Var}, Para), + sl_macro_expand(Exp++T, Para, Defs, [space |Res]); +%% para## var +sl_macro_expand([{para, N}, {char,$#}, {char,$#}, space, {var, Var} | T], Para, Defs, Res) -> + [{var, VarN}] = lists:nth(N,Para), + sl_macro_expand(T, Para, Defs, [{expanded,Var},{expanded,VarN}, space |Res]); +%% para ##var +sl_macro_expand([{para, N}, space, {char,$#}, {char,$#}, {var, Var} | T], Para, Defs, Res) -> + [{var, VarN}] = lists:nth(N,Para), + sl_macro_expand(T, Para, Defs, [{expanded,Var},{expanded,VarN}, space |Res]); +%% para##var +sl_macro_expand([{para, N}, {char,$#}, {char,$#}, {var, Var} | T], Para, Defs, Res) -> + [{var, VarN}] = lists:nth(N,Para), + sl_macro_expand(T, Para, Defs, [{expanded,Var},{expanded,VarN}, space |Res]); + +%% var ## para +sl_macro_expand([{var, Var}, space, {char,$#}, {char,$#}, space, {para,M} | T], Para, Defs, Res) -> + Exp = sl_var_para({var, Var},{para, M}, Para), + sl_macro_expand(Exp++T, Para, Defs, [space |Res]); +%% var## para +sl_macro_expand([{var, Var}, {char,$#}, {char,$#}, space, {para,M} | T], Para, Defs, Res) -> + Exp = sl_var_para({var, Var},{para, M}, Para), + sl_macro_expand(Exp++T, Para, Defs, [space |Res]); +%% var ##para +sl_macro_expand([{var, Var}, space, {char,$#}, {char,$#}, {para,M} | T], Para, Defs, Res) -> + Exp = sl_var_para({var, Var},{para, M}, Para), + sl_macro_expand(Exp++T, Para, Defs, [space |Res]); +%% var##para +sl_macro_expand([{var, Var}, {char,$#}, {char,$#}, {para,M} | T], Para, Defs, Res) -> + Exp = sl_var_para({var, Var},{para, M}, Para), + sl_macro_expand(Exp++T, Para, Defs, [space |Res]); + +%% expanded ## para +sl_macro_expand([space, {char,$#}, {char,$#}, space, {para,M} | T], Para, Defs, [{expanded, Var}|Res]) -> + [{var, VarM}] = lists:nth(M,Para), + sl_macro_expand(T, Para, Defs, [{expanded,VarM},{expanded,Var} |Res]); +%% expanded## para +sl_macro_expand([{char,$#}, {char,$#}, space, {para,M} | T], Para, Defs, [{expanded, Var}|Res]) -> + [{var, VarM}] = lists:nth(M,Para), + sl_macro_expand(T, Para, Defs, [{expanded,VarM},{expanded,Var} |Res]); +%% expanded ##para +sl_macro_expand([space, {char,$#}, {char,$#}, {para,M} | T], Para, Defs, [{expanded, Var}|Res]) -> + [{var, VarM}] = lists:nth(M,Para), + sl_macro_expand(T, Para, Defs, [{expanded,VarM},{expanded,Var} |Res]); +%% expanded##para +sl_macro_expand([{char,$#}, {char,$#}, {para,M} | T], Para, Defs, [{expanded, Var}|Res]) -> + [{var, VarM}] = lists:nth(M,Para), + sl_macro_expand(T, Para, Defs, [{expanded,VarM},{expanded,Var} |Res]); + +%% para ## ? +sl_macro_expand([{para, N}, space, {char,$#}, {char,$#}, space, X | T], Para, Defs, Res) -> + Reexp = sl_macro_reexpand(lists:nth(N,Para), Defs, []), + sl_macro_expand([X, space|T], Para, Defs, lists:flatten([Reexp, space|Res])); +%% para## ? +sl_macro_expand([{para, N}, {char,$#}, {char,$#}, space, X | T], Para, Defs, Res) -> + Reexp = sl_macro_reexpand(lists:nth(N,Para), Defs, []), + sl_macro_expand([X, space|T], Para, Defs, lists:flatten([Reexp, space|Res])); +%% para ##? +sl_macro_expand([{para, N}, space, {char,$#}, {char,$#}, X | T], Para, Defs, Res) -> + Reexp = sl_macro_reexpand(lists:nth(N,Para), Defs, []), + sl_macro_expand([X, space|T], Para, Defs, lists:flatten([Reexp, space|Res])); +%% para##? +sl_macro_expand([{para, N}, {char,$#}, {char,$#}, X | T], Para, Defs, Res) -> + Reexp = sl_macro_reexpand(lists:nth(N,Para), Defs, []), + sl_macro_expand([X, space|T], Para, Defs, lists:flatten([Reexp, space|Res])); + +sl_macro_expand([{char,$#}, {char,$#}, space |T], Para, Defs, [space|Res]) -> + sl_macro_expand(T, Para, Defs, Res); +sl_macro_expand([{char,$#}, {char,$#} |T], Para, Defs, [space|Res]) -> + sl_macro_expand(T, Para, Defs, Res); +sl_macro_expand([{char,$#}, {char,$#}, space |T], Para, Defs, Res) -> + sl_macro_expand(T, Para, Defs, Res); +sl_macro_expand([{char,$#}, {char,$#} |T], Para, Defs, Res) -> + sl_macro_expand(T, Para, Defs, Res); + +%%................... +%% Stringification +%%................... +sl_macro_expand([{char,$#}, {para, N}|T], Para, Defs, Res) -> + Nth = lists:nth(N,Para), + Tokens = detokenise(Nth), + sl_macro_expand(T, Para, Defs, [{string,Tokens}|Res]); +sl_macro_expand([{char,$#}, space, {para, N}|T], Para, Defs, Res) -> + Nth = lists:nth(N,Para), + Tokens = detokenise(Nth), + sl_macro_expand(T, Para, Defs, [{string,Tokens}|Res]); + +%%................... +%% A parameter +%%................... +sl_macro_expand([{para, N}|T], Para, Defs, Res) -> + Reexp = sl_macro_reexpand(lists:nth(N,Para), Defs, []), + sl_macro_expand(T, Para, Defs, lists:flatten([Reexp|Res])); + +%%................... +%% No parameter +%%................... +sl_macro_expand([H|T], Para, Defs, Res) -> + sl_macro_expand(T, Para, Defs, [H|Res]). + + + +%%------------------------------------------------- +%% Expand parameters +%%------------------------------------------------- +sl_para_para({para, N}, {para, M}, Para) -> + case sl_para_1st(lists:nth(N,Para)) of + {ok, Para1st} -> + Para1st ++ sl_para_2nd(lists:nth(M,Para)); + {exp, Para1st} -> + Para1st ++ sl_para_2nd(lists:nth(M,Para)) ++ [space_exp]; + {space, Para1st} -> + Para1st ++ [space_exp | sl_para_2nd(lists:nth(M,Para))] + end. + + +sl_var_para(Var, {para, M}, Para) -> + [Var|sl_para_2nd(lists:nth(M,Para))]. + + +sl_para_var({para, N}, Var, Para) -> + case sl_para_1st(lists:nth(N,Para)) of + {ok, Para1st} -> + Para1st ++ [Var]; + {exp, Para1st} -> + Para1st ++ [Var | space_exp]; + {space, Para1st} -> + Para1st ++ [space_exp | Var] + end. + + +sl_para_1st([{var, Var}]) -> + {ok,[{expanded,Var}]}; +sl_para_1st([{var, Var}, space]) -> + {ok,[{expanded,Var}]}; +sl_para_1st([{var, Var}, space_exp]) -> + {exp, [{expanded,Var}]}; +sl_para_1st(L) -> + {space, L}. + +sl_para_2nd([{var, Var}]) -> + [{expanded,Var}]; +sl_para_2nd([{var, Var}, space_exp]) -> + [{expanded,Var}]; +sl_para_2nd([space, {var, Var}]) -> + [{expanded,Var}]; +sl_para_2nd([space_exp, {var, Var}]) -> + [{expanded,Var}]; +sl_para_2nd(L) -> + L++[space]. + + + +%%------------------------------------------------- +%% Check if the expansion is a valid macro, +%% do not reexpand if concatination +%%------------------------------------------------- +sl_macro_reexpand([], _Defs, Result) -> + Result; +sl_macro_reexpand([{var,Var}|Rem], Defs, Result) -> + case lists:keysearch(Var, 1, Defs) of + {value, {Var, 0, _MacroPara, Macro}} -> + Rem2 = case Rem of + [space | RemT] -> + [space_exp | RemT]; + _ -> + [space_exp | Rem] + end, + sl_macro_reexpand(Macro++Rem2, Defs, Result); + _ -> + sl_macro_reexpand(Rem, Defs, [{var,Var}|Result]) + end; +sl_macro_reexpand([H|Rem], Defs, Result) -> + sl_macro_reexpand(Rem, Defs, [H|Result]). + + + +%%------------------------------------------------- +%% Self referring macros are marked not be reexpanded +%%------------------------------------------------- +sl_mark_expanded(QQ, Str) -> + sl_mark_expanded(QQ, Str, []). + +sl_mark_expanded([], _Str, Res) -> + lists:reverse(Res); +sl_mark_expanded([H|T], Str, Res) -> + case H of + {_,Str} -> + sl_mark_expanded(T, Str, [{expanded, Str}|Res]); + _ -> + sl_mark_expanded(T, Str, [H|Res]) + end. + + + + + + + + + +%%====================================================================================== +%%====================================================================================== +%%====================================================================================== +%% Misceleaneous functions +%%====================================================================================== +%%====================================================================================== +%%====================================================================================== + + +%%=============================================================== +%% Check the Flags for include directories +%%=============================================================== +include_dir(Flags) when is_list(Flags)-> + include_dir(Flags,[]); +include_dir(_Flags) -> + []. + +include_dir(Flags,IncDir) -> + case string:str(Flags,"-I") of + 0 -> + lists:reverse(IncDir); + X -> + Rem2 = string:sub_string(Flags, X+2), + Rem = string:strip(Rem2, left), + Y = string:str(Rem," "), + case string:str(Rem," ") of + 0 -> + lists:reverse([string:sub_string(Rem, Y+1)|IncDir]); + Y -> + include_dir(string:sub_string(Rem, Y+1), + [string:sub_string(Rem,1,Y-1)|IncDir]) + end + end. + + + +%%=============================================================== +%% Read a included file. Try current dir first then the IncDir list +%%=============================================================== + +read_inc_file(FileName, IncDir) -> + case catch file:read_file(FileName) of + {ok, Bin} -> + FileList = binary_to_list(Bin), + {ok, FileList, FileName}; + {error, _} -> + read_inc_file2(FileName, IncDir) + end. + +read_inc_file2(_FileName, []) -> + {error, "No such file or directory"}; +read_inc_file2(FileName, [D|Rem]) -> + Dir = case lists:last(D) of + $/ -> + D; + _ -> + D++"/" + end, + + case catch file:read_file(Dir++FileName) of + {ok, Bin} -> + FileList = binary_to_list(Bin), + {ok, FileList, Dir++FileName}; + {error, _} -> + read_inc_file2(FileName, Rem) + end. + + + + +%%=============================================================== +%% Read parameters of a macro or a variable in a source line +%%=============================================================== +read_para([{char,$(} | Rem]) -> + read_para(Rem, 1, [], [], 1); +read_para([space,{char,$(} | Rem]) -> + read_para(Rem, 1, [], [], 1); +read_para(_Rem) -> + {ok, [], [], 0}. + + +%% Abrupt end of the list +read_para([], _NoOfParen, _Current, _Para, _NoOfPara) -> + {error, illegal_arg}; +%% All parameters checked +read_para([{char,$)}|Rem], 1, [], Para, NoOfPara) -> + {ok, Rem, lists:reverse(Para), NoOfPara}; +read_para([{char,$)}|Rem], 1, Current, Para, NoOfPara) -> + {ok, Rem, lists:reverse([Current|Para]), NoOfPara}; + +%% Continue reading +read_para([{char,$)}|Rem], NoOfParen, Current, Para, NoOfPara) -> + read_para(Rem, NoOfParen-1, Current++[{char,$)}], Para, NoOfPara); +read_para([{char,$(}|Rem], NoOfParen, Current, Para, NoOfPara) -> + read_para(Rem, NoOfParen+1, Current++[{char,$(}], Para, NoOfPara); +read_para([{char,$,}|Rem], NoOfParen, Current, Para, NoOfPara) when NoOfParen == 1 -> + read_para(Rem, NoOfParen, [], [Current|Para], NoOfPara+1); +read_para([space|Rem], NoOfParen, [], Para, NoOfPara) -> + read_para(Rem, NoOfParen, [], Para, NoOfPara); +read_para([X|Rem], NoOfParen, Current, Para, NoOfPara) -> + read_para(Rem, NoOfParen, Current++[X], Para, NoOfPara). + + + + + + +%%=================================================================================== +%% check if a macro is already defined +%%=================================================================================== +is_define_ok(Name, No_of_para, Parameters, Macro, Defs) -> + + case lists:keysearch(Name, 1, Defs) of + {value, {Name, No_of_para, _MacroPara, Macro}} -> + {yes, Defs}; + {value, _} -> + Defs2 = lists:keydelete(Name, 1, Defs), + NewMacro = is_define_ok_check_para(Parameters, Macro, []), + case is_stringify_ok(NewMacro) of + yes -> + {no, [{Name, No_of_para, Parameters, NewMacro}|Defs2]}; + no -> + ErrorText = "`#' operator is not followed by a macro argument name", + {error, ErrorText, [{Name, No_of_para, Parameters, NewMacro}|Defs2]} + end; + false -> + NewMacro = is_define_ok_check_para(Parameters, Macro, []), + case is_stringify_ok(NewMacro) of + yes -> + {yes, [{Name, No_of_para, Parameters, NewMacro}|Defs]}; + no -> + ErrorText = "`#' operator is not followed by a macro argument name", + {error, ErrorText, [{Name, No_of_para, Parameters, NewMacro}|Defs]} + end + end. + +is_define_ok_check_para(_Para, [], Result) -> + lists:reverse(Result); + +is_define_ok_check_para(Para, [H|T], Result) -> + case define_arg_para_number(1, Para, H) of + no_para -> + is_define_ok_check_para(Para, T, [H|Result]); + N -> + is_define_ok_check_para(Para, T, [{para,N}|Result]) + end. + +define_arg_para_number(_N, [], _Current) -> + no_para; +define_arg_para_number(N, [H|_Para], Current) when H == [Current] -> + N; +define_arg_para_number(N, [_H|Para], Current) -> + define_arg_para_number(N+1, Para, Current). + + +is_stringify_ok([]) -> + yes; +is_stringify_ok([{char,$#},{char,$#}|T]) -> + is_stringify_ok(T); +is_stringify_ok([{char,$#},space,{para,_X}|T]) -> + is_stringify_ok(T); +is_stringify_ok([{char,$#},{para,_X}|T]) -> + is_stringify_ok(T); +is_stringify_ok([{char,$#},space,{var,_X}|T]) -> + is_stringify_ok(T); +is_stringify_ok([{char,$#},{var,_X}|T]) -> + is_stringify_ok(T); +is_stringify_ok([{char,$#},space,{nl,_X}|_T]) -> + no; +is_stringify_ok([{char,$#},{nl,_X}|_T]) -> + no; +is_stringify_ok([{char,$#}|_T]) -> + no; +is_stringify_ok([_H|T]) -> + is_stringify_ok(T). + +%%=================================================================================== +%% check if a macro is already defined +%%=================================================================================== +is_defined_before(Name, No_of_para, Defs) -> + case lists:keysearch(Name, 1, Defs) of + {value, {Name, No_of_para, _MacroPara, _Macro}} -> + yes; + {value, _} -> + no; + false -> + no + end. + + + + +%%=================================================================================== +%% read_to_nl(File) +%%=================================================================================== +read_to_nl([space|Rem]) -> + read_to_nl(Rem, [], 1); +read_to_nl(Rem) -> + read_to_nl(Rem, [], 1). + +read_to_nl([], Result, Nl) -> + {lists:reverse(Result), [], Nl}; +read_to_nl([{nl, _N}|Rem], [{string_part,String} | Result], Nl) -> + read_to_nl(Rem, [nl, {string_part,String}|Result], Nl+1); +read_to_nl([{nl, _N}|Rem], [{sys_head_part,String} | Result], Nl) -> + read_to_nl(Rem, [nl, {sys_head_part,String}|Result], Nl+1); +read_to_nl([{nl, _N}|Rem], Result, Nl) -> + {lists:reverse(Result), Rem, Nl}; +read_to_nl([space|Rem], Result, Nl) -> + read_to_nl(Rem, [space|Result], Nl); +read_to_nl([{X,String}|Rem], Result, Nl) -> + read_to_nl(Rem, [{X,String}|Result], Nl). + + + + +%%=========================================================== +%% Read characters until next newline +%%=========================================================== +%read_to_nl2(Str) -> read_to_nl2([],Str). + +%read_to_nl2(Line, []) -> {Line,[]}; +%read_to_nl2(Line, [$\n|Str]) -> {Line, Str}; +%read_to_nl2(Line, [X|Str]) -> read_to_nl2([X|Line], Str). + + + + +%%=========================================================== +%% Remove leading spaces from a list +%%=========================================================== +remove_leading_spaces([?space|List]) -> + remove_leading_spaces(List); +remove_leading_spaces([?tab|List]) -> + remove_leading_spaces(List); +remove_leading_spaces(List) -> + List. + + + + +%%=========================================================== +%% Skip characters until next newline +%%=========================================================== +skip_to_nl([]) -> []; +skip_to_nl([$\n | Str]) -> Str; +skip_to_nl([$\\,$\n | Str]) -> [$/,$/|Str]; +skip_to_nl([_|Str]) -> skip_to_nl(Str). + + + + +month(1) -> "Jan"; +month(2) -> "Feb"; +month(3) -> "Mar"; +month(4) -> "Apr"; +month(5) -> "May"; +month(6) -> "Jun"; +month(7) -> "Jul"; +month(8) -> "Aug"; +month(9) -> "Sep"; +month(10) -> "Oct"; +month(11) -> "Nov"; +month(12) -> "Dec". + + + + diff --git a/lib/ic/src/ic_pragma.erl b/lib/ic/src/ic_pragma.erl new file mode 100644 index 0000000000..9165e3b03b --- /dev/null +++ b/lib/ic/src/ic_pragma.erl @@ -0,0 +1,1957 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1998-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_pragma). + + +-export([pragma_reg/2,pragma_cover/3]). +-export([pragma_prefix/3,pragma_version/3,pragma_id/3]). +-export([mk_alias/3,get_alias/2,scope2id/2,id2scope/2,mk_scope/1]). +-export([mk_ref/3,get_incl_refs/1,get_local_refs/1]). +-export([get_dependencies/1, add_inh_data/3, preproc/3]). +-export([getBrokerData/3,defaultBrokerData/1,list_to_term/1]). +-export([get_local_c_headers/2,get_included_c_headers/1,is_inherited_by/3]). +-export([no_doubles/1,fetchRandomLocalType/1,fetchLocalOperationNames/2]). +-export([is_local/2]). + +%% Debug +-export([print_tab/1,slashify/1,is_short/1]). + +-import(lists,[suffix/2,delete/2,reverse/1,keysearch/3,member/2,last/1,flatten/1]). +-import(string,[tokens/2]). +-import(ets,[insert/2,lookup/2]). + +-import(ic_forms, [get_id2/1, get_body/1, get_line/1]). +-import(ic_util, [to_atom/1]). +-import(ic_genobj, [idlfile/1]). +-import(ic_options, [get_opt/2]). + +-include("icforms.hrl"). +-include("ic.hrl"). + + + + +%% Initialization of the pragma table and +%% start of pragma registration. +%% NOTE : this pragma registration is build +%% as a separate stage under compilation. +%% If it is to be optimised, it should be +%% embodied in one of other compiling stages. +pragma_reg(G,X) -> + S = ic_genobj:pragmatab(G), + init_idlfile(G,S), + init_pragma_status(S), + registerOptions(G,S), + pragma_reg_all(G, S, [], X), + denote_specific_code_opts(G), %%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + case get_pragma_compilation_status(S) of + true -> + %% Remove ugly pragmas from form + PragmaCleanForm = cleanup(X), + {ok,PragmaCleanForm}; + false -> + ErrorNr = get_pragma_error_nr(S), + %% Just print the number of errors found + case ErrorNr > 1 of + true -> + io:format("There were ~p errors found on file ~p~n", + [ErrorNr,get_idlfile(S)]), + error; + false -> + io:format("There were ~p error found on file ~p~n", + [ErrorNr,get_idlfile(S)]), + error + end + end. + + + +registerOptions(G,S) -> + OptList = ets:tab2list(ic_genobj:optiontab(G)), + registerOptions(G,S,OptList). + + +registerOptions(_G,_S,[]) -> + true; +registerOptions(G,S,[{{option,{broker,Scope}},{Mod,Type}}|Rest]) -> + insert(S, + {codeopt, + reverse(tokens(Scope,":")), + {broker,{Mod,Type}}, + -1, + nil, + nil}), + registerOptions(G,S,Rest); +registerOptions(G,S,[_|Rest]) -> + registerOptions(G,S,Rest). + + +%% Decide if to apply pragmas +%% by checking backend switch +applyPragmasInBe(G) -> + case get_opt(G, be) of + erl_plain -> + false; + _ -> + true + end. + + +%% Decide if the code option directive +%% is allowed to change backend +applyCodeOpt(G) -> + case get_opt(G, be) of + erl_corba -> %% Does not support codeopt + false; + erl_plain -> %% Does not support codeopt + false; + c_native -> %% Does not support codeopt + false; + _ -> + true + end. + + + +%% This removes all pragma records from the form. +%% When debugged, it can be enbodied in pragma_reg_all. +cleanup([],C) -> C; +cleanup([X|Xs],CSF) -> + cleanup(Xs, CSF++cleanup(X)). + +cleanup(X) when is_list(X) -> cleanup(X,[]); +cleanup(X) when is_record(X, preproc) -> [X]; +cleanup(X) when is_record(X, pragma) -> []; +cleanup(X) when is_record(X, op) -> % Clean inside operation parameters + [ X#op{params = cleanup(X#op.params,[])}]; + +cleanup(X) when is_record(X, module) -> % Clean inside module body + [ X#module{body = cleanup(X#module.body,[])}]; + +cleanup(X) when is_record(X, interface) -> % Clean inside interface body + [ X#interface{body = cleanup(X#interface.body,[])}]; + +cleanup(X) when is_record(X, except) -> % Clean inside exception body + [ X#except{body = cleanup(X#except.body,[])}]; + +cleanup(X) when is_record(X, struct) -> % Clean inside struct body + [ X#struct{body = cleanup(X#struct.body,[])}]; + +cleanup(X) when is_record(X, case_dcl) -> % Clean inside union body + [ X#case_dcl{label = cleanup(X#case_dcl.label,[])}]; + +cleanup(X) when is_record(X, union) -> % Clean inside union body + [ X#union{body = cleanup(X#union.body,[])}]; + +cleanup(X) when is_record(X, enum) -> % Clean inside enum body + [ X#enum{body = cleanup(X#enum.body,[])}]; + +cleanup(X) -> [X]. + + + + +%% pragma_reg_all is top level registration for pragmas +pragma_reg_all(_G, _S, _N, []) -> ok; +pragma_reg_all(G, S, N, [X|Xs]) -> + pragma_reg(G, S, N, X), + pragma_reg_all(G, S, N, Xs). + + +%% pragma_reg is top level registration for pragmas +pragma_reg(G, S, N, X) when is_list(X) -> pragma_reg_list(G, S, N, X); +pragma_reg(_G, S, _N, X) when element(1, X) == preproc -> + case X#preproc.aux of + [{_, _, "1"}] -> + IncludeEntryLNr = get_line(X#preproc.id), + IncludeFileName = element(3,element(3,X)), + insert(S,{includes,get_idlfile(S),IncludeFileName,IncludeEntryLNr}); + _Other -> + ok + end, + set_idlfile(S,element(3,element(3,X))); +pragma_reg(G, S, N, X) when element(1, X) == pragma -> + case applyPragmasInBe(G) of + + %% Pragmas are allowed to be + %% applied in this this backend. + true -> + + File = get_idlfile(S), % The current file or an included one. + Type = case idlfile(G) of % Local/Included flag + File -> + local; + _ -> + included + end, + + %% Register pragmas into pragmatab. + case X of + {pragma,{_,LineNr,"prefix"}, _To, _Apply} -> + insert(S,{prefix,X,LineNr,N,File,Type}); + + {pragma,{_,_,"ID"},_,_} -> + pragma_reg_ID(G, S, N, X); + + {pragma,{_,_,"version"},_,_} -> + pragma_reg_version(G, S, N, X ); + + {pragma,{_,_,"CODEOPT"},_,_} -> + pragma_reg_codeOpt(G,S,N,X); + + {pragma,{_,LineNr,BadPragma}, _To, _Apply} -> + io:format("Warning : on file ~p :~n",[get_idlfile(S)]), + io:format(" Unknown pragma directive ~p on line ~p, ignored.~n", + [BadPragma,LineNr]) + end; + + %% Pragmas are not to be applied in + %% this backend, ignore all pragmas. + false -> + true + end, + ok; + +pragma_reg(G, S, N, X) when is_record(X, module) -> + mk_ref(G,[get_id2(X) | N],mod_ref), + mk_file_data(G,X,N,module), + pragma_reg_all(G, S, [get_id2(X) | N], get_body(X)); + +pragma_reg(G, S, N, X) when is_record(X, interface) -> + mk_ref(G,[get_id2(X) | N],ifc_ref), + mk_file_data(G,X,N,interface), + pragma_reg_all(G, S, [get_id2(X) | N], get_body(X)); + +pragma_reg(G, S, N, X) when is_record(X, op) -> + %% Add operation in table + insert(S,{op, + get_id2(X), + N, + get_idlfile(S), + get_filepath(S)}), + mk_file_data(G,X,N,op), + pragma_reg_all(G, S, N, X#op.params); + +pragma_reg(G, S, N, X) when is_record(X, except) -> + mk_ref(G,[get_id2(X) | N],except_ref), + mk_file_data(G,X,N,except), + pragma_reg_all(G, S, N, X#except.body); + +pragma_reg(G, _S, N, X) when is_record(X, const) -> + mk_ref(G,[get_id2(X) | N],const_ref), + mk_file_data(G,X,N,const); + +pragma_reg(G, _S, N, X) when is_record(X, typedef) -> + XX = #id_of{type=X}, + lists:foreach(fun(Id) -> + mk_ref(G,[get_id2(Id) | N],typedef_ref), + mk_file_data(G,XX#id_of{id=Id},N,typedef) + end, + ic_forms:get_idlist(X)); + +pragma_reg(G, S, N, X) when is_record(X, enum) -> + mk_ref(G,[get_id2(X) | N],enum_ref), + mk_file_data(G,X,N,enum), + pragma_reg_all(G, S, N, X#enum.body); + +pragma_reg(G, S, N, X) when is_record(X, union) -> + mk_ref(G,[get_id2(X) | N],union_ref), + mk_file_data(G,X,N,union), + pragma_reg_all(G, S, N, X#union.body); + +pragma_reg(G, S, N, X) when is_record(X, struct) -> + mk_ref(G,[get_id2(X) | N],struct_ref), + mk_file_data(G,X,N,struct), + pragma_reg_all(G, S, N, X#struct.body); + +pragma_reg(G, _S, N, X) when is_record(X, attr) -> + XX = #id_of{type=X}, + lists:foreach(fun(Id) -> + mk_ref(G,[get_id2(Id) | N],attr_ref), + mk_file_data(G,XX#id_of{id=Id},N,attr) + end, + ic_forms:get_idlist(X)); + +pragma_reg(_G, _S, _N, _X) -> ok. + + + + +pragma_reg_list(_G, _S, _N, []) -> ok; +pragma_reg_list(G, S, N, List ) -> + CurrentFileName = get_idlfile(S), + pragma_reg_list(G, S, N, CurrentFileName, List). + +pragma_reg_list(_G, _S, _N, _CFN, []) -> ok; +pragma_reg_list(G, S, N, CFN, [X | Xs]) -> + case X of + {preproc,_,{_,_,FileName},_} -> + set_idlfile(S,FileName), + pragma_reg(G, S, N, X), + pragma_reg_list(G, S, N, FileName, Xs); + _ -> + pragma_reg(G, S, N, X), + pragma_reg_list(G, S, N, CFN, Xs) + end. + + + + + +pragma_reg_ID(G, S, N, X) -> + {pragma,{_,LineNr,"ID"}, _To, Apply} = X, + + + File = get_idlfile(S), % The current file or an included one. + Type = case idlfile(G) of % Local/Included flag + File -> + local; + _ -> + included + end, + + %% Check if ID is one of the allowed types : + %% * OMG IDL + %% * DCE UUID + %% * LOCAL + case tokens(element(3,Apply),":") of + ["IDL",_,_] -> + insert(S,{id,X,LineNr,N,File,Type}); + ["DCE",_,VSN] -> + case is_short(VSN) of + true -> + insert(S,{id,X,LineNr,N,File,Type}); + false -> + set_compilation_failure(S), + io:format("Error on file ~p :~n",[get_idlfile(S)]), + io:format(" Bad pragma ID ~p on line ~p,~n", + [element(3,Apply),LineNr]), + io:format(" the version part of ID is not a short integer.~n") + end; + ["LOCAL"|_] -> + insert(S,{id,X,LineNr,N,File,Type}); + _ -> + set_compilation_failure(S), + io:format("Error on file ~p :~n",[get_idlfile(S)]), + io:format(" Bad pragma ID ~p on line ~p.~n", + [element(3,Apply),LineNr]) + end. + + + +pragma_reg_version(G, S, N, X) -> + {pragma,{_,LineNr,"version"}, _To, Apply} = X, + + File = get_idlfile(S), % The current file or an included one. + Type = case idlfile(G) of % Local/Included flag + File -> + local; + _ -> + included + end, + + case tokens(Apply,".") of + [Major,Minor] -> + case is_short(Major) and is_short(Minor) of + true -> + insert(S,{version,X,LineNr,N,File,Type}); + false -> + set_compilation_failure(S), + io:format("Error on file ~p :~n",[get_idlfile(S)]), + io:format(" Bad pragma version ~p on line ~p,~n", + [Apply,LineNr]), + io:format(" the version is not valid.~n") + end; + _ -> + set_compilation_failure(S), + io:format("Error on file ~p :~n",[get_idlfile(S)]), + io:format(" Bad pragma version ~p on line ~p,~n", + [Apply,LineNr]), + io:format(" the version is not valid.~n") + end. + + +pragma_reg_codeOpt(G, S, _N, {pragma,{_,LineNr,"CODEOPT"},_,Apply} )-> + case applyCodeOpt(G) of + true -> + {_,_,OptionList_str} = Apply, + case list_to_term(OptionList_str) of + error -> + ic_error:error(G,{pragma_code_opt_bad_option_list,LineNr}); + OptionList -> + case lists:keysearch(be,1,OptionList) of + false -> + %% Add the terms of the option list + %% to the compiler option list + applyCodeOpts(G,S,LineNr,OptionList); + {value, {be,Type}} -> + %% If backend is set from user, + %% let the same backend be otherwize + %% set backend by codeOpt directive + case get_opt(G, be) of + false -> + %% Add the terms of the option list + %% to the compiler option list + applyCodeOpts(G,S,LineNr,OptionList); + _ -> + %% Add all the terms of the option list + %% to the compiler option list but the + %% backend option + applyCodeOpts(G, + S, + LineNr, + lists:delete({be,Type},OptionList)) + end + end + end; + false -> + true + end. + + + +applyCodeOpts(_,_,_,[]) -> + true; +applyCodeOpts(G,S,LNr,[{{broker,Scope},{M,T}}|Xs]) -> + ScopedId = reverse(tokens(Scope,":")), + case ets:match(S, + {codeopt,ScopedId, + '$1','$2','_','_'}) of + [] -> + %% Add pragma in table + insert(S, + {codeopt, + ScopedId, + {broker,{M,T}}, + LNr, + get_idlfile(S), + get_filepath(S)}), + %% Continue + applyCodeOpts(G,S,LNr,Xs); + _ -> + %% Use the code option + %% from user and continue + applyCodeOpts(G,S,LNr,Xs) + end; +applyCodeOpts(G,S,LNr,[X|Xs]) -> + case is_allowed_opt(X) of + true -> + %% Add that term of the option list + %% to the compiler option list + ic_options:add_opt(G, [X], true), + %% Continue + applyCodeOpts(G,S,LNr,Xs); + false -> + %% Print warning and continue + io:format("Warning on file ~p :~n",[get_idlfile(S)]), + io:format(" Bad option in pragma : ~p, ignored !~n",[X]), + applyCodeOpts(G,S,LNr,Xs) + end. + + +is_allowed_opt({X,Y}) -> + ic_options:allowed_opt(X,Y); +is_allowed_opt(_X) -> + false. + + + +%% Returns a tuple { PFX, VSN, ID }, that is the +%% pragma prefix, version and id coverages of +%% the scope SCOPE. This is done by use of the +%% function pragma_cover/4. +pragma_cover(G,Scope,Object) -> + pragma_cover(ic_genobj:pragmatab(G),get_id2(Object),Scope,get_line(Object)). + +%% Returns a tuple { PFX, VSN, ID }, that is the +%% pragma prefix, version and id coverages of +%% the scope SCOPE +pragma_cover(PragmaTab,Name,Scope,LineNr) -> + PFX = pragma_prefix_cover(PragmaTab,Name,Scope,LineNr), + VSN = pragma_version_cover(PragmaTab,Name,Scope,LineNr), + ID = pragma_id_cover(PragmaTab,Name,Scope,LineNr), + { PFX, VSN, ID }. + + + +%% Finds out which pragma PREFIX that affects +%% the scope Scope +pragma_prefix(G,Scope,Object) -> + pragma_prefix_cover(ic_genobj:pragmatab(G),get_id2(Object),Scope,get_line(Object)). + + +%% Finds out which pragma PREFIX that affects +%% the scope Scope +pragma_prefix_cover(PragmaTab,Name,Scope,LineNr) -> + case lookup(PragmaTab,prefix) of + [] -> + none; + PragmaPrefixList -> + FilteredPragmaPrefixList = + filter_pragma_prefix_list(PragmaTab,Name,Scope,PragmaPrefixList), + case most_local(FilteredPragmaPrefixList,Scope) of + [] -> + none; + MostLocalList -> + case dominant_prefix(MostLocalList,LineNr) of + none -> + none; + + %% Just filter empty pragma prefix + {prefix,{pragma,{_,_,_},_,{'',_,[]}},_,_,_,_} -> + none; + + DP -> + %% Return the scoped id (reversed list of + %% path elements, but remember to remove + %% '[]' that represents the top level + slashify(lists:sublist(Scope, 1, + length(Scope) - length(element(4,DP))) ++ + [ element(3,element(4,element(2,DP)))]) + end + end + end. + + +%% Returns a slashified name, [I1, M1] becomes "M1/I1" +slashify(List) -> lists:foldl(fun(X, Acc) -> X++"/"++Acc end, + hd(List), tl(List)). + + +%% Finds out which pragma VERSION that affects +%% the scope Scope +pragma_version(G,Scope,Object) -> + pragma_version_cover(ic_genobj:pragmatab(G),get_id2(Object),Scope,get_line(Object)). + +%% Finds out which pragma VERSION that affects +%% the scope Scope +pragma_version_cover(PragmaTab,Name,Scope,LineNr) -> + case lookup(PragmaTab,version) of + [] -> + default_version(); + PragmaVersionList -> + case all_actual_for_version_or_id( PragmaVersionList, Name ) of + [] -> + default_version(); + ActualVersionList -> + case most_local(ActualVersionList,Scope) of + [] -> + default_version(); + MostLocalList -> + case dominant_version(MostLocalList,LineNr) of + DV -> + element(4,element(2,DV)) + end + end + end + end. + + +default_version() -> "1.0". + + + +%% Finds out which pragma ID that affects +%% the scope Scope +pragma_id(G,Scope,Object) -> + pragma_id_cover(ic_genobj:pragmatab(G),get_id2(Object),Scope,get_line(Object)). + +%% Finds out which pragma ID that affects +%% the scope Scope +pragma_id_cover(PragmaTab,Name,Scope,LineNr) -> + case lookup(PragmaTab,id) of + [] -> + none; + PragmaIdList -> + case all_actual_for_version_or_id( PragmaIdList, Name ) of + [] -> + none; + ActualIdList -> + case most_local(ActualIdList,Scope) of + [] -> + none; + MostLocalList -> + case dominant_id(MostLocalList,LineNr) of + PI -> + element(3,element(4,element(2,PI))) + end + end + end + end. + + + + +%% Finds out which pragma VERSION ( or ID ) that +%% that affects the scope object with name NAME +all_actual_for_version_or_id(NList, Name) -> + all_actual_for_version_or_id( NList, [], Name ). + +all_actual_for_version_or_id([], Actual, _) -> + Actual; +all_actual_for_version_or_id([First|Rest], Found, Name) -> + case is_actual_for_version_or_id(First,Name) of + true -> + all_actual_for_version_or_id(Rest, [First|Found], Name); + false -> + all_actual_for_version_or_id(Rest, Found, Name) + end. + +is_actual_for_version_or_id( Current, Name ) -> + case element(3,element(3,element(2,Current))) of + Name -> + true; + OtherName -> + suffix([Name],tokens(OtherName,"::")) + end. + + + + +%% Find the most locally defind pragmas +%% to the scope SCOPE +most_local( SList, Scope ) -> + case SList of + [] -> + []; + [First|Rest] -> + case suffix( element(4,First), Scope ) of + true -> + most_local( Rest, First, Scope, [First] ); + false -> + most_local( Rest, Scope ) + end + end. + +%% Returns a list of all pragmas found in the +%% same scope. Should choose the right one by looking +%% att the position of the pragma in relation to +%% the current object..... ( For hairy cases ). +most_local( SList, Current, Scope, AllFound ) -> + case SList of + [] -> + AllFound; + [First|Rest] -> + FirstScope = element(4,First), + case suffix( FirstScope, Scope ) of + true -> + CurrentScope = element(4,Current), + case suffix( CurrentScope, FirstScope ) of + true -> + case length( CurrentScope ) == length( FirstScope ) of + true -> %% SAME SCOPE ! KEEP BOTH + most_local( Rest, Current, Scope, [First|AllFound] ); + false -> + most_local( Rest, First, Scope, [First] ) + end; + false -> + most_local( Rest, Current, Scope, AllFound ) + end; + false -> + most_local( Rest, Current, Scope, AllFound ) + end + end. + + + + +%% Find the most dominant prefix pragmas +%% located onto the SAME scope. Now +%% we look att the line number, the position +%% on the file. +dominant_prefix(SList,LineNr) -> + case SList of + [First|Rest] -> + dominant_prefix(Rest,First,LineNr) + end. + + +dominant_prefix([],{prefix,X,PLNr,N,F,T},LineNr) -> + case LineNr > PLNr of + true -> + {prefix,X,PLNr,N,F,T}; + false -> + none + end; +dominant_prefix([{prefix,FX,FPLNr,FN,F1,T1}|Rest],{prefix,CX,CPLNr,CN,F2,T2},LineNr) -> + case LineNr > FPLNr of % Check if FIRST before the object + true -> + case FPLNr > CPLNr of % Check if FIRST after CURRENT + true -> + dominant_prefix(Rest,{prefix,FX,FPLNr,FN,F1,T1},LineNr); + false -> + dominant_prefix(Rest,{prefix,CX,CPLNr,CN,F2,T2},LineNr) + end; + false -> % FIRST does not affect the object + dominant_prefix(Rest,{prefix,CX,CPLNr,CN,F2,T2},LineNr) + end. + + + + +%% Find the most dominant version pragmas +%% located onto the SAME scope. Now +%% we look att the line number, the position +%% on the file. +dominant_version(SList,LineNr) -> + case SList of + [First|Rest] -> + dominant_version(Rest,First,LineNr) + end. + + +dominant_version([],Current,_) -> Current; +dominant_version([{version,FX,FPLNr,FN,F1,T1}|Rest],{version,CX,CPLNr,CN,F2,T2},LineNr) -> + case FPLNr > CPLNr of % Check if FIRST after CURRENT + true -> + dominant_version(Rest,{prefix,FX,FPLNr,FN,F1,T1},LineNr); + false -> + dominant_version(Rest,{prefix,CX,CPLNr,CN,F2,T2},LineNr) + end. + + + + +%% Find the most dominant id pragmas +%% located onto the SAME scope. Now +%% we look att the line number, the position +%% on the file. +dominant_id(SList,LineNr) -> + case SList of + [First|Rest] -> + dominant_id(Rest,First,LineNr) + end. + + +dominant_id([],Current,_) -> Current; +dominant_id([{id,FX,FPLNr,FN,F1,T1}|Rest],{id,CX,CPLNr,CN,F2,T2},LineNr) -> + case FPLNr > CPLNr of % Check if FIRST after CURRENT + true -> + dominant_id(Rest,{id,FX,FPLNr,FN,F1,T1},LineNr); + false -> + dominant_id(Rest,{id,CX,CPLNr,CN,F2,T2},LineNr) + end. + + + + + +%% This registers a module defined inside the file or +%% an included file. A tuple that describes the module +%% is added to the table. +%% Observe that the modules registered are ONLY those +%% who are in the top level, not definedd inside others ! +mk_ref(G,Name,Type) -> + case length(Name) > 1 of + true -> %% The interface is NOT defined att top level + true; + false -> + S = ic_genobj:pragmatab(G), + File = get_idlfile(S), % The current file or an included one. + case idlfile(G) of % The current file to be compiled. + File -> + insert(S,{Type,Name,File,local}); + _ -> + insert(S,{Type,Name,File,included}) + end + end. + + +%% The same as mk_ref/3 but this registers everything with +%% all vital information available inside files. +%% Registers ESSENTIAL data for included files +mk_file_data(G,X,Scope,Type) -> + S = ic_genobj:pragmatab(G), + Name = get_id2(X), + PreprocFile = get_idlfile(S), % The current file or an included one. + CompFile = idlfile(G), % The current file compiled + Depth = length(Scope), % The depth of the scope + ScopedName = ic_util:to_undersc([Name|Scope]), + Line = ic_forms:get_line(X), + case PreprocFile of + CompFile -> + insert(S,{file_data_local,CompFile,CompFile,Type,Scope,Name,ScopedName,Depth,Line}); + PreprocFile -> + insert(S,{file_data_included,PreprocFile,CompFile,Type,Scope,Name,ScopedName,Depth,Line}) + end. + + + +%% Return a list with all the headers from +%% the local file that represent the module +%% or interface that is preciding the current +get_local_c_headers(G,X) -> + S = ic_genobj:pragmatab(G), + Local = lookup(S,file_data_local), + FoundLocal = get_local_c_headers(X,Local,Local), + no_doubles(FoundLocal). + +get_local_c_headers(X,Local,Local) -> + get_local_c_headers(X,Local,Local,[]). + +get_local_c_headers(_X,[],_All,Found) -> + Found; +get_local_c_headers(X,[{file_data_local,_PF_idl,_,module,_,_,SN,_,Line}|Hs],All,Found)-> + case ic_forms:get_line(X) > Line of + true -> + get_local_c_headers(X,Hs,All,[SN|Found]); + false -> + get_local_c_headers(X,Hs,All,Found) + end; +get_local_c_headers(X,[{file_data_local,_PF_idl,_,interface,_,_,SN,_,Line}|Hs],All,Found)-> + case ic_forms:get_line(X) > Line of + true -> + get_local_c_headers(X,Hs,All,[SN|Found]); + false -> + get_local_c_headers(X,Hs,All,Found) + end; +get_local_c_headers(X,[_|Hs],All,Found) -> + get_local_c_headers(X,Hs,All,Found). + + + +%% Return a list with all the headers from +%% the included file that represent the module +%% or interface that have to be included +get_included_c_headers(G) -> + S = ic_genobj:pragmatab(G), + Included = lookup(S,file_data_included), + FoundIncluded = get_included_c_headers(Included,Included), + no_doubles(FoundIncluded). + +get_included_c_headers(Included,Included) -> + get_included_c_headers(Included,Included,[]). + +get_included_c_headers([],_All,Found) -> + Found; +get_included_c_headers([{file_data_included,PF_idl,_CF_idl,T,_S,_N,SN,0,_}|Hs],All,Found) -> + Len = length(PF_idl), + FN = string:sub_string(PF_idl,1,Len-4), + case only_top_level(PF_idl,All) of + true -> + %% + L = string:tokens(FN,"/"), + FN2 = lists:last(L), + %% + get_included_c_headers(Hs,All,["oe_"++FN2|Found]); + false -> + case T of + module -> + case contains_interface(PF_idl,All) of + true -> + %% + L = string:tokens(FN,"/"), + FN2 = lists:last(L), + %% + get_included_c_headers(Hs,All,["oe_"++FN2|Found]); + false -> + get_included_c_headers(Hs,All,[SN|Found]) + end; + interface -> + case contains_interface(PF_idl,All) of + true -> + %% + L = string:tokens(FN,"/"), + FN2 = lists:last(L), + %% + get_included_c_headers(Hs,All,["oe_"++FN2|Found]); + false -> + get_included_c_headers(Hs,All,[SN|Found]) + end; + _ -> + get_included_c_headers(Hs,All,["oe_"++FN|Found]) + end + end; +get_included_c_headers([{file_data_included,_PF_idl,_,module,_,_,SN,_,_}|Hs],All,Found)-> + get_included_c_headers(Hs,All,[SN|Found]); +get_included_c_headers([{file_data_included,_PF_idl,_,interface,_,_,SN,_,_}|Hs],All,Found)-> + get_included_c_headers(Hs,All,[SN|Found]); +get_included_c_headers([_|Hs],All,Found) -> + get_included_c_headers(Hs,All,Found). + +%% Help functions for the above + +only_top_level(_PF_idl,[]) -> + true; +only_top_level(PF_idl,[H|Hs]) -> + case element(2,H) of + PF_idl -> + case element(8,H) > 0 of + true -> + false; + false -> + only_top_level(PF_idl,Hs) + end; + _ -> + only_top_level(PF_idl,Hs) + end. + +contains_interface(_PF_idl,[]) -> + false; +contains_interface(PF_idl,[H|Hs]) -> + case element(2,H) of + PF_idl -> + case element(4,H) of + interface -> + case element(8,H) > 0 of + true -> + true; + false -> + contains_interface(PF_idl,Hs) + end; + _ -> + contains_interface(PF_idl,Hs) + end; + _ -> + contains_interface(PF_idl,Hs) + end. + + + +%% This returns a list of everything defined in an included file. +get_incl_refs(G) -> + S = ic_genobj:pragmatab(G), + + RefList = + ets:match(S,{mod_ref,'$0','_',included}) ++ + ets:match(S,{ifc_ref,'$0','_',included}) ++ + ets:match(S,{const_ref,'$0','_',included}) ++ + ets:match(S,{typedef_ref,'$0','_',included}) ++ + ets:match(S,{except_ref,'$0','_',included}) ++ + ets:match(S,{struct_ref,'$0','_',included}) ++ + ets:match(S,{union_ref,'$0','_',included}) ++ + ets:match(S,{enum_ref,'$0','_',included}) ++ + ets:match(S,{attr_ref,'$0','_',included}), + + case RefList of + [] -> + none; + _ -> + RefList + end. + + + +%% This returns a list of everything locally defined. +get_local_refs(G) -> + S = ic_genobj:pragmatab(G), + + RefList = + ets:match(S,{mod_ref,'$0','_',local}) ++ + ets:match(S,{ifc_ref,'$0','_',local}) ++ + ets:match(S,{const_ref,'$0','_',local}) ++ + ets:match(S,{typedef_ref,'$0','_',local}) ++ + ets:match(S,{except_ref,'$0','_',local}) ++ + ets:match(S,{struct_ref,'$0','_',local}) ++ + ets:match(S,{union_ref,'$0','_',local}) ++ + ets:match(S,{enum_ref,'$0','_',local}) ++ + ets:match(S,{attr_ref,'$0','_',local}), + + case RefList of + [] -> + none; + _ -> + RefList + end. + + + + + +%% This is intented to be used for solving the identification +%% problem introduced by pragmas. It creates aliases between +%% scoped and "final" identities. +mk_alias(G,PragmaId,ScopedId) -> + %io:format("~nMaking alias -> ~p~n",[PragmaId]), + S = ic_genobj:pragmatab(G), + insert(S,{alias,ScopedId,PragmaId}). + + +%% This is used to find out if the object described with +%% the scoped id is created. If this is the case, it should +%% be registered as an alias and the identity of the object +%% is returned. Otherwize "none" is returned. +get_alias(G,ScopedId) -> + S = ic_genobj:pragmatab(G), + case ets:match(S,{alias,ScopedId,'$1'}) of + [] -> + none; + [[IfrId]] -> + %io:format("~nFound alias -> ~p~n",[IfrId]), + IfrId + end. + + + +%% Returns the alias id or constructs an id +scope2id(G,ScopedId) -> + case get_alias(G,ScopedId) of + none -> + case is_included(G,ScopedId) of + true -> %% File included + get_included_IR_ID(G,ScopedId); + false -> %% File local + NewIfrId = mk_id(ScopedId), % Create a "standard" id + mk_alias(G,NewIfrId,ScopedId), % Create an alias + NewIfrId + end; + IfrId -> + IfrId + end. + + + + +is_included(G,ScopedId) -> + S = ic_genobj:pragmatab(G), + Name = ic_util:to_undersc(ScopedId), + case ets:match(S,{file_data_included,'_','_','_','_','_',Name,'_','_'}) of + [[]] -> + true; + _ -> + false + end. + + + +get_included_IR_ID(G,ScopedId) -> + S = ic_genobj:pragmatab(G), + ScopedName = ic_util:to_undersc(ScopedId), + [[Scope,Name,LNr]] = ets:match(S,{file_data_included,'_','_','_','$3','$4',ScopedName,'_','$7'}), + {Prefix,Vsn,Id} = pragma_cover(S,Name,Scope,LNr), + case Id of + none -> + case Prefix of + none -> + IR_ID = + lists:flatten(io_lib:format("IDL:~s:~s",[ScopedName, Vsn])), + ic_pragma:mk_alias(G,IR_ID,ScopedId), + IR_ID; + _ -> + IR_ID = + lists:flatten(io_lib:format("IDL:~s:~s",[Prefix ++ "/" ++ ScopedName, Vsn])), + ic_pragma:mk_alias(G,IR_ID,ScopedId), + IR_ID + end; + _ -> + ic_pragma:mk_alias(G,Id,ScopedId), + Id + end. + + + + + +%% Returns the scope for object +id2scope(G,IfrId) -> + S = ic_genobj:pragmatab(G), + case lookup(S,alias) of + [] -> + mk_scope(IfrId); + AliasList -> + case keysearch(IfrId,3,AliasList) of + false -> + mk_scope(IfrId); + {value,{alias,ScopedId,_}} -> + ScopedId + end + end. + +%% Returns a "standard" IDL ID by getting the scope list +mk_id(ScopedId) -> + "IDL:" ++ ic_pragma:slashify(ScopedId) ++ ":" ++ default_version(). + +%% Returns the scope of an object when getting a "standard" IDL ID +mk_scope(IfrId) -> + [_,Body,_] = tokens(IfrId,":"), + reverse(tokens(Body,"/")). + + + +%% This is used to note the exact compiled file +%% under pragma creation. There are two options, the +%% main file or files included by the main file. This +%% just denotes the CURRENT file, the main file or +%% the included ones. A very usual field is the file +%% path that shows the include path of the file + +init_idlfile(G,S) -> + IdlFile = idlfile(G), + insert(S,{file,IdlFile,[]}). + +set_idlfile(S,FileName) -> + FilePath = get_filepath(S), + case FilePath of + [] -> + ets:delete(S,file), + insert(S,{file,FileName,[FileName|FilePath]}); + _ -> + case hd(FilePath) of + [] -> + ets:delete(S,file), + insert(S,{file,FileName,[FileName|FilePath]}); + _ -> + case tl(FilePath) of + [] -> + ets:delete(S,file), + insert(S,{file,FileName,[FileName|FilePath]}); + _ -> + case hd(tl(FilePath)) of + [] -> + ets:delete(S,file), + insert(S,{file,FileName,[FileName|FilePath]}); + FileName -> + ets:delete(S,file), + insert(S,{dependency,FilePath}), % Add dependency branch + insert(S,{file,FileName,tl(FilePath)}); + _ -> + ets:delete(S,file), + insert(S,{file,FileName,[FileName|FilePath]}) + end + end + end + end. + +get_idlfile(S) -> + [FT] = lookup(S,file), + element(2,FT). + +get_filepath(S) -> + [FT] = lookup(S,file), + element(3,FT). + + +%% This returns a list of file names +%% that direct or indirect the current +%% compiled file is depended on. +get_dependencies(G) -> + S = ic_genobj:pragmatab(G), + case lookup(S,dependency) of + [] -> + []; + Dependencies -> + {get_idlfile(S),get_dependencies(Dependencies,[])} + end. + +get_dependencies([],Dependencies) -> + no_doubles(Dependencies); +get_dependencies([{dependency,Path}|Tail],Current) -> + get_dependencies(Tail,[hd(Path)|Current]). + + +no_doubles(List) -> + no_doubles(List,[]). + +no_doubles([],NoDoubles) -> + NoDoubles; +no_doubles([X|Xs],Current) -> + case member(X,Xs) of + true -> + no_doubles(Xs,Current); + false -> + no_doubles(Xs,[X|Current]) + end. + + + + +%% Pragma compilation status initialization +init_pragma_status(S) -> + insert(S,{status,true,0}). + +%% Pragma compilation status set to failure +%% and count up the number of errors +set_compilation_failure(S) -> + [{status,_,ErrorNr}] = lookup(S,status), + ets:delete(S,status), + insert(S,{status,false,ErrorNr+1}). + +%% Pragma compilation status set to lookup +get_pragma_compilation_status(S) -> + [Status] = lookup(S,status), + element(2,Status). + +%% Pragma error number +get_pragma_error_nr(S) -> + [Status] = lookup(S,status), + element(3,Status). + + +%% Short check +is_short(N_str) when is_list(N_str) -> + case is_short_decimal_str(N_str) of + true -> + true; + false -> + false + end; +is_short(N) when is_integer(N)-> + (N < 65535) and (N > -65536); +is_short(_) -> false. + + +%% Check if the string is a +%% list of characters representing +%% a short. Avoid crash !. +is_short_decimal_str(N_str) -> + case is_decimal_str(N_str) of + true -> + N = list_to_integer(N_str), + (N < 65535) and (N > -65536); + false -> + false + end. + +%% Check if the string is a +%% list of characters representing +%% decimals. +is_decimal_str([]) -> + true; +is_decimal_str([First|Rest]) -> + case is_decimal_char(First) of + true -> + is_decimal_str(Rest); + false -> + false + end. + +%% True if D is a character +%% representing a decimal (0-9). +is_decimal_char(D) -> + case (48= + true; + false -> + false + end. + + +%% Prints out all the table +print_tab(G) -> + io:format("~nPragmaTab = ~p~n",[ets:tab2list(ic_genobj:pragmatab(G))]). + + +list_to_term(List) -> + case catch erl_scan:string(List) of + {ok, Tokens, _} -> + case erl_parse:parse_term(Tokens ++ [{dot, 1}]) of + {ok,Term} -> + Term; + _ -> + error + end; + _ -> + error + end. + + + +%% Cleanup all other code options for a specified scope +%% in the same file, but the most dominant. +cleanup_codeOptions(G,S,ScopedId) -> + case ets:match(S,{codeopt,ScopedId,'$1','$2',idlfile(G),'$4'}) of + [] -> + %% No codeOpt directive is placed inside the + %% currently compiled file. Try to find other + %% directives located in included files. + true; + List -> + %% A codeOpt directive is placed inside the + %% currently compiled file. This dominates + %% all other directives. + CodeOption = best_positioned_codeOpt(List), + %% Remove code options that do not affect + %% the code production (redundant) + remove_redundant_codeOpt(S,[ScopedId|CodeOption]) + end. + + +%% Best positioned is the codeopt located +%% "highest" on the SAME file, the one with +%% lowest line number. +best_positioned_codeOpt([X|Xs]) -> + best_positioned_codeOpt(Xs,X). + +best_positioned_codeOpt([],Found) -> + Found; +best_positioned_codeOpt([X|Xs],Current) -> + case hd(tl(X)) > hd(tl(Current)) of + true -> + best_positioned_codeOpt(Xs,Current); + false -> + best_positioned_codeOpt(Xs,X) + end. + + +remove_redundant_codeOpt(S,[ScopedId,CodeOption,LNr,FilePath]) -> + ets:match_delete(S,{codeopt,ScopedId,'$1','$2','$3','$4'}), + ets:insert(S,{codeopt,ScopedId,CodeOption,LNr,last(FilePath),FilePath}). + + + + +add_inh_data(G,InclScope,X) -> + S = ic_genobj:pragmatab(G), + case X#interface.inherit of + [] -> + true; + [InhBody] -> + Scope = [get_id2(X)|InclScope], + insert(S,{inherits,Scope,InhBody}); + InhList -> + add_inh_data(G, S, InclScope, X, InhList) + end. + +add_inh_data(_,_,_,_,[]) -> + true; +add_inh_data(G, S, InclScope, X, [InhBody|InhBodies]) -> + Scope = [get_id2(X)|InclScope], + insert(S, {inherits,Scope,InhBody}), + add_inh_data(G, S, InclScope, X, InhBodies). + + +%% Returns a default broker data +defaultBrokerData(G) -> + {to_atom(ic_genobj:impl(G)),transparent}. + + +%% Loops through the form and sdds inheritence data +preproc(G, N, [X|Xs]) when is_record(X, interface) -> + %% Add inheritence data to pragmatab + ic_pragma:add_inh_data(G,N,X), + N2 = [get_id2(X) | N], + preproc(G, N2, get_body(X)), + lists:foreach(fun({_Name, Body}) -> preproc(G, N2, Body) end, + X#interface.inherit_body), + preproc(G, N, Xs); + +preproc(G,N,[X|Xs]) when is_record(X, module) -> + N2 = [get_id2(X) | N], + preproc(G, N2, get_body(X)), + preproc(G,N,Xs); + +preproc(G,N,[_X|Xs]) -> + preproc(G,N,Xs); + +preproc(_G, _N, []) -> + ok. + + +%% Returns a tuple / list of tuples { Mod, Type } +%% Does not check overridence because it is the +%% top scope for the module to be produced and +%% cannot be overriden. +getBrokerData(G,X,Scope) -> + S = ic_genobj:pragmatab(G), + cleanup_codeOptions(G,S,Scope), + + %% Check if it is an operation denoted + case isOperation(S,Scope) of + %% Yes, check options + true -> + %% Look if there is a specific code option on top file + case hasSpecificCodeoptionOnTopFile(S,ic_genobj:idlfile(G),Scope) of + true -> + %% Yes, let it work + getBrokerData(G,S,X,Scope,[Scope],[]); + false -> + %% No, try to see if there is codeoption on top file + case hasNonSpecificCodeoptionOnTopFile(S,ic_genobj:idlfile(G)) of + true -> + %% Yes, override every other specific code option + [_H|T] = Scope, + getBrokerData(G,S,X,Scope,[T],[]); + false -> + %% No, let inherited specific code options work + getBrokerData(G,S,X,Scope,[Scope],[]) + end + end; + %% No, continue + false -> + getBrokerData(G,S,X,Scope,[Scope],[]) + end. + +%% Returns a tuple / list of tuples { Mod, Type } +%% Inside loop, uses overridence. +getBrokerData(G,X,RS,Scope,CSF) -> + S = ic_genobj:pragmatab(G), + cleanup_codeOptions(G,S,Scope), + OvScope = overridedFrom(S,RS,Scope), + getBrokerData(G,S,X,RS,[OvScope],[OvScope|CSF]). + + + +getBrokerData(G,S,X,RS,[[[First]|Rest]],CSF) when is_integer(First) -> + Scope = [[First]|Rest], + case ets:match(S,{codeopt,Scope,'$1','_','_','_'}) of + [] -> + case ets:match(S,{inherits,Scope,'$1'}) of + [] -> %% No inheritence, no pragma codeopt + defaultBrokerData(G); %% Default + [InhScope] -> + getBrokerData(G,S,X,RS,InhScope,CSF); + InhList -> + getBrokerDataInh(G,S,X,RS,Scope,CSF,InhList) + end; + [[{broker,{Module,Type}}]] -> %% A branch only, with pragma codeopt + {Module,Type}; + List -> %% Multiple branches with pragma codeopt + flatten(List) + end; + +getBrokerData(G,S,X,RS,[[[First]|Rest]],CSF) -> + getBrokerDataLoop(G,S,X,RS,[[First]|Rest],CSF); + +getBrokerData(G,S,X,RS,[Scope],CSF) -> + %io:format(" 1"), + case ets:match(S,{codeopt,Scope,'$1','_','_','_'}) of + [] -> + %io:format(" 2"), + case ets:match(S,{inherits,Scope,'$1'}) of + [] -> %% No inheritence, no pragma codeopt + %io:format(" 5"), + defaultBrokerData(G); %% Default + [InhScope] -> + %io:format(" 6"), + getBrokerData(G,S,X,RS,InhScope,CSF); + InhList -> + %io:format(" 7"), + getBrokerDataInh(G,S,X,RS,Scope,CSF,InhList) + end; + [[{broker,{Module,Type}}]] -> %% A branch only, with pragma codeopt + %io:format(" 3"), + {Module,Type}; + List -> %% Multiple branches with pragma codeopt + %io:format(" 4"), + flatten(List) + end. + + +%% Special treatment when X is an operation +getBrokerDataInh(G,S,X,RS,Scope,CSF,InhList) when is_record(X,op)-> + %io:format(" 8"), + case ets:match(S,{op,get_id2(X),'$1','_','_'}) of + [] -> + %io:format(" 10"), + CleanList = remove_inherited(S,InhList), + getBrokerDataLoop(G,S,X,RS,CleanList,CSF); + + [[Scope]] -> + %io:format(" 11"), + CleanList = remove_inherited(S,InhList), + getBrokerDataLoop(G,S,X,RS,CleanList,CSF); + + [[OpScope]] -> + %io:format(" 12"), + case member([OpScope],InhList) of + true -> + %io:format(" 14"), + %% No inherited scopes + getBrokerData(G,X,RS,OpScope,CSF); + false -> + %io:format(" 15"), + %% Inherited scopes + CleanList = remove_inherited(S,InhList), + getBrokerDataLoop(G,S,X,RS,CleanList,CSF) + end; + + ListOfOpScopes -> + %io:format(" 13"), + case get_inherited(S,Scope,ListOfOpScopes) of + [[OpScope]] -> + case member([OpScope],InhList) of + true -> + getBrokerData(G,X,RS,OpScope,CSF); + false -> + CleanList = remove_inherited(S,InhList), + getBrokerDataLoop(G,S,X,RS,CleanList,CSF) + end; + _ -> + CleanList = remove_inherited(S,InhList), + getBrokerDataLoop(G,S,X,RS,CleanList,CSF) + end + end; +%% Just add InhList after removing all inherited +getBrokerDataInh(G,S,X,RS,_Scope,CSF,InhList) -> + %io:format(" 9"), + CleanList = remove_inherited(S,InhList), + getBrokerDataLoop(G,S,X,RS,CleanList,CSF). + + + + +%% Loops over a list of scopes +getBrokerDataLoop(G,S,X,RS,List,CSF) -> + getBrokerDataLoop(G,S,X,RS,List,[],CSF). + +getBrokerDataLoop(G,_,_X,_RS,[],BrokerDataList,_CSF) -> + case no_doubles(BrokerDataList) of + [BrokerData] -> %% No pragma codeopt / Multiple branches with pragma codeopt + BrokerData; + List -> + DefaultBD = defaultBrokerData(G), + case member(DefaultBD,List) of + true -> + %% Remove default, choose codeoption + NewList = delete(DefaultBD,List), + case NewList of + [BData] -> %% A branch only, with pragma codeopt + BData; + _Other -> %% Multiple branches with pragma codeopt + %%io:format("Multiple branches ~p~n",[Other]), + NewList + end; + false -> %% Multiple branches with pragma codeopt + flatten(List) + end + end; + +getBrokerDataLoop(G,S,X,RS,[[Scope]|Scopes],_Found,CSF) when is_integer(Scope) -> + getBrokerData(G,S,X,RS,[[Scope]|Scopes],CSF); + +getBrokerDataLoop(G,S,X,RS,[[Scope]|Scopes],Found,CSF) -> + %% Start from the beginning, check for overridings + case member(overridedFrom(S,RS,Scope),CSF) of %% Avoid infinite loops + true -> + getBrokerDataLoop(G,S,X,RS,Scopes,Found,CSF); + false -> + BrokerData = getBrokerData(G,X,RS,Scope,CSF), + getBrokerDataLoop(G,S,X,RS,Scopes,[BrokerData|Found],[Scope|CSF]) + end. + + + + +%%%-------------------------------------- +%%% Finds out the overrider of a scope +%%%-------------------------------------- +overridedFrom(S,RS,Scope) -> + overridedFrom(S,RS,Scope,Scope). + +overridedFrom(S,RS,Last,Scope) -> + case ets:match(S,{inherits,'$0',Scope}) of + [] -> + %% No inheritence, no pragma codeopt, + %% choose the last scope. + Last; + + [[RS]] -> + %% Garbage, unused interface with pragma + %% code option ! Danger ! + Last; + + [[InhScope]] -> + case ets:match(S,{codeopt,InhScope,'$1','_','_','_'}) of + [] -> + %% InhScope has no code options, keep Last. + overridedFrom(S,RS,Scope,InhScope); + _ -> + %% InhScope has code option, Last = InhScope. + overridedFrom(S,RS,InhScope,InhScope) + end; + List -> + %% Several inherit from Scope, choose the one feeseble, + %% the one DIRECTLY inherited by Scope and not through + %% other interface. + case remove_inheriters(S,RS,List) of + [] -> + Scope; + Removed -> + Removed + end + end. + +%%%------------------------------------------------------ +%%% Removes all the scopes that inherit from others +%%%------------------------------------------------------ +remove_inheriters(S,RS,InheriterList) -> + DominantList = + dominantList(S,InheriterList), + ReducedInhList = + [X || X <- InheriterList, + member(X,DominantList)], + + case ReducedInhList of + [] -> + []; + [_OneOnly] -> + ReducedInhList; + _Other -> + EtsList = ets:tab2list(S), + CleanList = + [X || X <- EtsList, element(1,X) == inherits], +% CodeOptList = +% [X || X <- EtsList, element(1,X) == codeopt], + NoInheriters =remove_inheriters2(S,ReducedInhList,CleanList), + + [ [X] || [X] <- NoInheriters, + inherits(RS,X,CleanList)] + end. + +remove_inheriters2(_,[A],_) -> + [A]; +remove_inheriters2(_S,[A,B],EtsList) -> + case remove_inh(A,B,[A,B],EtsList) of + [[X]] -> + X; + List -> + List + end; +remove_inheriters2(S,[A,B|Rest],EtsList) -> + case remove_inh(A,B,[A,B|Rest],EtsList) of + [A,B|Rest] -> + [A,B|Rest]; + NewList -> + remove_inheriters2(S,NewList,EtsList) + end. + +remove_inh([X],[Y],List,EtsList) -> + case inherits(X,Y,EtsList) of + true -> + delete([X],List); + false -> + case inherits(Y,X,EtsList) of + true -> + delete([Y],List); + false -> + List + end + end. + + + +%%%---------------------------------------------- +%%% Should remove all scope links that inherit +%%% from others in the list +%%%---------------------------------------------- +remove_inherited(S,InheriterList) -> + EtsList = ets:tab2list(S), + CleanList = + [X || X <- EtsList, element(1,X) == inherits], + remove_inherited(S,InheriterList,CleanList). + + +remove_inherited(_S,[A,B],EtsList) -> + case remove_inhed(A,B,[A,B],EtsList) of + [[X]] -> + [[X]]; + List -> + List + end; +remove_inherited(S,[A,B|Rest],EtsList) -> + case remove_inhed(A,B,[A,B|Rest],EtsList) of + [A,B|Rest] -> + [A,B|Rest]; + NewList -> + remove_inherited(S,NewList,EtsList) + end. + + +remove_inhed([X],[Y],List,EtsList) -> + case inherits(X,Y,EtsList) of + true -> + delete([Y],List); + false -> + case inherits(Y,X,EtsList) of + true -> + delete([X],List); + false -> + List + end + end. + + + + + + + +%%%---------------------------------------------- +%%% Should return all scope links that is +%% are inherited from scope in the list +%%%---------------------------------------------- +get_inherited(S,Scope,OpScopeList) -> + EtsList = ets:tab2list(S), + [[element(3,X)] || X <- EtsList, + element(1,X) == inherits, + element(2,X) == Scope, + member([element(3,X)],OpScopeList)]. + + + + + + + +%%%--------------------------------------------------- +%%% Returns a the list of scopes that have codeoption +%%% from a list of scopes +%%%--------------------------------------------------- +dominantList(S,IL) -> + dominantList(S,IL,[]). + +dominantList(_S,[],Found) -> + Found; +dominantList(S,[[X]|Xs],Found) -> + case ets:match(S,{codeopt,X,'$1','_','_','_'}) of + [] -> + dominantList(S,Xs,Found); + _ -> + dominantList(S,Xs,[[X]|Found]) + end. + + + + +%%%--------------------------------------------------- +%%% Returns true if X direct or indirect inherits Y +%%%--------------------------------------------------- +inherits(X,Y,EtsList) -> + case member({inherits,X,Y},EtsList) of + true -> + %% Direct inherited + true; + false -> + %% Indirectly inherited + AllInh = [ B || {inherits,A,B} <- EtsList, A == X ], + inherits(X,Y,AllInh,EtsList) + end. + +inherits(_X,_Y,[],_EtsList) -> + false; +inherits(X,Y,[Z|Zs],EtsList) -> + case inherits2(X,Y,Z,EtsList) of + true -> + true; + false -> + inherits(X,Y,Zs,EtsList) + end. + +inherits2(_X,Y,Z,EtsList) -> + case member({inherits,Z,Y},EtsList) of + true -> + true; + false -> + inherits(Z,Y,EtsList) + end. + + + +%% +%% is_inherited_by/3 +%% +%% Returns : +%% +%% true if the first parameter is +%% inherited by the second one +%% +%% false otherwise +%% +is_inherited_by(Interface1,Interface2,PragmaTab) -> + FullList = ets:tab2list(PragmaTab), + InheritsList = + [X || X <- FullList, element(1,X) == inherits], + inherits(Interface2,Interface1,InheritsList). + + + + +%% Filters all pragma prefix from list not in same file +%% the object + +filter_pragma_prefix_list(PragmaTab, Name, Scope, List) -> + IdlFile = scoped_names_idl_file(PragmaTab, Name, Scope), + filter_pragma_prefix_list2(PragmaTab,IdlFile,List,[]). + + +filter_pragma_prefix_list2(_,_,[],Found) -> + Found; +filter_pragma_prefix_list2(PT, IdlFile, [PP|PPs], Found) -> + case PP of + {prefix,_,_,_,IdlFile,_} -> %% Same file as the Object, keep + filter_pragma_prefix_list2(PT, IdlFile, PPs, [PP|Found]); + + _Other -> %% NOT in same file as the Object, throw away + filter_pragma_prefix_list2(PT, IdlFile, PPs, Found) + end. + +scoped_names_idl_file(PragmaTab, Name, Scope) -> + case ets:match(PragmaTab,{'_','$0','_','$2',Scope,Name,'_','_','_'}) of + [[IdlFile, _Type]] -> %% Usual case + IdlFile; + [[_File,module]|_Files] -> %% Multiple modules, get LOCAL file + case ets:match(PragmaTab,{file_data_local,'$0','_',module,Scope,Name,'_','_','_'}) of + [[LocalIdlFile]] -> + LocalIdlFile; + _ -> %% Should NEVER occur + error + end; + + _ -> + error %% Should NEVER occur + end. + + + + + + +%%------------------------------------------------- +%% +%% Register specific pragma code options +%% +%% If there is an operation with that +%% scope, denote this as {codeopt_specific,Scope} +%% +%%------------------------------------------------- +denote_specific_code_opts(G) -> + case ic_options:get_opt(G, be) of + noc -> + S = ic_genobj:pragmatab(G), + COList = ets:match(S,{codeopt,'$0','_','_','_','_'}), + OPList = ets:match(S,{op,'$0','$1','_','_'}), + denote_specific_code_opts(S,COList,OPList); + _ -> + ok + end. + +denote_specific_code_opts(_,_,[]) -> + ok; +denote_specific_code_opts(S,COList,[[OpN,OpS]|OPSs]) -> + case lists:member([[OpN|OpS]],COList) of + true -> + insert(S, {codeopt_specific,[OpN|OpS]}); + false -> + ok + end, + denote_specific_code_opts(S,COList,OPSs). + + + +%%--------------------------------------------- +%% +%% Returns true/false if it denotes an operation +%% +%%--------------------------------------------- +isOperation(_S,[]) -> + false; +isOperation(_S,[_]) -> + false; +isOperation(S,[H|T]) -> + case ets:match(S,{op,H,T,'$2','$3'}) of + [] -> + false; + _ -> + true + end. + + +hasSpecificCodeoptionOnTopFile(S,File,Scope) -> + case ets:match(S,{codeopt,Scope,'_','$2',File,[File]}) of + [] -> + false; + _ -> + true + end. + + +hasNonSpecificCodeoptionOnTopFile(S,File) -> + case ets:match(S,{codeopt,'_','_','$2',File,[File]}) of + [] -> + false; + _ -> + true + end. + + + +%%--------------------------------------------- +%% +%% Returns {ok,IfrId}/error when searching a random local type +%% +%%--------------------------------------------- + + +fetchRandomLocalType(G) -> + + S = ic_genobj:pragmatab(G), + + case ets:match(S,{file_data_local,'_','_','$2','$3','$4','_','_','_'}) of + [] -> + false; + + List -> + fetchRandomLocalType(S,List) + end. + + +fetchRandomLocalType(_,[]) -> + false; +fetchRandomLocalType(S,[[module|_]|Tail]) -> + fetchRandomLocalType(S,Tail); +fetchRandomLocalType(S,[[_,Scope,Name]|Tail]) -> + case ets:match(S,{alias,[Name|Scope],'$1'}) of + [] -> + fetchRandomLocalType(S,Tail); + [[IfrId]] -> + {ok,IfrId} + end. + + + +%%--------------------------------------------- +%% +%% Returns A list of local operation mapping +%% for a given scope +%% +%%--------------------------------------------- + + +fetchLocalOperationNames(G,I) -> + S = ic_genobj:pragmatab(G), + case ets:match(S,{file_data_local,'_','_',op,I,'$4','_','_','_'}) of + [] -> + []; + List -> + fetchLocalOperationNames2(List,[]) + end. + +fetchLocalOperationNames2([],Found) -> + lists:reverse(Found); +fetchLocalOperationNames2([[Name]|Names],Found) -> + fetchLocalOperationNames2(Names,[Name|Found]). + + + +%%------------------------------------------------ +%% +%% Returns a true if this scoped id is a local +%% one, false otherwise +%% +%%------------------------------------------------ +is_local(G,ScopedId) -> + S = ic_genobj:pragmatab(G), + Name = ic_util:to_undersc(ScopedId), + case ets:match(S,{file_data_local,'_','_','_',tl(ScopedId),'_',Name,'_','_'}) of + [[]] -> + true; + _ -> + false + end. diff --git a/lib/ic/src/ic_sequence_java.erl b/lib/ic/src/ic_sequence_java.erl new file mode 100644 index 0000000000..b57652fb82 --- /dev/null +++ b/lib/ic/src/ic_sequence_java.erl @@ -0,0 +1,239 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1999-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_sequence_java). + + +-include("icforms.hrl"). +-include("ic.hrl"). +-include("ic_debug.hrl"). +%%----------------------------------------------------------------- +%% External exports +%%----------------------------------------------------------------- +-export([gen/4]). + +%%----------------------------------------------------------------- +%% Internal exports +%%----------------------------------------------------------------- +-export([]). + +%%----------------------------------------------------------------- +%% External functions +%%----------------------------------------------------------------- + +%%----------------------------------------------------------------- +%% Func: gen/4 +%%----------------------------------------------------------------- +gen(G, N, X, SequenceName) when is_record(X, sequence) -> + emit_holder_class(G, N, X, SequenceName), + emit_helper_class(G, N, X, SequenceName); +gen(_G, _N, _X, _SequenceName) -> + ok. + + +%%----------------------------------------------------------------- +%% Internal functions +%%----------------------------------------------------------------- + + +%%----------------------------------------------------------------- +%% Func: emit_holder_class/4 +%%----------------------------------------------------------------- +emit_holder_class(G, N, X, SequenceName) -> + SName = string:concat(SequenceName, "Holder"), + {Fd, _}= ic_file:open_java_file(G, N, SName), + + SequenceType = ic_java_type:getType(G, N, X), + + ic_codegen:emit(Fd, ["final public class ",SequenceName,"Holder {\n" + " // instance variables\n" + " public ",SequenceType," value;\n\n" + " // constructors\n" + " public ",SequenceName,"Holder() {}\n" + " public ",SequenceName,"Holder(",SequenceType," initial) {\n" + " value = initial;\n" + " }\n\n" + + " // methods\n" + + " public void _marshal(",?ERLANGPACKAGE,"OtpOutputStream out) throws java.lang.Exception{\n" + " ",SequenceName,"Helper.marshal(out, value);\n" + " }\n\n" + + " public void _unmarshal(",?ERLANGPACKAGE,"OtpInputStream in) throws java.lang.Exception {\n" + " value = ",SequenceName,"Helper.unmarshal(in);\n" + " }\n\n" + "}\n"]), + file:close(Fd). + + + +emit_helper_class(G, N, X, SequenceName) -> + SName = string:concat(SequenceName, "Helper"), + {Fd, _}= ic_file:open_java_file(G, N, SName), + + SequenceType = ic_java_type:getType(G, N, X), + ElementType = ic_forms:get_type(X), + + ic_codegen:emit(Fd, ["public class ",SequenceName,"Helper {\n" + + " // constructors\n" + " private ",SequenceName,"Helper() {}\n\n" + + " // methods\n" + " public static void marshal(",?ERLANGPACKAGE,"OtpOutputStream _out, ",SequenceType," _value) \n" + " throws java.lang.Exception {\n\n"]), + + emit_sequence_marshal_function(G, N, X, Fd, SequenceName, ElementType), + + ic_codegen:emit(Fd, [" }\n\n" + + " public static ",SequenceType," unmarshal(",?ERLANGPACKAGE,"OtpInputStream _in) \n" + " throws java.lang.Exception {\n\n"]), + + emit_sequence_unmarshal_function(G, N, X, Fd, SequenceName, ElementType), + + ic_codegen:emit(Fd, [" }\n\n" + + " public static String id() {\n" + " return \"",ic_pragma:scope2id(G, [SequenceName | N]),"\";\n" + " }\n\n" + + " public static String name() {\n" + " return \"",SequenceName,"\";\n" + " }\n\n"]), + + ic_jbe:emit_type_function(G, N, X, Fd), + + ic_codegen:emit(Fd, [" public static void insert(",?ICPACKAGE,"Any _any, ",SequenceType," _this)\n" + " throws java.lang.Exception {\n\n" + + " ",?ERLANGPACKAGE,"OtpOutputStream _os = \n" + " new ",?ERLANGPACKAGE,"OtpOutputStream();\n\n" + + " _any.type(type());\n" + " marshal(_os, _this);\n" + " _any.insert_Streamable(_os);\n" + " }\n\n" + + " public static ",SequenceType," extract(",?ICPACKAGE,"Any _any)\n" + " throws java.lang.Exception {\n\n" + + " return unmarshal(_any.extract_Streamable());\n" + " }\n\n" + + + %% In corba mapping there is also a _type function here. + "}\n\n"]), + file:close(Fd). + + +%%----------------------------------------------------------------- +%% Func: emit_sequence_marshal_function/6 +%%----------------------------------------------------------------- +emit_sequence_marshal_function(G, N, X, Fd, _SequenceName, ElementType) -> + ic_codegen:emit(Fd, [" int _length = _value.length;\n\n" + + " _out.write_list_head(_length);\n\n" + + " if (_length > 0) {\n" + " for(int _tmp = 0; _tmp < _length; _tmp++)\n"]), + + case ic_java_type:isBasicType(G, N, ElementType) of + true -> + ic_codegen:emit(Fd, [" _out",ic_java_type:marshalFun(G, N, X, ElementType),"(_value[_tmp]);\n\n"]); + false -> + ic_codegen:emit(Fd, [" ",ic_java_type:marshalFun(G, N, X, ElementType),"(_out, _value[_tmp]);\n\n"]) + end, + + ic_codegen:emit(Fd, [" _out.write_nil();\n" + " }\n\n"]). + + + + +%%----------------------------------------------------------------- +%% Func: emit_sequence_unmarshal_function/6 +%%----------------------------------------------------------------- +emit_sequence_unmarshal_function(G, N, X, Fd, _SequenceName, ElementType) -> + + SequenceElementType = ic_java_type:getType(G, N, ElementType), + + ic_codegen:emit(Fd, [" int _tag,_length;\n" + " ",SequenceElementType," _sequence[];\n" + " _tag = _in.peek();\n\n"]), + + case ic_java_type:isIntegerType(G, N, ElementType) of + true -> + ic_codegen:emit(Fd, [" switch(_tag) {\n" + " case ",?ERLANGPACKAGE,"OtpExternal.stringTag:\n" + " byte _compressed[] = (_in.read_string()).getBytes();\n" + " _length = _compressed.length;\n" + " _sequence = new ",ic_java_type:getFullType(G,N,X),";\n\n" + + " for(int _tmp = 0; _tmp < _length; _tmp++)\n" + " _sequence[_tmp] = (",ic_java_type:getType(G, N, ElementType),")(_compressed[_tmp] & 0xff);\n\n" + + " break;\n" + " default:\n" + " _length = _in.read_list_head();\n" + " _sequence = new ",ic_java_type:getFullType(G,N,X),";\n\n" + + " if(_length > 0) {\n" + " for(int _tmp = 0; _tmp < _length; _tmp++)\n" + " _sequence[_tmp] = _in",ic_java_type:unMarshalFun(G, N, X, ElementType),";\n\n" + + " _in.read_nil();\n" + " }\n" + " }\n"]); + false -> + ic_codegen:emit(Fd, [" _length = _in.read_list_head();\n" + " _sequence = new ",ic_java_type:getFullType(G,N,X),";\n\n" + + " if(_length > 0) {\n" + " for(int _tmp = 0; _tmp < _length; _tmp++)\n"]), + case ic_java_type:isBasicType(G, N, ElementType) of + true -> + ic_codegen:emit(Fd, [" _sequence[_tmp] = _in",ic_java_type:unMarshalFun(G, N, X, ElementType),";\n\n"]); + _ -> + ic_codegen:emit(Fd, [" _sequence[_tmp] = ",ic_java_type:getUnmarshalType(G, N, X, ElementType),".unmarshal(_in);\n\n"]) + end, + + ic_codegen:emit(Fd, [" _in.read_nil();\n" + " }\n\n"]) + end, + + ic_codegen:emit(Fd, " return _sequence;\n"). + + + + +%%--------------------------------------------------- +%% Utilities +%%--------------------------------------------------- + + + + + + + + + diff --git a/lib/ic/src/ic_struct_java.erl b/lib/ic/src/ic_struct_java.erl new file mode 100644 index 0000000000..e577fd64a3 --- /dev/null +++ b/lib/ic/src/ic_struct_java.erl @@ -0,0 +1,314 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1999-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_struct_java). + +-include("icforms.hrl"). +-include("ic.hrl"). +-include("ic_debug.hrl"). +%%----------------------------------------------------------------- +%% External exports +%%----------------------------------------------------------------- +-export([gen/3]). + +%%----------------------------------------------------------------- +%% Internal exports +%%----------------------------------------------------------------- +-export([]). + +%%----------------------------------------------------------------- +%% External functions +%%----------------------------------------------------------------- +gen(G, N, X) when is_record(X, struct) -> + StructName = ic_forms:get_java_id(X), + WireStructName = ic_forms:get_id2(X), + emit_struct_class(G, N, X, StructName), + emit_holder_class(G, N, X, StructName), + emit_helper_class(G, N, X, StructName, WireStructName), + N2 = [StructName ++ "Package" |N], + ic_jbe:gen(G, N2, ic_forms:get_body(X)); +gen(_G, _N, _X) -> + ok. + +%%----------------------------------------------------------------- +%% Internal functions +%%----------------------------------------------------------------- + +%%----------------------------------------------------------------- +%% Func: emit_struct_class/4 +%%----------------------------------------------------------------- +emit_struct_class(G, N, X, StructName) -> + {Fd, _}= ic_file:open_java_file(G, N, StructName), + + MList = struct_member_list(G, N, X), + ArgList = gen_parameter_list(G, [ StructName ++ "Package" |N], X, MList), + + ic_codegen:emit(Fd, ["final public class ",StructName," {\n" + " // instance variables\n"]), + + emit_struct_members_declarations(G, [StructName ++ "Package" |N], + X, Fd, MList), + + ic_codegen:emit(Fd, ["\n // constructors\n" + " public ",StructName,"() {}\n\n" + + " public ",StructName,"(",ArgList,") {\n"]), + + emit_struct_members_initialisation(G, N, X, Fd, MList), + + ic_codegen:emit(Fd, [" }\n\n" + + "}\n\n"]), + file:close(Fd). + + +%%----------------------------------------------------------------- +%% Func: emit_holder_class/4 +%%----------------------------------------------------------------- +emit_holder_class(G, N, _X, StructName) -> + SName = string:concat(StructName, "Holder"), + {Fd, _}= ic_file:open_java_file(G, N, SName), + + ic_codegen:emit(Fd, ["final public class ",StructName,"Holder {\n" + + " // instance variables\n" + " public ",StructName," value;\n\n" + + " // constructors\n" + " public ",StructName,"Holder() {}\n\n" + + " public ",StructName,"Holder(",StructName," initial) {\n" + " value = initial;\n" + " }\n\n" + + " // methods\n"]), + + ic_codegen:emit(Fd, [" public void _marshal(",?ERLANGPACKAGE,"OtpOutputStream out) throws java.lang.Exception {\n" + " ",StructName,"Helper.marshal(out, value);\n" + " }\n\n" + + " public void _unmarshal(",?ERLANGPACKAGE,"OtpInputStream in) throws java.lang.Exception {\n" + " value = ",StructName,"Helper.unmarshal(in);\n" + " }\n" + + "}\n\n"]), + file:close(Fd). + +%%----------------------------------------------------------------- +%% Func: emit_helper_class/5 +%%----------------------------------------------------------------- +emit_helper_class(G, N, X, StructName, WireStructName) -> + SName = string:concat(StructName, "Helper"), + {Fd, _}= ic_file:open_java_file(G, N, SName), + + ic_codegen:emit(Fd, ["public class ",StructName,"Helper {\n" + + " // constructors\n" + " private ",StructName,"Helper() {}\n\n" + + " // methods\n"]), + + MList = struct_member_list(G, N, X), + + ic_codegen:emit(Fd, [" public static void marshal(",?ERLANGPACKAGE,"OtpOutputStream _out, ",StructName," _value)\n" + " throws java.lang.Exception {\n\n"]), + + emit_struct_marshal_function(G, N, X, Fd, StructName, WireStructName, MList), + + ic_codegen:emit(Fd, [" }\n\n" + + " public static ",StructName," unmarshal(",?ERLANGPACKAGE,"OtpInputStream _in)\n" + " throws java.lang.Exception {\n\n"]), + + emit_struct_unmarshal_function(G, N, X, Fd, StructName, WireStructName, MList), + + ic_codegen:emit(Fd, [" }\n\n" + + " public static String id() {\n" + " return \"",ictk:get_IR_ID(G, N, X),"\";\n" + " }\n\n" + + " public static String name() {\n" + " return \"",StructName,"\";\n" + " }\n\n"]), + + ic_jbe:emit_type_function(G, N, X, Fd), + + ic_codegen:emit(Fd, [" public static void insert(",?ICPACKAGE,"Any _any, ",StructName," _this)\n" + " throws java.lang.Exception {\n\n" + + " ",?ERLANGPACKAGE,"OtpOutputStream _os = \n" + " new ",?ERLANGPACKAGE,"OtpOutputStream();\n\n" + + " _any.type(type());\n" + " marshal(_os, _this);\n" + " _any.insert_Streamable(_os);\n" + " }\n\n" + + " public static ",StructName," extract(",?ICPACKAGE,"Any _any)\n" + " throws java.lang.Exception {\n\n" + + " return unmarshal(_any.extract_Streamable());\n" + " }\n\n" + + + %% In corba mapping there is also a _type function here. + "}\n"]), + file:close(Fd). + + +%%----------------------------------------------------------------- +%% Func: emit_struct_members_declarations/ +%%----------------------------------------------------------------- +emit_struct_members_declarations(_, _, _, _, []) -> + ok; +emit_struct_members_declarations(G, N, X, Fd, [{Member, _Type, Id} | MList]) -> + ic_codegen:emit(Fd, [" public ",ic_java_type:getType(G, N, Member)," ",Id,";\n"]), + emit_struct_members_declarations(G, N, X, Fd, MList). + + + +%%----------------------------------------------------------------- +%% Func: emit_struct_members_initialisation/5 +%%----------------------------------------------------------------- +emit_struct_members_initialisation(_, _, _, _, []) -> + ok; +emit_struct_members_initialisation(G, N, X, Fd, [{_Member, _Type, Id} | MList]) -> + ic_codegen:emit(Fd, [" ",Id," = _",Id,";\n"]), + emit_struct_members_initialisation(G, N, X, Fd, MList). + + + + +%%----------------------------------------------------------------- +%% Func: emit_struct_marshal_function/7 +%%----------------------------------------------------------------- +emit_struct_marshal_function(G, N, X, Fd, StructName, WireStructName, MList) -> + + ic_codegen:emit(Fd, [" _out.write_tuple_head(",integer_to_list(length(MList) + 1),");\n" + " _out.write_atom(\"",ic_util:to_undersc([WireStructName|N]),"\");\n\n"]), + + emit_struct_marshal_function_loop(G, [StructName ++ "Package" |N], + X, Fd, MList, 1). + +%%----------------------------------------------------------------- +%% Func: emit_struct_marshal_function_loop/6 +%%----------------------------------------------------------------- +emit_struct_marshal_function_loop(_, _, _, Fd, [], _) -> + ic_codegen:nl(Fd); +emit_struct_marshal_function_loop(G, N, X, Fd, [{Member, Type, Id} |MList], Num) -> + + case ic_java_type:isBasicType(G, N, Member) of + true -> + ic_codegen:emit(Fd, [" _out",ic_java_type:marshalFun(G, N, Member, Type),"(_value.",Id,");\n"]); + _ -> + if (element(1,hd(element(3,Member))) == array) -> + ic_codegen:emit(Fd, + [" ", + ic_util:to_dot(G,[ic_forms:get_id2(Member)|N]), + "Helper.marshal(_out, _value.",Id,");\n"]); + true -> + ic_codegen:emit(Fd, [" ", + ic_java_type:marshalFun(G, N, Member, Type), + "(_out, _value.",Id,");\n"]) + end + end, + + emit_struct_marshal_function_loop(G, N, X, Fd, MList, Num+1). + + + + +%%----------------------------------------------------------------- +%% Func: emit_struct_unmarshal_function/7 +%%----------------------------------------------------------------- +emit_struct_unmarshal_function(G, N, X, Fd, StructName, WireStructName, MList) -> + + ic_codegen:emit(Fd, [" _in.read_tuple_head();\n\n" + + " if ((_in.read_atom()).compareTo(\"", + ic_util:to_undersc([WireStructName|N]), + "\") != 0)\n" + " throw new java.lang.Exception(\"\");\n\n" + + " ",StructName," _value = new ",StructName,"();\n"]), + + emit_struct_unmarshal_function_loop(G, [StructName ++ "Package"|N], + X, Fd, MList, 1), + + ic_codegen:emit(Fd, " return _value;\n"). + +%%----------------------------------------------------------------- +%% Func: emit_union_unmarshal_function_loop/6 +%%----------------------------------------------------------------- +emit_struct_unmarshal_function_loop(_, _, _, Fd, [], _) -> + ic_codegen:nl(Fd); +emit_struct_unmarshal_function_loop(G, N, X, Fd, [{Member, Type, Id} |MList], Num) -> + + case ic_java_type:isBasicType(G, N, Member) of + true -> + ic_codegen:emit(Fd, [" _value.",Id," = _in",ic_java_type:unMarshalFun(G, N, Member, Type),";\n"]); + _ -> + if (element(1,hd(element(3,Member))) == array) -> + ic_codegen:emit(Fd, + [" _value.",Id," = ",ic_util:to_dot(G,[ic_forms:get_id2(Member)|N]),"Helper.unmarshal(_in);\n"]); + true -> + ic_codegen:emit(Fd, + [" _value.",Id," = ",ic_java_type:getUnmarshalType(G, N, Member, Type),".unmarshal(_in);\n"]) + end + end, + + emit_struct_unmarshal_function_loop(G, N, X, Fd, MList, Num +1). + + + +%%----------------------------------------------------------------- +%% Func: gen_parameter_list/4 +%%----------------------------------------------------------------- +gen_parameter_list(G, N, _X, [{Member, _Type, Id}]) -> + ic_java_type:getType(G,N,Member) ++ + " _" ++ + ic_util:to_list(Id); +gen_parameter_list(G, N, X, [{Member, _Type, Id} | MList]) -> + ic_java_type:getType(G,N,Member) ++ + " _" ++ + ic_util:to_list(Id) ++ + ", " ++ + gen_parameter_list(G, N, X, MList). + + +%%----------------------------------------------------------------- +%% Func: struct_member_list/3 +%%----------------------------------------------------------------- +struct_member_list(_G, _N, X) -> + M = lists:map( + fun(Member) -> + lists:map( + fun(Id) -> + Type = ic_forms:get_type(Member), + { Member, Type, ic_forms:get_java_id(Id)} + end, + ic_forms:get_idlist(Member)) + end, + ic_forms:get_body(X)), + lists:flatten(M). + + + diff --git a/lib/ic/src/ic_symtab.erl b/lib/ic/src/ic_symtab.erl new file mode 100644 index 0000000000..889c75e3a2 --- /dev/null +++ b/lib/ic/src/ic_symtab.erl @@ -0,0 +1,232 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1998-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_symtab). + + +-include_lib("ic/src/ic.hrl"). +-include_lib("ic/src/icforms.hrl"). + +%%----------------------------------------------------------------- +%% External exports +%%----------------------------------------------------------------- +-export([new/0, store/3, retrieve/2, soft_retrieve/2, intf_resolv/3]). +-export([get_full_scoped_name/3, scoped_id_new_global/1, scoped_id_new/1]). +-export([scoped_id_strip/1,symtab_add_faked_included_types/1]). +-export([scoped_id_is_global/1, scoped_id_add/2]). + +%%----------------------------------------------------------------- +%% Internal exports +%%----------------------------------------------------------------- +-export([]). + +%%----------------------------------------------------------------- +%% External functions +%%----------------------------------------------------------------- + + +%%-------------------------------------------------------------------- +%% +%% Symbol table routines +%% +%% Symbol tables handles mappings Id -> Value, where Id is an +%% ordinary Id from the parser (or a string) and value is an +%% arbitrary term. +%% +%%-------------------------------------------------------------------- + +%%----------------------------------------------------------------- +%% Func: new/0 (used to be symtab_new) +%%----------------------------------------------------------------- +new() -> + ets:new(symtab, [set, public]). + +%%----------------------------------------------------------------- +%% Func: store/3 (used to be symtab_store) +%%----------------------------------------------------------------- +store(G, N, X) -> + Name = [ic_forms:get_id2(X) | N], + %%io:format("Adding id: ~p~n", [N]), + case soft_retrieve(G, Name) of + {error, _} -> + ets:insert(G#genobj.symtab, {Name, X}); + {ok, Y} when is_record(Y, forward) -> + ets:insert(G#genobj.symtab, {Name, X}); + {ok, _Y} -> + ic_error:error(G, {multiply_defined, X}) + end. + + +%%----------------------------------------------------------------- +%% Func: retrieve/2 (used to be symtab_retrieve) +%% +%% Makes a lookup in the symbol table for Id. Will throw +%% not_found if it fails. +%%----------------------------------------------------------------- +retrieve(G, Id) -> + case ets:lookup(G#genobj.symtab, Id) of + [{_, Val}] -> Val; + [] -> ic_error:error(G, {symtab_not_found, Id}) + end. + + +%%----------------------------------------------------------------- +%% Func: soft_retrieve/2 (used to be symtab_soft_retrieve) +%% +%% Same as retrieve but will use tagged return values. +%% +%%----------------------------------------------------------------- +soft_retrieve(G, Id) -> + case ets:lookup(G#genobj.symtab, Id) of + [{_, Val}] -> {ok, Val}; + [] -> {error, {symtab_not_found, Id}} + end. + + +%%----------------------------------------------------------------- +%% Func: intf_resolv/3 and resolv2/3 +%% (used to be symtab_intf_resolv and symtab_intf_resolv2) +%% +%% Tries to resolv the interface identifier reference. The id can +%% be either a scoped name or an standard identifier. The +%% function returns a global reference to the id. +%% +%% Will throw not_found if the id really cannot be found. Will +%% throw illegal_forward if any forward references are founf in +%% the inheritance list. +%% +%%----------------------------------------------------------------- +intf_resolv(G, Scope, Id) -> + case scoped_id_is_global(Id) of + true -> + retrieve(G, Id), + Id; + false -> + intf_resolv2(G, Scope, Id) + end. + +intf_resolv2(G, Scope, Id) -> + N = scoped_id_add(Scope, Id), + case soft_retrieve(G, scoped_id_strip(N)) of + {ok, F} when is_record(F, forward) -> + ic_error:error(G, {illegal_forward, Id}), []; + {ok, _Val} -> + scoped_id_mk_global(N); + _ -> + case scoped_id_is_top(Scope) of + false -> + intf_resolv2(G, scoped_id_up_one(Scope), Id); + true -> + ic_error:error(G, {symtab_not_found, Id}), [] + end + end. + + + +%%-------------------------------------------------------------------- +%% +%% Scoped id routines +%% +%% A scoped id is an id written as M::Id in IDL. Scoped ids are +%% implemented as lists of id in reverse order, so M1::F1 becomes +%% [F1, M1]. +%% +%%-------------------------------------------------------------------- + +get_full_scoped_name(G, N, S) when element(1, S) == scoped_id -> + ictype:scoped_lookup(G, ic_genobj:tktab(G), N, S). + +scoped_id_new_global(Id) -> + X=scoped_id_new(Id), X#scoped_id{type=global}. + +scoped_id_new(Id) -> + #scoped_id{line=ic_forms:get_line(Id), id=[ic_forms:get_id(Id)]}. + +%% Adds one more id to the list of ids +scoped_id_add(S1, S2) when is_record(S2, scoped_id) -> + S1#scoped_id{id=S2#scoped_id.id ++ S1#scoped_id.id, + line=S2#scoped_id.line}; +scoped_id_add(S, Id) -> + S#scoped_id{id=[ic_forms:get_id(Id) | S#scoped_id.id], line=ic_forms:get_line(Id)}. + + +scoped_id_mk_global(S) -> S#scoped_id{type=global}. + +scoped_id_is_global(S) when is_record(S, scoped_id), S#scoped_id.type==global -> + true; +scoped_id_is_global(_) -> false. + +%% Top level scope (i.e no more cd ..) +scoped_id_is_top(S) when S#scoped_id.id==[] -> true; +scoped_id_is_top(_) -> false. + + +scoped_id_up_one(S) -> S#scoped_id{id=tl(S#scoped_id.id)}. % cd .. in scope +%%scoped_id_get_def(S) -> hd(S#scoped_id.id). % Last added id +scoped_id_strip(S) -> S#scoped_id.id. % Strips all junk + + + + +% Add CORBA:: that as if they +% were defined in an included file. +% This is only supported in the case +% of Corba backend +symtab_add_faked_included_types(G) -> + case ic_options:get_opt(G, be) of + false -> + %% Add TypeCode as if it were defiend in included file + ets:insert(G#genobj.symtab, {["CORBA"], + {interface,{'',0,"TypeCode"}, + [], + [], + [], + {tk_objref, + "IDL:omg.org/CORBA/TypeCode:1.0", + "TypeCode"}}}); + erl_corba -> + %% Add TypeCode as if it were defiend in included file + ets:insert(G#genobj.symtab, {["CORBA"], + {interface,{'',0,"TypeCode"}, + [], + [], + [], + {tk_objref, + "IDL:omg.org/CORBA/TypeCode:1.0", + "TypeCode"}}}); + erl_template -> + %% Add TypeCode as if it were defiend in included file + ets:insert(G#genobj.symtab, {["CORBA"], + {interface,{'',0,"TypeCode"}, + [], + [], + [], + {tk_objref, + "IDL:omg.org/CORBA/TypeCode:1.0", + "TypeCode"}}}); + _ -> + ok + end. + + + +%%----------------------------------------------------------------- +%% Internal functions +%%----------------------------------------------------------------- diff --git a/lib/ic/src/ic_union_java.erl b/lib/ic/src/ic_union_java.erl new file mode 100644 index 0000000000..4be93f3c1f --- /dev/null +++ b/lib/ic/src/ic_union_java.erl @@ -0,0 +1,754 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1999-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_union_java). + +-include("icforms.hrl"). +-include("ic.hrl"). +-include("ic_debug.hrl"). +%%----------------------------------------------------------------- +%% External exports +%%----------------------------------------------------------------- +-export([gen/3]). + +%%----------------------------------------------------------------- +%% Internal exports +%%----------------------------------------------------------------- +-export([]). + +%%----------------------------------------------------------------- +%% External functions +%%----------------------------------------------------------------- + +%%----------------------------------------------------------------- +%% Func: gen/3 +%%----------------------------------------------------------------- +gen(G, N, X) when is_record(X, union) -> + + %% Create a TK value if not existed + %% Should be integrated in fetchTk + %% instead + NewX = case ic_forms:get_tk(X) of + undefined -> + S = ic_genobj:tktab(G), + Tk = ictype:tk(G, S, N, X), + #union{ id = X#union.id, + type = X#union.type, + body = X#union.body, + tk = Tk }; + _Tk -> + X + end, + + UnionName = ic_forms:get_java_id(NewX), + WiredUnionName = ic_forms:get_id2(NewX), + N2 = [UnionName ++ "Package"|N], + %%?PRINTDEBUG2("Recursive call over type ~p", + %% [[ic_forms:get_type(NewX)]]), + ic_jbe:gen(G, N, [ic_forms:get_type(NewX)]), + %%?PRINTDEBUG2("Recursive call over body: ~p", + %% [ic_forms:get_body(NewX)]), + ic_jbe:gen(G, N2, ic_forms:get_body(NewX)), + + emit_union_class(G, N, NewX, UnionName), + emit_holder_class(G, N, NewX, UnionName), + emit_helper_class(G, N, NewX, UnionName, WiredUnionName); +gen(_G, _N, _X) -> + ok. + + +%%----------------------------------------------------------------- +%% Internal functions +%%----------------------------------------------------------------- + +%%----------------------------------------------------------------- +%% Func: emit_union_class/4 +%%----------------------------------------------------------------- +emit_union_class(G, N, X, UnionName) -> + {Fd, _} = ic_file:open_java_file(G, N, UnionName), + + DiscrType = ic_java_type:getType(G, [UnionName ++ "Package"|N], + ic_forms:get_type(X)), + + MList = union_member_list(G, N, X, DiscrType), + + ic_codegen:emit(Fd, "final public class ~s {\n",[UnionName]), + + ic_codegen:emit(Fd, " // instance variables\n", []), + ic_codegen:emit(Fd, " private boolean _initialized;\n", []), + ic_codegen:emit(Fd, " private ~s _discriminator;\n", [DiscrType]), + ic_codegen:emit(Fd, " private java.lang.Object _value;\n", []), + + {tk_union,_, _,DiscrTk, _, _} = ic_forms:get_tk(X), + + DV = get_default_val(G, [UnionName |N], DiscrType, DiscrTk, MList), + + case DV of + none -> %% all values in case + ok; + _ -> + ic_codegen:emit(Fd, " private ~s _default = ~s;\n", + [DiscrType, DV]) + end, + + ic_codegen:nl(Fd), + ic_codegen:emit(Fd, " // constructors\n", []), + + ic_codegen:emit(Fd, " public ~s() {\n", [UnionName]), + ic_codegen:emit(Fd, " _initialized = false;\n", []), + ic_codegen:emit(Fd, " _value = null;\n", []), + ic_codegen:emit(Fd, " }\n", []), + ic_codegen:nl(Fd), + + ic_codegen:emit(Fd, " // discriminator access\n", []), + + ic_codegen:emit(Fd, " public ~s discriminator() " + "throws java.lang.Exception {\n", [DiscrType]), + ic_codegen:emit(Fd, " if (!_initialized) {\n", []), + ic_codegen:emit(Fd, " throw new java.lang.Exception(\"\");\n",[]), + ic_codegen:emit(Fd, " }\n", []), + ic_codegen:emit(Fd, " return _discriminator;\n", []), + ic_codegen:emit(Fd, " }\n", []), + ic_codegen:nl(Fd), + + emit_union_members_functions(G, [UnionName ++ "Package"|N], X, + Fd, UnionName, DiscrType, MList, MList), + ic_codegen:nl(Fd), + + ic_codegen:emit(Fd, "}\n", []), + file:close(Fd). + +%%----------------------------------------------------------------- +%% Func: emit_holder_class/4 +%%----------------------------------------------------------------- +emit_holder_class(G, N, _X, UnionName) -> + UName = string:concat(UnionName, "Holder"), + {Fd, _} = ic_file:open_java_file(G, N, UName), + + ic_codegen:emit(Fd, "final public class ~sHolder {\n",[UnionName]), + + ic_codegen:emit(Fd, " // instance variables\n"), + ic_codegen:emit(Fd, " public ~s value;\n", [UnionName]), + ic_codegen:nl(Fd), + + ic_codegen:emit(Fd, " // constructors\n"), + ic_codegen:emit(Fd, " public ~sHolder() {}\n", [UnionName]), + ic_codegen:emit(Fd, " public ~sHolder(~s initial) {\n", + [UnionName, UnionName]), + ic_codegen:emit(Fd, " value = initial;\n"), + ic_codegen:emit(Fd, " }\n"), + ic_codegen:nl(Fd), + + ic_codegen:emit(Fd, " // methods\n"), + + ic_codegen:emit(Fd, " public void _marshal(~sOtpOutputStream out) throws java.lang.Exception {\n", + [?ERLANGPACKAGE]), + ic_codegen:emit(Fd, " ~sHelper.marshal(out, value);\n", [UnionName]), + ic_codegen:emit(Fd, " }\n\n"), + + ic_codegen:emit(Fd, " public void _unmarshal(~sOtpInputStream in) throws java.lang.Exception {\n", + [?ERLANGPACKAGE]), + ic_codegen:emit(Fd, " value = ~sHelper.unmarshal(in);\n", [UnionName]), + ic_codegen:emit(Fd, " }\n\n"), + + ic_codegen:emit(Fd, "}\n"), + file:close(Fd). + + +%%----------------------------------------------------------------- +%% Func: emit_helper_class/4 +%%----------------------------------------------------------------- +emit_helper_class(G, N, X, UnionName, WiredUnionName) -> + UName = string:concat(UnionName, "Helper"), + {Fd, _} = ic_file:open_java_file(G, N, UName), + + DiscrType = ic_java_type:getType(G, [ UnionName ++ "Package" |N], + ic_forms:get_type(X)), + + ic_codegen:emit(Fd, "public class ~sHelper {\n",[UnionName]), + + ic_codegen:emit(Fd, " // constructors\n", []), + ic_codegen:emit(Fd, " private ~sHelper() {}\n", [UnionName]), + ic_codegen:nl(Fd), + + ic_codegen:emit(Fd, " // methods\n", []), + MList = union_member_list(G, N, X, DiscrType), + + ic_codegen:emit(Fd, " public static void marshal(~sOtpOutputStream _out, ~s _value)\n", + [?ERLANGPACKAGE, UnionName]), + ic_codegen:emit(Fd, " throws java.lang.Exception {\n\n"), + emit_union_marshal_function(G, N, X, Fd, UnionName, WiredUnionName, MList), + ic_codegen:emit(Fd, " }\n\n"), + + ic_codegen:emit(Fd, " public static ~s unmarshal(~sOtpInputStream _in)\n", + [UnionName, ?ERLANGPACKAGE]), + ic_codegen:emit(Fd, " throws java.lang.Exception {\n\n"), + emit_union_unmarshal_function(G, N, X, Fd, UnionName, WiredUnionName, MList), + ic_codegen:emit(Fd, " }\n\n"), + + ic_codegen:emit(Fd, " public static String id() {\n"), + ic_codegen:emit(Fd, " return ~p;\n",[ictk:get_IR_ID(G, N, X)]), + ic_codegen:emit(Fd, " }\n\n"), + + ic_codegen:emit(Fd, " public static String name() {\n"), + ic_codegen:emit(Fd, " return ~p;\n",[UnionName]), + ic_codegen:emit(Fd, " }\n\n"), + + ic_jbe:emit_type_function(G, N, X, Fd), + + + ic_codegen:emit(Fd, " public static void insert(~sAny _any, ~s _this)\n", + [?ICPACKAGE,UnionName]), + ic_codegen:emit(Fd, " throws java.lang.Exception {\n\n"), + + ic_codegen:emit(Fd, " ~sOtpOutputStream _os = \n",[?ERLANGPACKAGE]), + ic_codegen:emit(Fd, " new ~sOtpOutputStream();\n\n",[?ERLANGPACKAGE]), + + ic_codegen:emit(Fd, " _any.type(type());\n"), + ic_codegen:emit(Fd, " marshal(_os, _this);\n"), + ic_codegen:emit(Fd, " _any.insert_Streamable(_os);\n"), + ic_codegen:emit(Fd, " }\n\n"), + + ic_codegen:emit(Fd, " public static ~s extract(~sAny _any)\n", + [UnionName,?ICPACKAGE]), + ic_codegen:emit(Fd, " throws java.lang.Exception {\n\n"), + + ic_codegen:emit(Fd, " return unmarshal(_any.extract_Streamable());\n"), + ic_codegen:emit(Fd, " }\n\n"), + + ic_codegen:emit(Fd, " public static int discriminatorAsInt(~s _discriminator)\n", + [DiscrType]), + ic_codegen:emit(Fd, " throws java.lang.Exception {\n"), + emit_discriminator_as_int(G, N, ic_forms:get_type(X), Fd), + ic_codegen:emit(Fd, " }\n\n"), + + ic_codegen:emit(Fd, "}\n"), + file:close(Fd). + +%%----------------------------------------------------------------- +%% Func: emit_union_members_functions/7 +%%----------------------------------------------------------------- +emit_union_members_functions(_, _, _, _, _, _, [], _) -> + ok; +emit_union_members_functions(G, N, X, Fd, UnionName, DiscrType, + [{Label, Case, TypeDef, Id, Ls} | MList], MListTot) -> + + CaseId = Case#case_dcl.id, %% Maybe Array + CaseType = Case#case_dcl.type, %% Maybe Sequence + + Type = if element(1,CaseId) == array -> + ic_java_type:getType(G, N, TypeDef) ++ + ic_java_type:getdim(CaseId#array.size); + true -> + ic_java_type:getType(G, N, TypeDef) + end, + + HolderType = + if element(1,CaseId) == array -> + ic_java_type:getHolderType(G, N, CaseId); + true -> + if element(1,CaseType) == sequence -> + ic_util:to_dot(G,[Id|N]) ++"Holder"; + true -> + ic_java_type:getHolderType(G, N, TypeDef) + end + end, + + %% + %% Set method + %% + ic_codegen:emit(Fd, " // ~s access and set functions\n",[Id]), + ic_codegen:emit(Fd, " public void ~s(~s value) " + "throws java.lang.Exception {\n", + [Id, Type]), + ic_codegen:emit(Fd, " _initialized = true;\n", []), + case Label of + "default" -> + ic_codegen:emit(Fd, " _discriminator = (~s) _default;\n", + [DiscrType]); + _ -> + case ic_java_type:isBasicType(G, N, ic_forms:get_type(X)) of + true -> + ic_codegen:emit(Fd, " _discriminator = (~s) " + "~s;\n", + [DiscrType, Label]); + _ -> + ic_codegen:emit(Fd, " _discriminator = (~s) " + "~s.~s;\n", + [DiscrType, DiscrType, Label]) + end + end, + ic_codegen:emit(Fd, " _value = new ~s(value);\n", + [HolderType]), + ic_codegen:emit(Fd, " }\n", []), + + %% + %% Check this entry has more than one label and the generate an extra set method. + %% + case Ls of + [] -> + ok; + _ -> + ic_codegen:emit(Fd, " public void ~s(~s discriminator, ~s value) " + "throws java.lang.Exception {\n", + [Id, DiscrType, Type]), + ic_codegen:emit(Fd, " _initialized = true;\n", []), + ic_codegen:emit(Fd, " _discriminator = (~s) discriminator;\n", + [DiscrType]), + ic_codegen:emit(Fd, " _value = new ~s(value);\n", + [HolderType]), + ic_codegen:emit(Fd, " }\n", []) + end, + + %% + %% Get method + %% + ic_codegen:emit(Fd, " public ~s ~s() throws java.lang.Exception {\n", + [Type, Id]), + ic_codegen:emit(Fd, " if (!_initialized) {\n", []), + ic_codegen:emit(Fd, " throw new java.lang.Exception(\"\");\n",[]), + ic_codegen:emit(Fd, " }\n", []), + ic_codegen:emit(Fd, " switch (~sHelper.discriminatorAsInt" + "(discriminator())) {\n", + [UnionName]), + if + Label == "default" -> + ic_codegen:emit(Fd, " default:\n", []), + ic_codegen:emit(Fd, " break;\n", []), + emit_default_access_fun_switch_cases(G, N, X, Fd, DiscrType, + MListTot), + ic_codegen:emit(Fd, " throw new java.lang.Exception(\"\");\n", []); + true -> + ic_codegen:emit(Fd, " case ~s:\n", + [get_case_as_int(G, N, ic_forms:get_type(X), + DiscrType, Label)]), + ic_codegen:emit(Fd, " break;\n", []), + ic_codegen:emit(Fd, " default:\n", []), + ic_codegen:emit(Fd, " throw new java.lang.Exception(\"\");\n", []) + end, + ic_codegen:emit(Fd, " }\n", []), + + ic_codegen:emit(Fd, " return ((~s) _value).value;\n", + [HolderType]), + ic_codegen:emit(Fd, " }\n", []), + ic_codegen:nl(Fd), + emit_union_members_functions(G, N, X, Fd, UnionName, DiscrType, MList, + MListTot). + + +%%----------------------------------------------------------------- +%% Func: emit_default_access_fun_switch_cases/6 +%%----------------------------------------------------------------- +emit_default_access_fun_switch_cases(_G, _N, _X, _Fd, _DiscrType, []) -> + ok; +emit_default_access_fun_switch_cases(G, N, X, Fd, DiscrType, + [{"default", _, _, _, _} |MList]) -> + emit_default_access_fun_switch_cases(G, N, X, Fd, DiscrType, MList); +emit_default_access_fun_switch_cases(G, N, X, Fd, DiscrType, + [{Label, _Case, _TypeDef, _Id, _} | MList]) -> + ic_codegen:emit(Fd, " case ~s:\n", + [get_case_as_int(G, N, ic_forms:get_type(X), + DiscrType, Label)]), + emit_default_access_fun_switch_cases(G, N, X, Fd, DiscrType, MList). + + + +%%----------------------------------------------------------------- +%% Func: emit_union_unmarshal_function/5 +%%----------------------------------------------------------------- +emit_union_unmarshal_function(G, N, X, Fd, UnionName, WiredUnionName, MList) -> + DiscrTypeForm = ic_forms:get_type(X), + DiscrType = ic_java_type:getType(G, [UnionName ++ "Package"|N], + DiscrTypeForm), + + ic_codegen:emit(Fd, " _in.read_tuple_head();\n\n"), + + ic_codegen:emit(Fd, " if ((_in.read_atom()).compareTo(~p) != 0)\n", + [ic_util:to_undersc([WiredUnionName|N])]), + ic_codegen:emit(Fd, " throw new java.lang.Exception(\"\");\n\n",[]), + + ic_codegen:emit(Fd, " ~s _value = new ~s();\n", [UnionName, UnionName]), + + %% Decode discriminator + case ic_java_type:isBasicType(G, N, DiscrTypeForm) of + true -> + ic_codegen:emit(Fd, " ~s _discriminator = _in~s;\n\n", + [DiscrType, + ic_java_type:unMarshalFun(G, N, X, DiscrTypeForm)]); + _ -> + ic_codegen:emit(Fd, " ~s _discriminator = ~s.unmarshal(_in);\n\n", + [DiscrType,ic_java_type:getUnmarshalType(G, N, X, DiscrTypeForm)]) + end, + + ic_codegen:emit(Fd, " switch (~sHelper.discriminatorAsInt(_discriminator)) {\n", + [UnionName]), + + emit_union_unmarshal_function_loop(G, [UnionName ++ "Package"|N], X, + Fd, DiscrType, MList), + + ic_codegen:emit(Fd, " }\n\n"), + + ic_codegen:emit(Fd, " return _value;\n"). + +%%----------------------------------------------------------------- +%% Func: emit_union_unmarshal_function_loop/6 +%%----------------------------------------------------------------- +emit_union_unmarshal_function_loop(_, _, _, _, _, []) -> + ok; +emit_union_unmarshal_function_loop(G, N, X, Fd, DiscrType, + [{Label, Case, Type, Id, Ls} |MList]) -> + case Label of + "default" -> + ic_codegen:emit(Fd, " default:\n"); + _ -> + ic_codegen:emit(Fd, " case ~s:\n", + [get_case_as_int(G, N, ic_forms:get_type(X), + DiscrType, Label)]) + end, + + gen_multiple_cases(G, N, X, Fd, DiscrType, Ls), + + CaseId = Case#case_dcl.id, %% Maybe Array + CaseType = Case#case_dcl.type, %% Maybe Sequence + + case element(1,CaseId) of + array -> + ic_codegen:emit(Fd, " _value.~s(~s.unmarshal(_in));\n", + [Id, + ic_java_type:getUnmarshalType(G, N, Case, CaseId)]); + + _ -> + case element(1, CaseType) of + sequence -> + ic_codegen:emit(Fd, " _value.~s(~s.unmarshal(_in));\n", + [Id, + ic_java_type:getUnmarshalType(G, N, Case, CaseType)]); + _ -> + case ic_java_type:isBasicType(G, N, CaseType) of + true -> + ic_codegen:emit(Fd, " _value.~s(_in~s);\n", + [Id, + ic_java_type:unMarshalFun(G, N, X, Type)]); + false -> + ic_codegen:emit(Fd, " _value.~s(~s.unmarshal(_in));\n", + [Id, + ic_java_type:getUnmarshalType(G, N, X, Type)]) + end + end + end, + + ic_codegen:emit(Fd, " break;\n", []), + emit_union_unmarshal_function_loop(G, N, X, Fd, DiscrType, MList). + + + + + +%%----------------------------------------------------------------- +%% Func: emit_union_marshal_function/6 +%%----------------------------------------------------------------- +emit_union_marshal_function(G, N, X, Fd, UnionName, WiredUnionName, MList) -> + + DiscrTypeForm = ic_forms:get_type(X), + DiscrType = ic_java_type:getType(G, [UnionName ++ "Package" |N], + DiscrTypeForm), + + ic_codegen:emit(Fd, " _out.write_tuple_head(3);\n"), + ic_codegen:emit(Fd, " _out.write_atom(~p);\n", + [ic_util:to_undersc([WiredUnionName|N])]), + + case ic_java_type:isBasicType(G, N, DiscrTypeForm) of + true -> + ic_codegen:emit(Fd, " _out~s(_value.discriminator());\n\n", + [ic_java_type:marshalFun(G, N, X, DiscrTypeForm)]); + false -> + ic_codegen:emit(Fd, " ~s(_out, _value.discriminator());\n\n", + [ic_java_type:marshalFun(G, N, X, DiscrTypeForm)]) + end, + + ic_codegen:emit(Fd, " switch(~sHelper.discriminatorAsInt(_value.discriminator())) {\n", + [UnionName]), + + emit_union_marshal_function_loop(G, + [ UnionName ++ "Package"|N], + X, + Fd, + DiscrType, + MList), + + ic_codegen:emit(Fd, " }\n\n", []). + + +%%----------------------------------------------------------------- +%% Func: emit_union_marshal_function_loop/ +%%----------------------------------------------------------------- +emit_union_marshal_function_loop(_, _, _, _, _, []) -> + ok; +emit_union_marshal_function_loop(G, N, X, Fd, DiscrType, + [{Label, Case, Type, Id, Ls} |MList]) -> + case Label of + "default" -> + ic_codegen:emit(Fd, " default:\n", + []); + _ -> + ic_codegen:emit(Fd, " case ~s:\n", + [get_case_as_int(G, N, ic_forms:get_type(X), + DiscrType, Label)]) + end, + + gen_multiple_cases(G, N, X, Fd, DiscrType, Ls), + + + CaseId = Case#case_dcl.id, %% Maybe Array + CaseType = Case#case_dcl.type, %% Maybe Sequence + + case element(1,CaseId) of + array -> + ic_codegen:emit(Fd, " ~s(_out, _value.~s());\n", + [ic_java_type:marshalFun(G, N, Case, CaseId), + Id]); + _ -> + case element(1, CaseType) of + sequence -> + ic_codegen:emit(Fd, " ~s.marshal(_out, _value.~s());\n", + [ic_util:to_dot(G,[Id|N]) ++ "Helper", + Id]); + _ -> + case ic_java_type:isBasicType(G, N, CaseType) of + true -> + ic_codegen:emit(Fd, " _out~s(_value.~s());\n", + [ic_java_type:marshalFun(G, N, X, Type), + Id]); + false -> + ic_codegen:emit(Fd, " ~s(_out, _value.~s());\n", + [ic_java_type:marshalFun(G, N, X, Type), + Id]) + end + end + end, + + ic_codegen:emit(Fd, " break;\n", []), + emit_union_marshal_function_loop(G, N, X, Fd, DiscrType, MList). + + + +gen_multiple_cases(_G, _N, _X, _Fd, _DiscrType, []) -> + ok; +gen_multiple_cases(G, N, X, Fd, DiscrType, [Label |Ls]) -> + ic_codegen:emit(Fd, " case ~s:\n", + [get_case_as_int(G, N, ic_forms:get_type(X), + DiscrType, getLabel(DiscrType, Label))]), + gen_multiple_cases(G, N, X, Fd, DiscrType, Ls). + + +%%----------------------------------------------------------------- +%% Func: union_member_list/3 +%%----------------------------------------------------------------- +union_member_list(G, N, X, DiscrType) -> + M = lists:map( + fun(Case) -> + {Label, LabelList} = case check_default(ic_forms:get_idlist(Case)) of + {{default, C}, List} -> + {{default, C}, List}; + {L, []} -> + {L, []}; + {_, [L |Ls]} -> + {L, Ls} + end, + + CName = ic_forms:get_java_id(Case), + CId = Case#case_dcl.id, + CType = Case#case_dcl.type, + + if element(1,CId) == array -> + N2 = [ic_forms:get_id2(X) ++ "Package" |N], + ic_array_java:gen(G, N2, Case, CId); + true -> + if element(1,Case#case_dcl.type) == sequence -> + N2 = [ic_forms:get_id2(X) ++ "Package" |N], + ic_sequence_java:gen(G, N2, CType, CName); + true -> + ok + end + end, + + {getLabel(DiscrType, Label), + Case, + ic_forms:get_type(Case), + CName, + LabelList} + end, + ic_forms:get_body(X)), + lists:flatten(M). + +check_default([]) -> + {false, []}; +check_default([{default, X} |Ls]) -> + {{default, X}, Ls}; +check_default([L]) -> + {false, [L]}; +check_default([L |Ls]) -> + {X, Y} = check_default(Ls), + {X, [L | Y]}. + +getLabel(_, {'', _, N}) -> + N; +getLabel(_, {'', _, N}) -> + "'" ++ N ++ "'"; +getLabel(_, {'', _, N}) -> + "'" ++ N ++ "'"; +getLabel(_, {'TRUE',_}) -> + "true"; +getLabel(_, {'FALSE',_}) -> + "true"; +getLabel(_, {default, _}) -> + "default"; +getLabel(_DiscrType, X) -> %%DiscrType ++ "." ++ + ic_util:to_dot(ic_forms:get_id(X)). + +get_default_val(G, N, _, tk_short, MList) -> + integer_default_val(G, N, 1, lists:map(fun({V, _, _, _, _}) -> V end, MList)); +get_default_val(G, N, _, tk_long, MList) -> + integer_default_val(G, N, 1, lists:map(fun({V, _, _, _, _}) -> V end, MList)); +get_default_val(G, N, _, tk_ushort, MList) -> + integer_default_val(G, N, 1, lists:map(fun({V, _, _, _, _}) -> V end, MList)); +get_default_val(G, N, _, tk_ulong, MList) -> + integer_default_val(G, N, 1, lists:map(fun({V, _, _, _, _}) -> V end, MList)); +get_default_val(G, N, _, tk_char, MList) -> + char_default_val(G, N, $a, lists:map(fun({V, _, _, _, _}) -> V end, MList)); +get_default_val(G, N, _, tk_boolean, MList) -> + boolean_default_val(G, N, lists:map(fun({V, _, _, _, _}) -> V end, MList)); +get_default_val(G, N, DiscrType, {tk_enum, _, _, Values}, MList) -> + enum_default_val(G, N, DiscrType, Values, MList). + +integer_default_val(G, N, Num, MList) -> + Num2 = integer_to_list(Num), + case lists:member(Num2, MList) of + true -> + integer_default_val(G, N, Num + 1, MList); + false -> + Num2 + end. + +char_default_val(G, N, CharNum, MList) -> + Str = "'", + CharNum2 = Str ++ [CharNum | Str], + case lists:member(CharNum2, MList) of + true -> + char_default_val(G, N, CharNum + 1, MList); + false -> + CharNum2 + end. + +boolean_default_val(G, N, MList) -> + if + length(MList) > 2 -> + ic_error:error(G, {plain_error_string, + lists:flatten( + io_lib:format("Default value found while all values have label on ~s", + [ic_util:to_colon(N)]))}), + none; + true -> + case MList of + ["true"] -> + "false"; + ["false"] -> + "true"; + ["default","true"] -> + "false"; + ["true","default"] -> + "false"; + ["default","false"] -> + "true"; + ["false","default"] -> + "true"; + _ -> + none + end + end. + + + + +enum_default_val(G, N, DiscrType, Values, Mlist) -> + + VLen = length(Values), + MLen = length(Mlist), + + case MLen > VLen of + true -> + ic_error:error(G, {plain_error_string, + lists:flatten( + io_lib:format("Default value found while all values have label on ~s", + [ic_util:to_colon(N)]))}), + none; + false -> + enum_default_val_loop(G, N, DiscrType, Values, Mlist) + end. + +enum_default_val_loop(_G, _N, _, [], []) -> + none; +enum_default_val_loop(_G, _N, DiscrType, [Value| _], []) -> + DiscrType ++ "." ++ Value; +enum_default_val_loop(G, N, DiscrType, Values, [Case | MList]) when is_tuple(Case) -> + NewValues = lists:delete(element(1,Case), Values), + enum_default_val_loop(G, N, DiscrType, NewValues, MList). + + + +emit_discriminator_as_int(G, N, T, Fd) -> + case ictype:isBoolean(G,N,T) of + true -> + ic_codegen:emit(Fd, " if(_discriminator)\n", []), + ic_codegen:emit(Fd, " return 1;\n", []), + ic_codegen:emit(Fd, " else\n", []), + ic_codegen:emit(Fd, " return 0;\n", []); + false -> + case ictype:isEnum(G, N, T) of + true -> + ic_codegen:emit(Fd, " return _discriminator.value();\n", + []); + false -> + ic_codegen:emit(Fd, " return _discriminator;\n", []) + end + end. + + +get_case_as_int(G, N, T, DiscrJavaTypeName, Label) -> + case ictype:isBoolean(G,N,T) of + true -> + case Label of + "true" -> + "1"; + "false" -> + "0" + end; + false -> + case ictype:isEnum(G, N, T) of + true -> + DiscrJavaTypeName ++ "._" ++ Label; + false -> + "(" ++ DiscrJavaTypeName ++ ") " ++ Label + end + end. + + + diff --git a/lib/ic/src/ic_util.erl b/lib/ic/src/ic_util.erl new file mode 100644 index 0000000000..1a6acb286a --- /dev/null +++ b/lib/ic/src/ic_util.erl @@ -0,0 +1,313 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1998-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_util). + + +-include("icforms.hrl"). +-include("ic.hrl"). +-include("ic_debug.hrl"). + +%%----------------------------------------------------------------- +%% External exports +%%----------------------------------------------------------------- + +-export([mk_align/1, mk_list/1, join/2, chain/2, mk_name/2, + mk_OE_name/2, mk_oe_name/2, mk_var/1]). + +-export([to_atom/1, to_colon/1, to_list/1, to_undersc/1, to_dot/1, + to_dot/2]). +-export([to_uppercase/1, adjustScopeToJava/2, eval_java/3, eval_c/3]). + +%%----------------------------------------------------------------- +%% Internal exports +%%----------------------------------------------------------------- +-export([]). + +%%----------------------------------------------------------------- +%% External functions +%%----------------------------------------------------------------- + +%% mk_list produces a nice comma separated string of variable names +mk_list([]) -> []; +mk_list([Arg | Args]) -> + Arg ++ mk_list2(Args). +mk_list2([Arg | Args]) -> + ", " ++ Arg ++ mk_list2(Args); +mk_list2([]) -> []. + +%% Produce a list of items separated by S. +join([E1, E2| Es], S) -> + [E1, S| join([E2| Es], S)]; +join([E], _) -> + [E]; +join([], _) -> + []. + +%% Produce a list of items, each terminated by T. +chain([E| Es], T) -> + [E, T| chain(Es, T)]; +chain([], _) -> + []. + + +%% Shall convert a string to a Erlang variable name (Capitalise) +mk_var( [N | Str] ) when N >= $a, N =< $z -> + [ N+$A-$a | Str ]; +mk_var( [N | Str] ) when N >= $A, N =< $Z -> [N | Str]. + +%% Shall produce a "public" name for name. When we introduce new +%% identifiers in the mapping that must not collide with those from +%% the IDL spec. +%% +%% NOTE: Change name of IFR ID in system exceptions in corba.hrl when +%% prefix is changed here. +%% +mk_name(_Gen, Name) -> lists:flatten(["OE_" | Name]). +mk_OE_name(_Gen, Name) -> lists:flatten(["OE_" | Name]). +mk_oe_name(_Gen, Name) -> lists:flatten(["oe_" | Name]). + +mk_align(String) -> + io_lib:format("OE_ALIGN(~s)",[String]). + +to_atom(A) when is_atom(A) -> A; +to_atom(L) when is_list(L) -> list_to_atom(L). + +to_list(A) when is_list(A) -> A; +to_list(L) when is_atom(L) -> atom_to_list(L); +to_list(X) when is_integer(X) -> integer_to_list(X). + + + +%% Produce a colon (or under score) separated string repr of the name +%% X +%% +to_colon(X) when element(1, X) == scoped_id -> + to_colon2(ic_symtab:scoped_id_strip(X)); +to_colon(L) -> to_colon2(L). + +to_colon2([X]) -> X; +to_colon2([X | Xs]) -> to_colon2(Xs) ++ "::" ++ X; +to_colon2([]) -> "". + + +to_undersc(X) when element(1, X) == scoped_id -> + to_undersc2(ic_symtab:scoped_id_strip(X)); +to_undersc(L) -> to_undersc2(L). + +to_undersc2([X]) -> X; +to_undersc2([X | Xs]) -> to_undersc2(Xs) ++ "_" ++ X; +to_undersc2([]) -> "". + + +%% Z is a single name +to_uppercase(Z) -> + lists:map(fun(X) when X>=$a, X=<$z -> X-$a+$A; + (X) -> X end, Z). + + +%% +to_dot(X) when element(1, X) == scoped_id -> + to_dotLoop(ic_symtab:scoped_id_strip(X)); +to_dot(L) -> to_dotLoop(L). + +to_dotLoop([X]) -> ic_forms:get_java_id(X); +to_dotLoop([X | Xs]) -> to_dotLoop(Xs) ++ "." ++ ic_forms:get_java_id(X); +to_dotLoop([]) -> "". + + + +%% +to_dot(G,X) when element(1, X) == scoped_id -> + S = ic_genobj:pragmatab(G), + ScopedId = ic_symtab:scoped_id_strip(X), + case isConstScopedId(S, ScopedId) of %% Costants are left as is + true -> + to_dotLoop(ScopedId) ++ addDotValue(S, ScopedId); + false -> + to_dotLoop(S,ScopedId) + end; +to_dot(G,ScopedId) -> + S = ic_genobj:pragmatab(G), + case isConstScopedId(S, ScopedId) of %% Costants are left as is + true -> + to_dotLoop(ScopedId) ++ addDotValue(S, ScopedId); + false -> + to_dotLoop(S,ScopedId) + end. + +addDotValue(S, [_C | Ss]) -> + case isInterfaceScopedId(S, Ss) of + true -> + ""; + false -> + ".value" + end. + +to_dotLoop(S,[X]) -> + case isInterfaceScopedId(S, [X]) of + true -> + ic_forms:get_java_id(X) ++ "Package"; + false -> + ic_forms:get_java_id(X) + end; +to_dotLoop(S,[X | Xs]) -> + case isInterfaceScopedId(S, [X | Xs]) of + true -> + to_dotLoop(S,Xs) ++ "." ++ ic_forms:get_java_id(X) ++ "Package"; + false -> + to_dotLoop(S,Xs) ++ "." ++ ic_forms:get_java_id(X) + end; +to_dotLoop(_S,[]) -> "". + +isInterfaceScopedId(_S,[]) -> + false; +isInterfaceScopedId(S,[X|Xs]) -> + case ets:match(S,{file_data_local,'_','_',interface,Xs,X,'_','_','_'}) of + [] -> + case ets:match(S,{file_data_included,'_','_',interface,Xs,X,'_','_','_'}) of + [] -> + false; + _ -> + true + end; + _ -> + true + end. + +isConstScopedId(_S,[]) -> + false; +isConstScopedId(S,[X|Xs]) -> + case ets:match(S,{file_data_local,'_','_',const,Xs,X,'_','_','_'}) of + [] -> + case ets:match(S,{file_data_included,'_','_',const,Xs,X,'_','_','_'}) of + [] -> + false; + _ -> + true + end; + _ -> + true + end. + + + +%% +adjustScopeToJava(G,X) when element(1, X) == scoped_id -> + S = ic_genobj:pragmatab(G), + ScopedId = ic_symtab:scoped_id_strip(X), + case isConstScopedId(S, ScopedId) of %% Costants are left as is + true -> + ic_forms:get_java_id(ScopedId); + false -> + adjustScopeToJavaLoop(S,ScopedId) + end; +adjustScopeToJava(G,ScopedId) -> + S = ic_genobj:pragmatab(G), + case isConstScopedId(S, ScopedId) of %% Costants are left as is + true -> + ic_forms:get_java_id(ScopedId); + false -> + adjustScopeToJavaLoop(S,ScopedId) + end. + + + +adjustScopeToJavaLoop(_S,[]) -> + []; +adjustScopeToJavaLoop(S,[X | Xs]) -> + case isInterfaceScopedId(S, [X | Xs]) of + true -> + [ic_forms:get_java_id(X) ++ "Package" | adjustScopeToJavaLoop(S,Xs)]; + false -> + [ic_forms:get_java_id(X) | adjustScopeToJavaLoop(S,Xs)] + end. + + +%% +%% Expression evaluator for java +%% +%% Well, this is not an evaluator, it just +%% prints the hole operation, sorry. +%% +eval_java(G,N,Arg) when is_record(Arg, scoped_id) -> + {FSN, _, _, _} = + ic_symtab:get_full_scoped_name(G, N, Arg), + ic_util:to_dot(G,FSN); +eval_java(_G,_N,Arg) when is_tuple(Arg) andalso element(1,Arg) == '' -> + element(3,Arg); +eval_java(_G,_N,Arg) when is_tuple(Arg) andalso element(1,Arg) == '' -> + element(3,Arg); +eval_java(_G,_N,Arg) when is_tuple(Arg) andalso element(1,Arg) == '' -> + element(3,Arg); +eval_java(_G,_N,Arg) when is_tuple(Arg) andalso element(1,Arg) == '' -> + element(3,Arg); +eval_java(_G,_N,Arg) when is_tuple(Arg) andalso element(1,Arg) == '' -> + element(3,Arg); +eval_java(_G,_N,Arg) when is_tuple(Arg) andalso element(1,Arg) == '' -> + element(3,Arg); +eval_java(_G,_N,Arg) when is_tuple(Arg) andalso element(1,Arg) == '' -> + element(3,Arg); +eval_java(G,N,{Op,Arg1,Arg2}) -> + "(" ++ eval_java(G,N,Arg1) ++ + ic_forms:get_java_id(Op) ++ + eval_java(G,N,Arg2) ++ ")". + + + +%% +%% Expression evaluator for c +%% +%% Well, this is not an evaluator, it just +%% prints the hole operation, sorry. +%% +eval_c(G,N,Arg) when is_record(Arg, scoped_id) -> + {FSN, _, _, _} = + ic_symtab:get_full_scoped_name(G, N, Arg), + ic_util:to_undersc(FSN); +eval_c(_G,_N,Arg) when is_tuple(Arg) andalso element(1,Arg) == '' -> + element(3,Arg); +eval_c(_G,_N,Arg) when is_tuple(Arg) andalso element(1,Arg) == '' -> + element(3,Arg); +eval_c(_G,_N,Arg) when is_tuple(Arg) andalso element(1,Arg) == '' -> + element(3,Arg); +eval_c(_G,_N,Arg) when is_tuple(Arg) andalso element(1,Arg) == '' -> + element(3,Arg); +eval_c(_G,_N,Arg) when is_tuple(Arg) andalso element(1,Arg) == '' -> + element(3,Arg); +eval_c(_G,_N,Arg) when is_tuple(Arg) andalso element(1,Arg) == '' -> + element(3,Arg); +eval_c(_G,_N,Arg) when is_tuple(Arg) andalso element(1,Arg) == '' -> + element(3,Arg); +eval_c(G,N,{Op,Arg1,Arg2}) -> + "(" ++ eval_c(G,N,Arg1) ++ + atom_to_list(Op) ++ + eval_c(G,N,Arg2) ++ ")". + + +%%----------------------------------------------------------------- +%% Internal functions +%%----------------------------------------------------------------- + + + + + + diff --git a/lib/ic/src/icenum.erl b/lib/ic/src/icenum.erl new file mode 100644 index 0000000000..0af200e229 --- /dev/null +++ b/lib/ic/src/icenum.erl @@ -0,0 +1,205 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1998-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% +%% +%% +%%----------------------------------------------------------------- +%% File: icenum.erl +%% +%% +%%----------------------------------------------------------------- +%% +%% Code generation for enum's. +%%----------------------------------------------------------------- +-module(icenum). + +-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"). + +%%----------------------------------------------------------------- +%% External exports +%%----------------------------------------------------------------- +-export([enum_gen/4]). + +%%----------------------------------------------------------------- +%% Internal exports +%%----------------------------------------------------------------- +-export([]). + +enum_gen(G, N, X, c) when is_record(X, enum) -> + emit_c_enum(G, N, X); +enum_gen(_G, _N, _X, _L) -> + ok. + + +emit_c_enum(G, N, X) -> + case ic_genobj:is_hrlfile_open(G) of + true -> + EnumName = [ic_forms:get_id2(X) | N], + + case ic_pragma:is_local(G,EnumName) of + true -> + + Fd = ic_genobj:hrlfiled(G), + EnumNameStr = ic_util:to_undersc(EnumName), + ic_code:insert_typedef(G, EnumNameStr, {enum, EnumNameStr}), + {tk_enum,_,_,EList} = ic_forms:get_tk(X), + emit(Fd, "\n#ifndef __~s__\n",[ic_util:to_uppercase(EnumNameStr)]), + emit(Fd, "#define __~s__\n",[ic_util:to_uppercase(EnumNameStr)]), + ic_codegen:mcomment_light(Fd, + [io_lib:format("Enum definition: ~s", + [EnumNameStr])], + c), + emit(Fd, "typedef CORBA_enum {", []), + emit_c_enum_values(G, N, Fd, EList), + emit(Fd, "} ~s ;\n\n", [EnumNameStr]), + create_c_enum_file(G, N, EnumNameStr, EList), + emit(Fd, "\n#endif\n\n"); + + false -> %% Do not generate included types att all. + ok + end; + + false -> + ok + end. + + +emit_c_enum_values(_G, N, Fd, [E]) -> + emit(Fd, "~s", [ic_util:to_undersc([E| N])]); +emit_c_enum_values(G, N, Fd, [E |Es]) -> + emit(Fd, "~s, ", [ic_util:to_undersc([E| N])]), + emit_c_enum_values(G, N, Fd, Es). + + +open_c_coding_file(G, Name) -> + SName = string:concat(ic_util:mk_oe_name(G, "code_"), Name), + FName = + ic_file:join(ic_options:get_opt(G, stubdir),ic_file:add_dot_c(SName)), + case file:open(FName, [write]) of + {ok, Fd} -> + {Fd, SName}; + Other -> + exit(Other) + end. + + +create_c_enum_file(G, N, Name, Elist) -> + + {Fd , SName} = open_c_coding_file(G, Name), + HFd = ic_genobj:hrlfiled(G), %% Write on stubfile header + HrlFName = filename:basename(ic_genobj:include_file(G)), + ic_codegen:emit_stub_head(G, Fd, SName, c), + emit(Fd, "#include \"~s\"\n\n",[HrlFName]), + + %% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + %% Fd = ic_genobj:stubfiled(G), %% Write on stubfile + %% HFd = ic_genobj:hrlfiled(G), %% Write on stubfile header + %% HrlFName = filename:basename(ic_genobj:include_file(G)), + %% emit(Fd, "#include \"~s\"\n\n",[HrlFName]), + %% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + emit(Fd, "char* ~s[~p] = {\n", [ic_util:mk_oe_name(G, Name), + length(Elist)]), + emit_c_enum_array_values(Fd, Elist), + emit(Fd, "};\n\n",[]), + emit_sizecount(G, N, Fd, HFd, Name, Elist), + emit_encode(G, N, Fd, HFd, Name, Elist), + emit_decode(G, N, Fd, HFd, Name, Elist), + file:close(Fd). + +emit_c_enum_array_values(Fd, [E]) -> + emit(Fd, " ~p\n", [E]); +emit_c_enum_array_values(Fd, [E |Es]) -> + emit(Fd, " ~p,\n", [E]), + emit_c_enum_array_values(Fd, Es). + + +emit_sizecount(G, _N, Fd, HFd, Name, _Elist) -> + + emit(HFd, "int ~s~s(CORBA_Environment *oe_env, int*, int*);\n", + [ic_util:mk_oe_name(G, "sizecalc_"), Name]), + + emit(Fd, "int ~s~s(CORBA_Environment *oe_env, int* oe_size_count_index, int* oe_size)\n" + "{\n", + [ic_util:mk_oe_name(G, "sizecalc_"), Name]), + emit(Fd, " int oe_error_code = 0;\n\n",[]), + + AlignName = lists:concat(["*oe_size + sizeof(",Name,")"]), + emit(Fd, " *oe_size = ~s;\n\n",[ic_util:mk_align(AlignName)]), + + emit(Fd, " if ((oe_error_code = ei_decode_atom(oe_env->_inbuf, oe_size_count_index, 0)) < 0) {\n"), + emit_c_enc_rpt(Fd, " ", "ei_decode_atom", []), + emit(Fd, " return oe_error_code;\n }\n"), + emit(Fd, " return 0;\n\n",[]), + emit(Fd, "}\n\n",[]). + + +emit_encode(G, _N, Fd, HFd, Name, _Elist) -> + + emit(HFd, "int ~s~s(CORBA_Environment *oe_env, ~s);\n", + [ic_util:mk_oe_name(G, "encode_"), Name, Name]), + + emit(Fd, "int ~s~s(CORBA_Environment *oe_env, ~s oe_rec) {\n", + [ic_util:mk_oe_name(G, "encode_"), Name, Name]), + emit(Fd, " int oe_error_code = 0;\n\n",[]), + + emit(Fd, " if ((oe_error_code = oe_ei_encode_atom(oe_env, ~s[oe_rec])) < 0) {\n", + [ic_util:mk_oe_name(G, Name)]), + emit_c_enc_rpt(Fd, " ", "oe_ei_encode_atom", []), + emit(Fd, " return oe_error_code;\n }\n"), + + emit(Fd, " return 0;\n\n",[]), + emit(Fd, "}\n\n",[]). + +emit_decode(G, _N, Fd, HFd, Name, Elist) -> + + emit(HFd, "int ~s~s(CORBA_Environment *oe_env, char *, int*, ~s *);\n", + [ic_util:mk_oe_name(G, "decode_"), Name, Name]), + + emit(Fd, "int ~s~s(CORBA_Environment *oe_env, char *oe_first, int* oe_outindex, " + "~s *oe_out) {\n\n", + [ic_util:mk_oe_name(G, "decode_"), Name, Name]), + emit(Fd, " int oe_error_code = 0;\n",[]), + emit(Fd, " int oe_i;\n",[]), + emit(Fd, " char oe_atom[256];\n\n",[]), + + AlignName = lists:concat(["*oe_outindex + sizeof(",Name,")"]), + emit(Fd, " *oe_outindex = ~s;\n\n",[ic_util:mk_align(AlignName)]), + + emit(Fd, " if ((oe_error_code = ei_decode_atom(oe_env->_inbuf, &oe_env->_iin, oe_atom)) < 0) {\n"), + emit_c_enc_rpt(Fd, " ", "ei_decode_atom", []), + emit(Fd, " return oe_error_code;\n }\n"), + + Len = length(Elist), + emit(Fd, " for(oe_i = 0; oe_i < ~p && strcmp(oe_atom, ~s[oe_i]); oe_i++);\n", + [Len, ic_util:mk_oe_name(G, Name)]), + emit(Fd, " *oe_out = oe_i;\n\n", []), + + emit(Fd, " if (oe_i == ~p) {\n",[Len]), + emit_c_enc_rpt(Fd, " ", "decode atom failure", []), + emit(Fd, " return oe_error_code;\n }\n"), + + emit(Fd, " return 0;\n",[]), + emit(Fd, "}\n\n",[]). + + + + + diff --git a/lib/ic/src/iceval.erl b/lib/ic/src/iceval.erl new file mode 100644 index 0000000000..81093dcd5b --- /dev/null +++ b/lib/ic/src/iceval.erl @@ -0,0 +1,555 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1997-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(iceval). + +-include("icforms.hrl"). + +-export([eval_const/5, eval_e/5]). + +-export([check_tk/3, get_val/1, mk_val/1]). + +-define(get_max(__X, __Y), if __X > __Y -> __X; true -> __Y end). +-define(get_min(__X, __Y), if __X > __Y -> __Y; true -> __X end). + +-define(BASE, 100000000000000000000000000000000). +-define(FIXED_MAX, 9999999999999999999999999999999). + +%% Called fr: ictype 99, 522, 533 +%% Fixed constants can be declared as: +%% (1) const fixed pi = 3.14D; or +%% (2) typedef fixed<3,2> f32; +%% const f32 pi = 3.14D; +%% Hence, if fixed is declared as (1) we must handle it especially. +eval_const(G, S, N, tk_fixed, Expr) -> + case catch eval_e(G, S, N, tk_fixed, Expr) of + T when element(1, T) == error -> 0; + V when is_record(V, fixed) -> + {ok, {tk_fixed, V#fixed.digits, V#fixed.scale}, V}; + V -> + ic_error:error(G, {bad_tk_match, Expr, tk_fixed, get_val(V)}) + end; +eval_const(G, S, N, TK, Expr) -> + case catch eval_e(G, S, N, TK, Expr) of + T when element(1, T) == error -> 0; + V -> + case check_tk(G, TK, V) of + true -> ok; + false -> + ic_error:error(G, {bad_tk_match, Expr, TK, get_val(V)}) + end, + get_val(V) + end. + + +check_op(G, S, N, Tk, Types, Op, E1, E2) -> + V1 = eval_e(G, S, N, Tk, E1), + V2 = eval_e(G, S, N, Tk, E2), + check_types(G, Op, E1, Types, V1), + check_types(G, Op, E2, Types, V2), + case check_comb(V1, V2) of + true -> + {V1, V2}; + false -> + Err = {bad_type_combination, E1, get_val(V1), get_val(V2)}, + ic_error:error(G, Err), + throw({error, Err}) + end. + +check_op(G, S, N, Tk, Types, Op, E1) -> + V1 = eval_e(G, S, N, Tk, E1), + check_types(G, Op, E1, Types, V1), + V1. + +%% Match the declared type TK against the factual value of an constant +%% +check_tk(_G, _Any, default) -> true; % Default case in union +check_tk(_G, positive_int, V) when is_integer(V) andalso V >= 0 -> true; +check_tk(_G, tk_long, V) when is_integer(V) -> true; +check_tk(_G, tk_longlong, V) when is_integer(V) -> true; %% LLON_G +check_tk(_G, tk_short, V) when is_integer(V) -> true; +check_tk(_G, tk_ushort, V) when is_integer(V) andalso V >= 0 -> true; +check_tk(_G, tk_ulong, V) when is_integer(V) andalso V >= 0 -> true; +check_tk(_G, tk_ulonglong, V) when is_integer(V) andalso V >= 0 -> true; %% ULLON_G +check_tk(_G, tk_float, V) when is_float(V) -> true; +check_tk(_G, tk_double, V) when is_float(V) -> true; +check_tk(_G, tk_boolean, V) -> is_bool(V); +check_tk(_G, tk_char, {char, _V}) -> true; +check_tk(_G, tk_wchar, {wchar, _V}) -> true; %% WCHAR +check_tk(_G, {tk_string, _Len}, {string, _V}) -> true; +check_tk(_G, {tk_wstring, _Len}, {wstring, _V}) -> true; %% WSTRING +check_tk(_G, {tk_fixed, Digits, Scale}, {fixed, Digits, Scale, _V}) -> true; +check_tk(_G, tk_octet, V) when is_integer(V) -> true; +%%check_tk(_G, tk_null, V) when integer(V) -> true; +%%check_tk(_G, tk_void, V) when integer(V) -> true; +%%check_tk(_G, tk_any, V) when integer(V) -> true; +%%check_tk(_G, {tk_objref, "", "Object"}, V) when integer(V) -> true. +check_tk(_G, {tk_enum, _, _, Body}, {enum_id, Id}) -> + until(fun(X) when X == Id -> true; + (_X) -> + false + end, Body); +check_tk(_G, _TK, _V) -> + false. + +get_val({string, X}) -> X; +get_val({wstring, X}) -> X; %% WCHAR +get_val({char, X}) -> X; +get_val({wchar, X}) -> X; %% WSTRING +get_val({enum_id, X}) -> X; +get_val(X) -> X. + +check_types(G, Op, Expr, TypeList, V) -> + case until(fun(int) when is_integer(V) -> true; + (float) when is_float(V) -> true; + (bool) when V==true -> true; + (bool) when V==false -> true; + (fixed) when is_record(V, fixed) -> true; + (_) -> false end, + TypeList) of + true -> true; + false -> + Err = {bad_type, Expr, Op, TypeList, V}, + ic_error:error(G, Err), + throw({error, Err}) + end. + +%%get_op(T) when tuple(T) -> element(1, T). + +%% Should be in lists +until(F, [H|T]) -> + case F(H) of + true -> true; + false -> until(F, T) + end; +until(_F, []) -> false. + +%% Section of all the boolean operators (because Erlang ops don't like +%% boolean values. +e_or(X, Y) when is_integer(X) andalso is_integer(Y) -> X bor Y; +e_or(true, _) -> true; +e_or(_, true) -> true; +e_or(_, _) -> false. + +e_and(X, Y) when is_integer(X) andalso is_integer(Y) -> X band Y; +e_and(true, true) -> true; +e_and(_, _) -> false. + +e_xor(X, Y) when is_integer(X) andalso is_integer(Y) -> X bxor Y; +e_xor(X, X) -> false; +e_xor(_, _) -> true. + +%% Handling infix operators (+,-,*,/) for fixed type. +%% Boundries determined as fixed +e_fixed_add(#fixed{digits = D1, scale = S1, value = V1}, + #fixed{digits = D2, scale = S2, value = V2}) -> + Scale = ?get_max(S1, S2), + Digits = ?get_max((D1-S1), (D2-S2)) + Scale +1, + %% We must normalize the values before adding. Why? + %% 4.23 and 5.2 are represented as 423 and 52. To be able to get the + %% correct result we must add 4230 and 5200 == 9430. + {PV1, PV2} = normalize(S1, V1, S2, V2), + check_fixed_overflow(#fixed{digits = Digits, + scale = Scale, + value = (PV1 + PV2)}). + +%% Boundries determined as fixed +e_fixed_sub(#fixed{digits = D1, scale = S1, value = V1}, + #fixed{digits = D2, scale = S2, value = V2}) -> + Scale = ?get_max(S1, S2), + Digits = ?get_max((D1-S1), (D2-S2)) + Scale +1, + {PV1, PV2} = normalize(S1, V1, S2, V2), + check_fixed_overflow(#fixed{digits = Digits, + scale = Scale, + value = (PV1 - PV2)}). + +%% Boundries determined as fixed +e_fixed_mul(#fixed{digits = D1, scale = S1, value = V1}, + #fixed{digits = D2, scale = S2, value = V2}) -> + check_fixed_overflow(#fixed{digits = (D1+D2), + scale = (S1+S2), + value = V1*V2}). + +%% Boundries determined as fixed<(d1-s1+s2) + s inf ,s inf> +e_fixed_div(#fixed{digits = D1, scale = S1, value = V1}, + #fixed{digits = _D2, scale = S2, value = V2}) -> + {PV1, PV2} = normalize(S1, V1, S2, V2), + DigitsMin = (D1-S1+S2), + R1 = (PV1 div PV2), + R2 = (R1*?BASE + (PV1 rem PV2) * (?BASE div PV2)), + {Result2, Sinf} = delete_zeros_value(R2, 0, R1), + check_fixed_overflow(#fixed{digits = DigitsMin + Sinf, scale = Sinf, + value = Result2}). + + +%% Checks combination of argument types, basically floats and ints are +%% interchangeable, and all types are allowed with themselves. No +%% other combinations are allowed +%% +check_comb(X, Y) when is_integer(X) andalso is_integer(Y) -> true; +check_comb(X, Y) when is_float(X) andalso is_integer(Y) -> true; +check_comb(X, Y) when is_integer(X) andalso is_float(Y) -> true; +check_comb(X, Y) when is_float(X) andalso is_float(Y) -> true; +check_comb({X, _}, {X, _}) -> true; % Strings and chars are tuples +check_comb({fixed, _, _, _}, {fixed, _, _, _}) -> true; +check_comb(X, Y) -> + case {is_bool(X), is_bool(Y)} of + {true, true} -> + true; + _ -> + false + end. + +is_bool(true) -> true; +is_bool(false) -> true; +is_bool(_) -> false. + + +%%%% (15) +eval_e(G, S, N, Tk, {'or', T1, T2}) -> + {E1, E2} = check_op(G, S, N, Tk, [int, bool], 'or', T1, T2), + e_or(E1, E2); + +%%%% (16) +eval_e(G, S, N, Tk, {'xor', T1, T2}) -> + {E1, E2} = check_op(G, S, N, Tk, [int, bool], 'xor', T1, T2), + e_xor(E1, E2); + +%%%% (17) +eval_e(G, S, N, Tk, {'and', T1, T2}) -> + {E1, E2} = check_op(G, S, N, Tk, [int, bool], 'and', T1, T2), + e_and(E1, E2); + +%%%% (18) +eval_e(G, S, N, Tk, {'rshift', T1, T2}) -> + {E1, E2} = check_op(G, S, N, Tk, [int], 'rshift', T1, T2), + E1 bsr E2; +eval_e(G, S, N, Tk, {'lshift', T1, T2}) -> + {E1, E2} = check_op(G, S, N, Tk, [int], 'lshift', T1, T2), + E1 bsl E2; + +%%%% (19) +eval_e(G, S, N, Tk, {'+', T1, T2}) -> + case check_op(G, S, N, Tk, [int, float, fixed], '+', T1, T2) of + {F1, F2} when is_record(F1,fixed) andalso is_record(F2,fixed) -> + e_fixed_add(F1, F2); + {E1, E2} -> + E1 + E2 + end; +eval_e(G, S, N, Tk, {'-', T1, T2}) -> + case check_op(G, S, N, Tk, [int, float, fixed], '-', T1, T2) of + {F1, F2} when is_record(F1,fixed) andalso is_record(F2,fixed) -> + e_fixed_sub(F1, F2); + {E1, E2} -> + E1 - E2 + end; + +%%%% (20) +eval_e(G, S, N, Tk, {'*', T1, T2}) -> + case check_op(G, S, N, Tk, [int, float, fixed], '*', T1, T2) of + {F1, F2} when is_record(F1,fixed) andalso is_record(F2,fixed) -> + e_fixed_mul(F1, F2); + {E1, E2} -> + E1 * E2 + end; +eval_e(G, S, N, Tk, {'/', T1, T2}) -> + case check_op(G, S, N, Tk, [int, float, fixed], '/', T1, T2) of + {F1, F2} when is_record(F1,fixed) andalso is_record(F2,fixed) -> + e_fixed_div(F1, F2); + {E1, E2} -> + E1 / E2 + end; +eval_e(G, S, N, Tk, {'%', T1, T2}) -> + {E1, E2} = check_op(G, S, N, Tk, [int], '%', T1, T2), + E1 rem E2; + +%%%% (21) +eval_e(G, S, N, Tk, {{'-', _Line}, T}) -> + case check_op(G, S, N, Tk, [int, float, fixed], '-', T) of + F when is_record(F,fixed) -> + F#fixed{value = -(F#fixed.value)}; + Number -> + -Number + end; +eval_e(G, S, N, Tk, {{'+', _Line}, T}) -> + check_op(G, S, N, Tk, [int, float, fixed], '+', T); +eval_e(G, S, N, Tk, {{'~', Line}, T}) -> + ic_error:error(G, {unsupported_op, {'~', Line}}), + eval_e(G, S, N, Tk, T); + + +%% Ints are repr. by an Erlang integer val, floats and doubles by +%% Erlang floats, chars and strings must be tuplerized for type +%% checking. These tuples are removed just before returning from top +%% function. +%% +eval_e(_G, _S, _N, tk_fixed, {'', _Line, X}) -> + create_fixed(X); +eval_e(G, _S, _N, {tk_fixed, Digits, Scale}, {'', Line, X}) + when Digits < 32, Digits >= Scale -> + case convert_fixed(X, [], Digits, Digits-Scale) of + {error, Format, Args} -> + ic_error:error(G, {bad_fixed, Format, Args, Line}); + FixedData -> + {fixed, Digits, Scale, FixedData} + end; +eval_e(_G, _S, _N, _Tk, {'', _Line, X}) -> list_to_integer(X); +eval_e(_G, _S, _N, {tk_string,_}, {'', _Line, X}) -> {string, X}; +eval_e(_G, _S, _N, {tk_wstring,_}, {'', _Line, X}) -> {wstring, X}; %% WSTRING +eval_e(_G, _S, _N, tk_char, {'', _Line, X}) -> {char, hd(X)}; +eval_e(_G, _S, _N, tk_wchar, {'', _Line, X}) -> {wchar, hd(X)}; %% WCHAR +eval_e(_G, _S, _N, _Tk, {'TRUE', _Line}) -> true; +eval_e(_G, _S, _N, _Tk, {'FALSE', _Line}) -> false; +eval_e(_G, _S, _N, _Tk, {'', _Line, X}) -> to_float(X); +%% Some possible error conditions +eval_e(_G, _S, _N, _Tk, {'', _Line, X}) -> {char, hd(X)}; %% ERROR? +%% +eval_e(G, S, N, _Tk, X) when element(1, X) == scoped_id -> + mk_val(ictype:scoped_lookup(G, S, N, X)); +eval_e(_G, _S, _N, _Tk, {default, _}) -> default; % Default case in union +eval_e(G, _S, _N, Tk, Val) -> + ic_error:error(G, {plain_error_string, Val, + io_lib:format("value and declared type ~p differ", [Tk])}). + +%% A fixed type can be 123.45 or 123 but we represent it as integers (i.e. 12345 or 123). +convert_fixed([], Acc, 0, _) -> + list_to_integer(lists:reverse(Acc)); +convert_fixed([], _Acc, _, _) -> + {error, "Fixed type do not match the digits field", []}; +convert_fixed([$.|Rest], Acc, Digits, 0) -> + convert_fixed(Rest, Acc, Digits, -1); +convert_fixed([$.|_Rest], _Acc, _, _) -> + {error, "Fixed decimal point placed incorrectly", []}; +convert_fixed([X|Rest], Acc, Digits, Position) -> + convert_fixed(Rest, [X|Acc], Digits-1, Position-1). + + +create_fixed([$0|Rest]) -> + %% Leading zeros shall be ignored. + create_fixed(Rest); +create_fixed(Fixed) -> + create_fixed(Fixed, [], 0, 0, false). + +create_fixed([], Acc, Total, Frac, true) -> + {Fixed, N} = remove_trailing_zeros(Acc, 0), + Digits = Total-N, + Scale = Frac-N, + #fixed{digits = Digits, scale = Scale, value = list_to_integer(Fixed)}; +create_fixed([], Acc, Total, _Frac, false) -> + %% A '.' never found. Hence, must be 2000D + #fixed{digits = Total, scale = 0, value = list_to_integer(lists:reverse(Acc))}; +create_fixed([$.|Rest], Acc, Total, _, _) -> + create_fixed(Rest, Acc, Total, 0, true); +create_fixed([X|Rest], Acc, Total, Frac, FoundDot) -> + create_fixed(Rest, [X|Acc], Total+1, Frac+1, FoundDot). + +remove_trailing_zeros([$0|Rest], N) -> + remove_trailing_zeros(Rest, N+1); +remove_trailing_zeros(Fixed, N) -> + {lists:reverse(Fixed), N}. + +%% Make the newly looked up value a value that can be type checked. +mk_val({_, _, {tk_string, _}, V}) -> {string, V}; +mk_val({_, _, {tk_wstring, _}, V}) -> {wstring, V}; %% WSTRING +mk_val({_, _, tk_char, V}) -> {char, V}; +mk_val({_, _, tk_wchar, V}) -> {wchar, V}; %% WCHAR +mk_val({_, _, enum_val, V}) -> + {enum_id, ic_forms:get_id2(V)}; +mk_val(X) when element(1, X) == error -> X; +mk_val({_, _, _TK, V}) -> + V; +mk_val(V) -> V. + + + +%% Floating point numbers +%% +%% Conversion to Erlang floating points is neccessary because +%% list_to_float BIF differs from IDL floats. "1e2" ".4e2" is +%% allowed in IDL and must be translated to "1.0e2" and "0.4e2" + +to_float(X) -> + list_to_float(erlangify(X)). + +erlangify([$. | R]) -> + [$0, $. | R]; +erlangify(R) -> + look_for_dot(R). + +look_for_dot([$. | R]) -> [$. | dot_pending(R)]; +look_for_dot([$e | R]) -> [$., $0, $e | R]; +look_for_dot([$E | R]) -> [$., $0, $E | R]; +look_for_dot([X | R]) -> [X | look_for_dot(R)]. + +dot_pending([$e | R]) -> [$0, $e | R]; +dot_pending([$E | R]) -> [$0, $E | R]; +dot_pending([]) -> [$0]; +dot_pending(R) -> R. + + +%%------------------------------------------------------------------ +%%--------------- Fixed Datatype Helper Functions ------------------ +%%------------------------------------------------------------------ +%% Pretty?! No, but since we now the upper-limit this is the fastest way +%% to calculate 10^x +power(0) -> 1; +power(1) -> 10; +power(2) -> 100; +power(3) -> 1000; +power(4) -> 10000; +power(5) -> 100000; +power(6) -> 1000000; +power(7) -> 10000000; +power(8) -> 100000000; +power(9) -> 1000000000; +power(10) -> 10000000000; +power(11) -> 100000000000; +power(12) -> 1000000000000; +power(13) -> 10000000000000; +power(14) -> 100000000000000; +power(15) -> 1000000000000000; +power(16) -> 10000000000000000; +power(17) -> 100000000000000000; +power(18) -> 1000000000000000000; +power(19) -> 10000000000000000000; +power(20) -> 100000000000000000000; +power(21) -> 1000000000000000000000; +power(22) -> 10000000000000000000000; +power(23) -> 100000000000000000000000; +power(24) -> 1000000000000000000000000; +power(25) -> 10000000000000000000000000; +power(26) -> 100000000000000000000000000; +power(27) -> 1000000000000000000000000000; +power(28) -> 10000000000000000000000000000; +power(29) -> 100000000000000000000000000000; +power(30) -> 1000000000000000000000000000000; +power(31) -> 10000000000000000000000000000000; +power(_) -> 10000000000000000000000000000000. + + + +%% If the result of an operation (+, -, * or /) causes overflow we use this +%% operation. However, since these calculations are performed during compiletime, +%% shouldn't the IDL-specification be changed to not cause overflow?! But, since +%% the OMG standard allows this we must support it. +check_fixed_overflow(#fixed{digits = Digits, scale = Scale, value = Value}) -> + case count_digits(abs(Value)) of + overflow -> + {N, NewVal} = cut_overflow(0, Value), +% NewDigits = Digits - N, + if + N > Scale -> + #fixed{digits = 31, scale = 0, value = NewVal}; + true -> + NewScale = Scale - N, + {NewVal2, Removed} = delete_zeros(NewVal, NewScale), + #fixed{digits = 31, scale = NewScale-Removed, value = NewVal2} + end; + Count when Count > Digits -> + Diff = Count-Digits, + if + Diff > Scale -> + #fixed{digits = Digits, scale = 0, + value = (Value div power(Diff))}; + true -> + NewScale = Scale-Diff, + {NewVal, Removed} = delete_zeros((Value div power(Diff)), NewScale), + #fixed{digits = Digits-Removed, + scale = NewScale-Removed, + value = NewVal} + end; + Count -> + {NewVal, Removed} = delete_zeros(Value, Scale), + #fixed{digits = Count-Removed, scale = Scale-Removed, value = NewVal} + end. + +%% This function see to that the values are of the same baase. +normalize(S, V1, S, V2) -> + {V1, V2}; +normalize(S1, V1, S2, V2) when S1 > S2 -> + {V1, V2*power(S1-S2)}; +normalize(S1, V1, S2, V2) -> + {V1*power(S2-S1), V2}. + +%% If we have access to the integer part of the fixed type we use this +%% operation to remove all trailing zeros. If we know the scale, length of +%% fraction part, we can use delete_zeros as well. But, after a division +%% it's hard to know the scale and we don't need to calcluate the integer part. +delete_zeros_value(0, N, _) -> + {0, 32-N}; +delete_zeros_value(X, N, M) when X > M, (X rem 10) == 0 -> + delete_zeros_value((X div 10), N+1, M); +delete_zeros_value(X, N, _) -> + {X, 32-N}. + +%% If we know the exact scale of a fixed type we can use this operation to +%% remove all trailing zeros. +delete_zeros(0, _) -> + {0,0}; +delete_zeros(X, Max) -> + delete_zeros(X, 0, Max). +delete_zeros(X, Max, Max) -> + {X, Max}; +delete_zeros(X, N, Max) when (X rem 10) == 0 -> + delete_zeros((X div 10), N+1, Max); +delete_zeros(X, N, _) -> + {X, N}. + +cut_overflow(N, X) when X > ?FIXED_MAX -> + cut_overflow(N+1, (X div 10)); +cut_overflow(N, X) -> + {N, X}. + +%% A fast way to check the size of a fixed data type. +count_digits(X) when X > ?FIXED_MAX -> overflow; +count_digits(X) when X >= 1000000000000000000000000000000 -> 31; +count_digits(X) when X >= 100000000000000000000000000000 -> 30; +count_digits(X) when X >= 10000000000000000000000000000 -> 29; +count_digits(X) when X >= 1000000000000000000000000000 -> 28; +count_digits(X) when X >= 100000000000000000000000000 -> 27; +count_digits(X) when X >= 10000000000000000000000000 -> 26; +count_digits(X) when X >= 1000000000000000000000000 -> 25; +count_digits(X) when X >= 100000000000000000000000 -> 24; +count_digits(X) when X >= 10000000000000000000000 -> 23; +count_digits(X) when X >= 1000000000000000000000 -> 22; +count_digits(X) when X >= 100000000000000000000 -> 21; +count_digits(X) when X >= 10000000000000000000 -> 20; +count_digits(X) when X >= 1000000000000000000 -> 19; +count_digits(X) when X >= 100000000000000000 -> 18; +count_digits(X) when X >= 10000000000000000 -> 17; +count_digits(X) when X >= 1000000000000000 -> 16; +count_digits(X) when X >= 100000000000000 -> 15; +count_digits(X) when X >= 10000000000000 -> 14; +count_digits(X) when X >= 1000000000000 -> 13; +count_digits(X) when X >= 100000000000 -> 12; +count_digits(X) when X >= 10000000000 -> 11; +count_digits(X) when X >= 1000000000 -> 10; +count_digits(X) when X >= 100000000 -> 9; +count_digits(X) when X >= 10000000 -> 8; +count_digits(X) when X >= 1000000 -> 7; +count_digits(X) when X >= 100000 -> 6; +count_digits(X) when X >= 10000 -> 5; +count_digits(X) when X >= 1000 -> 4; +count_digits(X) when X >= 100 -> 3; +count_digits(X) when X >= 10 -> 2; +count_digits(_X) -> 1. + +%%------------------------------------------------------------------ +%%--------------- END Fixed Datatype Helper Functions -------------- +%%------------------------------------------------------------------ diff --git a/lib/ic/src/icforms.hrl b/lib/ic/src/icforms.hrl new file mode 100644 index 0000000000..d1869e6330 --- /dev/null +++ b/lib/ic/src/icforms.hrl @@ -0,0 +1,68 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1997-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 documentation: +%% --------------------- +%% +%% Header file for the Erlang IDL compiler. Contains all records +%% used in the parse tree +%% +%% +%%------------------------------------------------------------ + + + +%%------------------------------------------------------------ + +-record(module, {id, body}). +-record(interface, {id, inherit, body, inherit_body, tk}). +-record(forward, {id, tk}). +-record(const, {type, id, val, tk}). +-record(type_dcl, {type, tk}). +-record(typedef, {type, id, tk}). +-record(struct, {id, body, tk}). +-record(member, {type, id}). +-record(union, {id, type, body, tk}). +-record(case_dcl, {label, id, type}). +-record(enum, {id, body, tk}). +-record(enumerator, {id}). +-record(sequence, {type, length=0}). +-record(string, {length=0}). +-record(wstring, {length=0}). %% WSTRING +-record(array, {id, size}). +-record(attr, {readonly, type, id, tk}). +-record(except, {id, body, tk}). +-record(op, {oneway, type, id, params, raises, ctx, tk}). +-record(param, {inout, type, id, tk}). +-record(fixed, {digits, scale, value}). + +%% NON-STANDARD +-record(preproc, {cat, id, aux}). +-record(pragma, {type, to, apply}). + + + + + + + + + + diff --git a/lib/ic/src/icparse.yrl b/lib/ic/src/icparse.yrl new file mode 100644 index 0000000000..25b0f452e7 --- /dev/null +++ b/lib/ic/src/icparse.yrl @@ -0,0 +1,864 @@ +%% +%% 1997-2007 +%% Ericsson AB, 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. +%% +%% The Initial Developer of the Original Code is Ericsson AB. +%% +%% +%%------------------------------------------------------------ +%% Yecc spec for IDL +%% +%% +%% +%% Implementation Detail: +%% OorM_ means OneORMany and is used instead of +%% the "+" BNF notation +%% ZorM_ means ZeroORMany and is used instead of +%% the "*" BNF notation +%% +%% All the reverse/1 calls are because yecc+lists naturally leads +%% to reversed lists, which then have to be reversed. Maybe fix +%% this? +%% +%% Implementation history +%% +%% The IDL language supported is not the complete IDL. We skipped +%% the multiple declarator syntax allowed (i.e. typedef long T1, +%% T2). This also applies to attributes members in structs, +%% unions and exceptions, and to case labels in unions. The cases +%% where IDL has been altered is marked with comments containing +%% NIY. +%% +%% Above is chaging. Whenever we change a clause, we put (FIXED) in +%% its comment. +%% +%%------------------------------------------------------------ + + + + + +Nonterminals + '' + '' + '' + 'OorM_' + '' + '' + '' + '' + '' + '' + '' + 'ZorM_' + 'Opt_' + '' + '' + '' + '' + '' + '' + 'ZorM_' + 'Opt_' + '' + '' + '' + '' + '' + 'OorM_' + '' + '' + '' + '' + '' + '' + '' + '' + 'ZorM_' + '' + '' + '' + 'OorM_' + '' + '' + '' + '' + 'OorM_' + '' + '' + '' + '' + '' + '' + '' + '' + '' + '' + '' + '' + '' + '' + '' + '' + 'Opt_' + '' + '' + 'ZorM_' + '' + '' + '' + 'ZorM_' + 'ZorM_' + '' + '' + '' + '' + 'Opt_readonly' + '' + '' + '' + 'OorM_' + '' + '' + '' + '' + '' + '' + 'Opt_' + 'ZorM_' + '' + '' + '' + '' + 'ZorM_' + '' + 'OE_preproc' % NON standard + 'OE_pragma' % NON standard + 'Ugly_pragmas' % NON standard + 'ZorM_' + '' + '' + . + + +Terminals + '#' + 'in' + '[' + 'interface' + '(' + 'case' + 'union' + 'struct' + '' + '' + ')' + ']' + 'any' + 'long' + 'float' + 'out' + '*' + '^' + 'enum' + 'double' + '+' + 'context' + 'oneway' + 'sequence' + ',' + 'FALSE' + '' + '{' + 'readonly' + ':' + '-' + 'void' + ';' + 'char' + 'wchar' %% WCHAR + '|' + 'inout' + '}' + 'attribute' + '<' + 'octet' + '/' + 'TRUE' + '~' + '=' + '>' + 'switch' + 'unsigned' + 'typedef' + '>>' + 'const' + '' + '' + 'raises' + 'string' + 'wstring' + 'fixed' + 'default' + 'short' + '%' + '<<' + 'module' + 'exception' + 'boolean' + '' + '' + '' + '&' + '::' + 'Object' + . + + +Rootsymbol ''. + + +%%------------------------------------------------------------ +%% Clauses +%% + +%% Handling of pragmas. +%% Pragma prefix, id and version are not standard. + +%% pragma prefix, or codeopt +OE_pragma -> '#' '' '' + '' '' '#' + : #pragma{type='$4', to=followed, apply='$5'} . + +%% pragma id +OE_pragma -> '#' '' '' + '' '' '' '#' + : #pragma{type='$4', to='$5', apply='$6'} . + +%% pragma version +OE_pragma -> '#' '' '' + '' '' '' '#' + : #pragma{type='$4', to='$5', apply=ic_options:float_to_version('$6')} . + + + + + + + +%% Ugly pragmas +Ugly_pragmas -> '$empty' : []. +Ugly_pragmas -> 'Ugly_pragmas' 'OE_pragma' : ['$2'|'$1']. + + + +%% (0) Handling of preprocessor stuff. + +OE_preproc -> '#' '#' . + +OE_preproc -> '#' '' '' + 'ZorM_' '#' + : case '$4' of + [] -> + case '$2' of + {_,_,"1"} -> + #preproc{cat=line_nr, id='$3', aux='$4'}; + _ -> + [] + end; + _ -> + #preproc{cat=line_nr, id='$3', aux='$4'} + end. + +%% (0b) Non-standard +'ZorM_' -> '$empty' : [] . +'ZorM_' -> '' 'ZorM_' + : ['$1' | '$2'] . + +%% (1) +'' -> 'OorM_' : reverse('$1') . + + +%% Added clause +'OorM_' -> '' : ['$1'] . +'OorM_' -> 'OorM_' '' +: ['$2' | '$1'] . + + +%% (2) +'' -> '' ';' : '$1' . +'' -> '' ';' : '$1' . +'' -> '' ';' : '$1' . +'' -> '' ';' : '$1' . +'' -> '' ';' : '$1' . +'' -> 'OE_preproc' : '$1' . +'' -> 'OE_pragma' : '$1' . + + +%% (3) +'' -> 'module' '' '{' 'OorM_' '}' +: #module{ id='$2', body=reverse('$4')}. + + +%% (4) +'' -> '' : '$1' . +'' -> '' : '$1' . + + +%% (5) +'' -> '' '{' '' '}' + : #interface{id=element(1, '$1'), inherit=element(2, '$1'), + body=lists:reverse('$3')} . + + +%% (6) +'' -> 'interface' '' +: #forward{id='$2'} . + + +%% (7) +'' -> 'interface' '' 'Opt_' +: {'$2', '$3'} . + + +%% (8) +'' -> 'ZorM_' : '$1' . + + +%% Added clause +'ZorM_' -> '$empty' : [] . +'ZorM_' -> 'ZorM_' '' + %% Complicated because might be a list (of type defs for instance) + : if is_list('$2') -> '$2' ++ '$1'; + true -> ['$2' | '$1'] + end . + + +%% (9) +'' -> '' ';' : '$1' . +'' -> '' ';' : '$1' . +'' -> '' ';' : '$1' . +'' -> '' ';' : '$1' . +'' -> '' ';' : '$1' . +'' -> 'OE_preproc' : '$1' . +'' -> 'OE_pragma' : '$1' . + +%% Added clause +'Opt_' -> '$empty' : []. +'Opt_' -> '' : '$1'. + +%% (10) +'' -> ':' '' 'ZorM_' + : ['$2' | reverse('$3')] . + + +%% Added clause +'ZorM_' -> '$empty' : [] . +'ZorM_' -> 'ZorM_' ',' '' + : ['$3' | '$1'] . + + +%% (11) +'' -> '' : ic_symtab:scoped_id_new('$1') . +'' -> '::' '' : ic_symtab:scoped_id_new_global('$2') . +'' -> '' '::' '' + : ic_symtab:scoped_id_add('$1', '$3') . + + +%% (12) +'' -> 'const' '' '' '=' '' + : #const{type='$2', id='$3', val='$5'} . + + +%% (13) +'' -> '' : '$1' . +'' -> '' : '$1' . +'' -> '' : '$1' . +'' -> '' : '$1' . +'' -> '' : '$1' . +'' -> '' : '$1' . +'' -> '' : '$1' . +'' -> '' : '$1' . + + +%% (14) +'' -> '' : '$1' . + + +%% (15) +'' -> '' : '$1' . +'' -> '' '|' '' : {'or', '$1', '$3'} . + + +%% (16) +'' -> '' : '$1' . +'' -> '' '^' '' : {'xor', '$1', '$3'} . + + +%% (17) +'' -> '' : '$1' . +'' -> '' '&' '' : {'and', '$1', '$3'} . + + +%% (18) +'' -> '' : '$1' . +'' -> '' '>>' '' : {'rshift', '$1', '$3'} . +'' -> '' '<<' '' : {'lshift', '$1', '$3'} . + + +%% (19) +'' -> '' : '$1' . +'' -> '' '+' '' : {'+', '$1', '$3'} . +'' -> '' '-' '' : {'-', '$1', '$3'} . + + +%% (20) +'' -> '' : '$1' . +'' -> '' '*' '' : {'*', '$1', '$3'} . +'' -> '' '/' '' : {'/', '$1', '$3'} . +'' -> '' '%' '' : {'%', '$1', '$3'} . + + +%% (21) +'' -> '' '' : {'$1', '$2'} . +'' -> '' : '$1' . + + +%% (22) +'' -> '-' : '$1' . +'' -> '+' : '$1' . +'' -> '~' : '$1' . + + +%% (23) +'' -> '' : '$1' . +'' -> '' : '$1' . +'' -> '(' '' ')' : '$2' . + + +%% (24) +'' -> '' : '$1' . +'' -> '' : '$1' . +'' -> '' : '$1' . +'' -> '' : '$1' . +'' -> '' : '$1' . +'' -> '' : '$1' . +'' -> '' : '$1' . +'' -> '' : '$1' . + + +%% (25) +'' -> 'TRUE' : '$1' . +'' -> 'FALSE' : '$1' . + + +%% (26) +'' -> '' : '$1' . + + +%% (27) +'' -> 'typedef' '' : '$2' . +'' -> '' : '$1' . +'' -> '' : '$1' . +'' -> '' : '$1' . + +%% (28) NIY multiple declarators (FIXED) +'' -> '' '' + : #typedef{type='$1', id='$2'} . %%%ic:unfold(#typedef{type='$1', id='$2'}) . +%%'' -> '' '' +%% : #typedef{type='$1', id='$2'} . + +%% (29) +'' -> '' : '$1' . +'' -> '' : '$1' . + + +%% (30) +'' -> '' : '$1' . +'' -> '' : '$1' . +'' -> '' : '$1' . + + +%% (31) +'' -> '' : '$1' . +'' -> '' : '$1' . +'' -> '' : '$1' . +'' -> '' : '$1' . +'' -> '' : '$1' . +'' -> '' : '$1' . +'' -> 'Object' : '$1' . %% NON Standard, isn't a base type + + +%% (32) +'' -> '' : '$1' . +'' -> '' : '$1' . +'' -> '' : '$1' . + + +%% (33) +'' -> '' : '$1' . +'' -> '' : '$1' . +'' -> '' : '$1' . + + +%% (34) +'' -> '' 'ZorM_' +: ['$1' | reverse('$2')] . + +%% Added clause +'ZorM_' -> '$empty' : [] . +'ZorM_' -> 'ZorM_' ',' '' +: ['$3' | '$1'] . + + +%% (35) +'' -> '' : '$1' . +'' -> '' : '$1' . + + +%% (36) +'' -> '' : '$1' . + + +%% (37) +'' -> '' : '$1' . + + +%% (38) +'' -> 'float' : '$1' . +'' -> 'double' : '$1' . + + +%% (39) +'' -> '' : '$1' . +'' -> '' : {'unsigned', '$1'} . + + +%% (40) +'' -> '' : '$1' . +'' -> '' : '$1' . + + +%% (41) +'' -> 'long' : '$1' . +'' -> 'long' 'long': {'long long', element(2,'$2')} . + + +%% (42) +'' -> 'short' : '$1' . + + +%% (43) +'' -> '' : '$1' . +'' -> '' : '$1' . + + +%% (44) +'' -> 'unsigned' 'long' : '$2' . +'' -> 'unsigned' 'long' 'long' : {'long long', element(2,'$2')} . %% ULLONG + + +%% (45) +'' -> 'unsigned' 'short' : '$2' . + + +%% (46) +'' -> 'char' : '$1' . +'' -> 'wchar' : '$1' . %% WCHAR + + +%% (47) +'' -> 'boolean' : '$1' . + + +%% (48) +'' -> 'octet' : '$1' . + + +%% (49) +'' -> 'any' : '$1' . + +%% +'' -> 'fixed' : '$1'. + +%% (50) NIY: unfolding of struct decls (FIXED) +%%'' -> 'struct' '' '{' '' '}' +%% : #struct{id='$2', body=ic:unfold('$4')} . +'' -> 'struct' '' '{' '' '}' + : #struct{id='$2', body='$4'} . + + +%% (51) +'' -> 'OorM_' : reverse('$1') . + + +%% Added clause +%%'OorM_' -> '' : ['$1'] . +%%'OorM_' -> 'OorM_' '' +%% : ['$2' | '$1'] . + +'OorM_' -> '' : '$1' . +'OorM_' -> 'OorM_' '' + : '$2' ++ '$1' . + + + +%% (52) NIY: member multiple declarators (FIXED) +%%'' -> '' '' ';' +%% : #member{type='$1', id='$2'} . + +'' -> 'Ugly_pragmas' '' '' 'Ugly_pragmas' ';' 'Ugly_pragmas' + : '$1' ++ '$4' ++ '$6' ++ [#member{type='$2', id='$3'}] . + + +%% (53) NIY: unfolding of union cases (FIXED) +%%'' -> 'union' '' 'switch' +%% '(' '' ')' '{' '' '}' +%% : #union{id='$2', type='$5', body=ic:unfold('$8')} . +'' -> 'union' '' 'switch' + '(' '' ')' '{' '' '}' + : #union{id='$2', type='$5', body='$8'} . + + +%% (54) +'' -> '' : '$1' . +'' -> '' : '$1' . +'' -> '' : '$1' . +'' -> '' : '$1' . +'' -> '' : '$1' . + + +%% (55) +'' -> 'OorM_' : reverse(lists:flatten('$1')) . + +%%'' -> 'OorM_' : '$1' . + + +%% Added clause +'OorM_' -> '' : ['$1'] . +'OorM_' -> 'OorM_' '' : ['$2' | '$1'] . + + +%% (56) NIY thing: multiple case labels (FIXED) +%%'' -> 'OorM_' '' ';' +%% : '$2'#case_dcl{label=reverse('$1')} . + +'' -> + 'Ugly_pragmas' 'OorM_' + 'Ugly_pragmas' '' + 'Ugly_pragmas' ';' 'Ugly_pragmas' + : '$1' ++ '$3' ++ '$5' ++ '$7' ++ [ '$4'#case_dcl{label=reverse('$2')} ] . + + +%% Added clause +%%'OorM_' -> '' : ['$1'] . +%%'OorM_' -> 'OorM_' '' : ['$2' | '$1'] . + +'OorM_' -> 'Ugly_pragmas' '' 'Ugly_pragmas' + : '$1' ++ ['$2'] ++ '$3' . +'OorM_' -> 'OorM_' 'Ugly_pragmas' '' 'Ugly_pragmas' + : '$2' ++ ['$3'|'$1'] ++ '$4'. + + +%% (57) +'' -> 'case' '' ':' : '$2' . +'' -> 'default' ':' : '$1' . + + +%% (58) +'' -> '' '' +: #case_dcl{type='$1', id='$2'} . + + +%% (59) +%%'' -> 'enum' '' +%%'{' '' 'ZorM_' '}' +%%: #enum{id='$2', body=['$4' | reverse('$5')]} . + +'' -> 'enum' '' +'{' 'Ugly_pragmas' '' 'Ugly_pragmas' 'ZorM_' 'Ugly_pragmas' '}' +: #enum{id='$2', body='$4'++'$6'++'$8'++['$5' | reverse('$7')]} . + + + +%% Added clause +%%'ZorM_' -> '$empty' : [] . +%%'ZorM_' -> 'ZorM_' ',' '' : ['$3' | '$1'] . + +'ZorM_' -> '$empty' : [] . +'ZorM_' -> 'ZorM_' 'Ugly_pragmas' ',' 'Ugly_pragmas' '' + : '$2'++'$4'++['$5' | '$1'] . + +%% (60) +'' -> '' : #enumerator{id='$1'} . + + +%% (61) +'' -> 'sequence' '<' '' ',' + '' '>' + : #sequence{type='$3', length='$5'} . +'' -> 'sequence' '<' '' '>' + : #sequence{type='$3'} . + + +%% (62) +'' -> 'string' '<' '' '>' + : #string{length='$3'} . +'' -> 'string' : #string{} . + +'' -> 'wstring' '<' '' '>' %% WSTRING + : #wstring{length='$3'} . +'' -> 'wstring' : #wstring{} . %% WSTRING + + +%% (63) +'' -> '' 'OorM_' + : #array{id='$1', size=reverse('$2')} . + + +%% Added clause +'OorM_' -> '' : ['$1'] . +'OorM_' -> 'OorM_' '' + : ['$2' | '$1'] . + + +%% (64) +'' -> '[' '' ']' : '$2' . + + +%% (65) NIY: multiple attribute declarators (FIXED) +'' -> 'Opt_readonly' 'attribute' '' + '' 'ZorM_' + : #attr{readonly='$1', type='$3', id=['$4' | reverse('$5')]} . +%% : ic:unfold(#attr{readonly='$1', type='$3', id=['$4' | reverse('$5')]}) . +%%'' -> 'Opt_readonly' 'attribute' '' +%% '' + + +%% (66) NIY: unfolding of exception bodies (FIXED) +%%'' -> 'exception' '' '{' 'ZorM_' '}' +%% : #except{id='$2', body=ic:unfold('$4')} . +'' -> 'exception' '' '{' 'ZorM_' '}' + : #except{id='$2', body=reverse('$4')} . + +%% (67) +'' -> 'Opt_' '' '' '' 'Opt_' 'Opt_' + : #op{oneway='$1', type='$2', id='$3', params='$4', raises='$5', ctx='$6'} . + +%% Added clause +'Opt_' -> '$empty' : nil. +'Opt_' -> '' : '$1'. + +%% (68) +'' -> 'oneway' : '$1' . + + +%% (69) +'' -> '' : '$1' . +'' -> 'void' : '$1' . + + +%% (70) Rewritten +%'' -> '(' '' 'ZorM_' ')' +% : ['$2' | reverse('$3')] . +%'' -> '(' ')' : [] . + +'' -> '(' 'Ugly_pragmas' '' 'ZorM_' ')' + : '$2' ++ ['$3' | reverse('$4')] . +'' -> '(' 'Ugly_pragmas' ')' : '$2' . + + +%% Added clause +%'ZorM_' -> '$empty' : [] . +%'ZorM_' -> 'ZorM_' ',' '' : ['$3' | '$1'] . + + +'ZorM_' -> 'Ugly_pragmas' : '$1' . +'ZorM_' -> 'ZorM_' 'Ugly_pragmas' ',' 'Ugly_pragmas' '' 'Ugly_pragmas' + : '$2' ++ '$4' ++ '$6' ++ ['$5' | '$1'] . + + + + +%% (71) +'' -> '' '' '' + : #param{inout='$1', type='$2', id='$3'} . + + +%% (72) +'' -> 'in' : '$1' . +'' -> 'out' : '$1' . +'' -> 'inout' : '$1' . + + +%% Added clause +'Opt_' -> '$empty' : [] . +'Opt_' -> '' : '$1' . + +%% (73) +'' -> 'raises' '(' '' 'ZorM_' ')' + : ['$3'| reverse('$4')] . + + +%% Added clause +'Opt_' -> '$empty' : [] . +'Opt_' -> '' : '$1'. + +%% (74) +'' -> 'context' '(' '' 'ZorM_'')' + : ['$3' | reverse('$4')] . + + + +%% (75) +'' -> '' : '$1' . +'' -> '' : '$1' . +'' -> '' : '$1' . + + +%% (96) +'' -> 'fixed' '<' '' ',' '' '>' + : #fixed{digits='$3',scale='$5'} . + + +%% Added clause +'ZorM_' -> '$empty' : [] . +'ZorM_' -> 'ZorM_' ',' '' + : ['$3' | '$1'] . + +%% Added clause +'ZorM_' -> '$empty' : [] . +'ZorM_' -> 'ZorM_' ',' +'' : ['$3' | '$1'] . + +%% Added clause +%%'ZorM_' -> '$empty' : [] . +%%'ZorM_' -> 'ZorM_' '' : ['$2' | '$1'] . + +'ZorM_' -> 'Ugly_pragmas' : '$1' . +'ZorM_' -> 'ZorM_' '' : '$2' ++ '$1' . + + +%% Added clause +'Opt_readonly' -> '$empty' : nil. +'Opt_readonly' -> 'readonly' : '$1'. + + + +Erlang code. +%%----------------------------------------------------------- + + + diff --git a/lib/ic/src/icpreproc.erl b/lib/ic/src/icpreproc.erl new file mode 100644 index 0000000000..0ed7813ebd --- /dev/null +++ b/lib/ic/src/icpreproc.erl @@ -0,0 +1,111 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1997-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(icpreproc). + + + +-export([preproc/2]). + + +-import(lists, [filter/2]). + + +%%---------------------------------------------------------------------- +%%---------------------------------------------------------------------- + + +preproc(G, File) -> + Cmd = ic_options:get_opt(G, preproc_cmd), + Flags = ic_options:get_opt(G, preproc_flags), + + + case Cmd of + "erl" -> + case ic_pp:run(File,Flags) of + {ok, [$#, $ , $1 | Rest], []} -> + [$#, $ , $1 | Rest]; + {ok, [$#, $ , $1 | Rest], Warning} -> + print_warning(G,Warning), + [$#, $ , $1 | Rest]; + {error,Error} -> + print_error(G,Error) + end; + + _ -> + Line = Cmd++" "++Flags++" "++File, + % FIXME: Check status code of command instead of this test + case os:cmd(Line) of + [$#, $ , C | Rest] when is_integer(C), C > $0, C =< $9 -> + [$#, $ , C | Rest]; + X -> + ic_error:fatal_error(G, {preproc, filter(X)}) + end + end. + + +filter(X) -> + X2 = divide_nl(X, []), + filter_x_switch(X2). + + +divide_nl([10 | Xs], Out) -> + [lists:reverse(Out) | divide_nl(Xs, [])]; +divide_nl([X | Xs], Out) -> divide_nl(Xs, [X|Out]); +divide_nl([], Out) -> lists:reverse(Out). + + +filter_x_switch(L) -> + filter(fun([$g,$c,$c,$:,$ ,$W,$a,$r,$n,$i,$n,$g,$:,$ ,$`,$-,$x,$ | _]) -> + false; + (_) -> true end, L). + + +print_error(_G,[]) -> + ok; +print_error(G,[{File,Line,Text}]) -> + ErrorText = File++":"++integer_to_list(Line)++": "++Text, + ic_error:fatal_error(G, {ic_pp_error, ErrorText}), + ok; +print_error(G,[{File,Line,Text}|T]) -> + ErrorText = File++":"++integer_to_list(Line)++": "++Text, + ic_error:error(G, {ic_pp_error, ErrorText}), + print_error(G,T); +print_error(G,[H]) -> + ErrorText = H++"\n", + ic_error:fatal_error(G, {ic_pp_error, ErrorText}), + ok; +print_error(G,[H|T]) -> + ErrorText = H++"\n", + ic_error:error(G, {ic_pp_error, ErrorText}), + print_error(G,T). + + +print_warning(_G,[]) -> + ok; +print_warning(G,[{File,Line,Text}|T]) -> + WarText = File++":"++integer_to_list(Line)++": "++Text, + ic_error:warn(G, {ic_pp_warning, WarText}), + print_warning(G,T); +print_warning(G,[H|T]) -> + WarText = H++"\n", + ic_error:warn(G, {ic_pp_warning, WarText}), + print_warning(G,T). + + diff --git a/lib/ic/src/icscan.erl b/lib/ic/src/icscan.erl new file mode 100644 index 0000000000..0960ba5d70 --- /dev/null +++ b/lib/ic/src/icscan.erl @@ -0,0 +1,452 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1997-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(icscan). + + +-export([scan/2]). + +-include("ic.hrl"). + + +%%---------------------------------------------------------------------- +%%---------------------------------------------------------------------- + +-import(lists, [reverse/1]). + + +scan(G, File) -> + PL = call_preproc(G, File), + call_scan(G, PL). + +call_preproc(G, File) -> + case ic_options:get_opt(G, use_preproc) of + true -> + icpreproc:preproc(G, File); + false -> + case catch file:read_file(File) of + {ok, Bin} -> + binary_to_list(Bin); + Other -> + exit(Other) + end + end. + +call_scan(G, PL) -> + BE = ic_options:get_opt(G, be), + RSL = scan(G, BE, PL, 1, []), + lists:reverse(RSL). + + +%% Guard macros used at top scan functions only +-define(is_number(X), X >= $0 , X =< $9). +-define(is_upper(X), X >= $A , X =< $Z). +-define(is_lower(X), X >= $a, X =< $z). +-define(is_hex_uc(X), X >= $A , X =< $F). +-define(is_hex_lc(X), X >= $a , X =< $f). +-define(is_octal(X), X >=$0, X =< $7). + +%% Handle: +%% const wchar aWChar = L'X'; +scan(G, BE, [$L, $'|Str], Line, Out) -> + scan_const(G, BE, wchar, Str, [], Line, Out); +scan(G, BE, [$L, $"|Str], Line, Out) -> + scan_const(G, BE, wstring, Str, [], Line, Out); +scan(G, BE, [$_, X|Str], Line, Out) when ?is_upper(X) -> + scan_name(G, BE, Str, [X], false, Line, Out); +scan(G, BE, [$_, X|Str], Line, Out) when ?is_lower(X) -> + scan_name(G, BE, Str, [X], false, Line, Out); +scan(G, BE, [X|Str], Line, Out) when ?is_upper(X) -> + scan_name(G, BE, Str, [X], true, Line, Out); +scan(G, BE, [X|Str], Line, Out) when ?is_lower(X) -> + scan_name(G, BE, Str, [X], true, Line, Out); +scan(G, BE, [X|Str], Line, Out) when ?is_number(X) -> + scan_number(G, BE, Str, [X], Line, Out); +scan(G, BE, [9| T], Line, Out) -> scan(G, BE, T, Line, Out); +scan(G, BE, [32| T], Line, Out) -> scan(G, BE, T, Line, Out); +scan(G, BE, [$\r|Str], Line, Out) -> + scan(G, BE, Str, Line, Out); +scan(G, BE, [$\n|Str], Line, Out) -> + scan(G, BE, Str, Line+1, Out); +scan(G, BE, [$:, $: | Str], Line, Out) -> + scan(G, BE, Str, Line, [{'::', Line} | Out]); +scan(G, BE, [$/, $/ | Str], Line, Out) -> + Rest = skip_to_nl(Str), + scan(G, BE, Rest, Line, Out); +scan(G, BE, [$/, $* | Str], Line, Out) -> + Rest = skip_comment(Str), + scan(G, BE, Rest, Line, Out); +scan(G, BE, [$", $\\|Str], Line, Out) -> + scan_const(G, BE, string, [$\\|Str], [], Line, Out); +scan(G, BE, [$"|Str], Line, Out) -> + scan_const(G, BE, string, Str, [], Line, Out); +scan(G, BE, [$', $\\|Str], Line, Out) -> + scan_const(G, BE, char, [$\\|Str], [], Line, Out); +scan(G, BE, [$'|Str], Line, Out) -> + scan_const(G, BE, char, Str, [], Line, Out); +scan(G, BE, [$\\|Str], Line, Out) -> + scan_const(G, BE, escaped, [$\\|Str], [], Line, Out); +scan(G, BE, [$. | Str], Line, Out) -> + scan_frac(G, BE, Str, [$.], Line, Out); +scan(G, BE, [$# | Str], Line, Out) -> + scan_preproc(G, BE, Str, Line, Out); +scan(G, BE, [$<, $< | Str], Line, Out) -> + scan(G, BE, Str, Line, [{'<<', Line} | Out]); +scan(G, BE, [$>, $> | Str], Line, Out) -> + scan(G, BE, Str, Line, [{'>>', Line} | Out]); +scan(G, BE, [C|Str], Line, Out) -> + scan(G, BE, Str, Line, [{list_to_atom([C]), Line} | Out]); + +scan(_G, _BE, [], _Line, Out) -> + Out. + + +scan_number(G, BE, [X|Str], [$0], Line, Out) when X == $X ; X ==$x -> + case Str of + [D|_TmpStr] when ?is_number(D); ?is_hex_uc(D); ?is_hex_lc(D) -> + {Num,Rest} = scan_hex_number(Str,0), + scan(G, BE, Rest, Line, [{'', Line, + integer_to_list(Num)} | Out]); + [D|TmpStr] -> + scan(G, BE, TmpStr, Line, [{list_to_atom([D]), Line} | Out]) + end; +scan_number(G, BE, Str, [$0], Line, Out) -> + %% If an integer literal starts with a 0 it may indicate that + %% it is represented as an octal number. But, it can also be a fixed + %% type which must use padding to match a fixed typedef. For example: + %% typedef fixed<5,2> fixed52; + %% 123.45d, 123.00d and 023.00d is all valid fixed values. + %% Naturally, a float can be defined as 0.14 or 00.14. + case pre_scan_number(Str, [], octal) of + octal -> + {Num, Rest} = scan_octal_number(Str,0), + scan(G, BE, Rest, Line, [{'', Line, + integer_to_list(Num)} | Out]); + {fixed, Fixed, Rest} -> + scan(G, BE, Rest, Line, [{'', Line, Fixed} | Out]); + float -> + %% Not very likely that someone defines a constant as 00.14 but ... + NewStr = remove_leading_zeroes(Str), + scan(G, BE, NewStr, Line, Out) + end; +scan_number(G, BE, [X|Str], Accum, Line, Out) when ?is_number(X) -> + scan_number(G, BE, Str, [X|Accum], Line, Out); +scan_number(G, BE, [X|Str], Accum, Line, Out) when X==$. -> + scan_frac(G, BE, Str, [X|Accum], Line, Out); +scan_number(G, BE, [X|Str], Accum, Line, Out) when X==$e ; X==$e -> + scan_exp(G, BE, Str, [X|Accum], Line, Out); +scan_number(G, BE, [X|Str], Accum, Line, Out) when X==$D ; X==$d -> + scan(G, BE, Str, Line, [{'', Line, + (lists:reverse(Accum))} | Out]); +scan_number(G, BE, Str, Accum, Line, Out) -> + scan(G, BE, Str, Line, [{'', Line, + (lists:reverse(Accum))} | Out]). + + +remove_leading_zeroes([$0|Rest]) -> + remove_leading_zeroes(Rest); +remove_leading_zeroes(L) -> + L. + +scan_hex_number([X|Rest],Acc) when X >=$a, X =< $f -> + scan_hex_number(Rest,(Acc bsl 4) + (X - $a + 10)); +scan_hex_number([X|Rest],Acc) when X >=$A, X =< $F -> + scan_hex_number(Rest,(Acc bsl 4) + (X - $A + 10)); +scan_hex_number([X|Rest],Acc) when X >=$0, X =< $9 -> + scan_hex_number(Rest,(Acc bsl 4) + (X-$0)); +scan_hex_number(Rest,Acc) -> + {Acc,Rest}. + +pre_scan_number([$d|Rest], Acc, _) -> + {fixed, [$0|lists:reverse(Acc)], Rest}; +pre_scan_number([$D|Rest], Acc, _) -> + {fixed, [$0|lists:reverse(Acc)], Rest}; +pre_scan_number([$.|Rest], Acc, _) -> + %% Actually, we don't know if it's a float since it can be a fixed. + pre_scan_number(Rest, [$.|Acc], float); +pre_scan_number([X|_], _Acc, _) when X == $E ; X ==$e -> + %% Now we now it's a float. + float; +pre_scan_number([X|Rest], Acc, Type) when ?is_number(X) -> + pre_scan_number(Rest, [X|Acc], Type); +pre_scan_number(_Rest, _Acc, Type) -> + %% At this point we know it's a octal or float. + Type. + +scan_octal_number([X|Rest],Acc) when ?is_octal(X) -> + scan_octal_number(Rest,(Acc bsl 3) + (X-$0)); +scan_octal_number(Rest,Acc) -> + {Acc, Rest}. + +%% Floating point number scan. +%% +%% Non trivial scan. A float consists of an integral part, a +%% decimal point, a fraction part, an e or E and a signed integer +%% exponent. Either the integer part or the fraction part but not +%% both may be missing, and either the decimal point or the +%% exponent part but not both may be missing. The exponent part +%% must consist of an e or E and a possibly signed exponent. +%% +%% Analysis shows that "1." ".7" "1e2" ".5e-3" "1.7e2" "1.7e-2" +%% is allowed and "1" ".e9" is not. The sign is only allowed just +%% after an e or E. The scanner reads a number as an integer +%% until it encounters a "." so the integer part only error case +%% will not be caught in the scanner (but rather in expression +%% evaluation) + +scan_frac(G, _BE, [$e | _Str], [$.], Line, _Out) -> + ic_error:fatal_error(G, {illegal_float, Line}); +scan_frac(G, _BE, [$E | _Str], [$.], Line, _Out) -> + ic_error:fatal_error(G, {illegal_float, Line}); +scan_frac(G, BE, Str, Accum, Line, Out) -> + scan_frac2(G, BE, Str, Accum, Line, Out). + +scan_frac2(G, BE, [X|Str], Accum, Line, Out) when ?is_number(X) -> + scan_frac2(G, BE, Str, [X|Accum], Line, Out); +scan_frac2(G, BE, [X|Str], Accum, Line, Out) when X==$e ; X==$E -> + scan_exp(G, BE, Str, [X|Accum], Line, Out); +%% The following case is for fixed (e.g. 123.45d). +scan_frac2(G, BE, [X|Str], Accum, Line, Out) when X==$d ; X==$D -> + scan(G, BE, Str, Line, [{'', Line, + (lists:reverse(Accum))} | Out]); +scan_frac2(G, BE, Str, Accum, Line, Out) -> + scan(G, BE, Str, Line, [{'', Line, + (lists:reverse(Accum))} | Out]). + +scan_exp(G, BE, [X|Str], Accum, Line, Out) when X==$- -> + scan_exp2(G, BE, Str, [X|Accum], Line, Out); +scan_exp(G, BE, Str, Accum, Line, Out) -> + scan_exp2(G, BE, Str, Accum, Line, Out). + +scan_exp2(G, BE, [X|Str], Accum, Line, Out) when ?is_number(X) -> + scan_exp2(G, BE, Str, [X|Accum], Line, Out); +scan_exp2(G, BE, Str, Accum, Line, Out) -> + scan(G, BE, Str, Line, [{'', Line, + (lists:reverse(Accum))} | Out]). + + +scan_name(G, BE, [X|Str], Accum, TypeCheck, Line, Out) when ?is_upper(X) -> + scan_name(G, BE, Str, [X|Accum], TypeCheck, Line, Out); +scan_name(G, BE, [X|Str], Accum, TypeCheck, Line, Out) when ?is_lower(X) -> + scan_name(G, BE, Str, [X|Accum], TypeCheck, Line, Out); +scan_name(G, BE, [X|Str], Accum, TypeCheck, Line, Out) when ?is_number(X) -> + scan_name(G, BE, Str, [X|Accum], TypeCheck, Line, Out); +scan_name(G, BE, [$_|Str], Accum, TypeCheck, Line, Out) -> + scan_name(G, BE, Str, [$_|Accum], TypeCheck, Line, Out); +scan_name(G, BE, S, Accum, false, Line, Out) -> + %% The CORBA 2.3 specification allows the user to override typechecking: + %% typedef string _native; + %% interface i { + %% void foo(in _native VT); + %% }; + %% BUT, the IFR-id remains the same ("IDL:native:1.0") etc. The reason for + %% this is that one don't have to re-write a large chunk of IDL- and + %% application-code. + scan(G, BE, S, Line, [{'', Line, lists:reverse(Accum)} | Out]); +scan_name(G, BE, S, Accum, _, Line, Out) -> + L = lists:reverse(Accum), + X = case is_reserved(L, BE) of + undefined -> + {'', Line, L}; + Yes -> + {Yes, Line} + end, + scan(G, BE, S, Line, [X | Out]). + +%% Shall scan a constant +scan_const(G, BE, string, [$" | Rest], Accum, Line, [{'', _, Str}|Out]) -> + scan(G, BE, Rest, Line, + [{'', Line, Str ++ lists:reverse(Accum)} | Out]); +scan_const(G, BE, string, [$" | Rest], Accum, Line, Out) -> + scan(G, BE, Rest, Line, + [{'', Line, lists:reverse(Accum)} | Out]); +scan_const(G, BE, wstring, [$" | Rest], Accum, Line, [{'', _,Wstr}|Out]) -> %% WSTRING + scan(G, BE, Rest, Line, + [{'', Line, Wstr ++ lists:reverse(Accum)} | Out]); +scan_const(G, BE, wstring, [$" | Rest], Accum, Line, Out) -> %% WSTRING + scan(G, BE, Rest, Line, + [{'', Line, lists:reverse(Accum)} | Out]); +scan_const(G, _BE, string, [], _Accum, Line, Out) -> %% Bad string + ic_error:error(G, {bad_string, Line}), + Out; +scan_const(G, _BE, wstring, [], _Accum, Line, Out) -> %% Bad WSTRING + ic_error:error(G, {bad_string, Line}), + Out; +scan_const(G, BE, char, [$' | Rest], Accum, Line, Out) -> + scan(G, BE, Rest, Line, + [{'', Line, lists:reverse(Accum)} | Out]); +scan_const(G, BE, wchar, [$' | Rest], Accum, Line, Out) -> %% WCHAR + scan(G, BE, Rest, Line, + [{'', Line, lists:reverse(Accum)} | Out]); +scan_const(G, BE, Mode, [$\\, C | Rest], Accum, Line, Out) -> + case escaped_char(C) of + error -> + ic_error:error(G, {bad_escape_character, Line, C}), %% Bad escape character + scan_const(G, BE, Mode, Rest, [C | Accum], Line, Out); + octal -> + {Num,Rest2} = scan_octal_number([C|Rest], 0), + scan_const(G, BE, Mode, Rest2, [Num|Accum], Line, Out); + hexadecimal -> + {Num,Rest2} = scan_hex_number(Rest, 0), + if + Num > 255 -> %% 16#FF + ic_error:error(G, {bad_escape_character, Line, C}), + scan_const(G, BE, Mode, Rest, [C | Accum], Line, Out); + true -> + scan_const(G, BE, Mode, Rest2, [Num|Accum], Line, Out) + end; + unicode -> + {Num,Rest2} = scan_hex_number(Rest, 0), + if + Num > 65535 -> %% 16#FFFF + ic_error:error(G, {bad_escape_character, Line, C}), + scan_const(G, BE, Mode, Rest, [C | Accum], Line, Out); + true -> + scan_const(G, BE, Mode, Rest2, [Num|Accum], Line, Out) + end; + EC -> + scan_const(G, BE, Mode, Rest, [EC | Accum], Line, Out) + end; +scan_const(G, BE, Mode, [C | Rest], Accum, Line, Out) -> + scan_const(G, BE, Mode, Rest, [C | Accum], Line, Out). + + +%% +%% Preprocessor output handling +%% +%% gcc outputs a line with line number, file name (within \") and +%% one or more integer flags. The scanner scans the line number, +%% the id and all integers up to nl. +%% +%% NOTE: This will have to be enhanced in order to eat #pragma +%% +scan_preproc(G, BE, Str, Line, Out) -> + {List, Rest} = scan_to_nl(strip(Str), []), + NewLine = get_new_line_nr(strip(List), Line+1, []), + case scan_number(G, BE, List, [], Line, [{'#', Line} | Out]) of + L when is_list(L) -> + scan(G, BE, Rest, NewLine, [{'#', Line} | L]) + end. + +get_new_line_nr([C|R], Line, Acc) when C>=$0, C=<$9 -> + get_new_line_nr(R, Line, [C|Acc]); +get_new_line_nr(_, Line, []) -> Line; % No line nr found +get_new_line_nr(_, _, Acc) -> list_to_integer(reverse(Acc)). + +scan_to_nl([], Acc) -> {reverse(Acc), []}; +scan_to_nl([$\n|Str], Acc) -> {reverse(Acc), Str}; +scan_to_nl([$\r|R], Acc) -> scan_to_nl(R, Acc); +scan_to_nl([C|R], Acc) -> scan_to_nl(R, [C|Acc]). + +strip([$ |R]) -> strip(R); +strip(L) -> L. + +%% Escaped character. Escaped chars are repr as two characters in the +%% input list of letters and this is translated into one char. +escaped_char($n) -> $\n; +escaped_char($t) -> $\t; +escaped_char($v) -> $\v; +escaped_char($b) -> $\b; +escaped_char($r) -> $ ; +escaped_char($f) -> $\f; +escaped_char($a) -> $\a; +escaped_char($\\) -> $\\; +escaped_char($?) -> $?; +escaped_char($') -> $'; +escaped_char($") -> $"; +escaped_char($x) -> hexadecimal; +escaped_char($u) -> unicode; +escaped_char(X) when ?is_octal(X) -> octal; +%% Error +escaped_char(_Other) -> error. + +skip_to_nl([]) -> []; +skip_to_nl([$\n | Str]) ->[$\n | Str]; +skip_to_nl([_|Str]) -> + skip_to_nl(Str). + +skip_comment([$\\, _ | Str]) -> + skip_comment(Str); +skip_comment([$*, $/ | Str]) -> Str; +skip_comment([_|Str]) -> + skip_comment(Str). + + +%%---------------------------------------------------------------------- +%% Shall separate keywords from identifiers and numbers + +%% Fill in the ets of reserved words +is_reserved("Object", _) -> 'Object'; +is_reserved("in", _) -> in; +is_reserved("interface", _) -> interface; +is_reserved("case", _) -> 'case'; +is_reserved("union", _) -> union; +is_reserved("struct", _) -> struct; +is_reserved("any", _) -> any; +is_reserved("long", _) -> long; +is_reserved("float", _) -> float; +is_reserved("out", _) -> out; +is_reserved("enum", _) -> enum; +is_reserved("double", _) -> double; +is_reserved("context", _) -> context; +is_reserved("oneway", _) -> oneway; +is_reserved("sequence", _) -> sequence; +is_reserved("FALSE", _) -> 'FALSE'; +is_reserved("readonly", _) -> readonly; +is_reserved("char", _) -> char; +is_reserved("wchar", _) -> wchar; +is_reserved("void", _) -> void; +is_reserved("inout", _) -> inout; +is_reserved("attribute", _) -> attribute; +is_reserved("octet", _) -> octet; +is_reserved("TRUE", _) -> 'TRUE'; +is_reserved("switch", _) -> switch; +is_reserved("unsigned", _) -> unsigned; +is_reserved("typedef", _) -> typedef; +is_reserved("const", _) -> const; +is_reserved("raises", _) -> raises; +is_reserved("string", _) -> string; +is_reserved("wstring", _) -> wstring; +is_reserved("default", _) -> default; +is_reserved("short", _) -> short; +is_reserved("module", _) -> module; +is_reserved("exception", _) -> exception; +is_reserved("boolean", _) -> boolean; +%% --- New keywords Introduced in CORBA-2.3.1 --- +%% For now we cannot add these for all backends right now since it would cause +%% some problems for at least one customer. +is_reserved("fixed", BE) -> check_be(BE, fixed); +%is_reserved("abstract", BE) -> check_be(BE, abstract); +%is_reserved("custom", BE) -> check_be(BE, custom); +%is_reserved("factory", BE) -> check_be(BE, factory); +%is_reserved("local", BE) -> check_be(BE, local); +%is_reserved("native", BE) -> check_be(BE, native); +%is_reserved("private", BE) -> check_be(BE, private); +%is_reserved("public", BE) -> check_be(BE, public); +%is_reserved("supports", BE) -> check_be(BE, supports); +%is_reserved("truncatable", BE) -> check_be(BE, truncatable); +%is_reserved("ValueBase", BE) -> check_be(BE, 'ValueBase'); +%is_reserved("valuetype", BE) -> check_be(BE, valuetype); +is_reserved(_, _) -> undefined. + +check_be(erl_corba, KeyWord) -> + KeyWord; +check_be(_, _) -> + undefined. + diff --git a/lib/ic/src/icstruct.erl b/lib/ic/src/icstruct.erl new file mode 100644 index 0000000000..6058b3c455 --- /dev/null +++ b/lib/ic/src/icstruct.erl @@ -0,0 +1,1916 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1997-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(icstruct). + + +-export([struct_gen/4, except_gen/4, create_c_array_coding_file/5]). + +%%------------------------------------------------------------ +%% +%% Internal stuff +%% +%%------------------------------------------------------------ +-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"). + + + +%%------------------------------------------------------------ + +%%------------------------------------------------------------ +%% +%% File handling stuff +%% +%%------------------------------------------------------------ + + + +%%------------------------------------------------------------ +%% +%% Generation loop +%% +%% The idea is to traverse everything and find every struct that +%% may be hiding down in nested types. All structs that are found +%% are generated to a hrl file. +%% +%% struct_gen is entry point for structs and types, except_gen is +%% for exceptions +%% +%%------------------------------------------------------------ + + +except_gen(G, N, X, L) when is_record(X, except) -> + N2 = [ic_forms:get_id2(X) | N], + if + L == c -> + io:format("Warning : Exception not defined for c mapping\n", []); + true -> + emit_struct(G, N, X, L) + end, + struct_gen_list(G, N2, ic_forms:get_body(X), L). + +struct_gen(G, N, X, L) when is_record(X, struct) -> + N2 = [ic_forms:get_id2(X) | N], + struct_gen_list(G, N2, ic_forms:get_body(X), L), + emit_struct(G, N, X, L); +struct_gen(G, N, X, L) when is_record(X, union) -> + N2 = [ic_forms:get_id2(X) | N], + if + L == c -> + %% Produce the "body" first + struct_gen_list(G, N2, ic_forms:get_body(X), L), + icunion:union_gen(G, N, X, c); + true -> + struct_gen(G, N, ic_forms:get_type(X), L), + struct_gen_list(G, N2, ic_forms:get_body(X), L) + end, + emit_union(G, N, X, L); +struct_gen(G, N, X, L) when is_record(X, member) -> + struct_gen(G, N, ic_forms:get_type(X), L); +struct_gen(G, N, X, L) when is_record(X, typedef) -> + struct_gen(G, N, ic_forms:get_body(X), L), + emit_typedef(G, N, X, L); +struct_gen(G, N, X, L) when is_record(X, type_dcl) -> + struct_gen_list(G, N, ic_forms:get_type(X), L); +struct_gen(G, N, X, L) when is_record(X, case_dcl) -> + struct_gen(G, N, ic_forms:get_type(X), L); +struct_gen(G, N, X, L) when is_record(X, sequence) -> + struct_gen(G, N, ic_forms:get_type(X), L), + X; +struct_gen(G, N, X, L) when is_record(X, enum) -> + icenum:enum_gen(G, N, X, L); +struct_gen(_G, _N, _X, _L) -> + ok. + +%% List clause for struct_gen +struct_gen_list(G, N, Xs, L) -> + lists:foreach( + fun(X) -> + R = struct_gen(G, N, X, L), + if + L == c -> + if + is_record(R,sequence) -> + emit_sequence_head_def(G,N,X,R,L); + true -> + ok + end; + true -> + ok + end + end, Xs). + + +%% emit primitive for structs. +emit_struct(G, N, X, erlang) -> + case ic_genobj:is_hrlfile_open(G) of + true -> + %% Make a straight list of all member ids (this is a + %% variant of flatten) + EList = lists:map( + fun(XX) -> + lists:map( + fun(XXX) -> + ic_util:to_atom(ic_forms:get_id2(XXX)) + end, + ic_forms:get_idlist(XX)) + end, + ic_forms:get_body(X)), + ic_codegen:record(G, X, + ic_util:to_undersc([ic_forms:get_id2(X) | N]), + ictk:get_IR_ID(G, N, X), lists:flatten(EList)), + mkFileRecObj(G,N,X,erlang); + false -> + ok + end; +emit_struct(G, N, X, c) -> + + N1 = [ic_forms:get_id2(X) | N], + case ic_pragma:is_local(G,N1) of + true -> + emit_c_struct(G, N, X,local); + false -> + emit_c_struct(G, N, X,included) + end. + + +emit_c_struct(_G, _N, _X, included) -> + %% Do not generate included types att all. + ok; +emit_c_struct(G, N, X, local) -> + case ic_genobj:is_hrlfile_open(G) of + true -> + Fd = ic_genobj:hrlfiled(G), + + N1 = [ic_forms:get_id2(X) | N], + StructName = ic_util:to_undersc(N1), + + %% Make a straight list of all member ids (this is a + %% variant of flatten) + M = lists:map( + fun(XX) -> + lists:map( + fun(XXX) -> + if + is_record(XXX, array) -> + Type = ic_forms:get_type(XX), + Name = element(3,element(2,XXX)), + {_, _, StructTK, _} = + ic_symtab:get_full_scoped_name( + G, + N, + ic_symtab:scoped_id_new( + ic_forms:get_id2(X))), + ArrayTK = + get_structelement_tk(StructTK, + Name), + Dim = extract_dim(ArrayTK), + %% emit array file + emit(Fd, "\n#ifndef __~s__\n", + [ic_util:to_uppercase( + StructName ++ "_" + ++ Name)]), + emit(Fd, "#define __~s__\n\n", + [ic_util:to_uppercase( + StructName ++ "_" + ++ Name)]), + create_c_array_coding_file( + G, + N, + {StructName ++ "_" ++ Name, Dim}, + Type, + no_typedef), + emit(Fd, "\n#endif\n\n"), + {{Type, XXX}, + ic_forms:get_id2(XXX)}; + true -> + %% Ugly work around to fix the ETO + %% return patch problem + Name = + case ic_forms:get_id2(XXX) of + "return" -> + "return1"; + Other -> + Other + end, + {ic_forms:get_type(XX), Name} + end + end, + ic_forms:get_idlist(XX)) + end, + ic_forms:get_body(X)), + EList = lists:flatten(M), + %%io:format("Elist = ~p~n",[EList]), + + emit(Fd, "\n#ifndef __~s__\n",[ic_util:to_uppercase(StructName)]), + emit(Fd, "#define __~s__\n",[ic_util:to_uppercase(StructName)]), + ic_codegen:mcomment_light(Fd, + [io_lib:format("Struct definition: ~s", + [StructName])], + c), + emit(Fd, "typedef struct {\n"), + lists:foreach( + fun({Type, Name}) -> + emit_struct_member(Fd, G, N1, X, Name, Type) + end, + EList), + emit(Fd, "} ~s;\n\n", [StructName]), + create_c_struct_coding_file(G, N, X, nil, StructName, + EList, struct), + emit(Fd, "\n#endif\n\n"); + false -> + ok + end. + +%% Extracts array dimention(s) + +get_structelement_tk({tk_struct, _, _, EList}, EN) -> + {value, {EN, ArrayTK}} = lists:keysearch(EN, 1, EList), + ArrayTK. + +extract_dim({tk_array, {tk_array, T, D1}, D}) -> + [integer_to_list(D) | extract_dim({tk_array, T, D1})]; +extract_dim({tk_array, _, D}) -> + [integer_to_list(D)]. + +%% Makes the array name +mk_array_name(Name,Dim) -> + Name ++ mk_array_name(Dim). + +mk_array_name([]) -> + ""; +mk_array_name([Dim|Dims]) -> + "[" ++ Dim ++ "]" ++ mk_array_name(Dims). + + +emit_struct_member(Fd, G, N, X, Name,{Type,Array}) when is_record(Array, array)-> + {_, _, StructTK, _} = + ic_symtab:get_full_scoped_name( + G, + N, + ic_symtab:scoped_id_new(ic_forms:get_id2(X))), + ArrayTK = get_structelement_tk(StructTK, Name), + Dim = extract_dim(ArrayTK), + emit(Fd, " ~s ~s;\n", + [ic_cbe:mk_c_type(G, N, Type),mk_array_name(Name,Dim)]); +emit_struct_member(Fd, _G, N, _X, Name, Union) when is_record(Union, union)-> + emit(Fd, " ~s ~s;\n", + [ic_util:to_undersc([ic_forms:get_id2(Union) | N]),Name]); +emit_struct_member(Fd, _G, _N, _X, Name, {string, _}) -> + emit(Fd, " CORBA_char *~s;\n", + [Name]); +emit_struct_member(Fd, _G, N, _X, Name, {sequence, _Type, _Length}) -> + %% Sequence used as struct + emit(Fd, " ~s ~s;\n", + [ic_util:to_undersc([Name | N]), Name]); +emit_struct_member(Fd, G, N, X, Name, Type) + when element(1, Type) == scoped_id -> + CType = ic_cbe:mk_c_type(G, N, Type, evaluate_not), + emit_struct_member(Fd, G, N, X, Name, CType); +emit_struct_member(Fd, G, N, _X, Name, {enum, Type}) -> + emit(Fd, " ~s ~s;\n", + [ic_cbe:mk_c_type(G, N, Type), + Name]); +emit_struct_member(Fd, _G, _N, _X, Name, "ETERM*") -> + emit(Fd, " ETERM* ~s;\n", + [Name]); +emit_struct_member(Fd, _G, _N, _X, Name, Type) when is_list(Type) -> + emit(Fd, " ~s ~s;\n", + [Type, Name]); +emit_struct_member(Fd, G, N, _X, Name, Type) -> + emit(Fd, " ~s ~s;\n", + [ic_cbe:mk_c_type(G, N, Type), + Name]). + + +emit_typedef(G, N, X, erlang) -> + case X of + {typedef,_,[{array,_,_}],_} -> %% Array but not a typedef of + %% an array definition + case ic_options:get_opt(G, be) of + noc -> + mkFileArrObj(G,N,X,erlang); + _ -> + %% Search the table to see if the type is local or + %% inherited. + PTab = ic_genobj:pragmatab(G), + Id = ic_forms:get_id2(X), + case ets:match(PTab,{file_data_local,'_','_', + typedef,N,Id, + ic_util:to_undersc([Id | N]), + '_','_'}) of + [[]] -> + %% Local, create erlang file for the array + mkFileArrObj(G,N,X,erlang); + _ -> + %% Inherited, do nothing + ok + end + end; + + {typedef,{sequence,_,_},_,{tk_sequence,_,_}} -> + %% Sequence but not a typedef of + %% a typedef of a sequence definition + case ic_options:get_opt(G, be) of + noc -> + mkFileRecObj(G,N,X,erlang); + _ -> + %% Search the table to see if the type is local or + %% inherited. + PTab = ic_genobj:pragmatab(G), + Id = ic_forms:get_id2(X), + case ets:match(PTab,{file_data_local,'_','_',typedef, + N,Id, + ic_util:to_undersc([Id | N]), + '_','_'}) of + [[]] -> + %% Local, create erlang file for the sequence + mkFileRecObj(G,N,X,erlang); + _ -> + %% Inherited, do nothing + ok + end + end; + _ -> + ok + end; +emit_typedef(G, N, X, c) -> + B = ic_forms:get_body(X), + if + is_record(B, sequence) -> + emit_sequence_head_def(G, N, X, B, c); + true -> + lists:foreach(fun(D) -> + emit_typedef(G, N, D, B, c) + end, + ic_forms:get_idlist(X)) + end. + +emit_typedef(G, N, D, Type, c) when is_record(D, array) -> + emit_array(G, N, D, Type); +emit_typedef(G, N, D, Type, c) -> + Name = ic_util:to_undersc([ic_forms:get_id2(D) | N]), + CType = ic_cbe:mk_c_type(G, N, Type), + TDType = mk_base_type(G, N, Type), + ic_code:insert_typedef(G, Name, TDType), + case ic_genobj:is_hrlfile_open(G) of + true -> + Fd = ic_genobj:hrlfiled(G), + emit(Fd, "\n#ifndef __~s__\n",[ic_util:to_uppercase(Name)]), + emit(Fd, "#define __~s__\n",[ic_util:to_uppercase(Name)]), + ic_codegen:mcomment_light(Fd, + [io_lib:format("Type definition ~s " + "for type ~s", + [Name, CType])], + c), + emit(Fd, "typedef ~s ~s;\n", + [CType, Name]), + emit(Fd, "\n#endif\n\n"), + ic_codegen:nl(Fd); + false -> + ok + end. + + +mk_base_type(G, N, S) 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_base_type(_G, _N, S) -> + S. + +emit_array(G, N, D, Type) -> + case ic_genobj:is_hrlfile_open(G) of + true -> + Fd = ic_genobj:hrlfiled(G), + Name = ic_util:to_undersc([ic_forms:get_id2(D) | N]), + {_, _, ArrayTK, _} = + ic_symtab:get_full_scoped_name(G, N, + ic_symtab:scoped_id_new( + ic_forms:get_id(D))), + Dim = extract_dim(ArrayTK), + CType = ic_cbe:mk_c_type(G, N, Type), + emit(Fd, "\n#ifndef __~s__\n",[ic_util:to_uppercase(Name)]), + emit(Fd, "#define __~s__\n",[ic_util:to_uppercase(Name)]), + ic_codegen:mcomment_light(Fd, + [io_lib:format("Array definition ~s " + "for type ~s", + [Name, CType])], + c), + emit(Fd, "typedef ~s ~s~s;\n", + [CType, Name, ic_cbe:mk_dim(Dim)]), + emit(Fd, "typedef ~s ~s_slice~s;\n", + [CType, Name, ic_cbe:mk_slice_dim(Dim)]), + ic_codegen:nl(Fd), + create_c_array_coding_file(G, N, {Name, Dim}, Type, typedef), + emit(Fd, "\n#endif\n\n"); + false -> + ok + end. + +open_c_coding_file(G, Name) -> + SName = string:concat(ic_util:mk_oe_name(G, "code_"), Name), + FName = + ic_file:join(ic_options:get_opt(G, stubdir),ic_file:add_dot_c(SName)), + case file:open(FName, [write]) of + {ok, Fd} -> + {Fd, SName}; + Other -> + exit(Other) + end. + + + +create_c_array_coding_file(G, N, {Name, Dim}, Type, TypeDefFlag) -> + + {Fd , SName} = open_c_coding_file(G, Name), + HFd = ic_genobj:hrlfiled(G), %% Write on stubfile header + HrlFName = filename:basename(ic_genobj:include_file(G)), + ic_codegen:emit_stub_head(G, Fd, SName, c), + emit(Fd, "#include \"~s\"\n\n",[HrlFName]), + + %% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + %% Fd = ic_genobj:stubfiled(G), %% Write on stubfile + %% HFd = ic_genobj:hrlfiled(G), %% Write on stubfile header + %% HrlFName = filename:basename(ic_genobj:include_file(G)), + %% emit(Fd, "#include \"~s\"\n\n",[HrlFName]), + %% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + put(op_variable_count, 0), + put(tmp_declarations, []), + + emit(HFd, "int ~s~s(CORBA_Environment *oe_env, int*, int*);\n", + [ic_util:mk_oe_name(G, "sizecalc_"), Name]), + + emit(Fd, "int ~s~s(CORBA_Environment *oe_env, int* oe_size_count_index, " + "int* oe_size) {\n", [ic_util:mk_oe_name(G, "sizecalc_"), Name]), + + emit(Fd, " int oe_malloc_size = 0;\n",[]), + emit(Fd, " int oe_error_code = 0;\n",[]), + emit(Fd, " int oe_type = 0;\n",[]), + emit(Fd, " int oe_array_size = 0;\n",[]), + + {ok, RamFd} = ram_file:open([], [binary, write]), + + emit_sizecount(array, G, N, nil, RamFd, {Name, Dim}, Type), + + ic_cbe:emit_tmp_variables(Fd), + ic_codegen:nl(Fd), + %% Move data from ram file to output file. + {ok, Data} = ram_file:get_file(RamFd), + emit(Fd, Data), + ram_file:close(RamFd), + + emit(Fd, " return 0;\n\n",[]), + emit(Fd, "}\n",[]), + + put(op_variable_count, 0), + put(tmp_declarations, []), + + RefStr = get_refStr(Dim), + + case TypeDefFlag of + typedef -> + emit(HFd, "int ~s~s(CORBA_Environment *oe_env, ~s);\n", + [ic_util:mk_oe_name(G, "encode_"), Name, Name]), + + emit(Fd, "int ~s~s(CORBA_Environment *oe_env, ~s oe_rec) {\n", + [ic_util:mk_oe_name(G, "encode_"), Name, Name]); + no_typedef -> + + emit(HFd, "int ~s~s(CORBA_Environment *oe_env, ~s oe_rec~s);\n", + [ic_util:mk_oe_name(G, "encode_"), + Name, + ic_cbe:mk_c_type(G, N, Type), + RefStr]), + + emit(Fd, "int ~s~s(CORBA_Environment *oe_env, ~s oe_rec~s) {\n", + [ic_util:mk_oe_name(G, "encode_"), + Name, + ic_cbe:mk_c_type(G, N, Type), + RefStr]) + end, + + emit(Fd, " int oe_error_code = 0;\n",[]), + + {ok, RamFd1} = ram_file:open([], [binary, write]), + + case TypeDefFlag of + typedef -> + emit_encode(array, G, N, nil, RamFd1, {Name, Dim}, Type); + no_typedef -> + emit_encode(array_no_typedef, G, N, nil, RamFd1, {Name, Dim}, Type) + end, + + ic_cbe:emit_tmp_variables(Fd), + ic_codegen:nl(Fd), + %% Move data from ram file to output file. + {ok, Data1} = ram_file:get_file(RamFd1), + emit(Fd, Data1), + ram_file:close(RamFd1), + + emit(Fd, " return 0;\n\n",[]), + emit(Fd, "}\n",[]), + + put(op_variable_count, 0), + put(tmp_declarations, []), + + case TypeDefFlag of + typedef -> + emit(HFd, "int ~s~s(CORBA_Environment *oe_env, char *, " + "int*, ~s);\n", + [ic_util:mk_oe_name(G, "decode_"), Name, Name]), + + emit(Fd, "int ~s~s(CORBA_Environment *oe_env, char *oe_first, " + "int* oe_outindex, ~s oe_out) {\n", + [ic_util:mk_oe_name(G, "decode_"), Name, Name]); + no_typedef -> + emit(HFd, "int ~s~s(CORBA_Environment *oe_env, char *, int*, " + "~s oe_rec~s);\n", + [ic_util:mk_oe_name(G, "decode_"), + Name, + ic_cbe:mk_c_type(G, N, Type), + RefStr]), + + emit(Fd, "int ~s~s(CORBA_Environment *oe_env, char *oe_first, " + "int* oe_outindex, ~s oe_out~s) {\n", + [ic_util:mk_oe_name(G, "decode_"), + Name, + ic_cbe:mk_c_type(G, N, Type), + RefStr]) + end, + + emit(Fd, " int oe_error_code = 0;\n",[]), + emit(Fd, " int oe_array_size = 0;\n",[]), + + {ok, RamFd2} = ram_file:open([], [binary, write]), + + case TypeDefFlag of + typedef -> + emit_decode(array, G, N, nil, RamFd2, {Name, Dim}, Type); + no_typedef -> + emit_decode(array_no_typedef, G, N, nil, RamFd2, {Name, Dim}, Type) + end, + + + ic_cbe:emit_tmp_variables(Fd), + ic_codegen:nl(Fd), + %% Move data from ram file to output file. + {ok, Data2} = ram_file:get_file(RamFd2), + emit(Fd, Data2), + ram_file:close(RamFd2), + + emit(Fd, " *oe_outindex = ~s;\n\n",[align("*oe_outindex")]), + + emit(Fd, " return 0;\n\n",[]), + emit(Fd, "}\n",[]), + file:close(Fd). + + +get_refStr([]) -> + ""; +get_refStr([X|Xs]) -> + "[" ++ X ++ "]" ++ get_refStr(Xs). + + +emit_sequence_head_def(G, N, X, T, c) -> + %% T is the sequence + case ic_genobj:is_hrlfile_open(G) of + true -> + Fd = ic_genobj:hrlfiled(G), + SeqName = ic_util:to_undersc([ic_forms:get_id2(X) | N]), + emit(Fd, "\n#ifndef __~s__\n",[ic_util:to_uppercase(SeqName)]), + emit(Fd, "#define __~s__\n",[ic_util:to_uppercase(SeqName)]), + ic_codegen:mcomment_light(Fd, + [io_lib:format("Struct definition: ~s", + [SeqName])], + c), + emit(Fd, "typedef struct {\n"), + emit(Fd, " CORBA_unsigned_long _maximum;\n"), + emit(Fd, " CORBA_unsigned_long _length;\n"), + emit_seq_buffer(Fd, G, N, T#sequence.type), + emit(Fd, "} ~s;\n\n", [SeqName]), + create_c_struct_coding_file(G, N, X, T, SeqName, + T#sequence.type, sequence_head), + emit(Fd, "\n#endif\n\n"); + + false -> + ok + end. + +emit_seq_buffer(Fd, G, N, Type) -> + emit(Fd, " ~s* _buffer;\n", + [ic_cbe:mk_c_type(G, N, Type)]). + +%%------------------------------------------------------------ +%% +%% Emit decode bodies for functions in C for array, sequences and +%% structs. +%% +%%------------------------------------------------------------ +emit_decode(array, G, N, _T, Fd, {_Name, Dim}, Type) -> + emit(Fd, " if((char*) oe_out == oe_first)\n",[]), + AlignName = + lists:concat(["*oe_outindex + ", dim_multiplication(Dim), + " * sizeof(", ic_cbe:mk_c_type(G, N, Type),")"]), + emit(Fd, " *oe_outindex = ~s;\n\n",[align(AlignName)]), + array_decode_dimension_loop(G, N, Fd, Dim, "", Type, array); +emit_decode(array_no_typedef, G, N, _T, Fd, {_Name, Dim}, Type) -> + emit(Fd, " if((char*) oe_out == oe_first)\n",[]), + AlignName = + lists:concat(["*oe_outindex + ", dim_multiplication(Dim), + " * sizeof(", ic_cbe:mk_c_type(G, N, Type),")"]), + emit(Fd, " *oe_outindex = ~s;\n\n",[align(AlignName)]), + array_decode_dimension_loop(G, N, Fd, Dim, "", Type, array_no_typedef); +emit_decode(sequence_head, G, N, T, Fd, SeqName, ElType) -> + ic_cbe:store_tmp_decl(" int oe_seq_len = 0;\n", []), + ic_cbe:store_tmp_decl(" int oe_seq_count = 0;\n", []), + ic_cbe:store_tmp_decl(" int oe_seq_dummy = 0;\n", []), + + TmpBuf = + case ictype:isBasicTypeOrEterm(G, N, ElType) of + true -> + Tmp = "oe_seq_tmpbuf", + ic_cbe:store_tmp_decl(" char* ~s = 0;\n", [Tmp]), + Tmp; + false -> + "NOT USED" + end, + + MaxSize = get_seq_max(T), + emit(Fd, " if((char*) oe_out == oe_first)\n",[]), + emit(Fd, " *oe_outindex = ~s;\n\n", + [align(["*oe_outindex + sizeof(", SeqName, ")"])]), + + Ctype = ic_cbe:mk_c_type(G, N, ElType), + emit(Fd, " if ((oe_error_code = ei_decode_list_header(oe_env->_inbuf, " + "&oe_env->_iin, &oe_seq_len)) < 0) {\n"), + case ictype:isBasicTypeOrEterm(G, N, ElType) of + true -> + emit(Fd, " int oe_type = 0;\n"), + emit(Fd, " (int) ei_get_type(oe_env->_inbuf, &oe_env->_iin, " + "&oe_type, &oe_seq_len);\n\n"), + + if + MaxSize == infinity -> + ok; + true -> + emit(Fd, " if (oe_seq_len > ~w) {\n", [MaxSize]), + emit(Fd, " CORBA_exc_set(oe_env, " + "CORBA_SYSTEM_EXCEPTION, DATA_CONVERSION, " + "\"Length of sequence `~s' out of bound\");\n" + " return -1;\n }\n", [SeqName]) + end, + emit(Fd, " oe_out->_maximum = oe_seq_len;\n"), + emit(Fd, " oe_out->_length = oe_seq_len;\n"), + emit(Fd, " oe_out->_buffer = (void *) (oe_first + " + "*oe_outindex);\n"), + emit(Fd, " *oe_outindex = ~s;\n", + [align(["*oe_outindex + (sizeof(", Ctype, ") * " + "oe_out->_length)"])]), + emit(Fd, + " if ((~s = malloc(oe_seq_len + 1)) == NULL) {\n" + " CORBA_exc_set(oe_env, CORBA_SYSTEM_EXCEPTION, " + "NO_MEMORY, \"Cannot malloc\");\n" + " return -1;\n" + " }\n", [TmpBuf]), + emit(Fd, " if ((oe_error_code = ei_decode_string(" + "oe_env->_inbuf, &oe_env->_iin, ~s)) < 0) {\n", [TmpBuf]), + emit(Fd, " CORBA_free(~s);\n\n", [TmpBuf]), + emit_c_dec_rpt(Fd, " ", "string1", []), + emit(Fd, " return oe_error_code;\n }\n"), + emit(Fd, " for (oe_seq_count = 0; " + "oe_seq_count < oe_out->_length; oe_seq_count++)\n"), + case ictype:isBasicType(G, N, ElType) of + true -> + emit(Fd, " oe_out->_buffer[oe_seq_count] = (unsigned char) " + "~s[oe_seq_count];\n\n", [TmpBuf]); + false -> %% Term + emit(Fd, " oe_out->_buffer[oe_seq_count] = " + "erl_mk_int(~s[oe_seq_count]);\n\n",[TmpBuf]) % XXXX What? + end, + emit(Fd, " CORBA_free(~s);\n\n", [TmpBuf]); + false -> + emit(Fd, " return oe_error_code;\n") + end, + + emit(Fd, " } else {\n"), + + if + MaxSize == infinity -> + ok; + true -> + emit(Fd, " if (oe_seq_len > ~w) {\n", [MaxSize]), + emit(Fd, " CORBA_exc_set(oe_env, " + "CORBA_SYSTEM_EXCEPTION, DATA_CONVERSION, " + "\"Length of sequence `~s' out of bound\");\n" + " return -1;\n }\n", [SeqName]) + end, + + emit(Fd, " oe_out->_maximum = oe_seq_len;\n"), + emit(Fd, " oe_out->_length = oe_seq_len;\n"), + emit(Fd, " oe_out->_buffer = (void *) (oe_first + *oe_outindex);\n"), + emit(Fd, " *oe_outindex = ~s;\n\n", + [align(["*oe_outindex + (sizeof(", Ctype, ") * oe_out->_length)"])]), + + if + Ctype == "CORBA_char *" -> + emit(Fd, " for (oe_seq_count = 0; " + "oe_seq_count < oe_out->_length; oe_seq_count++) {\n"), + emit(Fd, " oe_out->_buffer[oe_seq_count] = " + "(void*) (oe_first + *oe_outindex);\n\n"), + ic_cbe:emit_decoding_stmt(G, N, Fd, ElType, + "oe_out->_buffer[oe_seq_count]", + "", + "oe_env->_inbuf", 0, "", caller_dyn), + emit(Fd, " *oe_outindex = ~s;", + [align(["*oe_outindex + strlen(oe_out->_buffer[" + "oe_seq_count]) + 1"])]); + true -> + emit(Fd, " for (oe_seq_count = 0; " + "oe_seq_count < oe_out->_length; oe_seq_count++) {\n"), + case ictype:isArray(G, N, ElType) of + %% XXX Silly. There is no real difference between the + %% C statements produced by the following calls. + true -> + ic_cbe:emit_decoding_stmt(G, N, Fd, ElType, + "oe_out->_buffer[oe_seq_count]", + "", + "oe_env->_inbuf", + 0, "oe_outindex", generator); + false -> + ic_cbe:emit_decoding_stmt(G, N, Fd, ElType, + "oe_out->_buffer + oe_seq_count", + "", + "oe_env->_inbuf", + 0, "oe_outindex", generator) + end + end, + emit(Fd, " }\n"), + emit(Fd, " if (oe_out->_length != 0) {\n"), + emit(Fd, " if ((oe_error_code = ei_decode_list_header(" + "oe_env->_inbuf, &oe_env->_iin, &oe_seq_dummy)) < 0) {\n"), + emit_c_dec_rpt(Fd, " ", "ei_decode_list_header", []), + emit(Fd, " return oe_error_code;\n }\n"), + emit(Fd, " } else\n"), + emit(Fd, " oe_out->_buffer = NULL;\n"), + emit(Fd, " }\n"); + +emit_decode(struct, G, N, _T, Fd, StructName, ElTypes) -> + Length = length(ElTypes) + 1, + Tname = ic_cbe:mk_variable_name(op_variable_count), + Tname1 = ic_cbe:mk_variable_name(op_variable_count), + + ic_cbe:store_tmp_decl(" int ~s = 0;\n",[Tname]), + ic_cbe:store_tmp_decl(" char ~s[256];\n\n",[Tname1]), + + emit(Fd, " if((char*) oe_out == oe_first)\n",[]), + AlignName = lists:concat(["*oe_outindex + sizeof(",StructName,")"]), + emit(Fd, " *oe_outindex = ~s;\n\n", [align(AlignName)]), + + emit(Fd, " if ((oe_error_code = ei_decode_tuple_header(oe_env->_inbuf, " + "&oe_env->_iin, &~s)) < 0) {\n", [Tname]), + emit_c_dec_rpt(Fd, " ", "ei_decode_tuple_header", []), + emit(Fd, " return oe_error_code;\n }\n"), + + emit(Fd, " if (~s != ~p) {\n",[Tname, Length]), + emit_c_dec_rpt(Fd, " ", "tuple header size != ~p", [Length]), + emit(Fd, " return -1;\n }\n"), + + emit(Fd, " if ((oe_error_code = ei_decode_atom(oe_env->_inbuf, " + "&oe_env->_iin, ~s)) < 0) {\n", [Tname1]), + emit_c_dec_rpt(Fd, " ", "ei_decode_atom", []), + emit(Fd, " return oe_error_code;\n }\n"), + emit(Fd, " if (strcmp(~s, ~p) != 0)\n",[Tname1, StructName]), + emit(Fd, " return -1;\n\n"), + lists:foreach( + fun({ET, EN}) -> + case ic_cbe:is_variable_size(G, N, ET) of + true -> + case ET of + + {struct, _, _, _} -> + %% Sequence member = a struct + ic_cbe:emit_decoding_stmt(G, N, Fd, + StructName ++ "_" ++ + ic_forms:get_id2(ET), + "&oe_out->" ++ EN, + "", "oe_env->_inbuf", + 0, + "oe_outindex", + generator); + + {sequence, _, _} -> + %% Sequence member = a struct XXX ?? + ic_cbe:emit_decoding_stmt(G, N, Fd, + StructName ++ "_" ++ + EN, + "&oe_out->" ++ EN, + "", + "oe_env->_inbuf", + 0, + "oe_outindex", + generator); + {_,{array, _, _}} -> + emit(Fd, " oe_out->~s = (void *) " + "(oe_first+*oe_outindex);\n\n",[EN]), + ic_cbe:emit_decoding_stmt(G, N, Fd, + StructName ++ "_" ++ + EN, "oe_out->" ++ EN , + "", + "oe_env->_inbuf", + 0, + "oe_outindex", + generator); + + {union, _, _, _, _} -> + %% Sequence member = a union + ic_cbe:emit_decoding_stmt(G, N, Fd, + StructName ++ "_" ++ + ic_forms:get_id2(ET), + "&oe_out->" ++ EN, + "", + "oe_env->_inbuf", + 0, + "oe_outindex", + generator); + + {string,_} -> + ic_cbe:emit_decoding_stmt(G, N, Fd, + ET, + "oe_out->" ++ EN , + "", + "oe_env->_inbuf", + 0, + "oe_outindex", + generator_malloc); + + {scoped_id,_,_,_} -> + case ictype:member2type(G,StructName,EN) of + array -> + ic_cbe:emit_decoding_stmt(G, N, Fd, + ET, + "oe_out->" ++ + EN, + "", + "oe_env->" + "_inbuf", + 0, + "oe_outindex", + generator); + struct -> + ic_cbe:emit_decoding_stmt(G, N, Fd, + ET, + "&oe_out->" ++ + EN , + "", + "oe_env->" + "_inbuf", + 0, + "oe_outindex", + generator); + sequence -> + ic_cbe:emit_decoding_stmt(G, N, Fd, + ET, + "&oe_out->" ++ + EN, + "", + "oe_env->" + "_inbuf", + 0, + "oe_outindex", + generator); + union -> + ic_cbe:emit_decoding_stmt(G, N, Fd, + ET, + "&oe_out->" ++ + EN, + "", + "oe_env->" + "_inbuf", + 0, + "oe_outindex", + generator); + _ -> + ic_cbe:emit_decoding_stmt(G, N, Fd, + ET, + "oe_out->" ++ + EN, + "", + "oe_env->" + "_inbuf", + 0, + "oe_outindex", + generator) + end; + + _ -> + emit(Fd, " oe_out->~s = (void *) " + "(oe_first+*oe_outindex);\n\n",[EN]), + ic_cbe:emit_decoding_stmt(G, N, Fd, + ET, + "oe_out->" ++ EN , + "", + "oe_env->_inbuf", + 0, "oe_outindex", + generator) + end; + false -> + case ET of + + {struct, _, _, _} -> + %% A struct member + ic_cbe:emit_decoding_stmt(G, N, Fd, + StructName ++ "_" ++ + ic_forms:get_id2(ET), + "&oe_out->" ++ EN , + "", + "oe_env->_inbuf", + 0, + "oe_outindex", + generator); + + {_,{array, _, _}} -> + ic_cbe:emit_decoding_stmt(G, N, Fd, + StructName ++ "_" ++ + EN, + "oe_out->" ++ EN , + "", + "oe_env->_inbuf", + 0, + "oe_outindex", + generator); + + {union, _, _, _, _} -> + %% Sequence member = a union + ic_cbe:emit_decoding_stmt(G, N, Fd, + StructName ++ "_" ++ + ic_forms:get_id2(ET), + "&oe_out->" ++ EN , + "", + "oe_env->_inbuf", + 0, + "oe_outindex", + generator); + + {_,_} -> + ic_cbe:emit_decoding_stmt(G, N, Fd, + ET, + "&oe_out->" ++ EN , + "", + "oe_env->_inbuf", + 0, + "oe_outindex", + generator); + {scoped_id,_,_,_} -> + case ic_symtab:get_full_scoped_name(G, N, ET) of + {_FullScopedName, _, {tk_array,_,_}, _} -> + ic_cbe:emit_decoding_stmt(G, N, Fd, + ET, + "oe_out->" ++ + EN, + "", + "oe_env->" + "_inbuf", + 0, + "oe_outindex", + generator); + {_FullScopedName, _, {tk_string,_}, _} -> + ic_cbe:emit_decoding_stmt(G, N, Fd, + ET, + "oe_out->" ++ + EN, + "", + "oe_env->" + "_inbuf", + 0, + "oe_outindex", + generator); + {_FullScopedName, _, {tk_struct,_,_,_}, _} -> + ic_cbe:emit_decoding_stmt(G, N, Fd, + ET, + "&oe_out->" ++ + EN, + "", + "oe_env->" + "_inbuf", + 0, + "oe_outindex", + generator); + + {_FullScopedName, _, + {tk_union,_,_,_,_,_}, _} -> + ic_cbe:emit_decoding_stmt(G, N, Fd, + ET, + "&oe_out->" ++ + EN, + "", + "oe_env->" + "_inbuf", + 0, + "oe_outindex", + generator); + + _ -> + ic_cbe:emit_decoding_stmt(G, N, Fd, + ET, + "&oe_out->" ++ + EN, + "", + "oe_env->" + "_inbuf", + 0, + "oe_outindex", + generator) + end + end + end + end, + ElTypes). + + +ref_array_static_dec(array, true) -> + %% Typedef, Static, Basic Type + "&(oe_out)"; +ref_array_static_dec(array, false) -> + %% Typedef, Static, Constr Type + "&(oe_out)"; +ref_array_static_dec(array_no_typedef, true) -> + %% No Typedef, Static, Basic Type + "&oe_out"; +ref_array_static_dec(array_no_typedef, false) -> + %% No Typedef, Static, Constr Type + "&oe_out". + + +ref_array_dynamic_dec(G, N, T, array) -> + case ictype:isString(G, N, T) of + true -> % Typedef, Dynamic, String + "oe_out"; + false -> % Typedef, Dynamic, No String + "&(oe_out)" + end; +ref_array_dynamic_dec(G, N, T, array_no_typedef) -> + case ictype:isString(G, N, T) of + true -> % No Typedef, Dynamic, String + "oe_out"; + false -> % No Typedef, Dynamic, No String + "&oe_out" + end. + + + +array_decode_dimension_loop(G, N, Fd, [Dim], Dimstr, Type, TDFlag) -> + Tname = ic_cbe:mk_variable_name(op_variable_count), + ic_cbe:store_tmp_decl(" int ~s = 0;\n",[Tname]), + + emit(Fd, " if ((oe_error_code = ei_decode_tuple_header(oe_env->_inbuf, " + "&oe_env->_iin, &oe_array_size)) < 0) {\n", + []), + emit_c_dec_rpt(Fd, " ", "ei_decode_tuple_header", []), + emit(Fd, " return oe_error_code;\n }\n"), + + %% This is disabled due to a bug in erl_interface : + %% tuples inside tuples hae no correct data about the size + %% of the tuple........( allways = 0 ) + %%emit(Fd, " if (oe_array_size != ~s)\n",[Dim]), + %%emit(Fd, " return -1;\n\n"), + + emit(Fd, " for (~s = 0; ~s < ~s; ~s++) {\n", + [Tname, Tname, Dim, Tname]), + + + ArrAccess = + case ic_cbe:is_variable_size(G, N, Type) of + true -> + ref_array_dynamic_dec(G, N, Type, TDFlag) ++ + Dimstr ++ "[" ++ Tname ++ "]"; + false -> + ref_array_static_dec(TDFlag, ictype:isBasicType(G,N,Type)) ++ + Dimstr ++ "[" ++ Tname ++ "]" + end, + + ic_cbe:emit_decoding_stmt(G, N, Fd, Type, + ArrAccess, + "", "oe_env->_inbuf", 0, + "oe_outindex", generator), + + %% emit(Fd, "\n *oe_outindex += + %% sizeof(~s);\n",[ic_cbe:mk_c_type(G, N, Type)]), + emit(Fd, " }\n"); +array_decode_dimension_loop(G, N, Fd, [Dim | Ds], _Dimstr, Type, TDFlag) -> + Tname = ic_cbe:mk_variable_name(op_variable_count), + ic_cbe:store_tmp_decl(" int ~s = 0;\n",[Tname]), + + emit(Fd, " if ((oe_error_code = ei_decode_tuple_header(oe_env->_inbuf, " + "&oe_env->_iin, &oe_array_size)) < 0) {\n", + []), + emit_c_dec_rpt(Fd, " ", "ei_decode_tuple_header", []), + emit(Fd, " return oe_error_code;\n }\n"), + + %% This is disabled due to a bug in erl_interface : + %% tuples inside tuples hae no correct data about the size + %% of the tuple........( allways = 0 ) + %%emit(Fd, " if (oe_array_size != ~s)\n",[Dim]), + %%emit(Fd, " return -1;\n\n"), + + emit(Fd, " for (~s = 0; ~s < ~s; ~s++) {\n", + [Tname, Tname, Dim, Tname]), + array_decode_dimension_loop(G, N, Fd, Ds, "[" ++ Tname ++ "]" , Type, + TDFlag), + + emit(Fd, " }\n"). + +dim_multiplication([D]) -> + D; +dim_multiplication([D |Ds]) -> + D ++ "*" ++ dim_multiplication(Ds). + +emit_encode(array, G, N, _T, Fd, {_Name, Dim}, Type) -> + array_encode_dimension_loop(G, N, Fd, Dim, {"",""}, Type, array); +emit_encode(array_no_typedef, G, N, _T, Fd, {_Name, Dim}, Type) -> + array_encode_dimension_loop(G, N, Fd, Dim, {"",""}, Type, + array_no_typedef); +emit_encode(sequence_head, G, N, T, Fd, SeqName, ElType) -> + Tname = ic_cbe:mk_variable_name(op_variable_count), + ic_cbe:store_tmp_decl(" int ~s = 0;\n\n",[Tname]), + + MaxSize = get_seq_max(T), + if + MaxSize == infinity -> + ok; + true -> + emit(Fd, " if (oe_rec->_length > ~w) {\n", [MaxSize]), + emit(Fd, " CORBA_exc_set(oe_env, CORBA_SYSTEM_EXCEPTION, " + "DATA_CONVERSION, \"Length of sequence `~s' " + "out of bound\");\n" + " return -1;\n }\n", [SeqName]) + end, + + emit(Fd, " if (oe_rec->_length != 0) {\n"), + + emit(Fd, " if ((oe_error_code = oe_ei_encode_list_header(oe_env, " + "oe_rec->_length)) < 0) {\n", + []), + emit_c_enc_rpt(Fd, " ", "oi_ei_encode_list_header", []), + emit(Fd, " return oe_error_code;\n }\n"), + + emit(Fd, " for (~s = 0; ~s < oe_rec->_length; ~s++) {\n", + [Tname, Tname, Tname]), + case ElType of + {_,_} -> %% ElType = elementary type or pointer type + ic_cbe:emit_encoding_stmt(G, N, Fd, ElType, "oe_rec->_buffer[" ++ + Tname ++ "]", "oe_env->_outbuf"); + + {scoped_id,local,_,["term","erlang"]} -> + ic_cbe:emit_encoding_stmt(G, N, Fd, ElType, "oe_rec->_buffer[" ++ + Tname ++ "]", "oe_env->_outbuf"); + + {scoped_id,_,_,_} -> + case ic_symtab:get_full_scoped_name(G, N, ElType) of + {_, typedef, TDef, _} -> + case TDef of + {tk_struct,_,_,_} -> + ic_cbe:emit_encoding_stmt(G, N, Fd, ElType, + "&oe_rec->_buffer[" ++ + Tname ++ "]", + "oe_env->_outbuf"); + {tk_sequence,_,_} -> + ic_cbe:emit_encoding_stmt(G, N, Fd, ElType, + "&oe_rec->_buffer[" ++ + Tname ++ "]", + "oe_env->_outbuf"); + {tk_union,_,_,_,_,_} -> + ic_cbe:emit_encoding_stmt(G, N, Fd, ElType, + "&oe_rec->_buffer[" ++ + Tname ++ "]", + "oe_env->_outbuf"); + _ -> + ic_cbe:emit_encoding_stmt(G, N, Fd, ElType, + "oe_rec->_buffer[" ++ + Tname ++ "]", + "oe_env->_outbuf") + end; + {_,enum,_,_} -> + ic_cbe:emit_encoding_stmt(G, N, Fd, ElType, + "oe_rec->_buffer[" ++ + Tname ++ "]", + "oe_env->_outbuf"); + _ -> + ic_cbe:emit_encoding_stmt(G, N, Fd, ElType, + "&oe_rec->_buffer[" ++ + Tname ++ "]", + "oe_env->_outbuf") + end; + + _ -> %% ElType = structure + ic_cbe:emit_encoding_stmt(G, N, Fd, ElType, + "&oe_rec->_buffer[" ++ Tname ++ "]", + "oe_env->_outbuf") + end, + emit(Fd, " }\n"), + emit(Fd, " }\n"), + emit(Fd, " if ((oe_error_code = oe_ei_encode_empty_list(oe_env)) < 0) {\n"), + emit_c_enc_rpt(Fd, " ", "oe_ei_encode_empty_list", []), + emit(Fd, " return oe_error_code;\n }\n"); +emit_encode(struct, G, N, _T, Fd, StructName, ElTypes) -> + Length = length(ElTypes) + 1, + emit(Fd, " if ((oe_error_code = " + "oe_ei_encode_tuple_header(oe_env, ~p)) < 0) {\n", [Length]), + emit_c_enc_rpt(Fd, " ", "oe_ei_encode_tuple_header", []), + emit(Fd, " return oe_error_code;\n }\n"), + emit(Fd, " if ((oe_error_code = " + "oe_ei_encode_atom(oe_env, ~p)) < 0) {\n", [StructName]), + emit_c_enc_rpt(Fd, " ", "oe_ei_encode_atom", []), + emit(Fd, " return oe_error_code;\n }\n"), + lists:foreach( + fun({ET, EN}) -> + case ET of + {sequence, _, _} -> + %% Sequence = struct + ic_cbe:emit_encoding_stmt(G, N, Fd, + StructName ++ "_" ++ EN, + "&oe_rec->" ++ EN, + "oe_env->_outbuf"); + {_,{array, _, _Dims}} -> + ic_cbe:emit_encoding_stmt(G, N, Fd, + StructName ++ "_" ++ EN, + "oe_rec->" ++ EN, + "oe_env->_outbuf"); + + {union,_,_,_,_} -> + ic_cbe:emit_encoding_stmt(G, N, Fd, + StructName ++ "_" ++ + ic_forms:get_id2(ET), + "&oe_rec->" ++ EN, + "oe_env->_outbuf"); + + {struct,_,_,_} -> + ic_cbe:emit_encoding_stmt(G, N, Fd, + StructName ++ "_" ++ + ic_forms:get_id2(ET), + "&oe_rec->" ++ EN, + "oe_env->_outbuf"); + + {scoped_id,_,_,_} -> + case ictype:member2type(G,StructName,EN) of + struct -> + ic_cbe:emit_encoding_stmt(G, N, Fd, + ET, + "&oe_rec->" ++ EN, + "oe_env->_outbuf"); + sequence -> + ic_cbe:emit_encoding_stmt(G, N, Fd, + ET, + "&oe_rec->" ++ EN, + "oe_env->_outbuf"); + union -> + ic_cbe:emit_encoding_stmt(G, N, Fd, + ET, + "&oe_rec->" ++ EN, + "oe_env->_outbuf"); + array -> + ic_cbe:emit_encoding_stmt(G, N, Fd, + ET, + "oe_rec->" ++ EN, + "oe_env->_outbuf"); + _ -> + ic_cbe:emit_encoding_stmt(G, N, Fd, + ET, + "oe_rec->" ++ EN, + "oe_env->_outbuf") + end; + _ -> + ic_cbe:emit_encoding_stmt(G, N, Fd, + ET, + "oe_rec->" ++ EN, + "oe_env->_outbuf") + end + end, + ElTypes). + +ref_array_static_enc(array, true) -> + %% Typedef, Static, Basic Type + "oe_rec"; +ref_array_static_enc(array, false) -> + %% Typedef, Static, Constr Type + "&(oe_rec)"; +ref_array_static_enc(array_no_typedef, true) -> + %% No Typedef, Static, Basic Type + "oe_rec"; +ref_array_static_enc(array_no_typedef, false) -> + %% No Typedef, Static, Constr Type + "&oe_rec". + + +ref_array_dynamic_enc(G, N, T, array) -> + case ictype:isString(G, N, T) of + true -> % Typedef, Dynamic, String + "oe_rec"; + false -> % Typedef, Dynamic, No String + "&(oe_rec)" + end; +ref_array_dynamic_enc(G, N, T, array_no_typedef) -> + case ictype:isString(G, N, T) of + true -> % No Typedef, Dynamic, String + "oe_rec"; + false -> % No Typedef, Dynamic, No String + "&oe_rec" + end. + + + +array_encode_dimension_loop(G, N, Fd, [Dim], {Str1,_Str2}, Type, TDFlag) -> + Tname = ic_cbe:mk_variable_name(op_variable_count), + ic_cbe:store_tmp_decl(" int ~s = 0;\n",[Tname]), + + emit(Fd, " if ((oe_error_code = " + "oe_ei_encode_tuple_header(oe_env, ~s)) < 0) {\n", [Dim]), + emit_c_enc_rpt(Fd, " ", "oe_ei_encode_tuple_header", []), + emit(Fd, " return oe_error_code;\n }\n"), + + emit(Fd, " for (~s = 0; ~s < ~s; ~s++) {\n", + [Tname, Tname, Dim, Tname]), + + ArrAccess = + case ic_cbe:is_variable_size(G, N, Type) of + true -> + ref_array_dynamic_enc(G, N, Type, TDFlag) ++ + Str1 ++ "[" ++ Tname ++ "]"; + false -> + ref_array_static_enc(TDFlag, ictype:isBasicType(G,N,Type)) ++ + Str1 ++ "[" ++ Tname ++ "]" + end, + + ic_cbe:emit_encoding_stmt(G, N, Fd, Type, ArrAccess, "oe_env->_outbuf"), + emit(Fd, " }\n"); +array_encode_dimension_loop(G, N, Fd, [Dim | Ds],{Str1,Str2}, Type, TDFlag) -> + Tname = ic_cbe:mk_variable_name(op_variable_count), + ic_cbe:store_tmp_decl(" int ~s = 0;\n",[Tname]), + + emit(Fd, " if ((oe_error_code = " + "oe_ei_encode_tuple_header(oe_env, ~s)) < 0) {\n", [Dim]), + emit_c_enc_rpt(Fd, " ", "oe_ei_encode_tuple_header", []), + emit(Fd, " return oe_error_code;\n }\n"), + + emit(Fd, " for (~s = 0; ~s < ~s; ~s++) {\n", + [Tname, Tname, Dim, Tname]), + array_encode_dimension_loop(G, N, Fd, Ds, + {Str1 ++ "[" ++ Tname ++ "]", Str2}, + Type, TDFlag), + emit(Fd, " }\n"). + + +emit_sizecount(array, G, N, _T, Fd, {_Name, Dim}, Type) -> + emit(Fd, " if(*oe_size == 0)\n",[]), + AlignName = lists:concat(["*oe_size + ", dim_multiplication(Dim), + " * sizeof(", ic_cbe:mk_c_type(G, N, Type),")"]), + emit(Fd, " *oe_size = ~s;\n\n",[align(AlignName)]), + array_size_dimension_loop(G, N, Fd, Dim, Type), + emit(Fd, " *oe_size = ~s;\n\n", + [align("*oe_size + oe_malloc_size")]), + ic_codegen:nl(Fd); + +emit_sizecount(sequence_head, G, N, T, Fd, SeqName, ElType) -> + ic_cbe:store_tmp_decl(" int oe_seq_len = 0;\n", []), + ic_cbe:store_tmp_decl(" int oe_seq_count = 0;\n", []), + + emit(Fd, " if(*oe_size == 0)\n",[]), + emit(Fd, " *oe_size = ~s;\n\n", + [align(["*oe_size + sizeof(", SeqName, ")"])]), + + MaxSize = get_seq_max(T), + + emit(Fd, " if ((oe_error_code = ei_get_type(oe_env->_inbuf, " + "oe_size_count_index, &oe_type, &oe_seq_len)) < 0) {\n"), + emit_c_dec_rpt(Fd, " ", "ei_get_type", []), + emit(Fd, " return oe_error_code;\n }\n"), + + if + MaxSize == infinity -> + ok; + true -> + emit(Fd, " if (oe_seq_len > ~w) {\n", [MaxSize]), + emit(Fd, " CORBA_exc_set(oe_env, CORBA_SYSTEM_EXCEPTION, " + "DATA_CONVERSION, \"Length of sequence `~s' " + "out of bound\");\n" + " return -1;\n }\n", [SeqName]) + end, + + CType = ic_cbe:mk_c_type(G, N, ElType), + + emit(Fd, " if ((oe_error_code = ei_decode_list_header(oe_env->_inbuf, " + "oe_size_count_index, NULL)) < 0) {\n"), + + case ictype:isBasicTypeOrEterm(G, N, ElType) of + true -> + emit(Fd, " if ((oe_error_code = ei_decode_string(oe_env->" + "_inbuf, oe_size_count_index, NULL)) < 0) {\n"), + emit_c_dec_rpt(Fd, " ", "ei_decode_string", []), + emit(Fd, " return oe_error_code;\n }\n"), + + emit(Fd, " oe_malloc_size = ~s;\n\n", + [align(["sizeof(", CType, ") * oe_seq_len"])]); + false -> + emit_c_dec_rpt(Fd, " ", "non mea culpa", []), + emit(Fd, " return oe_error_code;\n\n") + end, + + emit(Fd, " } else {\n"), + + emit(Fd, " oe_malloc_size = ~s;\n\n", + [align(["sizeof(", CType, ") * oe_seq_len"])]), + + emit(Fd, " for (oe_seq_count = 0; oe_seq_count < oe_seq_len; " + "oe_seq_count++) {\n"), + ic_cbe:emit_malloc_size_stmt(G, N, Fd, ElType, + "oe_env->_inbuf", 0, generator), + emit(Fd, " }\n"), + + emit(Fd, " if (oe_seq_len != 0) \n"), + emit(Fd, " if ((oe_error_code = ei_decode_list_header(oe_env->_inbuf," + "oe_size_count_index, NULL)) < 0) {\n"), + emit_c_dec_rpt(Fd, " ", "ei_decode_list_header", []), + emit(Fd, " return oe_error_code;\n }\n"), + emit(Fd, " }\n"), + emit(Fd, " *oe_size = ~s;\n\n", [align("*oe_size + oe_malloc_size")]); + +emit_sizecount(struct, G, N, _T, Fd, StructName, ElTypes) -> + Length = length(ElTypes) + 1, + Tname = ic_cbe:mk_variable_name(op_variable_count), + ic_cbe:store_tmp_decl(" int ~s = 0;\n\n",[Tname]), + + emit(Fd, " if(*oe_size == 0)\n",[]), + AlignName = lists:concat(["*oe_size + sizeof(",StructName,")"]), + emit(Fd, " *oe_size = ~s;\n\n", [align(AlignName)]), + ic_codegen:nl(Fd), + + emit(Fd, " if ((oe_error_code = " + "ei_get_type(oe_env->_inbuf, oe_size_count_index, &oe_type, " + "&~s)) < 0) {\n", [Tname]), + emit_c_dec_rpt(Fd, " ", "ei_get_type", []), + emit(Fd, " return oe_error_code;\n }\n"), + + emit(Fd, " if (~s != ~p) {\n",[Tname, Length]), + emit_c_dec_rpt(Fd, " ", "~s != ~p", [Tname, Length]), + emit(Fd, " return -1;\n }\n"), + + + emit(Fd, " if ((oe_error_code = " + "ei_decode_tuple_header(oe_env->_inbuf, " + "oe_size_count_index, 0)) < 0) {\n"), + emit_c_dec_rpt(Fd, " ", "ei_decode_tuple_header", []), + emit(Fd, " return oe_error_code;\n }\n"), + emit(Fd, " if ((oe_error_code = " + "ei_decode_atom(oe_env->_inbuf, oe_size_count_index, 0)) < 0) {\n", []), + emit_c_dec_rpt(Fd, " ", "ei_decode_atom", []), + emit(Fd, " return oe_error_code;\n }\n"), + lists:foreach( + fun({ET, EN}) -> + case ic_cbe:is_variable_size(G, N, ET) of + true -> + case ET of + {sequence, _, _} -> + ic_cbe:emit_malloc_size_stmt( + G, N, Fd, + StructName ++ "_" ++ EN, + "oe_env->_inbuf", + 0, + generator); + {_,{array, _, _}} -> + ic_cbe:emit_malloc_size_stmt( + G, N, Fd, + StructName ++ "_" ++ EN, + "oe_env->_inbuf", + 0, + generator); + {union,_,_,_,_} -> + ic_cbe:emit_malloc_size_stmt( + G, N, Fd, + StructName ++ "_" ++ ic_forms:get_id2(ET), + "oe_env->_inbuf", + 0, + generator); + + {struct,_,_,_} -> + ic_cbe:emit_malloc_size_stmt( + G, N, Fd, + StructName ++ "_" ++ ic_forms:get_id2(ET), + "oe_env->_inbuf", + 0, + generator); + + _ -> + ic_cbe:emit_malloc_size_stmt( + G, N, Fd, + ET, + "oe_env->_inbuf", + 0, + generator) + end; + false -> + case ET of + {_,{array, _, _}} -> + ic_cbe:emit_malloc_size_stmt( + G, N, Fd, + StructName ++ "_" ++ EN, + "oe_env->_inbuf", + 0, + generator); + + {union,_,_,_,_} -> + ic_cbe:emit_malloc_size_stmt( + G, N, Fd, + StructName ++ "_" ++ ic_forms:get_id2(ET), + "oe_env->_inbuf", + 0, + generator); + + {struct,_,_,_} -> + ic_cbe:emit_malloc_size_stmt( + G, N, Fd, + StructName ++ "_" ++ ic_forms:get_id2(ET), + "oe_env->_inbuf", + 0, + generator); + _ -> + ic_cbe:emit_malloc_size_stmt( + G, N, Fd, + ET, + "oe_env->_inbuf", + 1, + generator) + end + end + end, + ElTypes), + + emit(Fd, " *oe_size = ~s;\n\n", + [align("*oe_size + oe_malloc_size")]). + + +array_size_dimension_loop(G, N, Fd, [Dim], Type) -> + Tname = ic_cbe:mk_variable_name(op_variable_count), + + ic_cbe:store_tmp_decl(" int ~s = 0;\n",[Tname]), + emit(Fd, " if ((oe_error_code = " + "ei_get_type(oe_env->_inbuf, oe_size_count_index, " + "&oe_type, &oe_array_size)) < 0) {\n", + []), + emit_c_dec_rpt(Fd, " ", "ei_get_type", []), + emit(Fd, " return oe_error_code;\n }\n"), + + emit(Fd, " if (oe_array_size != ~s) {\n",[Dim]), + emit_c_dec_rpt(Fd, " ", "array size != ~s", [Dim]), + emit(Fd, " return -1;\n }\n"), + + emit(Fd, " if ((oe_error_code = ei_decode_tuple_header(oe_env->_inbuf, " + "oe_size_count_index, 0)) < 0) {\n", []), + emit_c_dec_rpt(Fd, " ", "ei_decode_tuple_header", []), + emit(Fd, " return oe_error_code;\n }\n"), + + emit(Fd, " for (~s = 0; ~s < ~s; ~s++) {\n", + [Tname, Tname, Dim, Tname]), + ic_cbe:emit_malloc_size_stmt(G, N, Fd, + Type, "oe_env->_inbuf", 0, generator), + emit(Fd, " }\n"); +array_size_dimension_loop(G, N, Fd, [Dim | Ds], Type) -> + Tname = ic_cbe:mk_variable_name(op_variable_count), + + ic_cbe:store_tmp_decl(" int ~s = 0;\n",[Tname]), + emit(Fd, " if ((oe_error_code = " + "ei_get_type(oe_env->_inbuf, oe_size_count_index, " + "&oe_type, &oe_array_size)) < 0) {\n", []), + emit_c_dec_rpt(Fd, " ", "ei_get_type", []), + emit(Fd, " return oe_error_code;\n }\n"), + + emit(Fd, " if (oe_array_size != ~s) {\n",[Dim]), + emit_c_dec_rpt(Fd, " ", "array size != ~s", [Dim]), + emit(Fd, " return -1;\n }\n"), + + emit(Fd, " if ((oe_error_code = ei_decode_tuple_header(oe_env->_inbuf, " + "oe_size_count_index, 0)) < 0) {\n", + []), + emit_c_dec_rpt(Fd, " ", "ei_decode_tuple_header", []), + emit(Fd, " return oe_error_code;\n }\n"), + + emit(Fd, " for (~s = 0; ~s < ~s; ~s++) {\n", + [Tname, Tname, Dim, Tname]), + array_size_dimension_loop(G, N, Fd, Ds, Type), + emit(Fd, " }\n"). + + +create_c_struct_coding_file(G, N, _X, T, StructName, ElTypes, StructType) -> + + {Fd , SName} = open_c_coding_file(G, StructName), % stub file + HFd = ic_genobj:hrlfiled(G), % stub header file + HrlFName = filename:basename(ic_genobj:include_file(G)), + + ic_codegen:emit_stub_head(G, Fd, SName, c), + HrlFName = filename:basename(ic_genobj:include_file(G)), + emit(Fd, "#include \"~s\"\n\n",[HrlFName]), + + %% Size count + + put(op_variable_count, 0), + put(tmp_declarations, []), + + emit(HFd, "int ~s~s(CORBA_Environment *oe_env, int*, int*);\n", + [ic_util:mk_oe_name(G, "sizecalc_"), StructName]), + + emit(Fd, "int ~s~s(CORBA_Environment *oe_env, " + "int* oe_size_count_index, int* oe_size)\n{\n", + [ic_util:mk_oe_name(G, "sizecalc_"), StructName]), + + emit(Fd, " int oe_malloc_size = 0;\n",[]), + emit(Fd, " int oe_error_code = 0;\n",[]), + emit(Fd, " int oe_type = 0;\n",[]), + + {ok, RamFd} = ram_file:open([], [binary, write]), + + emit_sizecount(StructType, G, N, T, RamFd, StructName, ElTypes), + + ic_cbe:emit_tmp_variables(Fd), + ic_codegen:nl(Fd), + %% Move data from ram file to output file. + {ok, Data} = ram_file:get_file(RamFd), + emit(Fd, Data), + ram_file:close(RamFd), + + emit(Fd, " return 0;\n\n",[]), + emit(Fd, "}\n\n",[]), + + %% Encode + + put(op_variable_count, 0), + put(tmp_declarations, []), + + + emit(HFd, "int ~s~s(CORBA_Environment *oe_env, ~s*);\n", + [ic_util:mk_oe_name(G, "encode_"), StructName, StructName]), + + emit(Fd, "int ~s~s(CORBA_Environment *oe_env, ~s* oe_rec)\n{\n", + [ic_util:mk_oe_name(G, "encode_"), StructName, StructName]), + + emit(Fd, " int oe_error_code = 0;\n",[]), + + {ok, RamFd1} = ram_file:open([], [binary, write]), + + emit_encode(StructType, G, N, T, RamFd1, StructName, ElTypes), + + ic_cbe:emit_tmp_variables(Fd), + ic_codegen:nl(Fd), + %% Move data from ram file to output file. + {ok, Data1} = ram_file:get_file(RamFd1), + emit(Fd, Data1), + ram_file:close(RamFd1), + + emit(Fd, " return 0;\n\n",[]), + emit(Fd, "}\n\n",[]), + + %% Decode + + put(op_variable_count, 0), + put(tmp_declarations, []), + + emit(HFd, "int ~s~s(CORBA_Environment *oe_env, char *, int*, ~s *);\n", + [ic_util:mk_oe_name(G, "decode_"), StructName, StructName]), + + emit(Fd, "int ~s~s(CORBA_Environment *oe_env, char *oe_first, " + "int* oe_outindex, " + "~s *oe_out)\n{\n", + [ic_util:mk_oe_name(G, "decode_"), StructName, StructName]), + + emit(Fd, " int oe_error_code = 0;\n",[]), + + {ok, RamFd2} = ram_file:open([], [binary, write]), + + emit_decode(StructType, G, N, T, RamFd2, StructName, ElTypes), + + ic_cbe:emit_tmp_variables(Fd), + ic_codegen:nl(Fd), + %% Move data from ram file to output file. + {ok, Data2} = ram_file:get_file(RamFd2), + emit(Fd, Data2), + ram_file:close(RamFd2), + + emit(Fd, " *oe_outindex = ~s;\n",[align("*oe_outindex")]), + emit(Fd, " return 0;\n\n",[]), + emit(Fd, "}\n\n",[]), + file:close(Fd). + + +%%------------------------------------------------------------ +%% +%% emit primitive for unions. +%% +%%------------------------------------------------------------ +emit_union(G, N, X, erlang) -> + case ic_genobj:is_hrlfile_open(G) of + true -> + ic_codegen:record(G, X, + ic_util:to_undersc([ic_forms:get_id2(X) | N]), + nil,nil), + mkFileRecObj(G,N,X,erlang); + false -> ok + end; +emit_union(_G, _N, _X, c) -> %% Not supported in c backend + true. + + +%%------------------------------------------------------------ +%% +%% emit erlang modules for objects with record definitions +%% (such as unions or structs), or sequences +%% +%% The record files, other than headers are only generated +%% for CORBA...... If wished an option could allows even +%% for other backends ( not necessary anyway ) +%% +%%------------------------------------------------------------ +mkFileRecObj(G,N,X,erlang) -> + case ic_options:get_opt(G, be) of + erl_corba -> + SName = + ic_util:to_undersc([ic_forms:get_id2(X) | N]), + FName = + ic_file:join(ic_options:get_opt(G, stubdir), + ic_file:add_dot_erl(SName)), + + case file:open(FName, [write]) of + {ok, Fd} -> + HrlFName = filename:basename(ic_genobj:include_file(G)), + + ic_codegen:emit_stub_head(G, Fd, SName, erlang), + emit(Fd, "-include(~p).\n\n",[HrlFName]), + emit_exports(G,Fd), + emit_rec_methods(G,N,X,SName,Fd), + ic_codegen:nl(Fd), + ic_codegen:nl(Fd), + file:close(Fd); + Other -> + exit(Other) + end; + _ -> + true + end. + + +%%------------------------------------------------------------ +%% +%% emit erlang modules for objects with array definitions.. +%% +%%------------------------------------------------------------ +mkFileArrObj(G,N,X,erlang) -> + SName = + ic_util:to_undersc([ic_forms:get_id2(X) | N]), + FName = + ic_file:join(ic_options:get_opt(G, stubdir), + ic_file:add_dot_erl(SName)), + + case file:open(FName, [write]) of + {ok, Fd} -> + HrlFName = filename:basename(ic_genobj:include_file(G)), + + ic_codegen:emit_stub_head(G, Fd, SName, erlang), + emit(Fd, "-include(~p).\n\n",[HrlFName]), + emit_exports(G,Fd), + emit_arr_methods(G,N,X,SName,Fd), + ic_codegen:nl(Fd), + ic_codegen:nl(Fd), + file:close(Fd); + Other -> + exit(Other) + end. + + + + +%%------------------------------------------------------------ +%% +%% emit exports for erlang modules which represent records. +%% +%%------------------------------------------------------------ +emit_exports(G,Fd) -> + case ic_options:get_opt(G, be) of + erl_corba -> + emit(Fd, "-export([tc/0,id/0,name/0]).\n\n\n\n",[]); + _ -> + emit(Fd, "-export([id/0,name/0]).\n\n\n\n",[]) + end. + + +%%------------------------------------------------------------ +%% +%% emit erlang module functions which represent records, yields +%% record information such as type code, identity and name. +%% +%%------------------------------------------------------------ +emit_rec_methods(G,N,X,Name,Fd) -> + + IR_ID = ictk:get_IR_ID(G, N, X), + + case ic_options:get_opt(G, be) of + + erl_corba -> + TK = ic_forms:get_tk(X), + + case TK of + undefined -> + STK = ic_forms:search_tk(G,ictk:get_IR_ID(G, N, X)), + emit(Fd, "%% returns type code\n",[]), + emit(Fd, "tc() -> ~p.\n\n",[STK]), + emit(Fd, "%% returns id\n",[]), + emit(Fd, "id() -> ~p.\n\n",[IR_ID]), + emit(Fd, "%% returns name\n",[]), + emit(Fd, "name() -> ~p.\n\n",[Name]); + _ -> + emit(Fd, "%% returns type code\n",[]), + emit(Fd, "tc() -> ~p.\n\n",[TK]), + emit(Fd, "%% returns id\n",[]), + emit(Fd, "id() -> ~p.\n\n",[IR_ID]), + emit(Fd, "%% returns name\n",[]), + emit(Fd, "name() -> ~p.\n\n",[Name]) + end; + + _ -> + emit(Fd, "%% returns id\n",[]), + emit(Fd, "id() -> ~p.\n\n",[IR_ID]), + emit(Fd, "%% returns name\n",[]), + emit(Fd, "name() -> ~p.\n\n",[Name]) + end. + + + +%%------------------------------------------------------------ +%% +%% emit erlang module functions which represent arrays, yields +%% record information such as type code, identity and name. +%% +%%------------------------------------------------------------ +emit_arr_methods(G,N,X,Name,Fd) -> + + IR_ID = ictk:get_IR_ID(G, N, X), + + case ic_options:get_opt(G, be) of + + erl_corba -> + + TK = ic_forms:get_type_code(G, N, X), + + emit(Fd, "%% returns type code\n",[]), + emit(Fd, "tc() -> ~p.\n\n",[TK]), + emit(Fd, "%% returns id\n",[]), + emit(Fd, "id() -> ~p.\n\n",[IR_ID]), + emit(Fd, "%% returns name\n",[]), + emit(Fd, "name() -> ~p.\n\n",[Name]); + + _ -> + + emit(Fd, "%% returns id\n",[]), + emit(Fd, "id() -> ~p.\n\n",[IR_ID]), + emit(Fd, "%% returns name\n",[]), + emit(Fd, "name() -> ~p.\n\n",[Name]) + end. + +get_seq_max(T) when is_record(T, sequence) andalso T#sequence.length == 0 -> + infinity; +get_seq_max(T) when is_record(T, sequence) andalso is_tuple(T#sequence.length) -> + list_to_integer(element(3, T#sequence.length)). + + +align(Cs) -> + ic_util:mk_align(Cs). + diff --git a/lib/ic/src/ictk.erl b/lib/ic/src/ictk.erl new file mode 100644 index 0000000000..63a7705699 --- /dev/null +++ b/lib/ic/src/ictk.erl @@ -0,0 +1,873 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1997-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(ictk). + + +%% Toplevel generation functions +-export([reg_gen/3, unreg_gen/3]). + + +%% Utilities +-export([get_IR_ID/3, get_IR_VSN/3, register_name/1, unregister_name/1]). + +-import(ic_forms, [get_id2/1, get_body/1, get_idlist/1]). +-import(ic_util, [mk_name/2, mk_oe_name/2, to_atom/1, to_list/1]). +-import(ic_codegen, [emit/2, emit/3, nl/1]). + +-include("icforms.hrl"). +-include("ic.hrl"). + +%%-------------------------------------------------------------------- +%% +%% IFR Registration Generation +%% +%% +%%-------------------------------------------------------------------- + +-define(IFRID(G), mk_name(G, "IFR")). +-define(VARID(G), mk_name(G, "VAR")). +-define(IFRMOD, orber_ifr). + +reg_gen(G, N, X) -> + S = ic_genobj:tktab(G), + Light = ic_options:get_opt(G, light_ifr), + init_var(), + case ic_genobj:is_stubfile_open(G) of + true when Light == false -> + Var = ?IFRID(G), + Fd = ic_genobj:stubfiled(G), + nl(Fd), nl(Fd), nl(Fd), + emit(Fd, "~p() ->\n", [to_atom(register_name(G))]), + emit(Fd, " ~s = ~p:find_repository(),\n", + [Var, ?IFRMOD]), + nl(Fd), + + %% Write call function that checks if included + %% modules and interfaces are created. + emit(Fd, " register_tests(~s),\n",[?IFRID(G)]), + + reg2(G, S, N, Var, X), + nl(Fd), + emit(Fd, " ok.\n"), + + %% Write general register test function. + register_tests(Fd,G), + + %% Write functopn that registers modules only if + %% they are not registered. + register_if_unregistered(Fd); + true when Light == true -> + Fd = ic_genobj:stubfiled(G), + nl(Fd), nl(Fd), nl(Fd), + Regname = to_atom(register_name(G)), + emit(Fd, "~p() ->\n\t~p([]).\n\n", [Regname, Regname]), + emit(Fd, "~p(OE_Options) ->\n\t~p:add_items(?MODULE, OE_Options,\n\t[", + [Regname, ?IFRMOD]), + reg_light(G, N, X), + emit(Fd, "ok]),\n\tok.\n"); + false -> + ok + end. + +reg_light(G, N, X) when is_list(X) -> + reg_light_list(G, N, X); +reg_light(G, N, X) when is_record(X, module) -> + reg_light_list(G, [get_id2(X) | N], get_body(X)); +reg_light(G, N, X) when is_record(X, struct) -> + emit(ic_genobj:stubfiled(G), "{~p, ~p, struct},\n\t", + [get_IR_ID(G, N, X), get_module(X, N)]); +reg_light(G, N, X) when is_record(X, except) -> + emit(ic_genobj:stubfiled(G), "{~p, ~p, except},\n\t", + [get_IR_ID(G, N, X), get_module(X, N)]); +reg_light(G, N, X) when is_record(X, union) -> + emit(ic_genobj:stubfiled(G), "{~p, ~p, union},\n\t", + [get_IR_ID(G, N, X), get_module(X, N)]); +reg_light(G, N, X) when is_record(X, interface) -> + emit(ic_genobj:stubfiled(G), "{~p, ~p, interface},\n\t", + [get_IR_ID(G, N, X), get_module(X, N)]), + reg_light_list(G, [get_id2(X)|N], get_body(X)); +reg_light(_G, _N, _X) -> + ok. + +get_module(X, N) -> + List = [get_id2(X) | N], + list_to_atom(lists:foldl(fun(E, Acc) -> E++"_"++Acc end, + hd(List), tl(List))). + +%% This function filters off all "#include .idl" code that +%% come along from preprocessor and scanner. Produces code ONLY for +%% the actuall file. See ticket OTP-2133 +reg_light_list(_G, _N, []) -> []; +reg_light_list(G, N, List ) -> + CurrentFileName = ic_genobj:idlfile(G), + reg_light_list(G, N, {CurrentFileName,true}, List). + +%% The filter function + loop +reg_light_list(_G, _N, {_CFN, _Status}, []) -> []; +reg_light_list(G, N, {CFN,Status}, [X | Xs]) -> + case Status of + true -> + case X of + {preproc,_,{_,_,_FileName},[{_,_,"1"}]} -> + reg_light_list(G, N, {CFN,false}, Xs); + _ -> + reg_light(G, N, X), + reg_light_list(G, N, {CFN,Status}, Xs) + end; + false -> + case X of + {preproc,_,{_,_,CFN},[{_,_,"2"}]} -> + reg_light(G, N, X), + reg_light_list(G, N, {CFN,true}, Xs); + _ -> + reg_light_list(G, N, {CFN,Status}, Xs) + end + end. + + +%% reg2 is top level registration + +reg2(G, S, N, Var, X) -> + reg2(G, S, N, "Repository_create_", Var, X). + +reg2(G, S, N, C, V, X) when is_list(X) -> reg2_list(G, S, N, C, V, X); + +reg2(G, S, N, C, V, X) when is_record(X, module) -> + NewV = r_emit2(G, S, N, C, V, X, "", []), + reg2_list(G, S, [get_id2(X) | N], "ModuleDef_create_", NewV, get_body(X)); + +reg2(G, S, N, C, V, X) when is_record(X, const) -> + r_emit2(G, S, N, C, V, X, ", ~s, ~p", + [get_idltype(G, S, N, X), {X#const.tk, X#const.val}]); + +reg2(G, S, N, C, V, X) when is_record(X, struct) -> + do_struct(G, S, N, C, V, X, ic_forms:get_tk(X)); + +reg2(G, S, N, C, V, X) when is_record(X, except) -> + do_except(G, S, N, C, V, X, ic_forms:get_tk(X)); + +reg2(G, S, N, C, V, X) when is_record(X, union) -> + do_union(G, S, N, C, V, X, ic_forms:get_tk(X)); + +reg2(G, S, N, C, V, X) when is_record(X, enum) -> + r_emit2(G, S, N, C, V, X, ", ~p", + [get_enum_member_list(G, S, N, get_body(X))]); + +reg2(G, S, N, C, V, X) when is_record(X, typedef) -> + do_typedef(G, S, N, C, V, X), + look_for_types(G, S, N, C, V, get_body(X)); + +reg2(G, S, N, C, V, X) when is_record(X, attr) -> + XX = #id_of{type=X}, + lists:foreach(fun(Id) -> r_emit2(G, S, N, C, V, XX#id_of{id=Id}, ", ~s, ~p", + [get_idltype(G, S, N, X), get_mode(G, N, X)]) + end, + get_idlist(X)); + +reg2(G, S, N, C, V, X) when is_record(X, interface) -> + N2 = [get_id2(X) | N], + Body = get_body(X), + BIs = get_base_interfaces(G,X), %% produce code for the interface inheritance + NewV = r_emit2(G, S, N, C, V, X, ", " ++ BIs,[]), + reg2_list(G, S, N2, "InterfaceDef_create_", NewV, Body); + + +reg2(G, S, N, C, V, X) when is_record(X, op) -> + r_emit2(G, S, N, C, V, X, ", ~s, ~p, [~s], [~s], ~p", + [get_idltype(G, S, N, X), get_mode(G, N, X), + get_params(G, S, N, X#op.params), get_exceptions(G, S, N, X), + get_context(G, S, N, X)]); + +reg2(_G, _S, _N, _C, _V, X) when is_record(X, preproc) -> ok; + +reg2(_G, _S, _N, _C, _V, X) when is_record(X, pragma) -> ok; + +reg2(_G, _S, _N, _C, _V, _X) -> ok. + + +%% This function filters off all "#include .idl" code that +%% come along from preprocessor and scanner. Produces code ONLY for +%% the actuall file. See ticket OTP-2133 +reg2_list(_G, _S, _N, _C, _V, []) -> []; +reg2_list(G, S, N, C, V, List ) -> + CurrentFileName = ic_genobj:idlfile(G), + reg2_list(G, S, N, C, V, {CurrentFileName,true}, List). + +%% The filter function + loop +reg2_list(_G, _S, _N, _C, _V, {_CFN, _Status}, []) -> []; +reg2_list(G, S, N, C, V, {CFN,Status}, [X | Xs]) -> + case Status of + true -> + case X of + {preproc,_,{_,_,_FileName},[{_,_,"1"}]} -> + reg2_list(G, S, N, C, V, {CFN,false}, Xs); + _ -> + F = reg2(G, S, N, C, V, X), + [F | reg2_list(G, S, N, C, V, {CFN,Status}, Xs)] + end; + false -> + case X of + {preproc,_,{_,_,CFN},[{_,_,"2"}]} -> + F = reg2(G, S, N, C, V, X), + [F | reg2_list(G, S, N, C, V, {CFN,true}, Xs)]; + _ -> + reg2_list(G, S, N, C, V, {CFN,Status}, Xs) + end + end. + + + + + +%% General registration tests +register_tests(Fd,G) -> + IfrId = ?IFRID(G), + emit(Fd,"\n\n%% General IFR registration checks.\n", []), + emit(Fd,"register_tests(~s)->\n",[IfrId]), + emit(Fd," re_register_test(~s),\n",[IfrId]), + emit(Fd," include_reg_test(~s).\n\n",[IfrId]), + + emit(Fd,"\n%% IFR type Re-registration checks.\n", []), + case ic_pragma:fetchRandomLocalType(G) of + {ok,TypeId} -> + emit(Fd,"re_register_test(~s)->\n",[IfrId]), + emit(Fd," case orber_ifr:'Repository_lookup_id'(~s,~p) of\n", [IfrId,TypeId]), + emit(Fd," [] ->\n true;\n",[]), + emit(Fd," _ ->\n exit({allready_registered,~p})\n end.\n\n", [TypeId]); + false -> + emit(Fd,"re_register_test(_)-> true.\n",[]) + end, + + emit(Fd,"~s",[check_include_regs(G)]). + + + + +%% This function produces code for existance check over +%% top level included modules and interfaces +check_include_regs(G) -> + IfrId = ?IFRID(G), + case ic_pragma:get_incl_refs(G) of + none -> + io_lib:format("\n%% No included idl-files detected.\n", []) ++ + io_lib:format("include_reg_test(_~s) -> true.\n",[IfrId]); + IMs -> + io_lib:format("\n%% IFR registration checks for included idl files.\n", []) ++ + io_lib:format("include_reg_test(~s) ->\n",[IfrId]) ++ + check_incl_refs(G,IfrId,IMs) + end. + + + +check_incl_refs(_,_,[]) -> + io_lib:format(" true.\n",[]); +check_incl_refs(G,IfrId,[[First]|Rest]) -> + ModId = ic_pragma:scope2id(G,First), + io_lib:format(" case orber_ifr:'Repository_lookup_id'(~s,~p) of~n", [IfrId,ModId]) ++ + io_lib:format(" [] ->~n exit({unregistered,~p});~n", [ModId]) ++ + io_lib:format(" _ ->~n true~n end,~n",[]) ++ + check_incl_refs(G,IfrId,Rest). + + + +%% This function will return module ref, it will +%% also register module if not registered. +register_if_unregistered(Fd) -> + emit(Fd, "\n\n%% Fetch top module reference, register if unregistered.\n"), + emit(Fd, "oe_get_top_module(OE_IFR, ID, Name, Version) ->\n"), + emit(Fd, " case orber_ifr:'Repository_lookup_id'(OE_IFR, ID) of\n"), + emit(Fd, " [] ->\n"), + emit(Fd, " orber_ifr:'Repository_create_module'(OE_IFR, ID, Name, Version);\n"), + emit(Fd, " Mod ->\n"), + emit(Fd, " Mod\n",[]), + emit(Fd, " end.\n\n"), + emit(Fd, "%% Fetch module reference, register if unregistered.\n"), + emit(Fd, "oe_get_module(OE_IFR, OE_Parent, ID, Name, Version) ->\n"), + emit(Fd, " case orber_ifr:'Repository_lookup_id'(OE_IFR, ID) of\n"), + emit(Fd, " [] ->\n"), + emit(Fd, " orber_ifr:'ModuleDef_create_module'(OE_Parent, ID, Name, Version);\n"), + emit(Fd, " Mod ->\n"), + emit(Fd, " Mod\n",[]), + emit(Fd, " end.\n"). + + + +do_typedef(G, S, N, C, V, X) -> + case ic_genobj:is_stubfile_open(G) of + false -> ok; + true -> + Fd = ic_genobj:stubfiled(G), + Thing = get_thing_name(X), + IR_VSN = get_IR_VSN(G, N, X), + TK = ic_forms:get_tk(X), + + lists:foreach( + fun(Id) -> + r_emit_raw(G, X, Fd, "", C, Thing, V, + get_IR_ID(G, N, Id), get_id2(Id), + IR_VSN, ", ~s", + [get_idltype_tk(G, S, N, + ictype:maybe_array(G, S, N, + Id, TK))]) + end, get_idlist(X)) + end. + + +do_union(G, S, N, C, V, X, {tk_union, _IFRID, _Name, DiscrTK, _DefNr, L}) -> + N2 = [get_id2(X) | N], + r_emit2(G, S, N, C, V, X, ", ~s, [~s]", + [get_idltype_tk(G, S, N, DiscrTK), + get_union_member_def(G, S, N2, L)]), + look_for_types(G, S, N2, C, V, get_body(X)). + +do_struct(G, S, N, C, V, X, {tk_struct, _IFRID, _Name, ElemList}) -> + N2 = [get_id2(X) | N], + r_emit2(G, S, N, C, V, X, ", [~s]", + [get_member_def(G, S, N, ElemList)]), + look_for_types(G, S, N2, C, V, get_body(X)). + +do_except(G, S, N, C, V, X, {tk_except, _IFRID, _Name, ElemList}) -> + N2 = [get_id2(X) | N], + r_emit2(G, S, N, C, V, X, ", [~s]", + [get_member_def(G, S, N, ElemList)]), + look_for_types(G, S, N2, C, V, get_body(X)). + + +%% new_var finds an unused Erlang variable name by increasing a +%% counter. +new_var(_G) -> + lists:flatten(["_OE_", integer_to_list(put(var_count, get(var_count) + 1))]). +init_var() -> + put(var_count, 1). + +%% Public interface. The name of the register function. +register_name(G) -> + mk_oe_name(G, "register"). +unregister_name(G) -> + mk_oe_name(G, "unregister"). + + + +look_for_types(G, S, N, C, V, L) when is_list(L) -> + lists:foreach(fun(X) -> look_for_types(G, S, N, C, V, X) end, L); +look_for_types(G, S, N, C, V, {_Name, TK}) -> % member + look_for_types(G, S, N, C, V, TK); +look_for_types(_G, _S, _N, _C, _V, {tk_union, _IFRID, _Name, _DT, _Def, _L}) -> + ok; +look_for_types(G, S, N, C, V, {_Label, _Name, TK}) -> % case_dcl + look_for_types(G, S, N, C, V, TK); +look_for_types(_G, _S, _N, _C, _V, {tk_struct, _IFRID, _Name, _L}) -> + ok; +look_for_types(_G, _S, _N, _C, _V, _X) -> + ok. + + + + +%% This function produces code for the interface inheritance registration. +%% It produces a string that represents a list of function calls. +%% This list becomes a list of object references when the main function +%% "orber_ifr:ModuleDef_create_interface" is called. + +get_base_interfaces(G,X) -> + case element(3,X) of + [] -> + "[]"; + L -> + "[" ++ + lists:flatten( + lists:foldl( + fun(E, Acc) -> [call_fun_str(G,E), ", " | Acc] end, + call_fun_str(G,hd(L)), + tl(L) + ) + ) ++ "]" + end. + +call_fun_str(G,S) -> + lists:flatten( + io_lib:format("orber_ifr:lookup_id(~s,\"~s\")", + [ ?IFRID(G), + ic_pragma:scope2id(G,S)] )). + + + + + +%%-------------------------------------------------------------------- +%% +%% r_emit emits an IFR register function call. It returns a new +%% variable (if further defs should be added to that one) +%% +%% G is genobj +%% +%% S is symbol table (ets) +%% +%% N is list of ids describing scope +%% +%% C is create stub (eg. "Repository_create_") +%% +%% V is variable name where current def should be added, +%% +%% X is the current def item, +%% +%% F and A is auxillary format and args that will be io_lib +%% formatted and inserted as a string (don't forget to start with +%% ", ") +%% +r_emit2(G, _S, N, C, V, X, F, A) -> + case ic_genobj:is_stubfile_open(G) of + false -> ok; + true -> + {NewV, Str} = get_assign(G, V, X), + r_emit_raw(G, X, ic_genobj:stubfiled(G), Str, + C, get_thing_name(X), V, + get_IR_ID(G, N, X), get_id2(X), get_IR_VSN(G, N, X), + F, A), + NewV + end. + + +%%-------------------------------------------------------------------- +%% +%% An IFR register line registers an entity (Thing) into the IFR. The +%% thing is registered INTO something, an type is registered into a +%% module for instance, and this is reflected in the Var parameter +%% below. The var parameter is the name of the parent IFR object. The +%% Thing parameter is the name of the thing we're trying to register, +%% a typdef is called an alias and an interface is called an +%% interface. Sometimes we need to store the thing we're registering +%% into a variable because we're going to add other things to it +%% later, modules and interfaces are such containers, so we must +%% remember that variable for later use. +%% +%% All parameters shall be strings unless otherwise noted +%% +%% Fd - File descriptor +%% AssignStr - Assign or not, empty except for interfaces and modules +%% Create - Create has diff. names dep. on into what we register +%% Thing - WHAT is registered, interface +%% Var - The name of the variable we register into +%% IR_ID - The IFR identifier (may be "") +%% Id - The identifier (name) of the object +%% IR_VSN - The IFR version as a string +%% AuxStr - An auxillary string +%% +%%r_emit_raw(Fd, AssignStr, Create, Thing, Var, IR_ID, Id, IR_VSN) -> +%% r_emit_raw(Fd, AssignStr, Create, Thing, Var, IR_ID, Id, IR_VSN, "", []). +r_emit_raw(_G, X, Fd, AssignStr, "Repository_create_", Thing, Var, IR_ID, Id, IR_VSN, F, A) + when is_record(X, module) -> + emit(Fd, "~n ~s~p(~s, \"~s\", \"~s\", \"~s\"~s),~n", + [AssignStr, to_atom("oe_get_top_"++Thing), Var, IR_ID, Id, + IR_VSN, io_lib:format(F, A)]); +r_emit_raw(G, X, Fd, AssignStr, "ModuleDef_create_", Thing, Var, IR_ID, Id, IR_VSN, F, A) + when is_record(X, module) -> + emit(Fd, "~n ~s~p(~s, ~s, \"~s\", \"~s\", \"~s\"~s),~n", + [AssignStr, to_atom("oe_get_"++Thing), ?IFRID(G), Var, IR_ID, Id, + IR_VSN, io_lib:format(F, A)]); +r_emit_raw(_G, _X, Fd, AssignStr, Create, Thing, Var, IR_ID, Id, IR_VSN, F, A) -> + emit(Fd, "~n ~s~p:~p(~s, \"~s\", \"~s\", \"~s\"~s),~n", + [AssignStr, ?IFRMOD, to_atom(Create++Thing), Var, IR_ID, Id, + IR_VSN, io_lib:format(F, A)]). + + + + +%% Used by r_emit. Returns tuple {Var, Str} where Var is the resulting +%% output var (if any, otherwise same as input arg) and Str is a +%% string of the assignment if any ("" or "Var = ") +get_assign(G, _V, X) when is_record(X, module) -> + mk_assign(G); +get_assign(G, _V, X) when is_record(X, interface) -> + mk_assign(G); +get_assign(_G, V, _X) -> {V, ""}. +mk_assign(G) -> + V = new_var(G), + {V, io_lib:format("~s = ", [V])}. + +%% Returns a list of strings of all enum members (suitable for ~p) +get_enum_member_list(_G, _S, _N, L) -> + lists:map(fun(M) -> get_id2(M) end, L). + +%% Will output a string of the union members. +get_union_member_def(_G, _S, _N, []) -> []; +get_union_member_def(G, S, N, L) -> + [union_member2str(G, S, N, hd(L)) | + lists:map(fun(M) -> [", ", union_member2str(G, S, N, M)] end, tl(L))]. +%% lists:foldl(fun(M, Acc) -> +%% [union_member2str(G, S, N, M),", " | Acc] end, +%% union_member2str(G, S, N, hd(L)), tl(L)). + +union_member2str(G, S, N, {Label, Name, TK}) -> + io_lib:format("~s{name=~p, label=~p, type=~p, type_def=~s}", + ["#unionmember", Name, Label, TK, + get_idltype_tk(G, S, N, TK)]). + + +%% Will output a string of the struct members. Works for exceptions +%% and structs +%% +get_member_def(_G, _S, _N, []) -> []; +get_member_def(G, S, N, L) -> + [member2str(G, S, N, hd(L)) | + lists:map(fun(M) -> [", ", member2str(G, S, N, M)] end, tl(L))]. + +member2str(G, S, N, {Id, TK}) -> + io_lib:format("~s{name=~p, type=~p, type_def=~s}", + ["#structmember", Id, TK, get_idltype_tk(G, S, N, TK)]). + +%% Translates between record names and create operation names. +get_thing_name(X) when is_record(X, op) -> "operation"; +get_thing_name(X) when is_record(X, const) -> "constant"; +get_thing_name(X) when is_record(X, typedef) -> "alias"; +get_thing_name(X) when is_record(X, attr) -> "attribute"; +get_thing_name(X) when is_record(X, except) -> "exception"; +get_thing_name(X) when is_record(X, id_of) -> get_thing_name(X#id_of.type); +get_thing_name(X) -> to_list(element(1,X)). + + +%% Returns the mode (in, out, oneway etc) of ops and params. Return +%% value is an atom. +get_mode(_G, _N, X) when is_record(X, op) -> + case X#op.oneway of + {oneway, _} -> 'OP_ONEWAY'; + _ -> 'OP_NORMAL' + end; +get_mode(_G, _N, X) when is_record(X, attr) -> + case X#attr.readonly of + {readonly, _} -> 'ATTR_READONLY'; + _ -> 'ATTR_NORMAL' + end; +get_mode(_G, _N, X) when is_record(X, param) -> + case X#param.inout of + {in, _} -> 'PARAM_IN'; + {inout, _} -> 'PARAM_INOUT'; + {out, _} -> 'PARAM_OUT' + end. + + +%% Returns a string form of idltype creation. +%%get_idltype_id(G, S, N, X, Id) -> +%% TK = ictype:tk_lookup(G, S, N, Id), +%% get_idltype_tk(G, S, N, TK). +get_idltype(G, S, N, X) -> + get_idltype_tk(G, S, N, ic_forms:get_tk(X)). +get_idltype_tk(G, _S, _N, TK) -> + io_lib:format("~p:~p(~s, ~p)", [orber_ifr, 'Repository_create_idltype', + ?IFRID(G), TK]). + +%% Returns a string form of typecode creation. This shall be found in +%% the type code symbol table. +%%get_typecode(G, S, N, X) -> typecode. +%%get_typecode(G, S, N, X) -> tk(G, S, N, get_type(X)). + + +%% Returns the string form of a list of parameters. +get_params(_G, _S, _N, []) -> ""; +get_params(G, S, N, L) -> + lists:foldl(fun(X, Acc) -> param2str(G, S, N, X)++", "++Acc end, + param2str(G, S, N, hd(L)), tl(L)). + + +%% Converts a parameter to a string. +param2str(G, S, N, X) -> + io_lib:format("~s{name=~p, type=~p, type_def=~s, mode=~p}~n", + ["#parameterdescription", get_id2(X), + ic_forms:get_tk(X), + %%tk_lookup(G, S, N, get_type(X)), + get_idltype(G, S, N, X), + get_mode(G, N, X)]). + + + + +%% Public interface. Returns the IFR ID of an object. This +%% is updated to comply with CORBA 2.0 pragma directives. +get_IR_ID(G, N, X) -> + ScopedId = [get_id2(X) | N], + case ic_pragma:get_alias(G,ScopedId) of + none -> + case ic_pragma:pragma_id(G, N, X) of + none -> + case ic_pragma:pragma_prefix(G, N, X) of + none -> + IR_ID = lists:flatten( + io_lib:format("IDL:~s:~s", + [slashify(ScopedId), + get_IR_VSN(G, N, X)])), + ic_pragma:mk_alias(G,IR_ID,ScopedId), + IR_ID; + PF -> + IR_ID = lists:flatten( + io_lib:format("IDL:~s:~s", + [ PF ++ "/" ++ + get_id2(X), + get_IR_VSN(G, N, X)])), + ic_pragma:mk_alias(G,IR_ID,ScopedId), + IR_ID + end; + PI -> + ic_pragma:mk_alias(G,PI,ScopedId), + PI + end; + Alias -> + Alias + end. + + +%% Public interface. Returns the IFR Version of an object. This +%% is updated to comply with CORBA 2.0 pragma directives. +get_IR_VSN(G, N, X) -> + ic_pragma:pragma_version(G,N,X). + + + + + +%% Returns a slashified name, [I1, M1] becomes "M1/I1" +%slashify(List) -> lists:foldl(fun(X, Acc) -> get_id2(X)++"/"++Acc end, +% hd(List), tl(List)). + +%% Returns a slashified name, [I1, M1] becomes "M1/I1" +slashify(List) -> lists:foldl(fun(X, Acc) -> X++"/"++Acc end, + hd(List), tl(List)). + + +%% Returns the context literals of an op +get_context(_G, _S, _N, X) -> + lists:map(fun(C) -> element(3, C) end, X#op.ctx). + + + +%% Returns the list of the exceptions of an operation +get_exceptions(G, S, N, X) -> + case X#op.raises of + [] -> + ""; + L -> + lists:flatten( + lists:foldl( + fun(E, Acc) -> [excdef(G, S, N, X, E), ", " | Acc] end, + excdef(G, S, N, X, hd(L)), + tl(L) + ) + ) + end. + + +%% Returns the definition of an exception of an operation +excdef(G, S, N, X, L) -> + io_lib:format("orber_ifr:lookup_id(~s,\"~s\")", + [ ?IFRID(G), + get_EXC_ID(G, S, N, X, L) ] ). + + + + + + +%% This function produces code for the exception registration. +%% It produces a string that represents a list of function calls. +%% This list becomes a list of object references when the main function +%% "orber_ifr:InterfaceDef_create_operation" is called. + +get_EXC_ID(G, _S, N, X, ScopedId) -> + case ic_pragma:get_alias(G,ScopedId) of + none -> + case ic_pragma:pragma_id(G, N, X) of + none -> + case ic_pragma:pragma_prefix(G, N, X) of + none -> + EXC_ID = lists:flatten( + io_lib:format("IDL:~s:~s", [slashify(ScopedId), + get_IR_VSN(G, N, X)])), + ic_pragma:mk_alias(G,EXC_ID,ScopedId), + EXC_ID; + PF -> + EXC_ID = lists:flatten( + io_lib:format("IDL:~s:~s", [ PF ++ "/" ++ + hd(ScopedId), + get_IR_VSN(G, N, X)])), + ic_pragma:mk_alias(G,EXC_ID,ScopedId), + EXC_ID + end; + PI -> + ic_pragma:mk_alias(G,PI,ScopedId), + PI + end; + Alias -> + Alias + end. + + + + + +%% unreg_gen/1 uses the information stored in pragma table +%% to decide which modules are to be unregistered +unreg_gen(G, N, X) -> + Light = ic_options:get_opt(G, light_ifr), + case ic_genobj:is_stubfile_open(G) of + true when Light == false -> + Var = ?IFRID(G), + Fd = ic_genobj:stubfiled(G), + nl(Fd), nl(Fd), nl(Fd), + emit(Fd, "~p() ->\n", [to_atom(unregister_name(G))]), + emit(Fd, " ~s = ~p:find_repository(),\n", + [Var, ?IFRMOD]), + nl(Fd), + + unreg2(G, N, X), + emit(Fd, " ok.\n\n"), + destroy(Fd); + true -> + Fd = ic_genobj:stubfiled(G), + nl(Fd), nl(Fd), + Unregname = to_atom(unregister_name(G)), + emit(Fd, "~p() ->\n\t~p([]).\n\n~p(OE_Options) ->\n", + [Unregname, Unregname, Unregname]), + emit(Fd, "\t~p:remove(?MODULE, OE_Options),\n\tok.\n\n", [?IFRMOD]); + false -> ok + end. + + +destroy(Fd) -> +emit(Fd," +oe_destroy_if_empty(OE_IFR,IFR_ID) -> + case orber_ifr:'Repository_lookup_id'(OE_IFR, IFR_ID) of + [] -> + ok; + Ref -> + case orber_ifr:contents(Ref, \'dk_All\', \'true\') of + [] -> + orber_ifr:destroy(Ref), + ok; + _ -> + ok + end + end. + +oe_destroy(OE_IFR,IFR_ID) -> + case orber_ifr:'Repository_lookup_id'(OE_IFR, IFR_ID) of + [] -> + ok; + Ref -> + orber_ifr:destroy(Ref), + ok + end. + +",[]). + + + + + + + + + + +%% unreg2 is top level registration + +unreg2(G, N, X) -> + emit(ic_genobj:stubfiled(G),"~s",[lists:flatten(unreg3(G, N, X))]). + +unreg3(G, N, X) when is_list(X) -> + unreg3_list(G, N, X, []); + +unreg3(G, N, X) when is_record(X, module) -> + unreg3_list(G, [get_id2(X) | N], get_body(X), [unreg_collect(G, N, X)]); + +unreg3(G, N, X) when is_record(X, const) -> + unreg_collect(G, N, X); + +unreg3(G, N, X) when is_record(X, struct) -> + unreg_collect(G, N, X); + +unreg3(G, N, X) when is_record(X, except) -> + unreg_collect(G, N, X); + +unreg3(G, N, X) when is_record(X, union) -> + unreg_collect(G, N, X); + +unreg3(G, N, X) when is_record(X, enum) -> + unreg_collect(G, N, X); + +unreg3(G, N, X) when is_record(X, typedef) -> + unreg_collect(G, N, X); + +unreg3(G, N, X) when is_record(X, interface) -> + unreg_collect(G, N, X); + +unreg3(_G, _N, X) when is_record(X, op) -> []; + +unreg3(_G, _N, X) when is_record(X, attr) -> []; + +unreg3(_G, _N, X) when is_record(X, preproc) -> []; + +unreg3(_G, _N, X) when is_record(X, pragma) -> []; + +unreg3(_G, _N, _X) -> []. + + +unreg3_list(_G, _N, [], Found) -> + Found; +unreg3_list(G, N, List, Found) -> + CurrentFileName = ic_genobj:idlfile(G), + unreg3_list(G, N, {CurrentFileName,true}, List, Found). + +%% The filter function + loop +unreg3_list(_G, _N, {_CFN, _Status}, [], Found) -> + Found; +unreg3_list(G, N, {CFN,Status}, [X | Xs], Found) -> + case Status of + true -> + case X of + {preproc,_,{_,_,_FileName},[{_,_,"1"}]} -> + unreg3_list(G, N, {CFN,false}, Xs, Found); + _ -> + unreg3_list(G, N, {CFN,Status}, Xs, [unreg3(G, N, X) | Found]) + end; + false -> + case X of + {preproc,_,{_,_,CFN},[{_,_,"2"}]} -> + unreg3_list(G, N, {CFN,true}, Xs,[unreg3(G, N, X) | Found]); + _ -> + unreg3_list(G, N, {CFN,Status}, Xs, Found) + end + end. + + + +unreg_collect(G, N, X) when is_record(X, module) -> + io_lib:format(" oe_destroy_if_empty(OE_IFR, ~p),\n", + [get_IR_ID(G, N, X)]); +unreg_collect(G, N, X) when is_record(X, typedef) -> + lists:map(fun(Id) -> + io_lib:format(" oe_destroy(OE_IFR, ~p),\n", + [get_IR_ID(G, N, Id)]) + end, + ic_forms:get_idlist(X)); +unreg_collect(G, N, X) -> + io_lib:format(" oe_destroy(OE_IFR, ~p),\n", + [get_IR_ID(G, N, X)]). + + + diff --git a/lib/ic/src/ictype.erl b/lib/ic/src/ictype.erl new file mode 100644 index 0000000000..4704191bee --- /dev/null +++ b/lib/ic/src/ictype.erl @@ -0,0 +1,1413 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1997-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(ictype). + + +-include("ic.hrl"). +-include("icforms.hrl"). + +%%----------------------------------------------------------------- +%% External exports +%%----------------------------------------------------------------- +-export([type_check/2, scoped_lookup/4, maybe_array/5, to_uppercase/1]). + +-export([name2type/2, member2type/3, isBasicTypeOrEterm/3, isEterm/3]). +-export([isBasicType/1, isBasicType/2, isBasicType/3, isString/3, isWString/3, + isArray/3, isStruct/3, isUnion/3, isEnum/3, isSequence/3, isBoolean/3 ]). +-export([fetchTk/3, fetchType/1, tk/4]). +%%----------------------------------------------------------------- +%% Internal exports +%%----------------------------------------------------------------- +-export([]). + +%%----------------------------------------------------------------- +%% Macros +%%----------------------------------------------------------------- +%%-define(DBG(F,A), io:format(F,A)). +-define(DBG(F,A), true). +-define(STDDBG, ?DBG(" dbg: ~p: ~p~n", [element(1,X), ic_forms:get_id2(X)])). + +%%----------------------------------------------------------------- +%% External functions +%%----------------------------------------------------------------- + +type_check(G, Forms) -> + S = ic_genobj:tktab(G), + check_list(G, S, [], Forms). + +scoped_lookup(G, S, N, X) -> + Id = ic_symtab:scoped_id_strip(X), + case ic_symtab:scoped_id_is_global(X) of + true -> + lookup(G, S, [], X, Id); + false -> + lookup(G, S, N, X, Id) + end. + + +%%-------------------------------------------------------------------- +%% maybe_array +%% +%% Array declarators are indicated on the declarator and not on +%% the type, therefore the declarator decides if the array type +%% kind is added or not. +%% +maybe_array(G, S, N, X, TK) when is_record(X, array) -> + mk_array(G, S, N, X#array.size, TK); +maybe_array(_G, _S, _N, _, TK) -> TK. + + + +name2type(G, Name) -> + S = ic_genobj:tktab(G), + ScopedName = lists:reverse(string:tokens(Name, "_")), + InfoList = ets:lookup(S, ScopedName ), + filter( InfoList ). + + +%% This is en overloaded function, +%% differs in input on unions +member2type(_G, X, I) when is_record(X, union)-> + Name = ic_forms:get_id2(I), + case lists:keysearch(Name,2,element(6,X#union.tk)) of + false -> + error; + {value,Rec} -> + fetchType(element(3,Rec)) + end; +member2type( G, SName, MName ) -> + + S = ic_genobj:tktab( G ), + SNList = lists:reverse(string:tokens(SName,"_")), + ScopedName = [MName | SNList], + InfoList = ets:lookup( S, ScopedName ), + + case filter( InfoList ) of + error -> + %% Try a little harder, seeking inside tktab + case lookup_member_type_in_tktab(S, ScopedName, MName) of + error -> + %% Check if this is the "return to return1" case + case MName of + "return1" -> + %% Do it all over again ! + ScopedName2 = ["return" | SNList], + InfoList2 = ets:lookup( S, ScopedName2 ), + case filter( InfoList2 ) of + error -> + %% Last resort: seek in pragma table + lookup_type_in_pragmatab(G, SName); + + Other -> + Other + end; + _ -> + %% Last resort: seek in pragma table + lookup_type_in_pragmatab(G, SName) + end; + Other -> + Other + end; + Other -> + Other + end. + + +lookup_member_type_in_tktab(S, ScopedName, MName) -> + case ets:match_object(S, {'_',member,{MName,'_'},nil}) of + [] -> + error; + [{_FullScopedName,member,{MName,TKInfo},nil}]-> + fetchType( TKInfo ); + List -> + lookup_member_type_in_tktab(List,ScopedName) + end. + +lookup_member_type_in_tktab([], _ScopedName) -> + error; +lookup_member_type_in_tktab([{FullScopedName,_,{_,TKInfo},_}|Rest],ScopedName) -> + case lists:reverse(string:tokens(ic_util:to_undersc(FullScopedName),"_")) of + ScopedName -> + fetchType(TKInfo); + _ -> + lookup_member_type_in_tktab(Rest,ScopedName) + end. + + +lookup_type_in_pragmatab(G, SName) -> + S = ic_genobj:pragmatab(G), + + %% Look locally first + case ets:match(S,{file_data_local,'_','_','$2','_','_',SName,'_','_'}) of + [] -> + %% No match, seek included + case ets:match(S,{file_data_included,'_','_','$2','_','_',SName,'_','_'}) of + + [] -> + error; + [[Type]] -> + io:format("1 Found(~p) : ~p~n",[SName,Type]), + Type + end; + + [[Type]] -> + io:format("2 Found(~p) : ~p~n",[SName,Type]), + Type + end. + + + + +isString(G, N, T) when element(1, T) == scoped_id -> + case ic_symtab:get_full_scoped_name(G, N, T) of + {_FullScopedName, _, {'tk_string',_}, _} -> + true; + _ -> + false + end; +isString(_G, _N, T) when is_record(T, string) -> + true; +isString(_G, _N, _Other) -> + false. + + +isWString(G, N, T) when element(1, T) == scoped_id -> %% WSTRING + case ic_symtab:get_full_scoped_name(G, N, T) of + {_FullScopedName, _, {'tk_wstring',_}, _} -> + true; + _ -> + false + end; +isWString(_G, _N, T) when is_record(T, wstring) -> + true; +isWString(_G, _N, _Other) -> + false. + + +isArray(G, N, T) when element(1, T) == scoped_id -> + case ic_symtab:get_full_scoped_name(G, N, T) of + {_FullScopedName, _, {'tk_array', _, _}, _} -> + true; + _ -> + false + end; +isArray(_G, _N, T) when is_record(T, array) -> + true; +isArray(_G, _N, _Other) -> + false. + + +isSequence(G, N, T) when element(1, T) == scoped_id -> + case ic_symtab:get_full_scoped_name(G, N, T) of + {_FullScopedName, _, {'tk_sequence', _, _}, _} -> + true; + _ -> + false + end; +isSequence(_G, _N, T) when is_record(T, sequence) -> + true; +isSequence(_G, _N, _Other) -> + false. + + +isStruct(G, N, T) when element(1, T) == scoped_id -> + case ic_symtab:get_full_scoped_name(G, N, T) of + {_FullScopedName, _, {'tk_struct', _, _, _}, _} -> + true; + _ -> + false + end; +isStruct(_G, _N, T) when is_record(T, struct) -> + true; +isStruct(_G, _N, _Other) -> + false. + + +isUnion(G, N, T) when element(1, T) == scoped_id -> + case ic_symtab:get_full_scoped_name(G, N, T) of + {_FullScopedName, _, {'tk_union', _, _, _,_,_}, _} -> + true; + _Other -> + false + end; +isUnion(_G, _N, T) when is_record(T, union) -> + true; +isUnion(_G, _N, _Other) -> + false. + + + +isEnum(G, N, T) when element(1, T) == scoped_id -> + case ic_symtab:get_full_scoped_name(G, N, T) of + {_FullScopedName, _, {'tk_enum',_,_,_}, _} -> + true; + _Other -> + false + end; +isEnum(_G, _N, T) when is_record(T, enum) -> + true; +isEnum(_G, _N, _Other) -> + false. + + + +isBoolean(G, N, T) when element(1, T) == scoped_id -> + {_, _, TK, _} = + ic_symtab:get_full_scoped_name(G, N, T), + case fetchType(TK) of + 'boolean' -> + true; + _ -> + false + end; +isBoolean(_, _, {'tk_boolean',_}) -> + true; +isBoolean(_, _, {'boolean',_}) -> + true; +isBoolean(_, _, _) -> + false. + + +%%% Just used for C + +isBasicTypeOrEterm(G, N, S) -> + case isBasicType(G, N, S) of + true -> + true; + false -> + isEterm(G, N, S) + end. + +isEterm(G, N, S) when element(1, S) == scoped_id -> + {FullScopedName, _, _TK, _} = ic_symtab:get_full_scoped_name(G, N, S), + case ic_code:get_basetype(G, ic_util:to_undersc(FullScopedName)) of + "erlang_term" -> + true; + "ETERM*" -> + true; + _X -> + false + end; +isEterm(_G, _Ni, _X) -> + false. + +isBasicType(_G, _N, {scoped_id,_,_,["term","erlang"]}) -> + false; +isBasicType(G, N, S) when element(1, S) == scoped_id -> + {_, _, TK, _} = ic_symtab:get_full_scoped_name(G, N, S), + isBasicType(fetchType(TK)); +isBasicType(_G, _N, {string, _} ) -> + false; +isBasicType(_G, _N, {wstring, _} ) -> %% WSTRING + false; +isBasicType(_G, _N, {unsigned, {long, _}} ) -> + true; +isBasicType(_G, _N, {unsigned, {short, _}} ) -> + true; +isBasicType(_G, _N, {Type, _} ) -> + isBasicType(Type); +isBasicType(_G, _N, _X) -> + false. + + +isBasicType( G, Name ) -> + isBasicType( name2type( G, Name ) ). + + +isBasicType( Type ) -> + lists:member(Type, + [tk_short,short, + tk_long,long, + tk_longlong,longlong, %% LLONG + tk_ushort,ushort, + tk_ulong,ulong, + tk_ulonglong,ulonglong, %% ULLONG + tk_float,float, + tk_double,double, + tk_boolean,boolean, + tk_char,char, + tk_wchar,wchar, %% WCHAR + tk_octet,octet, + tk_any,any]). %% Fix for any + + + +%%----------------------------------------------------------------- +%% Internal functions +%%----------------------------------------------------------------- +check(G, _S, N, X) when is_record(X, preproc) -> + handle_preproc(G, N, X#preproc.cat, X), + X; + +check(G, S, N, X) when is_record(X, op) -> + ?STDDBG, + TK = tk_base(G, S, N, ic_forms:get_type(X)), + tktab_add(G, S, N, X), + N2 = [ic_forms:get_id2(X) | N], + Ps = lists:map(fun(P) -> + tktab_add(G, S, N2, P), + P#param{tk=tk_base(G, S, N, ic_forms:get_type(P))} end, + X#op.params), + %% Check for exception defs. + Raises = lists:map(fun(E) -> name_lookup(G, S, N, E) end, + X#op.raises), + case ic_forms:is_oneway(X) of + true -> + if TK /= tk_void -> + ic_error:error(G, {bad_oneway_type, X, TK}); + true -> ok + end, + case ic:filter_params([inout, out], X#op.params) of + [] -> ok; % No out parameters! + _ -> + ic_error:error(G, {oneway_outparams, X}) + end, + case X#op.raises of + [] -> ok; + _ -> + ic_error:error(G, {oneway_raises, X}) + end; + false -> + ok + end, + X#op{params=Ps, tk=TK, raises=Raises}; + +check(G, S, N, X) when is_record(X, interface) -> + ?STDDBG, + N2 = [ic_forms:get_id2(X) | N], + TK = {tk_objref, ictk:get_IR_ID(G, N, X), ic_forms:get_id2(X)}, + Inherit = inherit_resolve(G, S, N, X#interface.inherit, []), + tktab_add(G, S, N, X, TK, Inherit), + CheckedBody = check_list(G, S, N2, ic_forms:get_body(X)), + InhBody = calc_inherit_body(G, N2, CheckedBody, Inherit, []), + X2 = X#interface{inherit=Inherit, tk=TK, body=CheckedBody, + inherit_body=InhBody}, + ic_symtab:store(G, N, X2), + X2; + +check(G, S, N, X) when is_record(X, forward) -> + ?STDDBG, + tktab_add(G, S, N, X, {tk_objref, ictk:get_IR_ID(G, N, X), ic_forms:get_id2(X)}), + X; + + +check(G, S, N, X) when is_record(X, const) -> + ?STDDBG, + case tk_base(G, S, N, ic_forms:get_type(X)) of + Err when element(1, Err) == error -> X; + TK -> + check_const_tk(G, S, N, X, TK), + case iceval:eval_const(G, S, N, TK, X#const.val) of + Err when element(1, Err) == error -> X; + {ok, NewTK, Val} -> + V = iceval:get_val(Val), + tktab_add(G, S, N, X, NewTK, V), + X#const{val=V, tk=NewTK}; + Val -> + V = iceval:get_val(Val), + tktab_add(G, S, N, X, TK, V), + X#const{val=V, tk=TK} + end + end; + +check(G, S, N, X) when is_record(X, const) -> + ?STDDBG, + case tk_base(G, S, N, ic_forms:get_type(X)) of + Err when element(1, Err) == error -> X; + TK -> + check_const_tk(G, S, N, X, TK), + case iceval:eval_const(G, S, N, TK, X#const.val) of + Err when element(1, Err) == error -> X; + Val -> + V = iceval:get_val(Val), + tktab_add(G, S, N, X, TK, V), + X#const{val=V, tk=TK} + end + end; + +check(G, S, N, X) when is_record(X, except) -> + ?STDDBG, + TK = tk(G, S, N, X), + X#except{tk=TK}; + +check(G, S, N, X) when is_record(X, struct) -> + ?STDDBG, + TK = tk(G, S, N, X), + X#struct{tk=TK}; + +check(G, S, N, X) when is_record(X, enum) -> + ?STDDBG, + TK = tk(G, S, N, X), + X#enum{tk=TK}; + +check(G, S, N, X) when is_record(X, union) -> + ?STDDBG, + TK = tk(G, S, N, X), + X#union{tk=TK}; + +check(G, S, N, X) when is_record(X, attr) -> + ?STDDBG, + TK = tk_base(G, S, N, ic_forms:get_type(X)), + XX = #id_of{type=X}, + lists:foreach(fun(Id) -> tktab_add(G, S, N, XX#id_of{id=Id}) end, + ic_forms:get_idlist(X)), + X#attr{tk=TK}; + +check(G, S, N, X) when is_record(X, module) -> + ?STDDBG, + tktab_add(G, S, N, X), + X#module{body=check_list(G, S, [ic_forms:get_id2(X) | N], ic_forms:get_body(X))}; + +check(G, S, N, X) when is_record(X, typedef) -> + ?STDDBG, + TKbase = tk(G, S, N, X), + X#typedef{tk=TKbase}; + +check(_G, _S, _N, X) -> + ?DBG(" dbg: ~p~n", [element(1,X)]), + X. + +handle_preproc(G, _N, line_nr, X) -> ic_genobj:set_idlfile(G, ic_forms:get_id2(X)); +handle_preproc(_G, _N, _C, _X) -> ok. + + +%%-------------------------------------------------------------------- +%% +%% TK calculation +%% +%%-------------------------------------------------------------------- + +tk(G, S, N, X) when is_record(X, union) -> + N2 = [ic_forms:get_id2(X) | N], + DisrcTK = tk(G, S, N, ic_forms:get_type(X)), + case check_switch_tk(G, S, N, X, DisrcTK) of + true -> + do_special_enum(G, S, N2, ic_forms:get_type(X)), + BodyTK = lists:reverse( + tk_caselist(G, S, N2, DisrcTK, ic_forms:get_body(X))), + tktab_add(G, S, N, X, + {tk_union, ictk:get_IR_ID(G, N, X), ic_forms:get_id2(X), + DisrcTK, default_count(ic_forms:get_body(X)), BodyTK}); + false -> + tk_void + end; + +tk(G, S, N, X) when is_record(X, enum) -> + N2 = [ic_forms:get_id2(X) | N], + tktab_add(G, S, N, X, + {tk_enum, ictk:get_IR_ID(G, N, X), ic_forms:get_id2(X), + enum_body(G, S, N2, ic_forms:get_body(X))}); + + +%% Note that the TK returned from this function is the base TK. It +%% must be modified for each of the identifiers in the idlist (for +%% array reasons). +tk(G, S, N, X) when is_record(X, typedef) -> + case X of + %% Special case only for term and java backend ! + {typedef,{any,_},[{'',_,"term"}],undefined} -> + case ic_options:get_opt(G, be) of + java -> + tktab_add(G, S, N, X, tk_term), + tk_term; + _ -> + TK = tk(G, S, N, ic_forms:get_body(X)), + lists:foreach(fun(Id) -> + tktab_add(G, S, N, #id_of{id=Id, type=X}, + maybe_array(G, S, N, Id, TK)) + end, + X#typedef.id), + TK + end; + _ -> + TK = tk(G, S, N, ic_forms:get_body(X)), + lists:foreach(fun(Id) -> + tktab_add(G, S, N, #id_of{id=Id, type=X}, + maybe_array(G, S, N, Id, TK)) + end, + X#typedef.id), + TK + end; + +tk(G, S, N, X) when is_record(X, struct) -> + N2 = [ic_forms:get_id2(X) | N], + tktab_add(G, S, N, X, {tk_struct, ictk:get_IR_ID(G, N, X), ic_forms:get_id2(X), + tk_memberlist(G, S, N2, ic_forms:get_body(X))}); + +tk(G, S, N, X) when is_record(X, except) -> + N2 = [ic_forms:get_id2(X) | N], + tktab_add(G, S, N, X, {tk_except, ictk:get_IR_ID(G, N, X), ic_forms:get_id2(X), + tk_memberlist(G, S, N2, ic_forms:get_body(X))}); + +tk(G, S, N, X) -> tk_base(G, S, N, X). + + +tk_base(G, S, N, X) when is_record(X, sequence) -> + {tk_sequence, tk(G, S, N, X#sequence.type), + len_eval(G, S, N, X#sequence.length)}; + +tk_base(G, S, N, X) when is_record(X, string) -> + {tk_string, len_eval(G, S, N, X#string.length)}; + +tk_base(G, S, N, X) when is_record(X, wstring) -> %% WSTRING + {tk_wstring, len_eval(G, S, N, X#wstring.length)}; + +%% Fixed constants can be declared as: +%% (1) const fixed pi = 3.14D; or +%% (2) typedef fixed<3,2> f32; +%% const f32 pi = 3.14D; +tk_base(G, S, N, X) when is_record(X, fixed) -> + %% Case 2 + {tk_fixed, len_eval(G, S, N, X#fixed.digits), len_eval(G, S, N, X#fixed.scale)}; +tk_base(_G, _S, _N, {fixed, _}) -> + %% Case 1 + tk_fixed; + + +%% Special case, here CORBA::TypeCode is built in +%% ONLY when erl_corba is the backend of choice +tk_base(G, S, N, {scoped_id,V1,V2,["TypeCode","CORBA"]}) -> + case ic_options:get_opt(G, be) of + false -> + tk_TypeCode; + erl_corba -> + tk_TypeCode; + erl_template -> + tk_TypeCode; + _ -> + case scoped_lookup(G, S, N, {scoped_id,V1,V2,["TypeCode","CORBA"]}) of + T when element(1, T) == error -> T; + T when is_tuple(T) -> element(3, T) + end + end; + +tk_base(G, S, N, X) when element(1, X) == scoped_id -> + case scoped_lookup(G, S, N, X) of + T when element(1, T) == error -> T; + T when is_tuple(T) -> element(3, T) + end; +tk_base(_G, _S, _N, {long, _}) -> tk_long; +tk_base(_G, _S, _N, {'long long', _}) -> tk_longlong; %% LLONG +tk_base(_G, _S, _N, {short, _}) -> tk_short; +tk_base(_G, _S, _N, {'unsigned', {short, _}}) -> tk_ushort; +tk_base(_G, _S, _N, {'unsigned', {long, _}}) -> tk_ulong; +tk_base(_G, _S, _N, {'unsigned', {'long long', _}})-> tk_ulonglong; %% ULLONG +tk_base(_G, _S, _N, {float, _}) -> tk_float; +tk_base(_G, _S, _N, {double, _}) -> tk_double; +tk_base(_G, _S, _N, {boolean, _}) -> tk_boolean; +tk_base(_G, _S, _N, {char, _}) -> tk_char; +tk_base(_G, _S, _N, {wchar, _}) -> tk_wchar; %% WCHAR +tk_base(_G, _S, _N, {octet, _}) -> tk_octet; +tk_base(_G, _S, _N, {null, _}) -> tk_null; +tk_base(_G, _S, _N, {void, _}) -> tk_void; +tk_base(_G, _S, _N, {any, _}) -> tk_any; +tk_base(_G, _S, _N, {'Object', _}) -> {tk_objref, "", "Object"}. + + +%%-------------------------------------------------------------------- +%% +%% Special handling of idlists. Note that the recursion case is given +%% as accumulator to foldr. Idlists are those lists of identifiers +%% that share the same definition, i.e. multiple cases, multiple type +%% declarations, multiple member names. +%% +tk_memberlist(G, S, N, [X | Xs]) -> + BaseTK = tk(G, S, N, ic_forms:get_type(X)), + + XX = #id_of{type=X}, + lists:foldr(fun(Id, Acc) -> + [tk_member(G, S, N, XX#id_of{id=Id}, BaseTK) | Acc] end, + tk_memberlist(G, S, N, Xs), + ic_forms:get_idlist(X)); +tk_memberlist(_G, _S, _N, []) -> []. + +%% same as above but for case dcls +tk_caselist(G, S, N, DiscrTK, Xs) -> + lists:foldl(fun(Case, Acc) -> + BaseTK = tk(G, S, N, ic_forms:get_type(Case)), + %% tktab_add for the uniqueness check of the declarator + tktab_add(G, S, N, Case), + lists:foldl(fun(Id, Acc2) -> + case tk_case(G, S, N, Case, BaseTK, + DiscrTK, Id) of + Err when element(1, Err)==error -> + Acc2; + TK -> + unique_add_case_label(G, S, N, Id, + TK, Acc2) + end + end, + Acc, + ic_forms:get_idlist(Case)) + end, + [], + Xs). + + +%% Handling of the things that can be in an idlist or caselist +tk_member(G, S, N, X, BaseTK) -> + tktab_add(G, S, N, X, + {ic_forms:get_id2(X), maybe_array(G, S, N, X#id_of.id, BaseTK)}). + + +get_case_id_and_check(G, _S, _N, _X, ScopedId) -> + case ic_symtab:scoped_id_is_global(ScopedId) of + true -> ic_error:error(G, {bad_scope_enum_case, ScopedId}); + false -> ok + end, + case ic_symtab:scoped_id_strip(ScopedId) of + [Id] -> Id; + _List -> + ic_error:error(G, {bad_scope_enum_case, ScopedId}), + "" + end. + + +tk_case(G, S, N, X, BaseTK, DiscrTK, Id) -> + case case_eval(G, S, N, DiscrTK, Id) of + Err when element(1, Err) == error -> Err; + Val -> + case iceval:check_tk(G, DiscrTK, Val) of + true -> + {iceval:get_val(Val), ic_forms:get_id2(X), + maybe_array(G, S, N, X#case_dcl.id, BaseTK)}; + false -> + ic_error:error(G, {bad_case_type, DiscrTK, X, + iceval:get_val(Val)}) + end + end. + +tktab_add(G, S, N, X) -> + tktab_add_id(G, S, N, X, ic_forms:get_id2(X), nil, nil). +tktab_add(G, S, N, X, TK) -> + tktab_add_id(G, S, N, X, ic_forms:get_id2(X), TK, nil). +tktab_add(G, S, N, X, TK, Aux) -> + tktab_add_id(G, S, N, X, ic_forms:get_id2(X), TK, Aux). + + +tktab_add_id(G, S, N, X, Id, TK, Aux) when is_record(X,enumerator) -> + + %% Check if the "scl" flag is set to true + %% if so, allow old semantics ( errornous ) + %% Warning, this is for compatibility reasons only. + Name = case ic_options:get_opt(G, scl) of + true -> + [Id | N]; + false -> + [Id | tl(N)] + end, + + UName = mk_uppercase(Name), + case ets:lookup(S, Name) of + [_] -> ic_error:error(G, {multiply_defined, X}); + [] -> + case ets:lookup(S, UName) of + [] -> ok; + [_] -> ic_error:error(G, {illegal_spelling, X}) + end + end, + ets:insert(S, {Name, element(1, get_beef(X)), TK, Aux}), + if UName =/= Name -> ets:insert(S, {UName, spellcheck}); + true -> true end, + TK; +%% +%% Fixes the multiple file module definition check +%% but ONLY for Corba backend +%% +tktab_add_id(G, S, N, X, Id, TK, Aux) when is_record(X,module) -> + case ic_options:get_opt(G, be) of + erl_template -> + Name = [Id | N], + UName = mk_uppercase(Name), + ets:insert(S, {Name, element(1, get_beef(X)), TK, Aux}), + if UName =/= Name -> ets:insert(S, {UName, spellcheck}); + true -> true end, + TK; + erl_corba -> + Name = [Id | N], + UName = mk_uppercase(Name), + ets:insert(S, {Name, element(1, get_beef(X)), TK, Aux}), + if UName =/= Name -> ets:insert(S, {UName, spellcheck}); + true -> true end, + TK; + false -> %% default == erl_corba + Name = [Id | N], + UName = mk_uppercase(Name), + ets:insert(S, {Name, element(1, get_beef(X)), TK, Aux}), + if UName =/= Name -> ets:insert(S, {UName, spellcheck}); + true -> true end, + TK; + java -> + Name = [Id | N], + UName = mk_uppercase(Name), + ets:insert(S, {Name, element(1, get_beef(X)), TK, Aux}), + if UName =/= Name -> ets:insert(S, {UName, spellcheck}); + true -> true end, + TK; + erl_genserv -> + Name = [Id | N], + UName = mk_uppercase(Name), + ets:insert(S, {Name, element(1, get_beef(X)), TK, Aux}), + if UName =/= Name -> ets:insert(S, {UName, spellcheck}); + true -> true end, + TK; + erl_plain -> + Name = [Id | N], + UName = mk_uppercase(Name), + ets:insert(S, {Name, element(1, get_beef(X)), TK, Aux}), + if UName =/= Name -> ets:insert(S, {UName, spellcheck}); + true -> true end, + TK; + _Be -> + Name = [Id | N], + UName = mk_uppercase(Name), + case ets:lookup(S, Name) of + [_] -> ic_error:error(G, {multiply_defined, X}); + [] -> + case ets:lookup(S, UName) of + [] -> ok; + [_] -> ic_error:error(G, {illegal_spelling, X}) + end + end, + ets:insert(S, {Name, element(1, get_beef(X)), TK, Aux}), + if UName =/= Name -> ets:insert(S, {UName, spellcheck}); + true -> true end, + TK + end; +tktab_add_id(G, S, N, X, Id, TK, Aux) -> + Name = [Id | N], + UName = mk_uppercase(Name), + case ets:lookup(S, Name) of + [{_, forward, _, _}] when is_record(X, interface) -> ok; + [XX] when is_record(X, forward) andalso element(2, XX)==interface -> ok; + [_] -> ic_error:error(G, {multiply_defined, X}); + [] -> + case ets:lookup(S, UName) of + [] -> ok; + [_] -> ic_error:error(G, {illegal_spelling, X}) + end + end, + ets:insert(S, {Name, element(1, get_beef(X)), TK, Aux}), + if UName =/= Name -> ets:insert(S, {UName, spellcheck}); + true -> true end, + TK. + + + + +%%-------------------------------------------------------------------- +%% enum_body +%% +%% Special because ids are treated different than usual. +%% +enum_body(G, S, N, [Enum | EnumList]) -> + tktab_add(G, S, N, Enum), %%%, enum_val, Enum), + %% tktab_add(G, S, N, X, TK, V), + [ic_forms:get_id2(Enum) | enum_body(G, S, N, EnumList)]; +enum_body(_G, _S, _N, []) -> []. + + +%%-------------------------------------------------------------------- +%% mk_array +%% +%% Multi dimensional arrays are written as nested tk_array +%% +mk_array(G, S, N, [Sz | Szs], TK) -> + case iceval:eval_const(G, S, N, positive_int, Sz) of + Err when element(1, Err) == error -> TK; + Val -> + {tk_array, mk_array(G, S, N, Szs, TK), iceval:get_val(Val)} + end; +mk_array(_G, _S, _N, [], TK) -> TK. + + +%%-------------------------------------------------------------------- +%% len_eval +%% +%% Evaluates the length, which in case it has been left out is a +%% plain 0 (zero) +%% +len_eval(_G, _S, _N, 0) -> 0; +len_eval(G, S, N, X) -> %%iceval:eval_const(G, S, N, positive_int, X). + case iceval:eval_const(G, S, N, positive_int, X) of + Err when element(1, Err) == error -> 0; + Val -> iceval:get_val(Val) + end. + + +%%-------------------------------------------------------------------- +%% case_eval +%% +%% Evaluates the case label. +%% + +case_eval(G, S, N, DiscrTK, X) when element(1, DiscrTK) == tk_enum, + element(1, X) == scoped_id -> + {tk_enum, _, _, Cases} = DiscrTK, + Id = get_case_id_and_check(G, S, N, X, X), + %%io:format("Matching: ~p to ~p~n", [Id, Cases]), + case lists:member(Id, Cases) of + true -> + {enum_id, Id}; + false -> + iceval:mk_val(scoped_lookup(G, S, N, X)) % Will generate error + end; + +case_eval(G, S, N, DiscrTK, X) -> + iceval:eval_e(G, S, N, DiscrTK, X). + + +%% The enum declarator is in the union scope. +do_special_enum(G, S, N, X) when is_record(X, enum) -> + tktab_add(G, S, N, #id_of{id=X#enum.id, type=X}); +do_special_enum(_G, _S, _N, _X) -> + ok. + + +unique_add_case_label(G, _S, _N, Id, TK, TKList) -> +%%%io:format("check_case_labels: TK:~p TKLIST:~p ~n", [TK, TKList]), + if element(1, TK) == error -> + TKList; + true -> + case lists:keysearch(element(1, TK), 1, TKList) of + {value, _} -> + ic_error:error(G, {multiple_cases, Id}), + TKList; + false -> + [TK | TKList] + end + end. + + +%%-------------------------------------------------------------------- +%% default_count +%% +%% Returns the position of the default case. +%% +%% Modified for OTP-2007 +%% +default_count(Xs) -> + default_count2(Xs, 0). + +default_count2([X | Xs], N) -> default_count3(X#case_dcl.label, Xs, N); +default_count2([], _) -> -1. + +default_count3([{default, _} | _Ys], _Xs, N) -> N; +default_count3([_ | Ys], Xs, N) -> default_count3(Ys, Xs, N+1); +default_count3([], Xs, N) -> default_count2(Xs, N). + + + + +%% +%% Type checks. +%% +%% Check constant type references (only for the scoped id case, others +%% are caught by the BNF) +%% +check_const_tk(_G, _S, _N, _X, tk_long) -> true; +check_const_tk(_G, _S, _N, _X, tk_longlong) -> true; %% LLONG +check_const_tk(_G, _S, _N, _X, tk_short) -> true; +check_const_tk(_G, _S, _N, _X, tk_ushort) -> true; +check_const_tk(_G, _S, _N, _X, tk_ulong) -> true; +check_const_tk(_G, _S, _N, _X, tk_ulonglong) -> true; %% ULLONG +check_const_tk(_G, _S, _N, _X, tk_float) -> true; +check_const_tk(_G, _S, _N, _X, tk_double) -> true; +check_const_tk(_G, _S, _N, _X, tk_boolean) -> true; +check_const_tk(_G, _S, _N, _X, tk_char) -> true; +check_const_tk(_G, _S, _N, _X, tk_wchar) -> true; %% WCHAR +check_const_tk(_G, _S, _N, _X, tk_octet) -> true; +check_const_tk(_G, _S, _N, _X, {tk_string, _Len}) -> true; +check_const_tk(_G, _S, _N, _X, {tk_wstring, _Len}) -> true; %% WSTRING +check_const_tk(_G, _S, _N, _X, tk_fixed) -> true; +check_const_tk(_G, _S, _N, _X, {tk_fixed, _Digits, _Scale}) -> true; +check_const_tk(G, _S, _N, X, TK) -> ic_error:error(G, {illegal_const_t, X, TK}). + + +check_switch_tk(_G, _S, _N, _X, tk_long) -> true; +check_switch_tk(_G, _S, _N, _X, tk_longlong) -> true; %% LLONG +check_switch_tk(_G, _S, _N, _X, tk_short) -> true; +check_switch_tk(_G, _S, _N, _X, tk_ushort) -> true; +check_switch_tk(_G, _S, _N, _X, tk_ulong) -> true; +check_switch_tk(_G, _S, _N, _X, tk_ulonglong) -> true; %% ULLONG +check_switch_tk(_G, _S, _N, _X, tk_boolean) -> true; +check_switch_tk(_G, _S, _N, _X, tk_char) -> true; +check_switch_tk(_G, _S, _N, _X, tk_wchar) -> true; %% WCHAR +check_switch_tk(_G, _S, _N, _X, TK) when element(1, TK) == tk_enum -> true; +check_switch_tk(G, _S, _N, X, TK) -> ic_error:error(G, {illegal_switch_t, X, TK}), + false. + + + +%% Lookup a name +name_lookup(G, S, N, X) -> + case scoped_lookup(G, S, N, X) of + T when is_tuple(T) -> element(1, T) + end. + + +lookup(G, S, N, X, Id) -> + N2 = Id ++ N, + ?DBG(" Trying ~p ...~n", [N2]), + case ets:lookup(S, N2) of + [] -> + case look_for_interface(G, S, [hd(N2)], tl(N2)) of + + %% First attempt: filtering inherited members ! + [{_, member, _, _}] -> + case look_for_interface(G, S, [hd(N)], tl(N2)) of + [T] -> + ?DBG(" -- found ~p~n", [T]), + T; + _ -> + lookup(G, S, tl(N), X, Id) + end; + %% + + [T] -> + ?DBG(" -- found ~p~n", [T]), + T; + + _ -> + if N == [] -> + ic_error:error(G, {tk_not_found, X}); + true -> + lookup(G, S, tl(N), X, Id) + end + + end; + + %% Second attempt: filtering members ! + [{_, member, _, _}] -> + case look_for_interface(G, S, [hd(N2)], tl(N2)) of + [T] -> + ?DBG(" -- found ~p~n", [T]), + T; + _ -> + if N == [] -> + ic_error:error(G, {tk_not_found, X}); + true -> + lookup(G, S, tl(N), X, Id) + end + end; + %% + [T] -> + ?DBG(" -- found ~p~n", [T]), + T + end. + + +look_for_interface(_G, _S, _Hd, []) -> + false; +look_for_interface(G, S, Hd, Tl) -> + case ets:lookup(S, Tl) of + [{_, interface, _TK, Inh}] -> + case look_in_inherit(G, S, Hd, Inh) of + %% gather_inherit(G, S, Inh, [])) of + [X] when is_tuple(X) -> + [X]; + _ -> + look_for_interface(G, S, Hd ++ [hd(Tl)], tl(Tl)) + end; + _ -> + look_for_interface(G, S, Hd ++ [hd(Tl)], tl(Tl)) + end. + +look_in_inherit(G, S, Id, [I | Is]) -> + case ets:lookup(S, Id ++ I) of + [X] when is_tuple(X) -> + [X]; + [] -> + look_in_inherit(G, S, Id, Is) + end; +look_in_inherit(_G, _S, _Id, []) -> + false. + + +%% L is a list of names +mk_uppercase(L) -> + lists:map(fun(Z) -> lists:map(fun(X) when X>=$a, X=<$z -> X-$a+$A; + (X) -> X end, Z) end, L). + + +%%-------------------------------------------------------------------- +%% +%% Inheritance stuff +%% +%% +%%-------------------------------------------------------------------- + +%% InhBody is an accumulating parameter + +calc_inherit_body(G, N, OrigBody, [X|Xs], InhBody) -> + case ic_symtab:retrieve(G, X) of + Intf when is_record(Intf, interface) -> + Body = filter_body(G, X, ic_forms:get_body(Intf), N, OrigBody, InhBody), + calc_inherit_body(G, N, OrigBody, Xs, [{X, Body} | InhBody]); + XXX -> + io:format("Oops, not found ~p~n", [XXX]), + calc_inherit_body(G, N, OrigBody, Xs, InhBody) + end; +calc_inherit_body(_G, _N, _OrigBody, [], InhBody) -> lists:reverse(InhBody). + + +filter_body(G, XPath, [X | Xs], OrigPath, OrigBody, InhBody) -> + case complex_body_member(G, XPath, X, OrigPath, OrigBody, InhBody) of + true -> + %%io:format("NOT adding ~p~n", [ic_forms:get_id2(X)]), + filter_body(G, XPath, Xs, OrigPath, OrigBody, InhBody); + {false, NewX} -> % For those with idlist + %%io:format("Adding from idlist~n", []), + [NewX | filter_body(G, XPath, Xs, OrigPath, OrigBody, InhBody)]; + false -> + %%io:format("Adding: ~p~n", [ic_forms:get_id2(X)]), + [X | filter_body(G, XPath, Xs, OrigPath, OrigBody, InhBody)] + end; +filter_body(_G, _XPath, [], _OrigPath, _OrigBody, _InhBody) -> []. + + +complex_body_member(G, XPath, X, OrigPath, OrigBody, InhBody) -> + case has_idlist(X) of + true -> + idlist_member(G, XPath, X, OrigPath, OrigBody, InhBody); + false -> + straight_member(G, XPath, X, OrigPath, OrigBody, InhBody) + end. + + +idlist_member(G, XPath, X, OrigPath, OrigBody, InhBody) -> + XX = #id_of{type=X}, + F = fun(Id) -> + not(straight_member(G, XPath, XX#id_of{id=Id}, OrigPath, + OrigBody, InhBody)) + end, + case lists:filter(F, ic_forms:get_idlist(X)) of + [] -> + true; + IdList -> +%%% io:format("Idlist added: ~p~n",[IdList]), + {false, replace_idlist(X, IdList)} + end. + + +straight_member(G, XPath, X, OrigPath, OrigBody, InhBody) -> + %%io:format("straight member: ~p~n", [ic_forms:get_id2(X)]), + case body_member(G, XPath, X, OrigPath, OrigBody) of + true -> + true; + false -> + inh_body_member(G, XPath, X, InhBody) + end. + + +inh_body_member(G, XPath, X, [{Name, Body} | InhBody]) -> + case body_member(G, XPath, X, Name, Body) of + true -> + true; + false -> + inh_body_member(G, XPath, X, InhBody) + end; +inh_body_member(_G, _XPath, _X, []) -> false. + + +body_member(G, XPath, X, YPath, [Y|Ys]) -> + case has_idlist(Y) of + true -> + YY = #id_of{type=Y}, + case list_and(fun(Y2) -> + not(is_equal(G, XPath, X, YPath, + YY#id_of{id=Y2})) end, + ic_forms:get_idlist(Y)) of + true -> + body_member(G, XPath, X, YPath, Ys); + false -> + true + end; + false -> + case is_equal(G, XPath, X, YPath, Y) of + false -> + body_member(G, XPath, X, YPath, Ys); + true -> + true + end + end; +body_member(_G, _XPath, _X, _YPath, []) -> false. + + +is_equal(G, XPath, X, YPath, Y) -> + case {ic_forms:get_id2(X), ic_forms:get_id2(Y)} of + {ID, ID} -> + collision(G, XPath, X, YPath, Y), + true; + _ -> + false + end. + + +%% X is the new item, Y is the old one. So it is X that collides with +%% Y and Y shadows X. +collision(G, XPath, X, YPath, Y) -> + I1 = get_beef(X), + % I2 = get_beef(Y), + if is_record(I1, op) -> %%, record(I2, op) -> + ic_error:error(G, {inherit_name_collision, + {YPath, Y}, {XPath, X}}); + is_record(I1, attr) -> %%, record(I2, attr) -> + ic_error:error(G, {inherit_name_collision, + {YPath, Y}, {XPath, X}}); + true -> + ?ifopt(G, warn_name_shadow, + ic_error:warn(G, {inherit_name_shadow, + {YPath, Y}, {XPath, X}})) + end. + +has_idlist(X) when is_record(X, typedef) -> true; +has_idlist(X) when is_record(X, member) -> true; +has_idlist(X) when is_record(X, case_dcl) -> true; +has_idlist(X) when is_record(X, attr) -> true; +has_idlist(_) -> false. + +replace_idlist(X, IdList) when is_record(X, typedef) -> X#typedef{id=IdList}; +replace_idlist(X, IdList) when is_record(X, attr) -> X#attr{id=IdList}. + +get_beef(X) when is_record(X, id_of) -> X#id_of.type; +get_beef(X) -> X. + + +%% And among all elements in list +list_and(F, [X|Xs]) -> + case F(X) of + true -> list_and(F, Xs); + false -> false + end; +list_and(_F, []) -> true. + + + + + +%%-------------------------------------------------------------------- +%% +%% resolve_inherit shall return a list of resolved inheritances, +%% that is all names replaced with their global names. +%% + +inherit_resolve(G, S, N, [X|Rest], Out) -> + case scoped_lookup(G, S, N, X) of + {Name, _T, _TK, Inh} -> + case lists:member(Name, Out) of + true -> + inherit_resolve(G, S, N, Rest, Out); + false -> + case unique_append(Inh, [Name|Out]) of + error -> + ic_error:error(G, {inherit_resolve, X, Name}), + inherit_resolve(G, S, N, Rest, []); + UA -> + inherit_resolve(G, S, N, Rest, UA) + end + end; + _ -> inherit_resolve(G, S, N, Rest, Out) + end; +inherit_resolve(_G, _S, _N, [], Out) -> lists:reverse(Out). + +unique_append([X|Xs], L) -> + case lists:member(X, L) of + true -> unique_append(Xs, L); + false -> unique_append(Xs, [X|L]) + end; +unique_append([], L) -> L; +%% Error +unique_append(_, _L) -> error. + + + + +%%-------------------------------------------------------------------- +%% +%% Utilities +%% + +%% Must preserve order, therefore had to write my own (instead of lists:map) +check_list(G, S, N, [X|Xs]) -> + X1 = check(G, S, N, X), + [X1 | check_list(G, S, N, Xs)]; +check_list(_G, _S, _N, []) -> []. + + + +filter( [] ) -> + error; +filter( [I | Is ] ) -> + case I of + { _, member, { _, TKINFO }, _ } -> + fetchType( TKINFO ); + + { _, struct, _, _ } -> + struct; + + { _, typedef, TKINFO, _ } -> + fetchType( TKINFO ); + + { _, module, _, _ } -> + module; + + { _, interface, _, _ } -> + interface; + + { _, op, _, _ } -> + op; + + { _,enum, _, _ } -> + enum; + + { _, spellcheck } -> + filter( Is ); + + _ -> + error + end. + + +fetchType( { tk_sequence, _, _ } ) -> + sequence; +fetchType( { tk_array, _, _ } ) -> + array; +fetchType( { tk_struct, _, _, _} ) -> + struct; +fetchType( { tk_string, _} ) -> + string; +fetchType( { tk_wstring, _} ) -> %% WSTRING + wstring; +fetchType( { tk_fixed, _, _} ) -> + fixed; +fetchType( tk_short ) -> + short; +fetchType( tk_long ) -> + long; +fetchType( tk_longlong ) -> %% LLONG + longlong; +fetchType( tk_ushort ) -> + ushort; +fetchType( tk_ulong ) -> + ulong; +fetchType( tk_ulonglong ) -> %% ULLONG + ulonglong; +fetchType( tk_float ) -> + float; +fetchType( tk_double ) -> + double; +fetchType( tk_boolean ) -> + boolean; +fetchType( tk_char ) -> + char; +fetchType( tk_wchar ) -> %% WCHAR + wchar; +fetchType( tk_octet ) -> + octet; +fetchType( { tk_enum, _, _, _ } ) -> + enum; +fetchType( { tk_union, _, _, _, _, _ } ) -> + union; +fetchType( tk_any ) -> + any; +fetchType( _ ) -> + error. + +%% Z is a single name +to_uppercase(Z) -> + lists:map(fun(X) when X>=$a, X=<$z -> X-$a+$A; + (X) -> X end, Z). + + +%%------------------------------------------------------------ +%% +%% Always fetchs TK of a record. +%% +%%------------------------------------------------------------ +fetchTk(G,N,X) -> + case ic_forms:get_tk(X) of + undefined -> + searchTk(G,ictk:get_IR_ID(G, N, X)); + TK -> + TK + end. + + +%%------------------------------------------------------------ +%% +%% seek type code when not accessible by get_tk/1 +%% +%%------------------------------------------------------------ +searchTk(G,IR_ID) -> + S = ic_genobj:tktab(G), + case catch searchTk(S,IR_ID,typedef) of + {value,TK} -> + TK; + _ -> %% false / exit + case catch searchTk(S,IR_ID,struct) of + {value,TK} -> + TK; + _ -> %% false / exit + case catch searchTk(S,IR_ID,union) of + {value,TK} -> + TK; + _ -> + undefined + end + end + end. + + +searchTk(S,IR_ID,Type) -> + L = lists:flatten(ets:match(S,{'_',Type,'$1','_'})), + case lists:keysearch(IR_ID,2,L) of + {value,TK} -> + {value,TK}; + false -> + searchInsideTks(L,IR_ID) + end. + + +searchInsideTks([],_IR_ID) -> + false; +searchInsideTks([{tk_array,TK,_}|Xs],IR_ID) -> + case searchIncludedTk(TK,IR_ID) of + {value,TK} -> + {value,TK}; + false -> + searchInsideTks(Xs,IR_ID) + end. + + +searchIncludedTk({tk_array,TK,_},IR_ID) -> + searchIncludedTk(TK,IR_ID); +searchIncludedTk({tk_sequence,TK,_},IR_ID) -> + searchIncludedTk(TK,IR_ID); +searchIncludedTk(TK, _IR_ID) when is_atom(TK) -> + false; +searchIncludedTk(TK,IR_ID) -> + case element(2,TK) == IR_ID of + true -> + {value,TK}; + false -> + false + end. + diff --git a/lib/ic/src/icunion.erl b/lib/ic/src/icunion.erl new file mode 100644 index 0000000000..38a2d14913 --- /dev/null +++ b/lib/ic/src/icunion.erl @@ -0,0 +1,1490 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1998-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(icunion). + +-import(ic_codegen, [emit/2, emit/3, emit/4, emit_c_enc_rpt/4, emit_c_dec_rpt/4]). +-import(ic_cbe, [mk_c_type/3, mk_c_type/4]). + +-include("icforms.hrl"). +-include("ic.hrl"). + +%%----------------------------------------------------------------- +%% External exports +%%----------------------------------------------------------------- +-export([union_gen/4]). + +%%----------------------------------------------------------------- +%% Internal exports +%%----------------------------------------------------------------- +-export([]). + +union_gen(G, N, X, c) when is_record(X, union) -> + emit_c_union(G, N, X); +union_gen(_G, _N, _X, _L) -> + ok. + + +%% Emits the union +emit_c_union(G, N, X) -> + %%io:format("Rec = ~p\n",[X]), + case ic_genobj:is_hrlfile_open(G) of + true -> + + %% Sort Union Default = put it last in case list + NewX = #union{ id = X#union.id, + type = X#union.type, + body = mvDefaultToTail(X#union.body), + tk = X#union.tk }, + + UnionScope = [ic_forms:get_id2(NewX) | N], + + case ic_pragma:is_local(G,UnionScope) of + + true -> + + HFd = ic_genobj:hrlfiled(G), + emit_c_union_values(G, N, NewX, HFd), + UnionName = ic_util:to_undersc(UnionScope), + + emit(HFd, "\n#ifndef __~s__\n",[ictype:to_uppercase(UnionName)]), + emit(HFd, "#define __~s__\n",[ictype:to_uppercase(UnionName)]), + ic_codegen:mcomment_light(HFd, + [io_lib:format("Union definition: ~s", + [UnionName])], + c), + emit(HFd, "typedef struct {\n"), + emit(HFd, " ~s _d;\n", [get_c_union_discriminator(G, N, NewX)]), + emit(HFd, " union {\n"), + emit_c_union_values_decl(G, N, NewX, HFd), + emit(HFd, " } _u;\n"), + emit(HFd, "} ~s;\n\n", [UnionName]), + + emit(HFd, "int ~s~s(CORBA_Environment *oe_env, int*, int*);\n", + [ic_util:mk_oe_name(G, "sizecalc_"), UnionName]), + emit(HFd, "int ~s~s(CORBA_Environment *oe_env, ~s*);\n", + [ic_util:mk_oe_name(G, "encode_"), UnionName, UnionName]), + emit(HFd, "int ~s~s(CORBA_Environment *oe_env, char *, int*, ~s*);\n", + [ic_util:mk_oe_name(G, "decode_"), UnionName, UnionName]), + emit(HFd, "\n#endif\n\n"), + create_c_union_file(G, N, NewX, UnionName); + + false -> %% Do not generate included types att all. + ok + end; + false -> + ok + end. + + + +%% Loops over union members and creates members typedefs +emit_c_union_values(G, N, X, Fd) -> + emit_c_union_values_loop(G, N, X, Fd, X#union.body). + +emit_c_union_values_loop(G, N, X, Fd, [CU]) -> + case CU of + {case_dcl,_,Id,Type} -> + case Id of + {array, _AID, _SZ} -> % Check for arrays + mk_array_file(G,N,X,Id,Type,Fd); + _ -> % Elementary types or seq/struct + ok + end; + _ -> + error + end; +emit_c_union_values_loop(G, N, X, Fd, [CU |CUs]) -> + case CU of + {case_dcl,_,Id,Type} -> + case Id of + {array, _AID, _SZ} -> % Check for arrays + mk_array_file(G,N,X,Id,Type,Fd); + _ -> % Elementary types or seq/struct + emit_c_union_values_loop(G, N, X, Fd, CUs) + end; + _ -> + error + end. + + +%% Loops over union members and declares members inside union structure +emit_c_union_values_decl(G, N, X, Fd) -> + emit_c_union_values_decl_loop(G, N, X, Fd, X#union.body). + +emit_c_union_values_decl_loop(G, N, X, Fd, [CU]) -> + case CU of + {case_dcl,_,Id,Type} -> + case Id of + {array, _AID, _SZ} -> % Check for arrays + mk_array_decl(G,N,X,Id,Type,Fd); + _ -> % Elementary types or seq/struct + mk_union_member_decl(G,N,X,Id,Type,Fd), + ok + end; + _ -> + error + end; +emit_c_union_values_decl_loop(G, N, X, Fd, [CU |CUs]) -> + case CU of + {case_dcl,_,Id,Type} -> + case Id of + {array, _AID, _SZ} -> % Check for arrays + mk_array_decl(G,N,X,Id,Type,Fd), + emit_c_union_values_decl_loop(G, N, X, Fd, CUs); + _ -> % Elementary types or seq/struct + mk_union_member_decl(G,N,X,Id,Type,Fd), + emit_c_union_values_decl_loop(G, N, X, Fd, CUs) + end; + _ -> + error + end. + + +%% Makes the declaration for the array in union +mk_array_decl(G,N,X,Id,Type,Fd) -> + emit(Fd, " ~s ~s;\n", + [getCaseTypeStr(G,N,X,Id,Type), + mk_array_name(Id)]). + +mk_array_name({array,Id,D}) -> + ic_forms:get_id2(Id) ++ mk_array_dim(D). + +mk_array_dim([]) -> + ""; +mk_array_dim([{_,_,Dim}|Dims]) -> + "[" ++ Dim ++ "]" ++ mk_array_dim(Dims). + + +%% Creates the array file +mk_array_file(G,N,X,{array,AID,SZ},Type,HFd) -> + ArrayName = ic_util:to_undersc([ic_forms:get_id2(AID),ic_forms:get_id2(X) | N]), + ArrayDim = extract_array_dim(SZ), + emit(HFd, "\n#ifndef __~s__\n",[ictype:to_uppercase(ArrayName)]), + emit(HFd, "#define __~s__\n\n",[ictype:to_uppercase(ArrayName)]), + icstruct:create_c_array_coding_file(G, + N, + {ArrayName,ArrayDim}, + Type, + no_typedef), + emit(HFd, "\n#endif\n\n"). + +extract_array_dim([{_,_,Dim}]) -> + [Dim]; +extract_array_dim([{_,_,Dim}|Dims]) -> + [Dim | extract_array_dim(Dims)]. + + +%% Makes the declaration for the member in union +mk_union_member_decl(G,N,X,Id,Type,Fd) -> + emit(Fd, " ~s ~s;\n", + [getCaseTypeStr(G,N,X,Id,Type), + ic_forms:get_id2(Id)]). + + + + +%% File utilities +create_c_union_file(G, N, X, UnionName) -> + + {Fd , SName} = open_c_coding_file(G, UnionName), + _HFd = ic_genobj:hrlfiled(G), %% Write on stubfile header + HrlFName = filename:basename(ic_genobj:include_file(G)), + ic_codegen:emit_stub_head(G, Fd, SName, c), + emit(Fd, "#include \"~s\"\n\n",[HrlFName]), + + %% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + %% Fd = ic_genobj:stubfiled(G), %% Write on stubfile + %% HFd = ic_genobj:hrlfiled(G), %% Write on stubfile header + %% HrlFName = filename:basename(ic_genobj:include_file(G)), + %% emit(Fd, "#include \"~s\"\n\n",[HrlFName]), + %% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + put(op_variable_count, 0), + put(tmp_declarations, []), + + %% Write generated code on file + emit_union_sizecount(G, N, X, Fd, UnionName), + emit_union_encode(G, N, X, Fd, UnionName), + emit_union_decode(G, N, X, Fd, UnionName), + file:close(Fd). + +open_c_coding_file(G, Name) -> + SName = string:concat(ic_util:mk_oe_name(G, "code_"), Name), + FName = + ic_file:join(ic_options:get_opt(G, stubdir),ic_file:add_dot_c(SName)), + case file:open(FName, [write]) of + {ok, Fd} -> + {Fd, SName}; + Other -> + exit(Other) + end. + + + + +get_c_union_discriminator(G, N, X) -> + case getDiscrStr(G, N, X#union.type) of + error -> + ic_error:fatal_error(G, {illegal_typecode_for_c, X#union.type, N}); + DiscrStr -> + case ic_code:get_basetype(G, DiscrStr) of + {short, _} -> + "CORBA_short"; + {unsigned,{short, _}} -> + "CORBA_unsigned_short"; + {long, _} -> + "CORBA_long"; + {unsigned,{long, _}} -> + "CORBA_unsigned_long"; + {boolean,_} -> + "CORBA_boolean"; + {char,_} -> + "CORBA_char"; + {enum, EnumType} -> + EnumType; + _ -> + DiscrStr + end + end. + +getDiscrStr(G, N, S) when element(1, S) == scoped_id -> + case ic_symtab:get_full_scoped_name(G, N, S) of + {FSN, _, tk_short, _} -> + ic_util:to_undersc(FSN); + {FSN, _, tk_ushort, _} -> + ic_util:to_undersc(FSN); + {FSN, _, tk_long, _} -> + ic_util:to_undersc(FSN); + {FSN, _, tk_ulong, _} -> + ic_util:to_undersc(FSN); + {FSN, _, tk_boolean, _} -> + ic_util:to_undersc(FSN); + {FSN, _, tk_char, _} -> + ic_util:to_undersc(FSN); + {FSN, _, {tk_enum,_,_,_}, _} -> + ic_util:to_undersc(FSN); + _ -> + error + end; +getDiscrStr(_G, N, X) -> + case X of + {short,_} -> + "CORBA_short"; + {unsigned,{short,_}} -> + "CORBA_unsigned_short"; + {long, _} -> + "CORBA_long"; + {unsigned,{long,_}} -> + "CORBA_unsigned_long"; + {boolean,_} -> + "CORBA_boolean"; + {char,_} -> + "CORBA_char"; + {enum,TID,_,_} -> + ic_util:to_undersc([ic_forms:get_id2(TID) | N]); + _ -> + error + end. + + + + +getCaseTypeStr(G, N, X, I, T) when element(1, T) == scoped_id -> + case catch ic_symtab:get_full_scoped_name(G, N, T) of + {FSN, _, _, _} -> + BT = ic_code:get_basetype(G, ic_util:to_undersc(FSN)), + case isList(BT) of + true -> + BT; + false -> + case BT of + {short,_} -> + "CORBA_short"; + {unsigned,{short,_}} -> + "CORBA_unsigned_short"; + {long, _} -> + "CORBA_long"; + {unsigned,{long,_}} -> + "CORBA_unsigned_long"; + {float,_} -> + "CORBA_float"; + {double,_} -> + "CORBA_double"; + {boolean,_} -> + "CORBA_boolean"; + {char,_} -> + "CORBA_char"; + {wchar,_} -> + "CORBA_wchar"; + {octet,_} -> + "CORBA_octet"; + {string,_} -> + "CORBA_char*"; + {wstring,_} -> + "CORBA_wchar*"; + {sequence,_,_} -> + ic_util:to_undersc([ic_forms:get_id2(I), ic_forms:get_id2(X) | N]); + {struct,SID,_,_} -> + ic_util:to_undersc([ic_forms:get_id2(SID), ic_forms:get_id2(X) | N]); + {enum,EID} -> + EID; + {any, _} -> %% Fix for any type + "CORBA_long"; + _ -> + %%io:format("BT = ~p~n",[BT]), + error + end + end + end; +getCaseTypeStr(_G, N, X, I, T) -> + case T of + {short,_} -> + "CORBA_short"; + {unsigned,{short,_}} -> + "CORBA_unsigned_short"; + {long, _} -> + "CORBA_long"; + {unsigned,{long,_}} -> + "CORBA_unsigned_long"; + {float,_} -> + "CORBA_float"; + {double,_} -> + "CORBA_double"; + {boolean,_} -> + "CORBA_boolean"; + {char,_} -> + "CORBA_char"; + {wchar,_} -> + "CORBA_wchar"; + {octet,_} -> + "CORBA_octet"; + {string,_} -> + "CORBA_char*"; + {wstring,_} -> + "CORBA_wchar*"; + {sequence,_,_} -> + ic_util:to_undersc([ic_forms:get_id2(I), ic_forms:get_id2(X) | N]); + {struct,SID,_,_} -> + ic_util:to_undersc([ic_forms:get_id2(SID), ic_forms:get_id2(X) | N]); + {union,UID,_,_,_} -> + ic_util:to_undersc([ic_forms:get_id2(UID), ic_forms:get_id2(X) | N]); + {any, _} -> %% Fix for any type + "CORBA_long"; + _ -> + error + end. + +isList(L) when is_list(L) -> + true; +isList(_) -> + false. + +%% +%% Sizecount facilities +%% +emit_union_sizecount(G, N, X, Fd, UnionName) -> + emit(Fd, "int ~s~s(CORBA_Environment *oe_env, int* oe_size_count_index, int* oe_size) {\n\n", + [ic_util:mk_oe_name(G, "sizecalc_"), UnionName]), + + emit(Fd, " int oe_malloc_size = 0;\n"), + emit(Fd, " int oe_error_code = 0;\n"), + emit(Fd, " int oe_type = 0;\n"), + emit(Fd, " int oe_tmp = 0;\n"), + emit_union_discr_var_decl(G, N, X, Fd), + + ic_codegen:nl(Fd), + emit(Fd, " if(*oe_size == 0)\n",[]), + AlignName = lists:concat(["*oe_size + sizeof(",UnionName,")"]), + emit(Fd, " *oe_size = ~s;\n\n", [ic_util:mk_align(AlignName)]), + + emit(Fd, " if ((oe_error_code = ei_get_type(oe_env->_inbuf, oe_size_count_index, &oe_type, &oe_tmp)) < 0) {\n"), + emit_c_dec_rpt(Fd, " ", "ei_get_type", []), + emit(Fd, " return oe_error_code;\n }\n"), + + %%emit(Fd, " if (oe_tmp != 3)\n"), + %%emit(Fd, " return -1;\n\n"), + + emit(Fd, " if ((oe_error_code = ei_decode_tuple_header(oe_env->_inbuf, oe_size_count_index, 0)) < 0) {\n"), + emit_c_dec_rpt(Fd, " ", "ei_decode_tuple_header", []), + emit(Fd, " return oe_error_code;\n }\n"), + emit(Fd, " if ((oe_error_code = ei_decode_atom(oe_env->_inbuf, oe_size_count_index, 0)) < 0) {\n", []), + emit_c_dec_rpt(Fd, " ", "ei_decode_atom", []), + emit(Fd, " return oe_error_code;\n }\n"), + + emit_c_union_discr_sizecount(G, N, X, Fd), + emit(Fd, " /* Calculate union size */\n"), + emit(Fd, " switch(oe_discr) {\n"), + + emit_c_union_loop(G, N, X, Fd, X#union.body, sizecalc), + emit(Fd, " }\n\n"), + + emit(Fd, " *oe_size = ~s;\n",[ic_util:mk_align("*oe_size+oe_malloc_size")]), + emit(Fd, " return 0;\n"), + emit(Fd, "}\n\n\n"). + + +emit_union_discr_var_decl(G, N, X, Fd) -> + UD = get_c_union_discriminator(G, N, X), + case UD of + "CORBA_short" -> + emit(Fd, " long oe_discr = 0;\n"); + "CORBA_unsigned_short" -> + emit(Fd, " unsigned long oe_discr = 0;\n"); + "CORBA_long" -> + emit(Fd, " long oe_discr = 0;\n"); + "CORBA_unsigned_long" -> + emit(Fd, " unsigned long oe_discr = 0;\n"); + "CORBA_boolean" -> + emit(Fd, " int oe_discr = 0;\n"), + emit(Fd, " char oe_bool[256];\n"); + "CORBA_char" -> + emit(Fd, " char oe_discr = 0;\n"); + _T -> + emit(Fd, " int oe_dummy = 0;\n"), + emit(Fd, " ~s oe_discr = 0;\n",[UD]) + end. + + +emit_c_union_discr_sizecount(G, N, X, Fd) -> + emit(Fd, " /* Calculate discriminator size */\n"), + UD = get_c_union_discriminator(G, N, X), + case UD of + "CORBA_short" -> + emit(Fd, " if ((oe_error_code = ei_decode_long(oe_env->_inbuf, oe_size_count_index, &oe_discr)) < 0) {\n"), + emit_c_dec_rpt(Fd, " ", "ei_decode_long", []), + emit(Fd, " return oe_error_code;\n }\n"); + "CORBA_unsigned_short" -> + emit(Fd, " if ((oe_error_code = ei_decode_ulong(oe_env->_inbuf, oe_size_count_index, &oe_discr)) < 0) {\n"), + emit_c_dec_rpt(Fd, " ", "ei_decode_ulong", []), + emit(Fd, " return oe_error_code;\n }\n"); + "CORBA_long" -> + emit(Fd, " if ((oe_error_code = ei_decode_long(oe_env->_inbuf, oe_size_count_index, &oe_discr)) < 0) {\n"), + emit_c_dec_rpt(Fd, " ", "ei_decode_long", []), + emit(Fd, " return oe_error_code;\n }\n"); + "CORBA_unsigned_long" -> + emit(Fd, " if ((oe_error_code = ei_decode_ulong(oe_env->_inbuf, oe_size_count_index, &oe_discr)) < 0) {\n"), + emit_c_dec_rpt(Fd, " ", "ei_decode_ulong", []), + emit(Fd, " return oe_error_code;\n }\n"); + "CORBA_boolean" -> + emit(Fd, " if ((oe_error_code = ei_decode_atom(oe_env->_inbuf, oe_size_count_index, oe_bool)) < 0) {\n"), + emit_c_dec_rpt(Fd, " ", "ei_decode_atom", []), + emit(Fd, " return oe_error_code;\n }\n"), + emit(Fd, " if (strcmp(oe_bool, \"false\") == 0) {\n"), + emit(Fd, " oe_discr = 0;\n"), + emit(Fd, " }\n"), + emit(Fd, " else if (strcmp(oe_bool, \"true\") == 0) {\n"), + emit(Fd, " oe_discr = 1;\n"), + emit(Fd, " }\n"), + emit(Fd, " else {\n"), + emit_c_dec_rpt(Fd, " ", "not boolean", []), + emit(Fd, " return -1;\n }\n"); + + "CORBA_char" -> + emit(Fd, " if ((oe_error_code = ei_decode_char(oe_env->_inbuf, oe_size_count_index, &oe_discr)) < 0) {\n"), + emit_c_dec_rpt(Fd, " ", "ei_decode_char", []), + emit(Fd, " return oe_error_code;\n }\n"); + T -> + emit(Fd, " oe_tmp = *oe_size_count_index;\n"), + emit(Fd, " if ((oe_error_code = oe_sizecalc_~s(oe_env, oe_size_count_index, &oe_malloc_size)) < 0) {\n", [T]), + ?emit_c_dec_rpt(Fd, " ", "oe_size_calc_~s", [T]), + emit(Fd, " return oe_error_code;\n }\n"), + + emit(Fd, " *oe_size_count_index = oe_tmp;\n"), + emit(Fd, " oe_tmp = oe_env->_iin;\n"), + emit(Fd, " oe_env->_iin = *oe_size_count_index;\n"), + emit(Fd, " if ((oe_error_code = oe_decode_~s(oe_env, NULL, &oe_dummy, &oe_discr)) < 0) {\n", [T]), + ?emit_c_dec_rpt(Fd, " ", "oe_decode_~s", [T]), + emit(Fd, " return oe_error_code;\n }\n"), + + emit(Fd, " *oe_size_count_index = oe_env->_iin;\n"), + emit(Fd, " oe_env->_iin = oe_tmp;\n\n") + end. + + + +emit_c_union_loop(G, N, X, Fd, CaseList, Case) -> + emit_c_union_loop(G, N, X, Fd, CaseList, false, Case). + +emit_c_union_loop(G, N, X, Fd, [], GotDefaultCase, Case) -> + case GotDefaultCase of + false -> + emit_c_union_valueless_discriminator(G, N, X, Fd, Case) + end; +emit_c_union_loop(G, N, X, Fd, [CU|CUs], GotDefaultCase, Case) -> + case CU of + {case_dcl,CaseList,I,T} -> + GotDefaultCase = emit_c_union_case(G, N, X, Fd, I, T, CaseList, Case), + emit_c_union_loop(G, N, X, Fd, CUs, GotDefaultCase, Case); + _ -> + error + end. + +emit_c_union_valueless_discriminator(_G, _N, _X, Fd, Case) -> + emit(Fd, " default:\n"), + case Case of + sizecalc -> + emit(Fd, " {\n"), + emit(Fd, " char oe_undefined[15];\n\n"), + emit(Fd, " if ((oe_error_code = ei_decode_atom(oe_env->_inbuf, " + "oe_size_count_index, oe_undefined)) < 0) {\n"), + emit_c_dec_rpt(Fd, " ", "ei_decode_atom", []), + emit(Fd, " return oe_error_code;\n }\n"), + emit(Fd, " }\n"); + encode -> + emit(Fd, " if ((oe_error_code = oe_ei_encode_atom(oe_env, \"undefined\")) < 0) {\n"), + emit_c_enc_rpt(Fd, " ", "oe_ei_encode_atom", []), + emit(Fd, " return oe_error_code;\n }\n"), + emit(Fd, " break;\n"); + decode -> + emit(Fd, " {\n"), + emit(Fd, " char oe_undefined[15];\n\n"), + emit(Fd, " if ((oe_error_code = ei_decode_atom(oe_env->_inbuf, &oe_env->_iin, " + "oe_undefined)) < 0) {\n"), + emit_c_dec_rpt(Fd, " ", "ei_decode_atom", []), + emit(Fd, " return oe_error_code;\n }\n"), + emit(Fd, " if (strcmp(oe_undefined, \"undefined\") != 0) {\n"), + emit_c_dec_rpt(Fd, " ", "undefined", []), + emit(Fd, " return -1;\n }\n"), + emit(Fd, " }\n") + end. + + +emit_c_union_case(G, N, X, Fd, I, T, [{default,_}], Case) -> + emit(Fd, " default:\n"), + case Case of + sizecalc -> + getCaseTypeSizecalc(G, N, X, Fd, I, T); + encode -> + getCaseTypeEncode(G, N, X, Fd, I, T); + decode -> + getCaseTypeDecode(G, N, X, Fd, I, T) + end, + true; +emit_c_union_case(G, N, X, Fd, I, T, [{Bool,_}], Case) -> %% Boolean discriminator + case Bool of + 'TRUE' -> + emit(Fd, " case 1:\n"); + 'FALSE' -> + emit(Fd, " case 0:\n") + end, + case Case of + sizecalc -> + getCaseTypeSizecalc(G, N, X, Fd, I, T); + encode -> + getCaseTypeEncode(G, N, X, Fd, I, T); + decode -> + getCaseTypeDecode(G, N, X, Fd, I, T) + end, + emit(Fd, " break;\n\n"), + false; +emit_c_union_case(G, N, X, Fd, I, T, [{Bool,_}|Rest], Case) -> %% Boolean discriminator + case Bool of + 'TRUE' -> + emit(Fd, " case 1:\n"); + 'FALSE' -> + emit(Fd, " case 0:\n") + end, + emit_c_union_case(G, N, X, Fd, I, T, Rest, Case), + false; +emit_c_union_case(G, N, X, Fd, I, T, [{_,_,NrStr}], Case) -> %% Integer type discriminator + case get_c_union_discriminator(G, N, X) of + "CORBA_char" -> + emit(Fd, " case \'~s\':\n",[NrStr]); + _ -> + emit(Fd, " case ~s:\n",[NrStr]) + end, + case Case of + sizecalc -> + getCaseTypeSizecalc(G, N, X, Fd, I, T); + encode -> + getCaseTypeEncode(G, N, X, Fd, I, T); + decode -> + getCaseTypeDecode(G, N, X, Fd, I, T) + end, + emit(Fd, " break;\n\n"), + false; +emit_c_union_case(G, N, X, Fd, I, T, [{_,_,NrStr}|Rest], Case) -> %% Integer type discriminator + emit(Fd, " case ~s:\n",[NrStr]), + emit_c_union_case(G, N, X, Fd, I, T, Rest, Case), + false; +emit_c_union_case(G, N, X, Fd, I, T, [{scoped_id,_,_,[EID]}], Case) -> %% Enumerant type discriminator + SID = ic_util:to_undersc([EID|get_c_union_discriminator_scope(G, N, X)]), + %%io:format("SID = ~p~n",[SID]), + emit(Fd, " case ~s:\n",[SID]), + case Case of + sizecalc -> + getCaseTypeSizecalc(G, N, X, Fd, I, T); + encode -> + getCaseTypeEncode(G, N, X, Fd, I, T); + decode -> + getCaseTypeDecode(G, N, X, Fd, I, T) + end, + emit(Fd, " break;\n\n"), + false; +emit_c_union_case(G, N, X, Fd, I, T, [{scoped_id,_,_,[EID]}|Rest], Case) -> %% Enumerant type discriminator + SID = ic_util:to_undersc([EID|get_c_union_discriminator_scope(G, N, X)]), + %%io:format("SID = ~p~n",[SID]), + emit(Fd, " case ~s:\n",[SID]), + emit_c_union_case(G, N, X, Fd, I, T, Rest, Case), + false. + + +%% +%% Returns the enumerant discriminator scope +%% +get_c_union_discriminator_scope(G, N, X) -> + {FullScopedName, _, _TK, _} = ic_symtab:get_full_scoped_name(G, N, X#union.type), + BT = case ic_code:get_basetype(G, ic_util:to_undersc(FullScopedName)) of + {enum,ST} -> + ST; + Other -> + Other + end, + tl(lists:reverse(string:tokens(BT,"_"))). %% Ugly work arround + + + + + +getCaseTypeSizecalc(G, N, X, Fd, I, T) when element(1, T) == scoped_id -> + case ic_fetch:member2type(G,X,I) of + ushort -> + emit(Fd, " if ((oe_error_code = ei_decode_ulong(oe_env->_inbuf, oe_size_count_index, 0)) < 0) {\n"), + ?emit_c_dec_rpt(Fd, " ", "ushort:ei_decode_ulong", []), + emit(Fd, " return oe_error_code;\n }\n"); + ulong -> + emit(Fd, " if ((oe_error_code = ei_decode_ulong(oe_env->_inbuf, oe_size_count_index, 0)) < 0) {\n"), + ?emit_c_dec_rpt(Fd, " ", "ulong:ei_decode_ulong", []), + emit(Fd, " return oe_error_code;\n }\n"); + short -> + emit(Fd, " if ((oe_error_code = ei_decode_long(oe_env->_inbuf, oe_size_count_index, 0)) < 0) {\n"), + ?emit_c_dec_rpt(Fd, " ", "short:ei_decode_long", []), + emit(Fd, " return oe_error_code;\n }\n"); + long -> + emit(Fd, " if ((oe_error_code = ei_decode_long(oe_env->_inbuf, oe_size_count_index, 0)) < 0) {\n"), + ?emit_c_dec_rpt(Fd, " ", "long:ei_decode_long", []), + emit(Fd, " return oe_error_code;\n }\n"); + float -> + emit(Fd, " if ((oe_error_code = ei_decode_double(oe_env->_inbuf, oe_size_count_index, 0)) < 0) {\n"), + ?emit_c_dec_rpt(Fd, " ", "float:ei_decode_double", []), + emit(Fd, " return oe_error_code;\n }\n"); + double -> + emit(Fd, " if ((oe_error_code = ei_decode_double(oe_env->_inbuf, oe_size_count_index, 0)) < 0) {\n"), + ?emit_c_dec_rpt(Fd, " ", "double:ei_decode_double", []), + emit(Fd, " return oe_error_code;\n }\n"); + boolean -> + emit(Fd, " if ((oe_error_code = ei_decode_atom(oe_env->_inbuf, oe_size_count_index, 0)) < 0) {\n"), + ?emit_c_dec_rpt(Fd, " ", "boolean:ei_decode_atom", []), + emit(Fd, " return oe_error_code;\n }\n"); + char -> + emit(Fd, " if ((oe_error_code = ei_decode_char(oe_env->_inbuf, oe_size_count_index, 0)) < 0) {\n"), + ?emit_c_dec_rpt(Fd, " ", "char:ei_decode_char", []), + emit(Fd, " return oe_error_code;\n }\n"); + octet -> + emit(Fd, " if ((oe_error_code = ei_decode_char(oe_env->_inbuf, oe_size_count_index, 0)) < 0) {\n"), + ?emit_c_dec_rpt(Fd, " ", "octet:ei_decode_char", []), + emit(Fd, " return oe_error_code;\n }\n"); + string -> + emit(Fd, " if ((oe_error_code = ei_get_type(oe_env->_inbuf, oe_size_count_index, &oe_type, &oe_tmp)) < 0) {\n"), + ?emit_c_dec_rpt(Fd, " ", "ei_get_type", []), + emit(Fd, " return oe_error_code;\n }\n"), + emit(Fd, " if ((oe_error_code = ei_decode_string(oe_env->_inbuf, oe_size_count_index, 0)) < 0) {\n"), + ?emit_c_dec_rpt(Fd, " ", "ei_decode_string", []), + emit(Fd, " return oe_error_code;\n }\n"), + emit(Fd, " oe_malloc_size = ~s;\n",[ic_util:mk_align("oe_malloc_size+oe_tmp+1")]); + any -> %% Fix for any type + emit(Fd, " if ((oe_error_code = ei_decode_long(oe_env->_inbuf, oe_size_count_index, 0)) < 0) {\n"), + ?emit_c_dec_rpt(Fd, " ", "ei_decode_long", []), + emit(Fd, " return oe_error_code;\n }\n"); + + _ -> + case getCaseTypeStr(G, N, X, I, T) of + "erlang_pid" -> + emit(Fd, " if ((oe_error_code = ei_decode_pid(oe_env->_inbuf, oe_size_count_index, 0)) < 0) {\n", + []), + ?emit_c_dec_rpt(Fd, " ", "ei_decode_pid", []), + emit(Fd, " return oe_error_code;\n }\n"); + "erlang_port" -> + emit(Fd, " if ((oe_error_code = ei_decode_port(oe_env->_inbuf, oe_size_count_index, 0)) < 0) {\n", + []), + ?emit_c_dec_rpt(Fd, " ", "ei_decode_port", []), + emit(Fd, " return oe_error_code;\n }\n"); + "erlang_ref" -> + emit(Fd, " if ((oe_error_code = ei_decode_ref(oe_env->_inbuf, oe_size_count_index, 0)) < 0) {\n", + []), + ?emit_c_dec_rpt(Fd, " ", "ei_decode_ref", []), + emit(Fd, " return oe_error_code;\n }\n"); + "erlang_term" -> + emit(Fd, " if ((oe_error_code = ei_decode_term(oe_env->_inbuf, oe_size_count_index, 0)) < 0) {\n", + []), + ?emit_c_dec_rpt(Fd, " ", "ei_deoce_term", []), + emit(Fd, " return oe_error_code;\n }\n"); + + Other -> + + emit(Fd, " if ((oe_error_code = oe_sizecalc_~s(oe_env, oe_size_count_index, &oe_malloc_size)) < 0) {\n", + [Other]), + ?emit_c_dec_rpt(Fd, " ", "oe_sizecalc_~s", [Other]), + emit(Fd, " return oe_error_code;\n }\n") + end + end; +getCaseTypeSizecalc(G, N, X, Fd, I, T) -> + case I of + {array,_,_} -> + ArrayName = ic_util:to_undersc([ic_forms:get_id2(I),ic_forms:get_id2(X) | N]), + emit(Fd, " if ((oe_error_code = oe_sizecalc_~s(oe_env, oe_size_count_index, &oe_malloc_size)) < 0) {\n", + [ArrayName]), + ?emit_c_dec_rpt(Fd, " ", "oe_sizecalc_~s", [ArrayName]), + emit(Fd, " return oe_error_code;\n }\n"); + _ -> + case T of + {short,_} -> + emit(Fd, " if ((oe_error_code = ei_decode_long(oe_env->_inbuf, oe_size_count_index, 0)) < 0) {\n"), + ?emit_c_dec_rpt(Fd, " ", "short:ei_decode_long", []), + emit(Fd, " return oe_error_code;\n }\n"); + {unsigned,{short,_}} -> + emit(Fd, " if ((oe_error_code = ei_decode_ulong(oe_env->_inbuf, oe_size_count_index, 0)) < 0) {\n"), + ?emit_c_dec_rpt(Fd, " ", "ushort:ei_decode_ulong", []), + emit(Fd, " return oe_error_code;\n }\n"); + {long, _} -> + emit(Fd, " if ((oe_error_code = ei_decode_long(oe_env->_inbuf, oe_size_count_index, 0)) < 0) {\n"), + ?emit_c_dec_rpt(Fd, " ", "long:ei_decode_long", []), + emit(Fd, " return oe_error_code;\n }\n"); + {unsigned,{long,_}} -> + emit(Fd, " if ((oe_error_code = ei_decode_ulong(oe_env->_inbuf, oe_size_count_index, 0)) < 0) {\n"), + ?emit_c_dec_rpt(Fd, " ", "ulong:ei_decode_ulong", []), + emit(Fd, " return oe_error_code;\n }\n"); + {float,_} -> + emit(Fd, " if ((oe_error_code = ei_decode_double(oe_env->_inbuf, oe_size_count_index, 0)) < 0) {\n"), + ?emit_c_dec_rpt(Fd, " ", "float:ei_decode_double", []), + emit(Fd, " return oe_error_code;\n }"); + {double,_} -> + emit(Fd, " if ((oe_error_code = ei_decode_double(oe_env->_inbuf, oe_size_count_index, 0)) < 0) {\n"), + ?emit_c_dec_rpt(Fd, " ", "double:ei_decode_double", []), + emit(Fd, " return oe_error_code;\n }\n"); + {boolean,_} -> + emit(Fd, " if ((oe_error_code = ei_decode_atom(oe_env->_inbuf, oe_size_count_index, 0)) < 0) {\n"), + ?emit_c_dec_rpt(Fd, " ", "boolean:ei_decode_atom", []), + emit(Fd, " return oe_error_code;\n }\n"); + {char,_} -> + emit(Fd, " if ((oe_error_code = ei_decode_char(oe_env->_inbuf, oe_size_count_index, 0)) < 0) {\n"), + ?emit_c_dec_rpt(Fd, " ", "char:ei_decode_char", []), + emit(Fd, " return oe_error_code;\n }\n"); + {octet,_} -> + emit(Fd, " if ((oe_error_code = ei_decode_char(oe_env->_inbuf, oe_size_count_index, 0)) < 0) {\n"), + ?emit_c_dec_rpt(Fd, " ", "octet:ei_decode_char", []), + emit(Fd, " return oe_error_code;\n }\n"); + {string,_} -> + emit(Fd, " if ((oe_error_code = ei_get_type(oe_env->_inbuf, oe_size_count_index, &oe_type, &oe_tmp)) < 0) {\n"), + ?emit_c_dec_rpt(Fd, " ", "ei_get_type", []), + emit(Fd, " return oe_error_code;\n }\n"), + emit(Fd, " if ((oe_error_code = ei_decode_string(oe_env->_inbuf, oe_size_count_index, 0)) < 0) {\n"), + ?emit_c_dec_rpt(Fd, " ", "ei_decode_string", []), + emit(Fd, " return oe_error_code;\n }\n"), + emit(Fd, " oe_malloc_size = ~s;\n",[ic_util:mk_align("oe_malloc_size+oe_tmp+1")]); + {sequence,_,_} -> + SeqName = ic_util:to_undersc([ic_forms:get_id2(I), ic_forms:get_id2(X) | N]), + emit(Fd, " if ((oe_error_code = oe_sizecalc_~s(oe_env, oe_size_count_index, &oe_malloc_size)) < 0) {\n", + [SeqName]), + ?emit_c_dec_rpt(Fd, " ", "sequence:oe_sizecalc_~s", [SeqName]), + emit(Fd, " return oe_error_code;\n }\n"); + {struct,SID,_,_} -> + StructName = ic_util:to_undersc([ic_forms:get_id2(SID), ic_forms:get_id2(X) | N]), + emit(Fd, " if ((oe_error_code = oe_sizecalc_~s(oe_env, oe_size_count_index, &oe_malloc_size)) < 0) {\n", + [StructName]), + ?emit_c_dec_rpt(Fd, " ", "struct:oe_sizecalc_~s", [StructName]), + emit(Fd, " return oe_error_code;\n }\n"); + {union,UID,_,_,_} -> + UnionName = ic_util:to_undersc([ic_forms:get_id2(UID), ic_forms:get_id2(X) | N]), + emit(Fd, " if ((oe_error_code = oe_sizecalc_~s(oe_env, oe_size_count_index, &oe_malloc_size)) < 0) {\n", + [UnionName]), + ?emit_c_dec_rpt(Fd, " ", "union:oe_sizecalce_~s", [UnionName]), + emit(Fd, " return oe_error_code;\n }\n"); + {any, _} -> %% Fix for any type + emit(Fd, " if ((oe_error_code = ei_decode_long(oe_env->_inbuf, oe_size_count_index, 0)) < 0) {\n"), + ?emit_c_dec_rpt(Fd, " ", "any:ei_decode_long", []), + emit(Fd, " return oe_error_code;\n }\n"); + _ -> + ic_error:fatal_error(G, {illegal_typecode_for_c, T, N}) + end + end. + + + + + +%% +%% Encode facilities +%% +emit_union_encode(G, N, X, Fd, UnionName) -> + emit(Fd, "int ~s~s(CORBA_Environment *oe_env, ~s* oe_rec) {\n\n", + [ic_util:mk_oe_name(G, "encode_"), UnionName, UnionName]), + + emit(Fd, " int oe_error_code = 0;\n\n"), + + emit(Fd, " if ((oe_error_code = oe_ei_encode_tuple_header(oe_env, 3)) < 0) {\n"), + emit_c_enc_rpt(Fd, " ", "oe_ei_encode_tuple_header", []), + emit(Fd, " return oe_error_code;\n }\n"), + + emit(Fd, " if ((oe_error_code = oe_ei_encode_atom(oe_env, \"~s\")) < 0) {\n", + [UnionName]), + emit_c_enc_rpt(Fd, " ", "oe_ei_encode_atom", []), + emit(Fd, " return oe_error_code;\n }\n"), + + emit_c_union_discr_encode(G, N, X, Fd), + emit(Fd, " /* Encode union */\n"), + emit(Fd, " switch(oe_rec->_d) {\n"), + emit_c_union_loop(G, N, X, Fd, X#union.body, encode), + emit(Fd, " }\n\n"), + emit(Fd, " return 0;\n"), + emit(Fd, "}\n\n\n"). + + +emit_c_union_discr_encode(G, N, X, Fd) -> + emit(Fd, " /* Encode descriminator */\n"), + UD = get_c_union_discriminator(G, N, X), + case UD of + "CORBA_short" -> + emit(Fd, " if ((oe_error_code = oe_ei_encode_long(oe_env, oe_rec->_d)) < 0) {\n"), + emit_c_enc_rpt(Fd, " ", "oe_ei_encode_long", []), + emit(Fd, " return oe_error_code;\n }\n"); + "CORBA_unsigned_short" -> + emit(Fd, " if ((oe_error_code = oe_ei_encode_ulong(oe_env, oe_rec->_d)) < 0) {\n"), + emit_c_enc_rpt(Fd, " ", "oe_ei_encode_ulong", []), + emit(Fd, " return oe_error_code;\n }\n"); + "CORBA_long" -> + emit(Fd, " if ((oe_error_code = oe_ei_encode_long(oe_env, oe_rec->_d)) < 0) {\n"), + emit_c_enc_rpt(Fd, " ", "oe_ei_encode_long", []), + emit(Fd, " return oe_error_code;\n }\n"); + "CORBA_unsigned_long" -> + emit(Fd, " if ((oe_error_code = oe_ei_encode_ulong(oe_env, oe_rec->_d)) < 0) {\n"), + emit_c_enc_rpt(Fd, " ", "oe_ei_encode_ulong", []), + emit(Fd, " return oe_error_code;\n }\n"); + "CORBA_boolean" -> + emit(Fd, " switch(oe_rec->_d) {\n"), + 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, " ", "oe_ei_encode_atom", []), + 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, " ", "oe_ei_encode_atom", []), + emit(Fd, " return oe_error_code;\n }\n"), + emit(Fd, " break;\n"), + emit(Fd, " default:\n"), + emit_c_enc_rpt(Fd, " ", "boolean failure", []), + emit(Fd, " return -1;\n"), + emit(Fd, " }\n\n"); + "CORBA_char" -> + emit(Fd, " if ((oe_error_code = oe_ei_encode_char(oe_env, oe_rec->_d)) < 0) {\n"), + emit_c_enc_rpt(Fd, " ", "oe_ei_encode_char", []), + emit(Fd, " return oe_error_code;\n }\n"); + T -> + emit(Fd, " if ((oe_error_code = oe_encode_~s(oe_env, oe_rec->_d)) < 0) {\n", [T]), + ?emit_c_enc_rpt(Fd, " ", "oe_encode_~s", [T]), + emit(Fd, " return oe_error_code;\n }\n") + end. + + +getCaseTypeEncode(G, N, X, Fd, I, T) when element(1, T) == scoped_id -> + case ic_fetch:member2type(G,X,I) of + ushort -> + emit(Fd, " if ((oe_error_code = oe_ei_encode_ulong(oe_env, oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_enc_rpt(Fd, " ", "ushort:oe_ei_encode_ulong", []), + emit(Fd, " return oe_error_code;\n }\n"); + ulong -> + emit(Fd, " if ((oe_error_code = oe_ei_encode_ulong(oe_env, oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_enc_rpt(Fd, " ", "ulong:oe_ei_encode_ulong", []), + emit(Fd, " return oe_error_code;\n }\n"); + short -> + emit(Fd, " if ((oe_error_code = oe_ei_encode_long(oe_env, oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_enc_rpt(Fd, " ", "short:oe_ei_encode_long", []), + emit(Fd, " return oe_error_code;\n }\n"); + long -> + emit(Fd, " if ((oe_error_code = oe_ei_encode_long(oe_env, oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_enc_rpt(Fd, " ", "long:oe_ei_encode_long", []), + emit(Fd, " return oe_error_code;\n }\n"); + float -> + emit(Fd, " if ((oe_error_code = oe_ei_encode_double(oe_env, oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_enc_rpt(Fd, " ", "float:oe_ei_encode_double", []), + emit(Fd, " return oe_error_code;\n }\n"); + double -> + emit(Fd, " if ((oe_error_code = oe_ei_encode_double(oe_env, oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_enc_rpt(Fd, " ", "double:oe_ei_encode_double", []), + emit(Fd, " return oe_error_code;\n }\n"); + boolean -> + emit(Fd, " switch(oe_rec->_u.~s) {\n",[ic_forms:get_id2(I)]), + 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:oe_ei_encode_atom", []), + 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:oe_ei_encode_atom", []), + emit(Fd, " return oe_error_code;\n }\n"), + emit(Fd, " break;\n"), + emit(Fd, " default:\n"), + ?emit_c_enc_rpt(Fd, " ", "boolean failure", []), + emit(Fd, " return -1;\n"), + emit(Fd, " }\n"); + char -> + emit(Fd, " if ((oe_error_code = oe_ei_encode_char(oe_env, oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_enc_rpt(Fd, " ", "char:oe_ei_encode_char", []), + emit(Fd, " return oe_error_code;\n }\n"); + octet -> + emit(Fd, " if ((oe_error_code = oe_ei_encode_char(oe_env, oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_enc_rpt(Fd, " ", "octet:oe_ei_encode_char", []), + emit(Fd, " return oe_error_code;\n }\n"); + string -> + emit(Fd, " if ((oe_error_code = oe_ei_encode_string(oe_env, oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_enc_rpt(Fd, " ", "oe_ei_encode_string", []), + emit(Fd, " return oe_error_code;\n }\n"); + struct -> + case ic_cbe:mk_c_type(G, N, T, evaluate_not) of + "erlang_pid" -> + emit(Fd, " if ((oe_error_code = oe_ei_encode_pid(oe_env, &oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?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, &oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?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, &oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?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, &oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_enc_rpt(Fd, " ", "oe_ei_encode_term", []), + emit(Fd, " return oe_error_code;\n }\n"); + _ -> + emit(Fd, " if ((oe_error_code = oe_encode_~s(oe_env, &oe_rec->_u.~s)) < 0) {\n", + [getCaseTypeStr(G, N, X, I, T), ic_forms:get_id2(I)]), + ?emit_c_enc_rpt(Fd, " ", "oe_encode_~s", + [getCaseTypeStr(G, N, X, I, T)]), + emit(Fd, " return oe_error_code;\n }\n") + end; + sequence -> + emit(Fd, " if ((oe_error_code = oe_encode_~s(oe_env, &oe_rec->_u.~s)) < 0) {\n", + [getCaseTypeStr(G, N, X, I, T),ic_forms:get_id2(I)]), + ?emit_c_enc_rpt(Fd, " ", "sequence:oe_encode_~s", + [getCaseTypeStr(G, N, X, I, T)]), + emit(Fd, " return oe_error_code;\n }\n"); + array -> + emit(Fd, " if ((oe_error_code = oe_encode_~s(oe_env, oe_rec->_u.~s)) < 0) {\n", + [getCaseTypeStr(G, N, X, I, T),ic_forms:get_id2(I)]), + ?emit_c_enc_rpt(Fd, " ", "array:oe_encode_~s", + [getCaseTypeStr(G, N, X, I, T)]), + emit(Fd, " return oe_error_code;\n }\n"); + union -> + emit(Fd, " if ((oe_error_code = oe_encode_~s(oe_env, &oe_rec->_u.~s)) < 0) {\n", + [getCaseTypeStr(G, N, X, I, T),ic_forms:get_id2(I)]), + ?emit_c_enc_rpt(Fd, " ", "union:oe_encode_~s", + [getCaseTypeStr(G, N, X, I, T)]), + emit(Fd, " return oe_error_code;\n }\n"); + enum -> + emit(Fd, " if ((oe_error_code = oe_encode_~s(oe_env, oe_rec->_u.~s)) < 0) {\n", + [getCaseTypeStr(G, N, X, I, T),ic_forms:get_id2(I)]), + ?emit_c_enc_rpt(Fd, " ", "enum:oe_encode_~s", + [getCaseTypeStr(G, N, X, I, T)]), + emit(Fd, " return oe_error_code;\n }\n"); + any -> %% Fix for any type + emit(Fd, " if ((oe_error_code = oe_ei_encode_long(oe_env, oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_enc_rpt(Fd, " ", "enum:oe_ei_encodelong", []), + emit(Fd, " return oe_error_code;\n }\n"); + _ -> + ic_error:fatal_error(G, {illegal_typecode_for_c, T, N}) + end; +getCaseTypeEncode(G, N, X, Fd, I, T) -> + case I of + {array,AID,_} -> + ArrayName = ic_util:to_undersc([ic_forms:get_id2(AID),ic_forms:get_id2(X) | N]), + emit(Fd, " if ((oe_error_code = oe_encode_~s(oe_env, oe_rec->_u.~s)) < 0) {\n", + [ArrayName,ic_forms:get_id2(AID)]), + ?emit_c_enc_rpt(Fd, " ", "array:oe_encode_~s", [ArrayName]), + emit(Fd, " return oe_error_code;\n }\n"); + _ -> + case T of + {short,_} -> + emit(Fd, " if ((oe_error_code = oe_ei_encode_long(oe_env, oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_enc_rpt(Fd, " ", "short:oe_ei_encode_long", []), + emit(Fd, " return oe_error_code;\n }\n"); + {unsigned,{short,_}} -> + emit(Fd, " if ((oe_error_code = oe_ei_encode_ulong(oe_env, oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_enc_rpt(Fd, " ", "ushort:oe_ei_encode_ulong", []), + emit(Fd, " return oe_error_code;\n }\n"); + {long, _} -> + emit(Fd, " if ((oe_error_code = oe_ei_encode_long(oe_env, oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_enc_rpt(Fd, " ", "long:oe_ei_encode_long", []), + emit(Fd, " return oe_error_code;\n }\n"); + {unsigned,{long,_}} -> + emit(Fd, " if ((oe_error_code = oe_ei_encode_ulong(oe_env, oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_enc_rpt(Fd, " ", "ulong:oe_ei_encode_ulong", []), + emit(Fd, " return oe_error_code;\n }\n"); + {float,_} -> + emit(Fd, " if ((oe_error_code = oe_ei_encode_double(oe_env, oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_enc_rpt(Fd, " ", "float:oe_ei_encode_double", []), + emit(Fd, " return oe_error_code;\n }\n"); + {double,_} -> + emit(Fd, " if ((oe_error_code = oe_ei_encode_double(oe_env, oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_enc_rpt(Fd, " ", "double:oe_ei_encode_double", []), + emit(Fd, " return oe_error_code;\n }\n"); + {boolean,_} -> + emit(Fd, " switch(oe_rec->_u.~s) {\n",[ic_forms:get_id2(I)]), + 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:oe_ei_encode_atom", []), + 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:oe_ei_encode_atom", []), + emit(Fd, " return oe_error_code;\n }\n"), + emit(Fd, " break;\n"), + emit(Fd, " default:\n"), + ?emit_c_enc_rpt(Fd, " ", "boolean failure", []), + emit(Fd, " return -1;\n"), + emit(Fd, " }\n"); + {char,_} -> + emit(Fd, " if ((oe_error_code = oe_ei_encode_char(oe_env, oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_enc_rpt(Fd, " ", "char:oe_ei_encode_char", []), + emit(Fd, " return oe_error_code;\n }\n"); + {octet,_} -> + emit(Fd, " if ((oe_error_code = oe_ei_encode_char(oe_env, oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_enc_rpt(Fd, " ", "octet:oe_ei_encode_char", []), + emit(Fd, " return oe_error_code;\n }\n"); + {string,_} -> + emit(Fd, " if ((oe_error_code = oe_ei_encode_string(oe_env, oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_enc_rpt(Fd, " ", "oe_ei_encode_string", []), + emit(Fd, " return oe_error_code;\n }\n"); + {sequence,_,_} -> + SeqName = ic_util:to_undersc([ic_forms:get_id2(I), ic_forms:get_id2(X) | N]), + emit(Fd, " if ((oe_error_code = oe_encode_~s(oe_env, &oe_rec->_u.~s)) < 0) {\n", + [SeqName,ic_forms:get_id2(I)]), + ?emit_c_enc_rpt(Fd, " ", "sequence:oe_encode_~s", [SeqName]), + emit(Fd, " return oe_error_code;\n }\n"); + {struct,SID,_,_} -> + StructName = ic_util:to_undersc([ic_forms:get_id2(SID), ic_forms:get_id2(X) | N]), + emit(Fd, " if ((oe_error_code = oe_encode_~s(oe_env, &oe_rec->_u.~s)) < 0) {\n", + [StructName,ic_forms:get_id2(I)]), + ?emit_c_enc_rpt(Fd, " ", "struct:oe_encode_~s", [StructName]), + emit(Fd, " return oe_error_code;\n }\n"); + {union,UID,_,_,_} -> + UnionName = ic_util:to_undersc([ic_forms:get_id2(UID), ic_forms:get_id2(X) | N]), + emit(Fd, " if ((oe_error_code = oe_encode_~s(oe_env, &oe_rec->_u.~s)) < 0) {\n", + [UnionName,ic_forms:get_id2(I)]), + ?emit_c_enc_rpt(Fd, " ", "union:oe_encode_~s", [UnionName]), + emit(Fd, " return oe_error_code;\n }\n"); + _ -> + ic_error:fatal_error(G, {illegal_typecode_for_c, T, N}) + end + end. + + + + +%% +%% Decode facilities +%% +emit_union_decode(G, N, X, Fd, UnionName) -> + emit(Fd, "int ~s~s(CORBA_Environment *oe_env, char *oe_first, int* oe_index, ~s* oe_rec) {\n\n", + [ic_util:mk_oe_name(G, "decode_"), UnionName, UnionName]), + + emit(Fd, " int oe_error_code = 0;\n"), + emit(Fd, " int oe_tmp = 0;\n"), + emit(Fd, " char oe_union_name[256];\n\n"), + + emit(Fd, " if((char*) oe_rec == oe_first)\n",[]), + AlignName = lists:concat(["*oe_index + sizeof(",UnionName,")"]), + emit(Fd, " *oe_index = ~s;\n\n", [ic_util:mk_align(AlignName)]), + + emit(Fd, " if ((oe_error_code = ei_decode_tuple_header(oe_env->_inbuf, &oe_env->_iin, &oe_tmp)) < 0) {\n"), + emit_c_dec_rpt(Fd, " ", "ei_decode_tuple_header", []), + emit(Fd, " return oe_error_code;\n }\n"), + + emit(Fd, " if ((oe_error_code = ei_decode_atom(oe_env->_inbuf, &oe_env->_iin, oe_union_name)) < 0) {\n"), + emit_c_dec_rpt(Fd, " ", "ei_decode_atom", []), + emit(Fd, " return oe_error_code;\n }\n"), + + emit_c_union_discr_decode(G, N, X, Fd), + emit(Fd, " /* Decode union */\n"), + emit(Fd, " switch(oe_rec->_d) {\n"), + emit_c_union_loop(G, N, X, Fd, X#union.body, decode), + emit(Fd, " }\n\n"), + + emit(Fd, " *oe_index = ~s;\n", [ic_util:mk_align("*oe_index")]), + emit(Fd, " return 0;\n"), + emit(Fd, "}\n\n\n"). + + +emit_c_union_discr_decode(G, N, X, Fd) -> + emit(Fd, " /* Decode descriminator */\n"), + UD = get_c_union_discriminator(G, N, X), + case UD of + "CORBA_short" -> + emit(Fd, " {\n"), + emit(Fd, " long oe_long;\n"), + emit(Fd, " if ((oe_error_code = ei_decode_long(oe_env->_inbuf, &oe_env->_iin, &oe_long)) < 0) {\n"), + emit_c_dec_rpt(Fd, " ", "short:ei_decode_long", []), + emit(Fd, " return oe_error_code;\n }\n"), + emit(Fd, " oe_rec->_d = (short) oe_long;\n\n"), + emit(Fd, " if (oe_rec->_d != oe_long)\n return -1;\n"), + emit(Fd, " }\n\n"); + "CORBA_unsigned_short" -> + emit(Fd, " {\n"), + emit(Fd, " unsigned long oe_ulong;\n"), + emit(Fd, " if ((oe_error_code = ei_decode_ulong(oe_env->_inbuf, &oe_env->_iin, &oe_ulong)) < 0) {\n"), + emit_c_dec_rpt(Fd, " ", "unshort:ei_decode_ulong", []), + emit(Fd, " return oe_error_code;\n }\n"), + emit(Fd, " oe_rec->_d = (unsigned short) oe_ulong;\n\n"), + emit(Fd, " if (oe_rec->_d != oe_ulong)\n return -1;\n"), + emit(Fd, " }\n\n"); + "CORBA_long" -> + emit(Fd, " if ((oe_error_code = ei_decode_long(oe_env->_inbuf, &oe_env->_iin, &oe_rec->_d)) < 0) {\n"), + emit_c_dec_rpt(Fd, " ", "long:ei_decode_long", []), + emit(Fd, " return oe_error_code;\n }\n"); + "CORBA_unsigned_long" -> + emit(Fd, " if ((oe_error_code = ei_decode_ulong(oe_env->_inbuf, &oe_env->_iin, &oe_rec->_d)) < 0) {\n"), + emit_c_dec_rpt(Fd, " ", "ulong:ei_decode_ulong", []), + emit(Fd, " return oe_error_code;\n }\n"); + "CORBA_boolean" -> + emit(Fd, " {\n"), + emit(Fd, " char oe_bool[25];\n\n"), + emit(Fd, " if ((oe_error_code = ei_decode_atom(oe_env->_inbuf, &oe_env->_iin, oe_bool)) < 0) {\n"), + emit_c_dec_rpt(Fd, " ", "boolean:ei_decode_atom", []), + emit(Fd, " return oe_error_code;\n }\n"), + emit(Fd, " if (strcmp(oe_bool, \"false\") == 0) {\n"), + emit(Fd, " oe_rec->_d = 0;\n"), + emit(Fd, " }else if (strcmp(oe_bool, \"true\") == 0) {\n"), + emit(Fd, " oe_rec->_d = 1;\n"), + emit(Fd, " } else {\n"), + emit_c_dec_rpt(Fd, " ", "boolean failure", []), + emit(Fd, " return -1;\n }\n"), + emit(Fd, " }\n\n"); + "CORBA_char" -> + emit(Fd, " if ((oe_error_code = ei_decode_char(oe_env->_inbuf, &oe_env->_iin, &oe_rec->_d)) < 0) {\n"), + emit_c_dec_rpt(Fd, " ", "char:ei_decode_char", []), + emit(Fd, " return oe_error_code;\n }\n"); + T -> + emit(Fd, " if ((oe_error_code = oe_decode_~s(oe_env, oe_first, oe_index, &oe_rec->_d)) < 0) {\n", + [T]), + ?emit_c_dec_rpt(Fd, " ", "oe_decode_~s", [T]), + emit(Fd, " return oe_error_code;\n }\n") + end. + + + +getCaseTypeDecode(G, N, X, Fd, I, T) when element(1, T) == scoped_id -> + case ic_fetch:member2type(G,X,I) of + ushort -> + emit(Fd, " {\n"), + emit(Fd, " unsigned long oe_ulong;\n"), + emit(Fd, " if ((oe_error_code = ei_decode_ulong(oe_env->_inbuf, &oe_env->_iin, &oe_ulong)) < 0) {\n"), + ?emit_c_dec_rpt(Fd, " ", "ushort:ei_decode_ulong", []), + emit(Fd, " return oe_error_code;\n }\n"), + emit(Fd, " oe_rec->_u.~s = (unsigned short) oe_ulong;\n\n",[ic_forms:get_id2(I)]), + emit(Fd, " if (oe_rec->_u.~s != oe_ulong)\n return -1;\n",[ic_forms:get_id2(I)]), + emit(Fd, " }\n"); + ulong -> + emit(Fd, " if ((oe_error_code = ei_decode_ulong(oe_env->_inbuf, &oe_env->_iin, &oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_dec_rpt(Fd, " ", "ulong:ei_decode_ulong", []), + emit(Fd, " return oe_error_code;\n }\n"); + short -> + emit(Fd, " {\n"), + emit(Fd, " long oe_long;\n"), + emit(Fd, " if ((oe_error_code = ei_decode_long(oe_env->_inbuf, &oe_env->_iin, &oe_long)) < 0) {\n"), + ?emit_c_dec_rpt(Fd, " ", "short:ei_decode_long", []), + emit(Fd, " return oe_error_code;\n }\n"), + emit(Fd, " oe_rec->_u.~s = (short) oe_long;\n\n",[ic_forms:get_id2(I)]), + emit(Fd, " if (oe_rec->_u.~s != oe_long)\n return -1;\n",[ic_forms:get_id2(I)]), + emit(Fd, " }\n"); + long -> + emit(Fd, " if ((oe_error_code = ei_decode_long(oe_env->_inbuf, &oe_env->_iin, &oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_dec_rpt(Fd, " ", "long:ei_decode_long", []), + emit(Fd, " return oe_error_code;\n }\n"); + float -> + emit(Fd, " {\n"), + emit(Fd, " double oe_double;\n"), + emit(Fd, " if ((oe_error_code = ei_decode_double(oe_env->_inbuf, &oe_env->_iin, &oe_double)) < 0) {\n"), + ?emit_c_dec_rpt(Fd, " ", "float:ei_decode_double", []), + emit(Fd, " return oe_error_code;\n }\n"), + emit(Fd, " oe_rec->_u.~s = (float) oe_double;\n",[ic_forms:get_id2(I)]), + emit(Fd, " }\n"); + double -> + emit(Fd, " if ((oe_error_code = ei_decode_double(oe_env->_inbuf, &oe_env->_iin, &oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_dec_rpt(Fd, " ", "double:ei_decode_double", []), + emit(Fd, " return oe_error_code;\n }\n"); + boolean -> + emit(Fd, " {\n"), + emit(Fd, " char oe_bool[25];\n\n"), + emit(Fd, " if ((oe_error_code = ei_decode_atom(oe_env->_inbuf, &oe_env->_iin, oe_bool)) < 0) {\n"), + ?emit_c_dec_rpt(Fd, " ", "boolean:ei_decode_atom", []), + emit(Fd, " return oe_error_code;\n }\n"), + emit(Fd, " if (strcmp(oe_bool, \"false\") == 0) {\n"), + emit(Fd, " oe_rec->_u.~s = 0;\n",[ic_forms:get_id2(I)]), + emit(Fd, " } else if (strcmp(oe_bool, \"true\") == 0) {\n"), + emit(Fd, " oe_rec->_u.~s = 1;\n",[ic_forms:get_id2(I)]), + emit(Fd, " } else {\n"), + ?emit_c_dec_rpt(Fd, " ", "boolean failure", []), + emit(Fd, " return -1;\n }\n"), + emit(Fd, " }\n"); + char -> + emit(Fd, " if ((oe_error_code = ei_decode_char(oe_env->_inbuf, &oe_env->_iin, &oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_dec_rpt(Fd, " ", "char:ei_decode_char", []), + emit(Fd, " return oe_error_code;\n }\n"); + octet -> + emit(Fd, " if ((oe_error_code = ei_decode_char(oe_env->_inbuf, &oe_env->_iin, &oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_dec_rpt(Fd, " ", "octet:ei_decode_char", []), + emit(Fd, " return oe_error_code;\n }\n"); + string -> + emit(Fd, " {\n"), + emit(Fd, " int oe_type = 0;\n"), + emit(Fd, " int oe_string_ctr = 0;\n\n"), + + emit(Fd, " (int) ei_get_type(oe_env->_inbuf, &oe_env->_iin, &oe_type, &oe_string_ctr);\n\n"), + + emit(Fd, " oe_rec->_u.~s = (void *) (oe_first + *oe_index);\n\n",[ic_forms:get_id2(I)]), + + emit(Fd, " if ((oe_error_code = ei_decode_string(oe_env->_inbuf, &oe_env->_iin, oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_dec_rpt(Fd, " ", "ei_decode_string", []), + emit(Fd, " return oe_error_code;\n }\n"), + + emit(Fd, " *oe_index = ~s;\n",[ic_util:mk_align("*oe_index+oe_string_ctr+1")]), + emit(Fd, " }\n"); + struct -> + case ic_cbe:mk_c_type(G, N, T, evaluate_not) of + "erlang_pid" -> + emit(Fd, " if ((oe_error_code = ei_decode_pid(oe_env->_inbuf, &oe_env->_iin, &oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_dec_rpt(Fd, " ", "ei_decode_pid", []), + emit(Fd, " return oe_error_code;\n }\n"); + "erlang_port" -> + emit(Fd, " if ((oe_error_code = ei_decode_port(oe_env->_inbuf, &oe_env->_iin, &oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_dec_rpt(Fd, " ", "ei_decode_port", []), + emit(Fd, " return oe_error_code;\n }\n"); + "erlang_ref" -> + emit(Fd, " if ((oe_error_code = ei_decode_ref(oe_env->_inbuf, &oe_env->_iin, &oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_dec_rpt(Fd, " ", "ei_decode_ref", []), + emit(Fd, " return oe_error_code;\n }\n"); + "ETERM*" -> + emit(Fd, " if ((oe_error_code = ei_decode_term(oe_env->_inbuf, &oe_env->_iin, (void **)&oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_dec_rpt(Fd, " ", "ei_decode_term", []), + emit(Fd, " return oe_error_code;\n }\n"); + + _ -> + emit(Fd, " if ((oe_error_code = oe_decode_~s(oe_env, oe_first, oe_index, &oe_rec->_u.~s)) < 0) {\n", + [getCaseTypeStr(G, N, X, I, T),ic_forms:get_id2(I)]), + ?emit_c_dec_rpt(Fd, " ", "oe_decode_~s", + [getCaseTypeStr(G, N, X, I, T)]), + emit(Fd, " return oe_error_code;\n }\n") + end; + sequence -> + emit(Fd, " if ((oe_error_code = oe_decode_~s(oe_env, oe_first, oe_index, &oe_rec->_u.~s)) < 0) {\n", + [getCaseTypeStr(G, N, X, I, T),ic_forms:get_id2(I)]), + ?emit_c_dec_rpt(Fd, " ", "sequence:oe_decode_~s", + [getCaseTypeStr(G, N, X, I, T)]), + emit(Fd, " return oe_error_code;\n }\n"); + array -> + emit(Fd, " if ((oe_error_code = oe_decode_~s(oe_env, oe_first, oe_index, oe_rec->_u.~s)) < 0) {\n", + [getCaseTypeStr(G, N, X, I, T),ic_forms:get_id2(I)]), + ?emit_c_dec_rpt(Fd, " ", "array:oe_decode_~s", [getCaseTypeStr(G, N, X, I, T)]), + emit(Fd, " return oe_error_code;\n }\n"); + union -> + emit(Fd, " if ((oe_error_code = oe_decode_~s(oe_env, oe_first, oe_index, &oe_rec->_u.~s)) < 0) {\n", + [getCaseTypeStr(G, N, X, I, T),ic_forms:get_id2(I)]), + ?emit_c_dec_rpt(Fd, " ", "union:oe_decode_~s", [getCaseTypeStr(G, N, X, I, T)]), + emit(Fd, " return oe_error_code;\n }\n"); + enum -> + emit(Fd, " if ((oe_error_code = oe_decode_~s(oe_env, oe_first, oe_index, &oe_rec->_u.~s)) < 0) {\n", + [getCaseTypeStr(G, N, X, I, T),ic_forms:get_id2(I)]), + ?emit_c_dec_rpt(Fd, " ", "enum:oe_decode_~s", [getCaseTypeStr(G, N, X, I, T)]), + emit(Fd, " return oe_error_code;\n }\n"); + any -> %% Fix for any type + emit(Fd, " if ((oe_error_code = ei_decode_long(oe_env->_inbuf, &oe_env->_iin, &oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_dec_rpt(Fd, " ", "any:ei_decodelong", []), + emit(Fd, " return oe_error_code;\n }\n"); + _ -> + ic_error:fatal_error(G, {illegal_typecode_for_c, T, N}) + end; +getCaseTypeDecode(G, N, X, Fd, I, T) -> + case I of + {array,AID,_} -> + ArrayName = ic_util:to_undersc([ic_forms:get_id2(AID),ic_forms:get_id2(X) | N]), + emit(Fd, " if ((oe_error_code = oe_decode_~s(oe_env, oe_first, oe_index, oe_rec->_u.~s)) < 0) {\n", + [ArrayName,ic_forms:get_id2(AID)]), + ?emit_c_dec_rpt(Fd, " ", "array:oe_decode_~s", [ArrayName]), + emit(Fd, " return oe_error_code;\n }\n"); + _ -> + case T of + {short,_} -> + emit(Fd, " {\n"), + emit(Fd, " long oe_long;\n"), + emit(Fd, " if ((oe_error_code = ei_decode_long(oe_env->_inbuf, &oe_env->_iin, &oe_long)) < 0) {\n"), + ?emit_c_dec_rpt(Fd, " ", "short:ei_decode_long", []), + emit(Fd, " return oe_error_code;\n }\n"), + emit(Fd, " oe_rec->_u.~s = (short) oe_long;\n\n",[ic_forms:get_id2(I)]), + emit(Fd, " if (oe_rec->_u.~s != oe_long)\n return -1;\n",[ic_forms:get_id2(I)]), + emit(Fd, " }\n"); + {unsigned,{short,_}} -> + emit(Fd, " {\n"), + emit(Fd, " unsigned long oe_ulong;\n"), + emit(Fd, " if ((oe_error_code = ei_decode_ulong(oe_env->_inbuf, &oe_env->_iin, &oe_ulong)) < 0) {\n"), + ?emit_c_dec_rpt(Fd, " ", "ushort:ei_decode_ulong", []), + emit(Fd, " return oe_error_code;\n }\n"), + emit(Fd, " oe_rec->_u.~s = (unsigned short) oe_ulong;\n\n",[ic_forms:get_id2(I)]), + emit(Fd, " if (oe_rec->_u.~s != oe_ulong)\n return -1;\n",[ic_forms:get_id2(I)]), + emit(Fd, " }\n"); + {long, _} -> + emit(Fd, " if ((oe_error_code = ei_decode_long(oe_env->_inbuf, &oe_env->_iin, &oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_dec_rpt(Fd, " ", "long:ei_decode_long", []), + emit(Fd, " return oe_error_code;\n }\n"); + {unsigned,{long,_}} -> + emit(Fd, " if ((oe_error_code = ei_decode_ulong(oe_env->_inbuf, &oe_env->_iin, &oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_dec_rpt(Fd, " ", "ulong:ei_decode_ulong", []), + emit(Fd, " return oe_error_code;\n }\n"); + {float,_} -> + emit(Fd, " {\n"), + emit(Fd, " double oe_double;\n"), + emit(Fd, " if ((oe_error_code = ei_decode_double(oe_env->_inbuf, &oe_env->_iin, &oe_double)) < 0) {\n"), + ?emit_c_dec_rpt(Fd, " ", "float:ei_decode_double", []), + emit(Fd, " return oe_error_code;\n }\n"), + emit(Fd, " oe_rec->_u.~s = (float) oe_double;\n",[ic_forms:get_id2(I)]), + emit(Fd, " }\n"); + {double,_} -> + emit(Fd, " if ((oe_error_code = ei_decode_double(oe_env->_inbuf, &oe_env->_iin, &oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_dec_rpt(Fd, " ", "dobule:ei_decode_double", []), + emit(Fd, " return oe_error_code;\n }\n"); + {boolean,_} -> + emit(Fd, " {\n"), + emit(Fd, " char oe_bool[25];\n\n"), + emit(Fd, " if ((oe_error_code = ei_decode_atom(oe_env->_inbuf, &oe_env->_iin, oe_bool)) < 0) {\n"), + ?emit_c_dec_rpt(Fd, " ", "boolean:ei_decode_atom", []), + emit(Fd, " return oe_error_code;\n }\n"), + emit(Fd, " if (strcmp(oe_bool, \"false\") == 0) {\n"), + emit(Fd, " oe_rec->_u.~s = 0;\n",[ic_forms:get_id2(I)]), + emit(Fd, " } else if (strcmp(oe_bool, \"true\") == 0) {\n"), + emit(Fd, " oe_rec->_u.~s = 1;\n",[ic_forms:get_id2(I)]), + emit(Fd, " } else {\n"), + ?emit_c_dec_rpt(Fd, " ", "boolean failure", []), + emit(Fd, " return -1;\n }\n"), + emit(Fd, " }\n"); + {char,_} -> + emit(Fd, " if ((oe_error_code = ei_decode_char(oe_env->_inbuf, &oe_env->_iin, &oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_dec_rpt(Fd, " ", "char:ei_decode_char", []), + emit(Fd, " return oe_error_code;\n }\n"); + {octet,_} -> + emit(Fd, " if ((oe_error_code = ei_decode_char(oe_env->_inbuf, &oe_env->_iin, &oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + emit(Fd, " return oe_error_code;\n }\n"); + {string,_} -> + emit(Fd, " {\n"), + emit(Fd, " int oe_type = 0;\n"), + emit(Fd, " int oe_string_ctr = 0;\n\n"), + + emit(Fd, " (int) ei_get_type(oe_env->_inbuf, &oe_env->_iin, &oe_type, &oe_string_ctr);\n\n"), + + emit(Fd, " oe_rec->_u.~s = (void *) (oe_first + *oe_index);\n\n",[ic_forms:get_id2(I)]), + + emit(Fd, " if ((oe_error_code = ei_decode_string(oe_env->_inbuf, &oe_env->_iin, oe_rec->_u.~s)) < 0) {\n", + [ic_forms:get_id2(I)]), + ?emit_c_dec_rpt(Fd, " ", "ei_decode_string", []), + emit(Fd, " return oe_error_code;\n }\n"), + + emit(Fd, " *oe_index = ~s;\n",[ic_util:mk_align("*oe_index+oe_string_ctr+1")]), + emit(Fd, " }\n"); + {sequence,_,_} -> + SeqName = ic_util:to_undersc([ic_forms:get_id2(I), ic_forms:get_id2(X) | N]), + emit(Fd, " if ((oe_error_code = oe_decode_~s(oe_env, oe_first, oe_index, &oe_rec->_u.~s)) < 0) {\n", + [SeqName,ic_forms:get_id2(I)]), + ?emit_c_dec_rpt(Fd, " ", "sequence:oe_decode_~s", [SeqName]), + emit(Fd, " return oe_error_code;\n }\n"); + {struct,SID,_,_} -> + StructName = ic_util:to_undersc([ic_forms:get_id2(SID), ic_forms:get_id2(X) | N]), + emit(Fd, " if ((oe_error_code = oe_decode_~s(oe_env, oe_first, oe_index, &oe_rec->_u.~s)) < 0) {\n", + [StructName,ic_forms:get_id2(I)]), + ?emit_c_dec_rpt(Fd, " ", "struct:oe_decode_~s", [StructName]), + emit(Fd, " return oe_error_code;\n }\n"); + {union,UID,_,_,_} -> + UnionName = ic_util:to_undersc([ic_forms:get_id2(UID), ic_forms:get_id2(X) | N]), + emit(Fd, " if ((oe_error_code = oe_decode_~s(oe_env, oe_first, oe_index, &oe_rec->_u.~s)) < 0) {\n", + [UnionName,ic_forms:get_id2(I)]), + ?emit_c_dec_rpt(Fd, " ", "union:oe_decode_~s", [UnionName]), + emit(Fd, " return oe_error_code;\n }"); + _ -> + ic_error:fatal_error(G, {illegal_typecode_for_c, T, N}) + end + end. + +mvDefaultToTail(CDclL) -> + mvDefaultToTail(CDclL,[],[]). + + +mvDefaultToTail([], F, FD) -> + lists:reverse(F) ++ FD; +mvDefaultToTail([{case_dcl,CaseList,I,T}|Rest], Found, FoundDefault) -> + case lists:keysearch(default, 1, CaseList) of + {value,Default} -> + NewCaseList = lists:delete(Default, CaseList) ++ [Default], + mvDefaultToTail(Rest, Found, [{case_dcl,NewCaseList,I,T}|FoundDefault]); + false -> + mvDefaultToTail(Rest, [{case_dcl,CaseList,I,T}|Found], FoundDefault) + end. + + diff --git a/lib/ic/src/icyeccpre.hrl b/lib/ic/src/icyeccpre.hrl new file mode 100644 index 0000000000..71b02b784b --- /dev/null +++ b/lib/ic/src/icyeccpre.hrl @@ -0,0 +1,124 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1997-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% +%% +%% + + +-export([parse/1, parse_and_scan/1, format_error/1]). + +-import(lists, [reverse/1]). + +-ifdef(JAM). +-compile([{parse_transform,jam_yecc_pj},pj]). +-endif. + + +-include("icforms.hrl"). + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% The parser generator will insert appropriate declarations before this line.% + +parse(Tokens) -> + case catch yeccpars1(Tokens, false, 0, [], []) of + error -> + Errorline = + if Tokens == [] -> 0; true -> element(2, hd(Tokens)) end, + {error, + {Errorline, ?MODULE, "syntax error at or after this line."}}; + Other -> + Other + end. + +parse_and_scan({Mod, Fun, Args}) -> + case apply(Mod, Fun, Args) of + {eof, _} -> + {ok, eof}; + {error, Descriptor, _} -> + {error, Descriptor}; + {ok, Tokens, _} -> + yeccpars1(Tokens, {Mod, Fun, Args}, 0, [], []) + end. + +format_error(Message) -> + case io_lib:deep_char_list(Message) of + true -> + Message; + _ -> + io_lib:write(Message) + end. + +% To be used in grammar files to throw an error message to the parser toplevel. +% Doesn't have to be exported! +return_error(Line, Message) -> + throw({error, {Line, ?MODULE, Message}}). + + +% Don't change yeccpars1/6 too much, it is called recursively by yeccpars2/8! +yeccpars1([Token | Tokens], Tokenizer, State, States, Vstack) -> + yeccpars2(State, element(1, Token), States, Vstack, Token, Tokens, + Tokenizer); +yeccpars1([], {M, F, A}, State, States, Vstack) -> + case catch apply(M, F, A) of + {eof, Endline} -> + {error, {Endline, ?MODULE, "end_of_file"}}; + {error, Descriptor, _Endline} -> + {error, Descriptor}; + {'EXIT', Reason} -> + {error, {0, ?MODULE, Reason}}; + {ok, Tokens, _Endline} -> + case catch yeccpars1(Tokens, {M, F, A}, State, States, Vstack) of + error -> + Errorline = element(2, hd(Tokens)), + {error, {Errorline, ?MODULE, + "syntax error at or after this line."}}; + Other -> + Other + end + end; +yeccpars1([], false, State, States, Vstack) -> + yeccpars2(State, '$end', States, Vstack, {'$end', 999999}, [], false). + +% For internal use only. +yeccerror(Token) -> + {error, + {element(2, Token), ?MODULE, + ["syntax error before: ", yecctoken2string(Token)]}}. + +yecctoken2string({atom, _, A}) -> io_lib:write(A); +yecctoken2string({integer,_,N}) -> io_lib:write(N); +yecctoken2string({float,_,F}) -> io_lib:write(F); +yecctoken2string({char,_,C}) -> io_lib:write_char(C); +yecctoken2string({var,_,V}) -> io_lib:format("~s", [V]); +yecctoken2string({string,_,S}) -> io_lib:write_string(S); +yecctoken2string({reserved_symbol, _, A}) -> io_lib:format("~w", [A]); +yecctoken2string({'dot', _}) -> "'.'"; +yecctoken2string({'$end', _}) -> + []; +yecctoken2string({Other, _}) when is_atom(Other) -> + io_lib:format("~w", [Other]); +yecctoken2string({_, _, Other}) when is_list(Other) andalso is_number(hd(Other)) -> + Other; +yecctoken2string({_, _, Other}) -> + io_lib:format("~p", [Other]); +yecctoken2string(Other) -> + io_lib:write(Other). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + -- cgit v1.2.3