ifc.sa
Generated by gen_html_sa_files from ICSI. Contact gomes@icsi.berkeley.edu for details
---------------------------> Sather 1.1 source file <--------------------------
-- Copyright (C) International Computer Science Institute, 1994. COPYRIGHT --
-- NOTICE: This code is provided "AS IS" WITHOUT ANY WARRANTY and is subject --
-- to the terms of the SATHER LIBRARY GENERAL PUBLIC LICENSE contained in --
-- the file "Doc/License" of the Sather distribution. The license is also --
-- available from ICSI, 1947 Center St., Suite 600, Berkeley CA 94704, USA. --
--------> Please email comments to sather-bugs@icsi.berkeley.edu. <----------
-- ifc.sa: Type interfaces in the Sather compiler.
-- IFC: The interface of a type.
-- IFC_TBL: A table of interfaces indexed by type.
-- IFC_ABS_CREATE: Create an interface for an abstract type.
-- SELECT_SIG: a partial class that contains suff for overloading
-- resolution. Included by IFC and IMPL
class IFC < $STR
class IFC < $STR is
include SELECT_SIG; --resolves calls on overloaded functions
-- A type interface.
attr tp:$TP; -- The type whose interface this is.
attr sigs:SIG_TBL; -- The interface signatures.
str:STR is
s:STR:="public interface of class "+tp.str+" is\n";-- IFC::tp STR::plus
a:ARRAY{STR}:=#(sigs.size);-- ARRAY{1}::create IFC::sigs SIG_TBL::size
i::=0;
loop
sig::=sigs.elt!;-- IFC::sigs SIG_TBL::elt!
st::=sig.str;-- SIG::str
if ~void(sig.srcsig) then-- SIG::srcsig BOOL::not
st:=st+" ["+sig.srcsig.str+"]";-- STR::plus STR::plus SIG::srcsig SIG::str STR::plus
end;
a.set!(st);-- ARRAY{1}::set!
end;
a.sort;-- ARRAY{1}::sort
loop
s:=s+" "+a.elt!+"\n";-- STR::plus STR::plus ARRAY{1}::elt! STR::plus
end;
s:=s+"end;\n";-- STR::plus
return s;
end;
create(sigs:SIG_TBL, tp:$TP):SAME is
-- An interface with the signatures `sigs' for the type `tp'.
-- Never gives void.
r::=new; r.sigs:=sigs; r.tp:=tp; return r end; -- IFC::sigs IFC::tp
prog:PROG is
-- The program this interface belongs to.
return tp.prog end;-- IFC::tp
sig_conforming_to(s:SIG):SIG
-- A signature from the interface which conforms to `s' or void
-- if none. This will be unique if the interface has no conflicts.
pre ~void(self) and ~void(s) is-- BOOL::not BOOL::not
loop ts::=sigs.get_query!(s.name);-- IFC::sigs SIG_TBL::get_query! SIG::name
if ts.conforms_to(s) then return ts end end;-- SIG::conforms_to
return void end;
sig_equal_to(s:SIG):SIG
-- A signature from self which is equal to `s' if present,
-- void if not.
pre ~void(self) and ~void(s) is
loop ts::=sigs.get_query!(s.name);
if ts.is_eq(s) then return ts end end;
return void end;
nonconforming_sig(i:IFC):SIG
-- If self conforms to `i' then return void, otherwise return
-- a signature in `i' for which there is no conforming signature
-- in self.
pre ~void(self) and ~void(i) is-- BOOL::not BOOL::not
loop s::=i.sigs.elt!; -- IFC::sigs SIG_TBL::elt!
if void(sig_conforming_to(s)) then return s end end;-- IFC::sig_conforming_to
return void end;
nonconforming_sig_list(i: IFC): FLIST{SIG}
-- Version of nonconforming_sig that returns all the nonconforming
-- signatures for better error reporting
-- and so generates all the non-conforming messages at one go, rather
-- than one at a time
pre ~void(self) and ~void(i) -- BOOL::not
is-- BOOL::not
res: FLIST{SIG}; -- Void to begin with
loop s::=i.sigs.elt!; -- IFC::sigs SIG_TBL::elt!
if void(sig_conforming_to(s)) then res := res.push(s); end -- IFC::sig_conforming_to FLIST{1}::push
end;
return res;
end;
conforms_to(i:IFC):BOOL is
-- True if self conforms to `i'. This means that for every
-- signature in `i' there is a signature in self which conforms
-- to it.
return void(nonconforming_sig(i)) end; -- IFC::nonconforming_sig
conflicting_sigs:TUP{SIG,SIG}
-- If self has a conflict, return two conflicting signatures.
-- Otherwise, return #(void,void).
pre ~void(self) is
loop s::=sigs.elt!;
loop st::=sigs.get_query!(s.name);
if ~SYS::ob_eq(st,s) and st.conflicts_with(s) then
return #(s,st) end end end;
return #(void,void) end;
is_conflict_free:BOOL is
-- True if self is free of conflicting signatures.
return void(conflicting_sigs) end;
sig_for_call(c:CALL_SIG):SIG
-- A signature from the interface to which the call `c' conforms.
-- Void if none. Reports an error if the call is ambiguous
-- or missing (assumes that "err_loc" has been set).
-- If it is unknown whether there is a return value, then
-- choose the signature without one in case of conflict.
pre ~void(self) and ~void(c) is-- BOOL::not BOOL::not
r:SIG;
sig_list:FLIST{SIG} := #; -- a list of sigs conformed to by the call-- FLIST{1}::create
loop s::=sigs.get_query!(c.name);-- IFC::sigs SIG_TBL::get_query! CALL_SIG::name
if c.conforms_to(s) then-- CALL_SIG::conforms_to
if c.unknown_ret or (c.has_ret and ~void(s.ret)) -- CALL_SIG::unknown_ret CALL_SIG::has_ret SIG::ret BOOL::not
or (~c.unknown_ret and ~c.has_ret and void(s.ret)) then-- CALL_SIG::unknown_ret BOOL::not CALL_SIG::has_ret BOOL::not SIG::ret
sig_list := sig_list.push(s);-- FLIST{1}::push
end;
end
end;
r := select_sig(c, sig_list, false);-- IFC::select_sig
if void(r) then
found_one ::= false;
res ::= "";
loop s ::= sigs.get_query!(c.name);-- IFC::sigs SIG_TBL::get_query! CALL_SIG::name
found_one := true;
res := res+" or\n\t".separate!(s.str);-- STR::plus STR::separate! SIG::str
end;
-- #ERR+"Printing result:"+res+"\n";
print_err: STR := c.str;-- CALL_SIG::str
if found_one then
print_err := print_err+"\n"+"\tSuggest:"+res;-- STR::plus STR::plus STR::plus
end;
c.prog.err("No match for the call " + print_err);-- CALL_SIG::prog PROG::err STR::plus
end;
return r;
end;
ifc_for_rout(t:TP_ROUT):SAME
-- The interface of a bound routine type.
pre ~void(t) is-- BOOL::not
r::=new; r.tp:=t;-- IFC::tp
r.sigs:=r.sigs.insert(SIG::bound_routine_call(t));-- IFC::sigs IFC::sigs SIG_TBL::insert SIG::bound_routine_call
return r;
end;
ifc_for_iter(t:TP_ITER):SAME
-- The interface of a bound iter type.
pre ~void(t) is-- BOOL::not
r::=new; r.tp:=t;-- IFC::tp
r.sigs:=r.sigs.insert(SIG::bound_iter_call(t));-- IFC::sigs IFC::sigs SIG_TBL::insert SIG::bound_iter_call
return r
end;
ifc_for_class(t:TP_CLASS):SAME
pre ~void(t)
is-- BOOL::not
res: SAME := void;
if t.is_abstract then-- TP_CLASS::is_abstract
cq::=#TUP{IDENT,INT}(t.name,t.params.size);-- TUP{2}::create TP_CLASS::name TP_CLASS::params ARRAY{1}::size
if abs_cur.test(cq) then-- IFC::abs_cur FSET{1}::test
cycle_err; abs_cur:=abs_cur.clear; -- IFC::cycle_err IFC::abs_cur IFC::abs_cur FSET{1}::clear
else
abs_cur:=abs_cur.insert(cq);-- IFC::abs_cur IFC::abs_cur FSET{1}::insert
res := IFC_ABS_CREATE::ifc_of(t);-- IFC_ABS_CREATE::ifc_of
abs_cur:=abs_cur.delete(cq);-- IFC::abs_cur IFC::abs_cur FSET{1}::delete
end
else
im:IMPL:=t.impl;-- TP_CLASS::impl
if ~void(im) then res := im.ifc end;-- BOOL::not IMPL::ifc
end;
return res
end;
shared abs_cur:FSET{TUP{IDENT,INT}}; -- The set of abstract class
-- names and number of parameters which are currently having
-- their interfaces worked out.
cycle_err is
-- Print an error message about a cycle of include type names.
s:STR := "Cycle detected in `subtyping' clauses involving the types: ";
loop
cur ::= abs_cur.elt!;-- IFC::abs_cur FSET{1}::elt!
s := s + ", ".separate!(cur.t1.str(cur.t2))-- STR::plus STR::separate! TUP{2}::t1 IDENT::str TUP{2}::t2
end;
prog.err(s)-- IFC::prog PROG::err
end;
show is
-- Print the interface on OUT.
if void(self) then #OUT + "Interface=void\n"; return end;-- OUT::create OUT::plus
if void(tp) then #OUT + "Interface tp=void\n"; return end;-- IFC::tp OUT::create OUT::plus
#OUT + "Interface of " + tp.str + " = ";-- OUT::create OUT::plus IFC::tp OUT::plus
if void(sigs) then #OUT + "void\n"; return end;-- IFC::sigs OUT::create OUT::plus
loop s::=sigs.elt!;-- IFC::sigs SIG_TBL::elt!
if ~void(s) then #OUT + " ".separate!(s.str) end end;-- BOOL::not OUT::create OUT::plus STR::separate! SIG::str
#OUT + "\n" end;-- OUT::create OUT::plus
end; -- class IFC
class IFC_ABS_CREATE
class IFC_ABS_CREATE is
-- Create an interface for an abstract type.
attr tp:TP_CLASS; -- The abstract type it is for.
attr con:TP_CONTEXT; -- The type context for tp.
attr tr:AS_CLASS_DEF; -- The definition tree for tp.
attr class_sigs:SIG_TBL; -- Table of signature explicitly
-- in the class.
attr supers:FLIST{IFC}; -- Interfaces of supertypes.
ifc_of(t:TP_CLASS):IFC
-- Compute the interface of the abstract type `t'.
pre ~void(t) is-- BOOL::not
if t.prog.show_ifc_abs_create then-- TP_CLASS::prog PROG::show_ifc_abs_create
#OUT + "(Abstract ifc create " + t.str + ") " end;-- OUT::create OUT::plus OUT::plus TP_CLASS::str OUT::plus
ic::=new; ic.tp:=t;-- IFC_ABS_CREATE::tp
ic.con:=t.tp_context_for;-- IFC_ABS_CREATE::con TP_CLASS::tp_context_for
if void(ic.con) then return void end;-- IFC_ABS_CREATE::con
ic.tr:=ic.prog.parse.tree_for(t.name,t.params.size);-- IFC_ABS_CREATE::tr IFC_ABS_CREATE::prog PROG::parse TP_CLASS::name TP_CLASS::params ARRAY{1}::size
if void(ic.tr) then -- IFC_ABS_CREATE::tr
t.prog.err("Compiler error: IFC_ABS_CREATE:ifc_of tr=void for " +-- TP_CLASS::prog PROG::err
t.str + "."); return void end;-- STR::plus TP_CLASS::str STR::plus
ic.do_explicit_class_sigs;-- IFC_ABS_CREATE::do_explicit_class_sigs
ic.do_supers;-- IFC_ABS_CREATE::do_supers
return IFC::create(ic.do_sigs,t) end;-- IFC::create IFC_ABS_CREATE::do_sigs
prog:PROG is
-- The program this belongs to.
return tp.prog end;-- IFC_ABS_CREATE::tp TP_CLASS::prog
do_explicit_class_sigs is
-- Compute `class_sigs'.
be:$AS_CLASS_ELT:=tr.body;-- IFC_ABS_CREATE::tr AS_CLASS_DEF::body
loop until!(void(be)); prog.err_loc(be);-- IFC_ABS_CREATE::prog PROG::err_loc
typecase be
when AS_CONST_DEF then
prog.err("Abstract classes may not define constants.");-- IFC_ABS_CREATE::prog PROG::err
when AS_SHARED_DEF then
prog.err("Abstract classes may not define shareds.");-- IFC_ABS_CREATE::prog PROG::err
when AS_ATTR_DEF then
prog.err("Abstract classes may not define attributes.");-- IFC_ABS_CREATE::prog PROG::err
when AS_ROUT_DEF then
if ~be.is_abstract then prog.err(-- AS_ROUT_DEF::is_abstract BOOL::not IFC_ABS_CREATE::prog PROG::err
"Abstract classes may only have abstract routines.") end;
ns:SIG:=SIG::rout_sig(be,be.name,con.ptypes,con);-- SIG::rout_sig AS_ROUT_DEF::name IFC_ABS_CREATE::con TP_CONTEXT::ptypes IFC_ABS_CREATE::con
cs:SIG:=class_sigs.sig_conflicting_with(ns);-- IFC_ABS_CREATE::class_sigs SIG_TBL::sig_conflicting_with
if ~void(cs) then-- BOOL::not
prog.err("The two explicitly defined signatures " +-- IFC_ABS_CREATE::prog PROG::err
ns.str + " and " + cs.str + " conflict.") -- STR::plus SIG::str STR::plus STR::plus SIG::str STR::plus
else class_sigs:=class_sigs.insert(ns) end;-- IFC_ABS_CREATE::class_sigs IFC_ABS_CREATE::class_sigs SIG_TBL::insert
when AS_INCLUDE_CLAUSE then
prog.err("Abstract classes may not have include clauses.");-- IFC_ABS_CREATE::prog PROG::err
end;
be:=be.next end end;
do_supers is
-- Compute `supers'.
ut:AS_TYPE_SPEC:=tr.under;-- IFC_ABS_CREATE::tr AS_CLASS_DEF::under
loop until!(void(ut));
tp:$TP:=con.tp_of(ut); prog.err_loc(ut);-- IFC_ABS_CREATE::con TP_CONTEXT::tp_of IFC_ABS_CREATE::prog PROG::err_loc
typecase tp
when TP_CLASS then
if ~tp.is_abstract then-- TP_CLASS::is_abstract BOOL::not
prog.err("Abstract types must have abstract supertypes.") -- IFC_ABS_CREATE::prog PROG::err
else
itp:IFC:= tp.ifc;-- TP_CLASS::ifc
supers:=supers.push(itp) end;-- IFC_ABS_CREATE::supers IFC_ABS_CREATE::supers FLIST{1}::push
else
prog.err("Abstract types must have abstract supertypes.") end;-- IFC_ABS_CREATE::prog PROG::err
ut:=ut.next end end;-- AS_TYPE_SPEC::next
do_sigs:SIG_TBL is
-- The final sig table assuming everything else has been computed.
r:SIG_TBL;
loop r:=r.insert(class_sigs.elt!) end;-- SIG_TBL::insert IFC_ABS_CREATE::class_sigs SIG_TBL::elt!
loop
if supers.is_empty then break!-- IFC_ABS_CREATE::supers FLIST{1}::is_empty
else
si:IFC:=supers.pop; -- IFC_ABS_CREATE::supers FLIST{1}::pop
loop sig::=si.sigs.elt!;-- IFC::sigs SIG_TBL::elt!
if ~void(r.sig_conflicting_with(sig)) then-- SIG_TBL::sig_conflicting_with BOOL::not
-- included signature is overridden by explicit one
-- or we've already done this one.
else
i:INT:=0;
loop while!(i<supers.size);-- IFC_ABS_CREATE::supers FLIST{1}::size
cs:SIG:=supers[i].sigs.sig_conflicting_with(sig);-- IFC_ABS_CREATE::supers FLIST{1}::aget IFC::sigs SIG_TBL::sig_conflicting_with
if ~void(cs) then-- BOOL::not
if ~cs.is_eq_but_tp(sig) then-- SIG::is_eq_but_tp BOOL::not
prog.err_loc(tr);-- IFC_ABS_CREATE::prog PROG::err_loc IFC_ABS_CREATE::tr
prog.err("The signatures " + sig.str +-- IFC_ABS_CREATE::prog PROG::err STR::plus SIG::str
" and " + cs.str +-- STR::plus STR::plus SIG::str
" must be disambiguated by an explicit sig.") -- STR::plus
end end;
i:=i+1 end;-- INT::plus
r:=r.insert(sig.with_new_type(tp)) -- SIG_TBL::insert SIG::with_new_type IFC_ABS_CREATE::tp
end;
end;
end;
end;
return r end;
end; -- class IFC_ABS_CREATE
partial class SELECT_SIG
partial class SELECT_SIG is
-- This partial class is meant to be included by IFC and IMPL.
-- IFC will use this to select a signature for an external class
-- while IMPL needs this for internal calls. Basically, this is where
-- calls on overloaded functions get resolved
stub tp:$TP;
stub prog: PROG;
select_sig(c:CALL_SIG, sig_list:FLIST{SIG}, internal_call:BOOL):SIG is
-- selects a signature corresponding to a call form the list of
-- overloaded sigs
-- For each argument position, for the winning sig, we must have:
-- in, once arg: the type of arg must be a subtype of all the
-- corresponding arg types in all other sigs
-- inout arg: no contest here, all types are the same
-- We use a simple algorithm here. We use the above rules to find
-- the winner signature for each argument. It MUST be the same for all.
-- If it is not, we have an error
winner_sig:SIG;
winners:FSET{SIG}; -- winner sigs up to current position-- FLIST{1}::size INT::is_lt
if sig_list.size > 1 then-- INT::upto! CALL_SIG::args ARRAY{1}::size INT::minus
loop-- FLIST{1}::top SIG::args ARRAY{1}::aget
i::=0.upto!(c.args.size-1); -- current arg position
cba ::= sig_list.top.args[i];-- FSET{1}::clear
pos_winner_sigs:FSET{SIG};
pos_winner_sigs := pos_winner_sigs.clear;-- FLIST{1}::elt!
loop-- SIG::args ARRAY{1}::aget
s ::= sig_list.elt!;-- ARG::mode
sa ::= s.args[i]; -- arg in a considered sig-- MODES::in_mode
case sa.mode -- ARG::tp ARG::tp
when MODES::in_mode then
if sa.tp.is_subtype(cba.tp) then
-- found better match
cba := sa;-- MODES::out_mode
end;-- ARG::tp ARG::tp
when MODES::out_mode then
if cba.tp.is_subtype(sa.tp) then
-- found better match
cba := sa;-- MODES::inout_mode
end;
when MODES::inout_mode then-- MODES::once_mode
-- nothing to do, these are the same-- ARG::tp ARG::tp
when MODES::once_mode then
if sa.tp.is_subtype(cba.tp) then
-- found better match
cba := sa;
end;
end;
end;
-- we found a winning argument, however, there may be a few
-- sigs that have it in the proper position. Collect them all.
-- Note, if call tp for this argument is one of the special
-- types (CALL_TP_VOID, CALL_TP_CREATE, CALL_TP_BOUND_CREATE,
-- CALL_TP_ARRAY,
-- CALL_TP_UNDERSCORE) we add all sigs to the list.-- FLIST{1}::elt!
loop-- IMPL::is_special_call_tp CALL_SIG::args ARRAY{1}::aget CALL_ARG::tp SIG::args ARRAY{1}::aget ARG::tp ARG::tp
s ::= sig_list.elt!;
if is_special_call_tp(c.args[i].tp) or s.args[i].tp = cba.tp-- FSET{1}::insert
then
pos_winner_sigs := pos_winner_sigs.insert(s);
end;
end;
-- intersect with best up to (i-1)th arg signatures-- FSET{1}::copy
if void(winners) then
winners := pos_winner_sigs.copy;-- FSET{1}::intersect
else
winners := winners.intersect(pos_winner_sigs);
end;
-- FSET{1}::size INT::is_lt
end;
if winners.size > 1 then
err_msg::="";-- FSET{1}::elt!
loop-- STR::plus STR::separate! SIG::str
s::=winners.elt!;
err_msg := err_msg + "\n\t".separate!(s.str);-- CALL_SIG::prog PROG::err
end;-- STR::plus
c.prog.err("Incorrect use of overloading: multiple matches for call\n\t" +
err_msg);
return void;-- FSET{1}::size INT::is_eq
elsif winners.size = 0 then-- CALL_SIG::prog PROG::err STR::plus CALL_SIG::str
if internal_call then
c.prog.err("No match internal call " + c.str); -- CALL_SIG::prog PROG::err STR::plus CALL_SIG::str
else
c.prog.err("No match for the call " + c.str);
end;-- FSET{1}::size INT::is_eq
return void;-- FSET{1}::first_elt
elsif winners.size = 1 then
winner_sig := winners.first_elt;
end;-- FLIST{1}::size INT::is_eq
elsif sig_list.size = 1 then-- FLIST{1}::top
-- there is only one candidate;
winner_sig := sig_list.top;-- IMPL::prog PROG::show_calls BOOL::not
end;-- IMPL::prog PROG::show_calls STR::is_eq SIG::tp STR::plus STR::plus CALL_SIG::name IDENT::str
if ~void(prog.show_calls) and
((prog.show_calls = winner_sig.tp.str+"::"+c.name.str)-- IMPL::prog PROG::show_calls
or-- STR::is_eq
prog.show_calls = "all"-- IMPL::prog PROG::show_calls
or -- STR::is_eq
prog.show_calls = "all_debug"
)
then
-- Get the sfile id of the source and destination (ben)
-- Avoid type inference to make the chain obvious
dest_elts: ELT_TBL;
dest: SIG := winner_sig;-- BOOL::not
dest_sfileid: SFILE_ID;-- SIG::tp
if ~void(dest) then-- BOOL::not
dest_tp: $TP := dest.tp;
if ~void(dest_tp) then-- BOOL::not
dest_impl: IMPL := dest_tp.impl;-- IMPL::elts
if ~void(dest_impl) then
dest_elts := dest_impl.elts;
end;
end;-- IMPL::prog PROG::show_calls STR::is_eq
end;-- OUT::create OUT::plus
if prog.show_calls = "all_debug" then
#OUT+"Getting the destination element next\n";-- BOOL::not
end;-- SIG::name
if ~void(dest_elts) then
dest_id: IDENT := dest.name;-- ELT_TBL::get_query!
loop -- ELT::sig
query_dest_elt: ELT := dest_elts.get_query!(dest_id);-- SIG::is_eq_but_tp
query_dest_sig: SIG := query_dest_elt.sig;-- ELT::as
if query_dest_sig.is_eq_but_tp(dest) then
dest_as: $AS_CLASS_ELT := query_dest_elt.as;
dest_sfileid := dest_as.source;
end;
end;-- IMPL::prog PROG::show_calls STR::is_eq
end;-- OUT::create OUT::plus
if prog.show_calls = "all_debug" then
#OUT+"Got the dest sfile\n";
end;
caller: CALL_SIG := c;
-- Ok. so this is a complete hack. The problem is when you
-- are down here you no longer have access to the AM node
-- from which the call came. CALL_SIG does not provide any
-- way to go backwards. Short of changing the calls three
-- levels up, the only solution is to use the err location,
-- which is set correctly before any of this happens. (we-- IMPL::prog PROG::eloc
-- hope!)-- BOOL::not BOOL::not
caller_sfileid: SFILE_ID := prog.eloc;
if ~void(dest_sfileid) and ~void(caller_sfileid) then-- BOOL::not BOOL::not CALL_SIG::name BOOL::not
winner_tp: $TP;-- SIG::tp
if ~void(winner_sig) and ~void(caller) and ~void(caller.name) then-- STORE_CALL_MAP::store CALL_SIG::name IDENT::str
winner_tp := winner_sig.tp;-- IMPL::prog PROG::show_calls STR::is_eq
STORE_CALL_MAP::store(caller_sfileid,dest_sfileid,winner_tp,caller.name.str);-- OUT::create OUT::plus OUT::plus SFILE_ID::str OUT::plus OUT::plus SFILE_ID::str OUT::plus
if prog.show_calls = "all_debug" then
#OUT+"Storing:"+caller_sfileid.str+" to:"+dest_sfileid.str+"\n";
end;
end;
-- #OUT + "show_calls "+caller.name.str+" at:"+dest_sfileid.str
-- +" \n\tcalled by:"+caller_sfileid.str+"\n";
end;
end;
return winner_sig;
end;
is_special_call_tp(ctp:$CALL_TP):BOOL is
-- returns true if ctp is one of the special case "untyped" call types:
-- CALL_TP_VOID, CALL_TP_CREATE, CALL_TP_ARRAY, CALL_TP_UNDERSCORE
typecase ctp
when CALL_TP_VOID then return true;
when CALL_TP_CREATE then return true;
when CALL_TP_BOUND_CREATE then return true;
when CALL_TP_ARRAY then return true;
when CALL_TP_UNDERSCORE then return true;
else
return false;
end;
end
end; -- class SELECT_SIG
class STORE_CALL_MAP
class STORE_CALL_MAP is
-- Storage for a mapping from source to dest sfileids for calls
-- After all calls are registered, the calls are sorted
-- and then dumped to the stdout
private shared src_dest: FMAP{SFILE_ID,SFILE_ID};
private shared src_funcs: FMAP{SFILE_ID,STR};
private shared src_tps: FMAP{SFILE_ID,$TP};
private shared srcs: FLIST{SFILE_ID};
-- STORE_CALL_MAP::src_dest FMAP{2}::test BOOL::not
store(src,dest: SFILE_ID,tp: $TP,func: STR) is-- STORE_CALL_MAP::src_dest STORE_CALL_MAP::src_dest FMAP{2}::insert
if ~src_dest.test(src) then-- STORE_CALL_MAP::src_funcs STORE_CALL_MAP::src_funcs FMAP{2}::insert
src_dest := src_dest.insert(src,dest);-- STORE_CALL_MAP::src_tps STORE_CALL_MAP::src_tps FMAP{2}::insert
src_funcs := src_funcs.insert(src,func);-- STORE_CALL_MAP::srcs STORE_CALL_MAP::srcs FLIST{1}::push
src_tps := src_tps.insert(src,tp);
srcs := srcs.push(src);
end;
end;
-- STORE_CALL_MAP::src_dest BOOL::not
print_stored is-- STORE_CALL_MAP::srcs FLIST{1}::array
if ~void(src_dest) then-- ARRAY{1}::sort
srcs_arr ::= srcs.array;
srcs_arr.sort;-- ARRAY{1}::elt!
prev_file: STR := void;-- SFILE_ID::file_in STR::is_eq BOOL::not
loop s::=srcs_arr.elt!;-- BOOL::not
if s.file_in /= prev_file then-- OUT::create OUT::plus
if ~void(prev_file) then
#OUT+"}\n"; -- OUT::create OUT::plus OUT::plus SFILE_ID::file_in OUT::plus
end;-- SFILE_ID::file_in
#OUT + "\n{ "+s.file_in+"\n";
prev_file := s.file_in;-- STORE_CALL_MAP::src_dest FMAP{2}::test
end;-- STORE_CALL_MAP::src_dest FMAP{2}::get
if src_dest.test(s) then-- STORE_CALL_MAP::src_funcs FMAP{2}::get
dest ::= src_dest.get(s);-- STORE_CALL_MAP::src_tps FMAP{2}::get
src_name ::= src_funcs.get(s);-- SFILE_ID::line_num_in
src_tp ::= src_tps.get(s);
next_line ::= s.line_num_in;
typecase src_tp-- TP_CLASS::params ARRAY{1}::size INT::is_lt
when TP_CLASS then-- OUT::create OUT::plus OUT::plus TP_CLASS::name IDENT::str OUT::plus OUT::plus TP_CLASS::params ARRAY{1}::size OUT::plus OUT::plus
if src_tp.params.size > 0 then
#OUT+"{ "+src_tp.name.str+'{'+src_tp.params.size+"}::"+src_name;-- OUT::create OUT::plus OUT::plus TP_CLASS::str OUT::plus OUT::plus
else
#OUT+"{ "+src_tp.str+"::"+src_name;
end;-- OUT::create OUT::plus OUT::plus OUT::plus OUT::plus
else
#OUT+"{ "+src_tp.str+"::"+src_name;-- OUT::create OUT::plus OUT::plus SFILE_ID::line_num_in OUT::plus OUT::plus SFILE_ID::col_num_in OUT::plus
end;-- OUT::plus SFILE_ID::file_in OUT::plus OUT::plus SFILE_ID::line_num_in OUT::plus
#OUT+' '+s.line_num_in+' '+s.col_num_in+' '+-- OUT::plus SFILE_ID::col_num_in OUT::plus
dest.file_in+' '+dest.line_num_in+' '+
dest.col_num_in+" }\n";
end;-- OUT::create OUT::plus
end;
#OUT+"\n}\n";
end;
end;
end;