impl.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. <----------
-- impl.sa: Type implementations.
-- IMPL: The implementation of a type.
-- IMPL_TBL: A table of implementations indexed by type.
-- IMPL_INCLUDE: Information for handling an `include' clause.
-- IMPL_CREATE: An object used while creating an interface.
class IMPL
class IMPL is
include SELECT_SIG; -- needed to resolve overloaded calls
-- The implementation of a type.
attr tp:$TP; -- The type this is for.
attr ifc:IFC; -- The public interface of the type.
attr elts:ELT_TBL; -- The elements of the type.
attr arr:TP_CLASS; -- AREF{T} or AVAL{T} if there is an
private attr is_ref_cache:BOOL;
private attr use_ref_cache:BOOL;
-- include path to one of them, or void if not.
prog:PROG is
-- The program this belongs to.
return tp.prog end;-- IMPL::tp
create:SAME is
-- An empty IMPL object.
return new end;
sig_for_internal_call(c:CALL_SIG):SIG
-- The signature in self which corresponds to the internal call
-- signature `c'. err_call_sig if none. Reports an error if the call
-- is ambiguous or missing (assumes that "err_loc" has been set).
pre ~void(c) is-- BOOL::not
r:SIG;
sig_list:FLIST{SIG}:=#; --a list of sigs conformed to by the call-- FLIST{1}::create
loop s::=elts.get_query!(c.name).sig;-- IMPL::elts ELT_TBL::get_query! CALL_SIG::name ELT::sig
if c.conforms_to(s) then-- CALL_SIG::conforms_to
sig_list := sig_list.push(s);-- FLIST{1}::push
end;
end;
r := select_sig(c, sig_list, true);-- IMPL::select_sig
if void(r) then
found_one ::= false;
res ::= "";
loop s ::= elts.get_query!(c.name).sig;-- IMPL::elts ELT_TBL::get_query! CALL_SIG::name ELT::sig
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 internal call " + print_err);-- CALL_SIG::prog PROG::err STR::plus
end;
return r;
end;
sig_for_call(c:CALL_SIG):SIG is
-- The signature in the public interface which corresponds to
-- the call `c'. Void if none. Reports an error if the call is
-- ambiguous or missing (assumes that "err_loc" has been set).
return ifc.sig_for_call(c) end;
elt_with_sig(s:SIG):ELT is
-- The element in this implementation with the signature `s',
-- if present, void if not.
return elts.elt_with_sig(s) end;-- IMPL::elts ELT_TBL::elt_with_sig
has_invariant:BOOL is
-- True if this implementation defines a routine: `invariant:BOOL'.
loop
if elts.get_query!(IDENT_BUILTIN::invariant_ident).is_invariant then
return true end end;
return false end;
invariant_sig:SIG is
-- Return the invariant signature if there is one, void if not.
loop e::=elts.get_query!(IDENT_BUILTIN::invariant_ident);-- IMPL::elts ELT_TBL::get_query! IDENT_BUILTIN::invariant_ident
if e.is_invariant then return e.sig end end;-- ELT::is_invariant ELT::sig
return void end;
asize_val:INT is
-- If `asize' is defined as an integer constant, this returns its
-- value. Otherwise it returns -1.
loop asze::=elts.get_query!(IDENT_BUILTIN::asize_ident);-- IMPL::elts ELT_TBL::get_query! IDENT_BUILTIN::asize_ident
if asze.is_const_reader and -- ELT::is_const_reader
asze.sig.ret=TP_BUILTIN::int then-- ELT::sig SIG::ret TP_BUILTIN::int
as::=asze.as;-- ELT::as
typecase as
when AS_CONST_DEF then
ai::=as.init;-- AS_CONST_DEF::init
typecase ai when AS_INT_LIT_EXPR then
return ai.val.int;-- AS_INT_LIT_EXPR::val INTI::int
else
prog.barf("asize for AVAL has to be a integer literal!");-- IMPL::prog PROG::barf
end;
else
prog.barf("asize for AVAL has to be a integer literal!");-- IMPL::prog PROG::barf
end;
else return -1 end end;
return -1; -- added this ???
end;
is_reference_free:BOOL pre ~void(self) is-- BOOL::not
-- return true if we can be allocated atomically.
if use_ref_cache then return is_ref_cache; end;-- IMPL::use_ref_cache IMPL::is_ref_cache
use_ref_cache:=true;-- IMPL::use_ref_cache
if tp.is_builtin then-- IMPL::tp
d::=prog.config.get_def("REFERENCE_FREE");-- IMPL::prog PROG::config CONFIG_TBL::get_def
loop e::=d.elt!;-- CONFIG_DEF::elt!
loop
c::=e.elt!;-- ARRAY{1}::elt!
if tp.str=c then -- IMPL::tp STR::is_eq
is_ref_cache:=true;-- IMPL::is_ref_cache
return true;
end;
end;
end;
is_ref_cache:=false;-- IMPL::is_ref_cache
return false;
end;
loop e::= elts.elt!;-- IMPL::elts ELT_TBL::elt!
if e.is_attr_reader then-- ELT::is_attr_reader
atp::=e.sig.ret; -- the type of this attribute.-- ELT::sig SIG::ret
if ~(atp.is_immutable) then-- BOOL::not
-- we have a reference type or bound type.
--#ERR + tp.str + " is non-atomic because attribute "
--+e.sig.str+" is not a value type\n";
is_ref_cache:=false;-- IMPL::is_ref_cache
return false;
end;
if ~(atp.is_reference_free) then-- BOOL::not
--#ERR + tp.str + " is non-atomic because value attribute "
--+e.sig.str+" is not atomic\n";
is_ref_cache:=false;-- IMPL::is_ref_cache
return false;
end;
end;
end;
-- now we check included AREF{T} or AVAL{T}.
if void(arr) then-- IMPL::arr
-- guess it's OK
--#ERR + tp.str + " looks atomic with no included AREF/AVAL\n";
is_ref_cache:=true;-- IMPL::is_ref_cache
return true;
else
-- now we need implementation of array portion to find out
-- it's type parameter.
if void(arr.params) then-- IMPL::arr TP_CLASS::params
--#ERR + "Void parameter list in inclusion of AREF{T}\n";
is_ref_cache:=false;-- IMPL::is_ref_cache
return false;
elsif arr.params.asize /= 1 then-- IMPL::arr TP_CLASS::params ARRAY{1}::asize INT::is_eq BOOL::not
--#ERR + "Funny, >1 type param found in AREF{T} atomic checking.\n";
is_ref_cache:=false;-- IMPL::is_ref_cache
return false;
else
tparam ::= arr.params[0];-- IMPL::arr TP_CLASS::params ARRAY{1}::aget
if ~(tparam.is_immutable) then-- BOOL::not
--#ERR + tp.str + " is non-atomic because included array param "
--+ " is not immutable type.\n";
is_ref_cache:=false;-- IMPL::is_ref_cache
return false;
elsif ~(tparam.is_reference_free) then-- BOOL::not
--#ERR + tp.str + " is non-atomic because included value" +
--" array param is not atomic.\n";
is_ref_cache:=false;-- IMPL::is_ref_cache
return false;
else
--#ERR + tp.str + " looks atomic with atomic AREF/AVAL.\n";
is_ref_cache:=true;-- IMPL::is_ref_cache
return true;
end;
end;
end;
end;
end; -- class IMPL
class IMPL_INCLUDE
class IMPL_INCLUDE is
-- Information for handling an `include' clause.
attr tp:TP_CLASS; -- The type with the include clause.
attr as:AS_INCLUDE_CLAUSE; -- The include clause.
attr itp: TP_CLASS; -- The included class.
attr con:TP_CONTEXT; -- The context, in which impl is to be created.
attr impl:IMPL; -- The implementation of the included class
-- but with SAME referring to 'tp'.
attr used_mods:FSET{AS_FEAT_MOD}; -- The modifiers which were used.
attr elt_tbl:ELT_TBL; -- The translated included elements.
prog:PROG is
-- The program object for this interface.
return tp.prog end; -- IMPL_INCLUDE::tp TP_CLASS::prog
create(
tp:TP_CLASS, -- Class which includes.
as:AS_INCLUDE_CLAUSE, -- AS-tree of the include.
context:TP_CONTEXT -- Context in which the include occured.
):SAME
-- Compute the "include" information corresponding to the clause
-- `as' within the definition of the type `tp'. If there
-- is an error, return void.
pre ~void(tp) and ~void(as)-- BOOL::not
is-- BOOL::not
r::=new; r.tp:=tp; r.as:=as;-- IMPL_INCLUDE::tp IMPL_INCLUDE::as
r.con := context;-- IMPL_INCLUDE::con
r.itp:=r.included_tp;-- IMPL_INCLUDE::itp IMPL_INCLUDE::included_tp
if void(r.itp) then return void end; -- IMPL_INCLUDE::itp
if tp.prog.show_include then-- TP_CLASS::prog PROG::show_include
#OUT + "(Including " + r.itp.str + " in " +-- OUT::create OUT::plus OUT::plus IMPL_INCLUDE::itp TP_CLASS::str OUT::plus
tp.str + ") " end;-- OUT::plus TP_CLASS::str OUT::plus
r.impl:=r.included_impl;-- IMPL_INCLUDE::impl IMPL_INCLUDE::included_impl
if void(r.impl) then return void end;-- IMPL_INCLUDE::impl
if r.test_array_err then return void end;-- IMPL_INCLUDE::test_array_err
if r.test_duplicate_feat_mod_err then return void end;-- IMPL_INCLUDE::test_duplicate_feat_mod_err
r.elt_tbl:=r.included_elt_tbl; -- IMPL_INCLUDE::elt_tbl IMPL_INCLUDE::included_elt_tbl
if void(r.elt_tbl) then return void end;-- IMPL_INCLUDE::elt_tbl
return r
end;
included_tp:TP_CLASS is
-- Compute the type which is included by the clause `as' in
-- the type `tp'. Print an error and return void if the included
-- type is external, bound, or a type parameter.
if con.type_spec_is_param(as.tp) then-- IMPL_INCLUDE::con TP_CONTEXT::type_spec_is_param IMPL_INCLUDE::as AS_INCLUDE_CLAUSE::tp
param_include_err(as); return void-- IMPL_INCLUDE::as
end;
r::=con.tp_of(as.tp,false); -- IMPL_INCLUDE::con TP_CONTEXT::tp_of IMPL_INCLUDE::as AS_INCLUDE_CLAUSE::tp
typecase r
when TP_CLASS then
if r.is_abstract then -- TP_CLASS::is_abstract
prog.err_loc(as); -- IMPL_INCLUDE::prog PROG::err_loc IMPL_INCLUDE::as
prog.err("Classes may not include abstract types."); -- IMPL_INCLUDE::prog PROG::err
return void end;
if r.is_external then -- TP_CLASS::is_external
include_ext_err(as); return void end; -- IMPL_INCLUDE::as
return r
when TP_ROUT then
include_bound_err(as); return void-- IMPL_INCLUDE::as
when TP_ITER then
include_bound_err(as); return void-- IMPL_INCLUDE::as
end
end;
param_include_err(t:$AS_CLASS_ELT) is
prog.err_loc(t);-- IMPL_INCLUDE::prog PROG::err_loc
prog.err("Type specifiers in include clauses may not be class "-- IMPL_INCLUDE::prog PROG::err
"parameters.") end;
include_ext_err(t:$AS_CLASS_ELT) is
prog.err_loc(t);-- IMPL_INCLUDE::prog PROG::err_loc
prog.err("Classes may not include external types.") end;-- IMPL_INCLUDE::prog PROG::err
include_bound_err(t:$AS_CLASS_ELT) is
-- Print an error message about including bound types.
prog.err_loc(t);-- IMPL_INCLUDE::prog PROG::err_loc
prog.err("Classes may not include bound types.") end;-- IMPL_INCLUDE::prog PROG::err
include_readonly_err(t:$AS_CLASS_ELT) is
-- Print an error message if a reader or writer (or both)
-- are missing for readonly features.
prog.err_loc(t);-- IMPL_INCLUDE::prog PROG::err_loc
prog.err("Both reader and writer routines must be present for readonly modifier"); -- IMPL_INCLUDE::prog PROG::err
end;
included_impl:IMPL
-- Compute the implementation `impl' of the included
-- type. Set the location for reporting an error in case a loop
-- is found.
is
prog.err_loc(as);-- IMPL_INCLUDE::prog PROG::err_loc IMPL_INCLUDE::as
itp_context ::= itp.tp_context_for;-- IMPL_INCLUDE::itp TP_CLASS::tp_context_for
subcon ::= #TP_CONTEXT(con.same,-- TP_CONTEXT::create IMPL_INCLUDE::con TP_CONTEXT::same
itp_context.pnames, itp_context.ptypes, prog);-- TP_CONTEXT::pnames TP_CONTEXT::ptypes IMPL_INCLUDE::prog
return IMPL_CREATE::impl_of( itp, subcon );-- IMPL_CREATE::impl_of IMPL_INCLUDE::itp
end;
test_array_err:BOOL is
-- Print an error message and return true if `tp' is a value type
-- and `itp' includes AREF or if `tp' is a reference type and
-- `itp' includes AVAL.
k:INT:=tp.kind;-- IMPL_INCLUDE::tp TP_CLASS::kind
if void(impl.arr) then return false end;-- IMPL_INCLUDE::impl IMPL::arr
if k=TP_KIND::val_tp and -- INT::is_eq TP_KIND::val_tp
impl.arr.name=IDENT_BUILTIN::AREF_ident then-- IMPL_INCLUDE::impl IMPL::arr TP_CLASS::name IDENT::is_eq IDENT_BUILTIN::AREF_ident
prog.err_loc(as); -- IMPL_INCLUDE::prog PROG::err_loc IMPL_INCLUDE::as
prog.err("The value type " + tp.str +-- IMPL_INCLUDE::prog PROG::err IMPL_INCLUDE::tp TP_CLASS::str
" may not have an include path to the reference array type " +-- STR::plus
impl.arr.str + '.');-- IMPL_INCLUDE::impl IMPL::arr TP_CLASS::str STR::plus
return true
elsif (k=TP_KIND::ref_tp or k=TP_KIND::spr_tp) and -- INT::is_eq TP_KIND::ref_tp INT::is_eq TP_KIND::spr_tp
impl.arr.name=IDENT_BUILTIN::AVAL_ident then-- IMPL_INCLUDE::impl IMPL::arr TP_CLASS::name IDENT::is_eq IDENT_BUILTIN::AVAL_ident
prog.err_loc(as); -- IMPL_INCLUDE::prog PROG::err_loc IMPL_INCLUDE::as
prog.err("The reference type " + tp.str +-- IMPL_INCLUDE::prog PROG::err IMPL_INCLUDE::tp TP_CLASS::str
" may not have an include path to the value array type " +-- STR::plus
impl.arr.str + '.');-- IMPL_INCLUDE::impl IMPL::arr TP_CLASS::str STR::plus
return true end;
return false end;
test_duplicate_feat_mod_err:BOOL is
-- If two feature modifiers have the same name then print
-- an error and return true, otherwise return false.
m1::=as.mods;-- IMPL_INCLUDE::as AS_INCLUDE_CLAUSE::mods
loop until!(void(m1));
m2::=as.mods;-- IMPL_INCLUDE::as AS_INCLUDE_CLAUSE::mods
loop until!(void(m2));
if ~SYS::ob_eq(m1,m2) and m1.name=m2.name then-- SYS::ob_eq BOOL::not AS_FEAT_MOD::name IDENT::is_eq AS_FEAT_MOD::name
prog.err_loc(m1);-- IMPL_INCLUDE::prog PROG::err_loc
prog.err("There are two feature modifiers for the name: " + -- IMPL_INCLUDE::prog PROG::err
m1.name.str + "."); -- STR::plus AS_FEAT_MOD::name IDENT::str STR::plus
return true end;
m2:=m2.next end;-- AS_FEAT_MOD::next
m1:=m1.next end;-- AS_FEAT_MOD::next
return false end;
modifier_for_name(i:IDENT):AS_FEAT_MOD is
-- Return the feature modifier in `as' for the name `i', or
-- void, if there isn't one for that name.
e::=as.mods;-- IMPL_INCLUDE::as AS_INCLUDE_CLAUSE::mods
loop until!(void(e)); if e.name=i then -- AS_FEAT_MOD::name IDENT::is_eq
used_mods:=used_mods.insert(e);-- IMPL_INCLUDE::used_mods IMPL_INCLUDE::used_mods FSET{1}::insert
return e;
end;
e:=e.next end;-- AS_FEAT_MOD::next
return void end;
included_elt_tbl:ELT_TBL is
-- The table of elements as transformeded by the new value of SAME
-- and any feature modification clauses.
r:ELT_TBL;
loop e::=impl.elts.elt!; en::=modify_elt(e);-- IMPL_INCLUDE::impl IMPL::elts ELT_TBL::elt! IMPL_INCLUDE::modify_elt
if ~void(en) then-- BOOL::not
f::=r.elt_conflicting_with(en);-- ELT_TBL::elt_conflicting_with
if ~void(f) then -- BOOL::not
include_conflict_err(en,f);-- IMPL_INCLUDE::include_conflict_err
else r:=r.insert(en) end end end;-- ELT_TBL::insert
if used_mods.size/=as.mods.size then-- IMPL_INCLUDE::used_mods FSET{1}::size IMPL_INCLUDE::as AS_INCLUDE_CLAUSE::mods AS_FEAT_MOD::size BOOL::not
m::=as.mods;-- IMPL_INCLUDE::as AS_INCLUDE_CLAUSE::mods
loop until!(void(m));
if ~used_mods.test(m) then unused_mod_err(m) end;-- IMPL_INCLUDE::used_mods FSET{1}::test BOOL::not IMPL_INCLUDE::unused_mod_err
m:=m.next end end;-- AS_FEAT_MOD::next
return r end;
include_conflict_err(en,f:ELT) is
prog.err_loc(as); -- IMPL_INCLUDE::prog PROG::err_loc IMPL_INCLUDE::as
prog.err("Two of the included signatures conflict: " +-- IMPL_INCLUDE::prog PROG::err
en.sig.str + " and " + f.sig.str + ".") end; -- STR::plus ELT::sig SIG::str STR::plus STR::plus ELT::sig SIG::str STR::plus
unused_mod_err(t:AS_FEAT_MOD) is
prog.err_loc(t);-- IMPL_INCLUDE::prog PROG::err_loc
prog.err("There are no features with the name: " + t.name.str -- IMPL_INCLUDE::prog PROG::err STR::plus AS_FEAT_MOD::name IDENT::str
+ ".") end;-- STR::plus
modify_elt(e:ELT):ELT
-- Make a new element from `e' by changing its name by the
-- modifiers in `as', by changing SAME to have the value
-- `tp', and by modifying `is_private' according to the include
-- clause and feature modifier. Make `srctp' be the old `srctp'.
-- Return void if an error or if the element is made to be undefined.
pre ~void(e) and ~void(con)-- BOOL::not IMPL_INCLUDE::con
is-- BOOL::not
--con::=#TP_CONTEXT(tp, e.con.pnames, e.con.ptypes, prog);
--if void(con) then return void end;
con ::= e.con; -- WARNING !!! SHADOWS CONTEXT OF IMPL_CREATE-- ELT::con
name:IDENT; read_pri:BOOL; write_pri:BOOL;
m::=modifier_for_name(e.name);-- IMPL_INCLUDE::modifier_for_name ELT::name
srcparams ::= e.srcsig.src_tparams;-- ELT::srcsig SIG::src_tparams
if ~void(m) then -- Have a matching modifier. -- BOOL::not
if m.new_name=#IDENT(void) then return void end; -- Feat undef.-- AS_FEAT_MOD::new_name IDENT::is_eq IDENT::create
name:=m.new_name; -- AS_FEAT_MOD::new_name
read_pri:=m.is_private; -- AS_FEAT_MOD::is_private
write_pri:=m.is_private or m.is_readonly;-- AS_FEAT_MOD::is_private AS_FEAT_MOD::is_readonly
-- if readonly, need to make sure that the included class
-- has both the reader and writer routines
if m.is_readonly then-- AS_FEAT_MOD::is_readonly
has_reader:BOOL := false;
has_writer:BOOL := false;
loop
elt::=impl.elts.get_query!(e.name);-- IMPL_INCLUDE::impl IMPL::elts ELT_TBL::get_query! ELT::name
es ::= elt.sig;-- ELT::sig
if es.is_reader_sig then-- SIG::is_reader_sig
has_reader := true;
elsif es.is_attr_writer_sig or es.is_shared_writer_sig then-- SIG::is_attr_writer_sig SIG::is_shared_writer_sig
has_writer := true;
end;
end;
if ~(has_reader and has_writer) then-- BOOL::not
include_readonly_err(as);-- IMPL_INCLUDE::as
return void;
end;
end;
else name:=e.name;-- ELT::name
read_pri:=as.is_private or e.is_private; -- IMPL_INCLUDE::as AS_INCLUDE_CLAUSE::is_private ELT::is_private
write_pri:=read_pri end;
sig:SIG; pri:BOOL;
eas::=e.as; typecase eas-- ELT::as
when AS_CONST_DEF then
sig:=SIG::const_reader_sig(eas,name,srcparams,con); pri:=read_pri;-- SIG::const_reader_sig
when AS_SHARED_DEF then
if e.is_shared_writer then -- ELT::is_shared_writer
sig:=SIG::shared_writer_sig(eas,name,srcparams,con);-- SIG::shared_writer_sig
pri:=write_pri;
else
sig:=SIG::shared_reader_sig(eas,name,srcparams,con);-- SIG::shared_reader_sig
pri:=read_pri end;
when AS_ATTR_DEF then
if e.is_attr_writer then -- ELT::is_attr_writer
sig:=SIG::attr_writer_sig(eas,name,srcparams,con); pri:=write_pri;-- SIG::attr_writer_sig
else
sig:=SIG::attr_reader_sig(eas,name,srcparams,con);-- SIG::attr_reader_sig
pri:=read_pri;
end;
when AS_ROUT_DEF then
sig:=SIG::rout_sig(eas,name,srcparams,con); -- SIG::rout_sig
-- if ``readonly'' feature modifier used, use read_pri for readers
-- and write_pri for writers
pri:=read_pri;
if ~void(m) then-- BOOL::not
if m.is_readonly then-- AS_FEAT_MOD::is_readonly
if ~sig.is_reader_sig then-- SIG::is_reader_sig BOOL::not
pri := write_pri;
end;
end;
end;
end;
if void(sig) then return void end;
return ELT::create(sig, e.srcsig, e.as, con, pri) end;-- ELT::create ELT::srcsig ELT::as
end; -- class IMPL_INCLUDE
class IMPL_CREATE
class IMPL_CREATE is
-- An object used while creating an interface.
attr tp:TP_CLASS; -- The type it is for.
attr is_external:BOOL; -- True if an external class.
attr con:TP_CONTEXT; -- The type context for tp.
attr as:AS_CLASS_DEF; -- The definition tree for tp.
attr class_elts:ELT_TBL; -- Table of the elements explicitly
-- defined by this class.
attr incs:FLIST{IMPL_INCLUDE}; -- A list of information
-- computed from each include clause.
create_for_tp_class(t:TP_CLASS): IMPL
-- Computes the implementation of type 't'.
pre ~void(t) and void(self)-- BOOL::not
is
if t.is_abstract then return void end;-- TP_CLASS::is_abstract
return impl_of(t,t.tp_context_for);-- IMPL_CREATE::impl_of TP_CLASS::tp_context_for
end;
impl_of(t:TP_CLASS,context:TP_CONTEXT):IMPL
-- Compute the implementation of the type `t'.
pre ~void(t)
is-- BOOL::not
if t.prog.show_impl_create then-- TP_CLASS::prog PROG::show_impl_create
#OUT + "(Impl create " + t.str + ") Context = " + context.str +"\n"-- OUT::create OUT::plus OUT::plus TP_CLASS::str OUT::plus OUT::plus TP_CONTEXT::str
end;-- OUT::plus
ic:IMPL_CREATE:=new; ic.tp:=t;-- IMPL_CREATE::tp
ic.is_external:=t.is_external;-- IMPL_CREATE::is_external TP_CLASS::is_external
ic.con:=context;-- IMPL_CREATE::con
if void(ic.con) then return void end;-- IMPL_CREATE::con
ic.as:=ic.prog.parse.tree_for(t.name,t.params.size);-- IMPL_CREATE::as IMPL_CREATE::prog PROG::parse TP_CLASS::name TP_CLASS::params ARRAY{1}::size
if void(ic.as) then return void end;-- IMPL_CREATE::as
ic.class_elts:=ic.explicit_class_elts;-- IMPL_CREATE::class_elts IMPL_CREATE::explicit_class_elts
ic.do_incs;-- IMPL_CREATE::do_incs
r::=#IMPL; r.tp:=t; -- IMPL::create IMPL::tp
r.arr:=ic.get_arr; -- IMPL::arr IMPL_CREATE::get_arr
r.elts:=ic.elt_tbl;-- IMPL::elts IMPL_CREATE::elt_tbl
r.ifc:=r.elts.public_ifc;-- IMPL::ifc IMPL::elts ELT_TBL::public_ifc
if void(r.ifc) then r.ifc:=IFC::create(void,t) end;-- IMPL::ifc IMPL::ifc IFC::create
return r end;
prog:PROG is
-- The program this belongs to.
return tp.prog end;-- IMPL_CREATE::tp TP_CLASS::prog
explicit_class_elts:ELT_TBL is
-- A table of class elements explicit defined in the class
-- (i.e. ignoring "include" clauses). Prints an error
-- if features with conflicting signatures are defined.
t:$AS_CLASS_ELT:=as.body; r:ELT_TBL;-- IMPL_CREATE::as AS_CLASS_DEF::body
loop while!(~void(t)); -- BOOL::not
er:ELT:=reader_elt_for(t);-- IMPL_CREATE::reader_elt_for
if ~void(er) then-- BOOL::not
if is_external then-- IMPL_CREATE::is_external
f:ELT:=r.elt_same_name_as(er);-- ELT_TBL::elt_same_name_as
if ~void(f) then ext_conflict_err(er,f)-- BOOL::not IMPL_CREATE::ext_conflict_err
else r:=r.insert(er) end;-- ELT_TBL::insert
else
f:ELT:=r.elt_conflicting_with(er);-- ELT_TBL::elt_conflicting_with
if ~void(f) then reader_conflict_err(er,f)-- BOOL::not IMPL_CREATE::reader_conflict_err
else r:=r.insert(er) end end end; -- ELT_TBL::insert
ew:ELT:=writer_elt_for(t);-- IMPL_CREATE::writer_elt_for
if ~void(ew) then-- BOOL::not
f:ELT:=r.elt_conflicting_with(ew);-- ELT_TBL::elt_conflicting_with
if ~void(f) then writer_conflict_err(ew,f)-- BOOL::not IMPL_CREATE::writer_conflict_err
else r:=r.insert(ew) end end;-- ELT_TBL::insert
t:=t.next;
end;
return r end;
reader_conflict_err(er,f:ELT) is
prog.err_loc(er.as);-- IMPL_CREATE::prog PROG::err_loc ELT::as
prog.err("The signature: " + er.sig.str +-- IMPL_CREATE::prog PROG::err STR::plus ELT::sig SIG::str
" of the reader routine for this feature conflicts with "
"the earlier feature signature: " + f.sig.str + '.') end;-- STR::plus STR::plus ELT::sig SIG::str STR::plus
ext_conflict_err(er,f:ELT) is
prog.err_loc(er.as);-- IMPL_CREATE::prog PROG::err_loc ELT::as
prog.err("The signature: " + er.sig.str +-- IMPL_CREATE::prog PROG::err STR::plus ELT::sig SIG::str
" has the same name as the earlier feature signature: " +-- STR::plus
f.sig.str + " in an external class.") end;-- STR::plus ELT::sig SIG::str STR::plus
writer_conflict_err(ew,f:ELT) is
prog.err_loc(ew.as);-- IMPL_CREATE::prog PROG::err_loc ELT::as
prog.err("The signature: " + ew.sig.str +-- IMPL_CREATE::prog PROG::err STR::plus ELT::sig SIG::str
" of the writer routine for this feature conflicts with "
"the earlier feature signature: " + f.sig.str + '.') end;-- STR::plus STR::plus ELT::sig SIG::str STR::plus
reader_elt_for(t:$AS_CLASS_ELT):ELT
-- The "reader" elt corresponding to `t' if there is one,
-- void if not.
pre ~void(t) is-- BOOL::not
sig:SIG; r:ELT;
typecase t
when AS_CONST_DEF then
if is_external then prog.err_loc(t);-- IMPL_CREATE::is_external IMPL_CREATE::prog PROG::err_loc
prog.err("External classes may not define constants.");-- IMPL_CREATE::prog PROG::err
return void end;
sig:=SIG::const_reader_sig(t,t.name,con.ptypes,con)-- SIG::const_reader_sig AS_CONST_DEF::name IMPL_CREATE::con TP_CONTEXT::ptypes IMPL_CREATE::con
when AS_SHARED_DEF then
if is_external then prog.err_loc(t);-- IMPL_CREATE::is_external IMPL_CREATE::prog PROG::err_loc
prog.err("External classes may not define shareds.");-- IMPL_CREATE::prog PROG::err
return void end;
sig:=SIG::shared_reader_sig(t,t.name,con.ptypes,con)-- SIG::shared_reader_sig AS_SHARED_DEF::name IMPL_CREATE::con TP_CONTEXT::ptypes IMPL_CREATE::con
when AS_ATTR_DEF then
if is_external then prog.err_loc(t);-- IMPL_CREATE::is_external IMPL_CREATE::prog PROG::err_loc
prog.err("External classes may not define attributes.");-- IMPL_CREATE::prog PROG::err
return void end;
sig:=SIG::attr_reader_sig(t,t.name,con.ptypes,con)-- SIG::attr_reader_sig AS_ATTR_DEF::name IMPL_CREATE::con TP_CONTEXT::ptypes IMPL_CREATE::con
when AS_ROUT_DEF then
sig:=SIG::rout_sig(t,t.name,con.ptypes,con);-- SIG::rout_sig AS_ROUT_DEF::name IMPL_CREATE::con TP_CONTEXT::ptypes IMPL_CREATE::con
if t.is_abstract then-- AS_ROUT_DEF::is_abstract
if is_external then-- IMPL_CREATE::is_external
if ~sig.is_legal_ext_abs then return void end;-- SIG::is_legal_ext_abs BOOL::not
r:=ELT::create(sig,sig,t,con,t.is_private); -- ELT::create IMPL_CREATE::con AS_ROUT_DEF::is_private
r.is_external:=true; return r-- ELT::is_external
elsif ~tp.is_partial then-- IMPL_CREATE::tp TP_CLASS::is_partial BOOL::not
prog.err_loc(t);-- IMPL_CREATE::prog PROG::err_loc
prog.err("Only external classes may have routines "-- IMPL_CREATE::prog PROG::err
"without bodies."); return void end;
elsif is_external then-- IMPL_CREATE::is_external
if ~sig.is_legal_ext_bod then return void end;-- SIG::is_legal_ext_bod BOOL::not
r:=#ELT(sig,sig,t,con,t.is_private); -- ELT::create IMPL_CREATE::con AS_ROUT_DEF::is_private
r.is_external:=true; return r end;-- ELT::is_external
else return void end; -- Nothing for includes
if void(sig) then return void end;
r:=#ELT(sig,sig,t,con,t.is_private);-- ELT::create IMPL_CREATE::con
return r end;
writer_elt_for(t:$AS_CLASS_ELT):ELT is
-- The "writer" elt corresponding to `t' if there is one,
-- void if not.
sig:SIG; pri:BOOL;
if is_external then return void end; -- Already complained at reader.-- IMPL_CREATE::is_external
typecase t
when AS_SHARED_DEF then
sig:=SIG::shared_writer_sig(t,t.name,con.ptypes,con);-- SIG::shared_writer_sig AS_SHARED_DEF::name IMPL_CREATE::con TP_CONTEXT::ptypes IMPL_CREATE::con
pri:=t.is_private or t.is_readonly; -- AS_SHARED_DEF::is_private AS_SHARED_DEF::is_readonly
when AS_ATTR_DEF then
sig:=SIG::attr_writer_sig(t,t.name,con.ptypes,con); -- SIG::attr_writer_sig AS_ATTR_DEF::name IMPL_CREATE::con TP_CONTEXT::ptypes IMPL_CREATE::con
pri:=t.is_private or t.is_readonly; -- AS_ATTR_DEF::is_private AS_ATTR_DEF::is_readonly
else return void end;
if void(sig) then return void end;
return ELT::create(sig,sig,t,con,pri) end;-- ELT::create IMPL_CREATE::con
do_incs is
-- Compute and fill in `incs' with information computed from
-- each include statement in `tp'.
e:$AS_CLASS_ELT:=as.body;-- IMPL_CREATE::as AS_CLASS_DEF::body
loop while!(~void(e));-- BOOL::not
typecase e
when AS_INCLUDE_CLAUSE then
if is_external then prog.err_loc(e);-- IMPL_CREATE::is_external IMPL_CREATE::prog PROG::err_loc
prog.err("External classes may not have include clauses.");-- IMPL_CREATE::prog PROG::err
else
ii::=IMPL_INCLUDE::create(tp, e, con);-- IMPL_INCLUDE::create IMPL_CREATE::tp IMPL_CREATE::con
if ~void(ii) then incs:=incs.push(ii) end end;-- BOOL::not IMPL_CREATE::incs IMPL_CREATE::incs FLIST{1}::push
else end;
e:=e.next end end;
get_arr:TP_CLASS is
-- If we include AREF{T} or AVAL{T} or any class which includes
-- one of these return it. If we include more than one and they
-- are different, then print an error.
if tp.name=IDENT_BUILTIN::AREF_ident and tp.params.size=1 then -- IMPL_CREATE::tp TP_CLASS::name IDENT::is_eq IDENT_BUILTIN::AREF_ident IMPL_CREATE::tp TP_CLASS::params ARRAY{1}::size INT::is_eq
return tp end;-- IMPL_CREATE::tp
if tp.name=IDENT_BUILTIN::AVAL_ident and tp.params.size=1 then -- IMPL_CREATE::tp TP_CLASS::name IDENT::is_eq IDENT_BUILTIN::AVAL_ident IMPL_CREATE::tp TP_CLASS::params ARRAY{1}::size INT::is_eq
return tp end; -- IMPL_CREATE::tp
r:TP_CLASS;
loop
inc::=incs.elt!;-- IMPL_CREATE::incs FLIST{1}::elt!
a::=inc.impl.arr;-- IMPL_INCLUDE::impl IMPL::arr
if ~void(a) then-- BOOL::not
if void(r) then r:=a;
elsif r=a then -- They agree.-- TP_CLASS::is_eq
else
array_conflict_err(inc,r,a)-- IMPL_CREATE::array_conflict_err
end
end
end;
return r
end;
array_conflict_err(inc:IMPL_INCLUDE, a1,a2:TP_CLASS) is
prog.err_loc(inc.as);-- IMPL_CREATE::prog PROG::err_loc IMPL_INCLUDE::as
prog.err("This class has include paths to the array types: " +-- IMPL_CREATE::prog PROG::err
a1.str + " and " + a2.str + '.') end;-- STR::plus TP_CLASS::str STR::plus STR::plus TP_CLASS::str STR::plus
elt_tbl:ELT_TBL is
-- Compute the final element table for the class. Print an error
-- if there is a conflict.
r:ELT_TBL;
loop r:=r.insert(class_elts.elt!) end;-- ELT_TBL::insert IMPL_CREATE::class_elts ELT_TBL::elt!
loop while!(incs.is_empty.not); inc::=incs.pop; -- IMPL_CREATE::incs FLIST{1}::is_empty BOOL::not IMPL_CREATE::incs FLIST{1}::pop
loop e::=inc.elt_tbl.elt!;-- IMPL_INCLUDE::elt_tbl ELT_TBL::elt!
f::=r.elt_conflicting_with(e);-- ELT_TBL::elt_conflicting_with
-- DPS: added "and ~f.is_ATTR_access" below
if ~void(f) and e.is_attr_access and ~f.is_attr_access then-- BOOL::not ELT::is_attr_access ELT::is_attr_access BOOL::not
attr_conflict_err(e,f,inc) end;-- IMPL_CREATE::attr_conflict_err
if void(f) and ~tp.is_partial and ~tp.is_abstract and-- IMPL_CREATE::tp TP_CLASS::is_partial BOOL::not IMPL_CREATE::tp TP_CLASS::is_abstract BOOL::not
~tp.is_external and e.is_abstract then-- IMPL_CREATE::tp TP_CLASS::is_external BOOL::not ELT::is_abstract
-- need to check included elements to make sure the
-- stub is not implemented
found:BOOL := false;
loop
inc2::=incs.elt!;-- IMPL_CREATE::incs FLIST{1}::elt!
g::=inc2.elt_tbl.elt_conflicting_with(e);-- IMPL_INCLUDE::elt_tbl ELT_TBL::elt_conflicting_with
if ~void(g) and ~g.is_abstract then-- BOOL::not ELT::is_abstract BOOL::not
found := true;
end;
end;
if ~found then-- BOOL::not
undef_stub_err(e, inc);-- IMPL_CREATE::undef_stub_err
end;
end;
if void(f) and (~e.is_abstract or tp.is_abstract or -- ELT::is_abstract BOOL::not IMPL_CREATE::tp TP_CLASS::is_abstract
tp.is_partial ) then-- IMPL_CREATE::tp TP_CLASS::is_partial
-- Abstract routines don't go into
-- non-abstract or partial classes
-- and also aren't tested for conflict in this case.
loop inc2::=incs.elt!;-- IMPL_CREATE::incs FLIST{1}::elt!
g::=inc2.elt_tbl.elt_conflicting_with(e);-- IMPL_INCLUDE::elt_tbl ELT_TBL::elt_conflicting_with
if ~void(g) then -- BOOL::not
-- stubs don't cause a conflict error when
-- colliding with implemented included features
if ~((inc.itp.is_partial and e.is_abstract) or-- IMPL_INCLUDE::itp TP_CLASS::is_partial ELT::is_abstract
(inc2.itp.is_partial and g.is_abstract)) then -- IMPL_INCLUDE::itp TP_CLASS::is_partial ELT::is_abstract BOOL::not
include_conflict_err(inc,inc2,e,g) -- IMPL_CREATE::include_conflict_err
end;
end;
end;
r:=r.insert(e) end end end;-- ELT_TBL::insert
return r end;
attr_conflict_err(e,f:ELT, inc:IMPL_INCLUDE) is
prog.err_loc(f.as);-- IMPL_CREATE::prog PROG::err_loc ELT::as
prog.err("This explicitly defined routine conflicts with "-- IMPL_CREATE::prog PROG::err
"the attribute access routine: " + e.sig.str + -- STR::plus ELT::sig SIG::str
" which is included from " + inc.itp.str + ".") end;-- STR::plus STR::plus IMPL_INCLUDE::itp TP_CLASS::str STR::plus
undef_stub_err(e:ELT, inc:IMPL_INCLUDE) is
prog.err_loc(as);-- IMPL_CREATE::prog PROG::err_loc IMPL_CREATE::as
prog.err("Unimplemented stub: " + e.sig.str + -- IMPL_CREATE::prog PROG::err STR::plus ELT::sig SIG::str
" which is included from " + inc.itp.str + ".") -- STR::plus STR::plus IMPL_INCLUDE::itp TP_CLASS::str STR::plus
end;
include_conflict_err(inc,inc2:IMPL_INCLUDE, e,g:ELT) is
prog.err_loc(inc.as);-- IMPL_CREATE::prog PROG::err_loc IMPL_INCLUDE::as
prog.err("This includes the feature: " + e.sig.str + -- IMPL_CREATE::prog PROG::err STR::plus ELT::sig SIG::str
" which conflicts with: " + g.sig.str + -- STR::plus STR::plus ELT::sig SIG::str
" which is included from: " + inc2.itp.str + ".") end; -- STR::plus STR::plus IMPL_INCLUDE::itp TP_CLASS::str STR::plus
end; -- class IMPL_CREATE