home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
OS/2 Shareware BBS: 10 Tools
/
10-Tools.zip
/
sa104os2.zip
/
SATHR104.ZIP
/
SATHER
/
COMPILER
/
IMPL.SA
< prev
next >
Wrap
Text File
|
1995-02-13
|
24KB
|
623 lines
-- 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 is
-- 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
-- include path to one of them, or void if not.
prog:PROG is
-- The program this belongs to.
return tp.prog end;
create_for_tp(t:$TP):SAME
-- Compute the interface of the type `t'.
pre ~void(t) is
typecase t
when TP_CLASS then
if t.is_abstract then
prog.err(
"Compiler error: Implementation requested for abstract type " +
t.str);
return void end;
return IMPL_CREATE::impl_of(t)
else
t.prog.err("Compiler error: IMPL requested for non class type.");
-- return void end end; -- NLP
end; return void; end; -- NLP
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
r:SIG;
loop s::=elts.get_query!(c.name).sig;
if c.conforms_to(s) then
if void(r) then r:=s
else c.prog.err("The internal call " + c.str +
" matches both the features: " + r.str +
" and " + s.str + ".") end end end;
if void(r) then
c.prog.err("No match for the internal call " + c.str + ".") 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;
has_invariant:BOOL is
-- True if this implementation defines a routine: `invariant:BOOL'.
loop
if elts.get_query!(
prog.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!(
prog.ident_builtin.invariant_ident);
if e.is_invariant then return e.sig end end;
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!(prog.ident_builtin.asize_ident);
if asze.is_const_reader and
prog.tp_builtin.int=asze.sig.ret then
return 32
-- *** Have to fix this to read the const value!
else return -1 end end;
return -1; -- added this ???
end;
am_ob_def:AM_OB_DEF
-- An object layout object for this interface.
pre ~void(self) is
r::=#AM_OB_DEF(void); r.tp:=tp;
if ~void(arr) then a::=arr;
typecase a when TP_CLASS then r.arr:=a.params[0] end end;
r.asize:=asize_val;
loop e::=elts.elt!;
if e.is_attr_reader then
r.at:=r.at.insert(e.sig.name,e.sig.ret) end end;
return r end;
is_atomic:BOOL pre ~void(self) is
-- return true if we can be allocated atomically.
loop e::= elts.elt!;
if e.is_attr_reader then
atp::=e.sig.ret; -- the type of this attribute.
if ~(atp.is_value) then
-- 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";
return false;
end;
if ~(atp.is_atomic) then
--#ERR + tp.str + " is non-atomic because value attribute "
--+e.sig.str+" is not atomic\n";
return false;
end;
end;
end;
-- now we check included AREF{T} or AVAL{T}.
if void(arr) then
-- guess it's OK
--#ERR + tp.str + " looks atomic with no included AREF/AVAL\n";
return true;
else
-- now we need implementation of array portion to find out
-- it's type parameter.
if void(arr.params) then
--#ERR + "Void parameter list in inclusion of AREF{T}\n";
return false;
elsif arr.params.asize /= 1 then
--#ERR + "Funny, >1 type param found in AREF{T} atomic checking.\n";
return false;
else
tparam ::= arr.params[0];
if ~(tparam.is_value) then
--#ERR + tp.str + " is non-atomic because included array param "
--+ " is not value type.\n";
return false;
elsif ~(tparam.is_atomic) then
--#ERR + tp.str + " is non-atomic because included value" +
--" array param is not atomic.\n";
return false;
else
--#ERR + tp.str + " looks atomic with atomic AREF/AVAL.\n";
return true;
end;
end;
end;
return true; -- NLP
end;
end; -- class IMPL
-------------------------------------------------------------------
class IMPL_TBL is
-- A table of implementations indexed by type.
attr prog:PROG; -- The program this is for.
attr tbl:FMAP{$TP,IMPL}; -- The table mapping types to their
-- implementations.
attr cur:FSET{TUP{IDENT,INT}}; -- The set of class names and number
-- of parameters which are currently having their implementations
-- worked out.
create(p:PROG):SAME is
-- A new table for the program `p'.
r::=new; r.prog:=p; return r end;
impl_of(t:$TP):IMPL
-- The implementation corresponding to arg. Void if not computable.
-- Any caller of this should set the appropriate error location.
pre ~void(t) is
r::=tbl.get(t); if ~void(r) then return r end;
typecase t
when TP_CLASS then
if t.is_abstract then
prog.err("Compiler error, IMPL_TBL::impl_of(" + t.str + ").");
return void end;
if cur.test(#(t.name, t.params.size)) then
cycle_err; cur:=cur.clear; return void
else cur:=cur.insert(#(t.name,t.params.size));
r:=IMPL::create_for_tp(t); tbl:=tbl.insert(t,r);
cur:=cur.delete(#(t.name,t.params.size)); return r end;
when TP_ROUT then
prog.err("Compiler error, IMPL_TBL::impl_of(" + t.str + ").");
return void
when TP_ITER then
prog.err("Compiler error, IMPL_TBL::impl_of(" + t.str + ").");
-- return void end end; -- NLP
return void end; return void; end; -- NLP
tup_str(t:TUP{IDENT,INT}):STR is
-- A string for the specified type of the form "FOO{_,_,_}".
r::=t.t1.str;
if t.t2=0 then return r end;
r:=r+"{";
loop t.t2.times!; r:=r+",".separate!("_") end;
r:=r+"}"; return r end;
cycle_err is
-- Print an error message about a cycle of include type names.
s:STR:="Cycle detected in `include' clauses involving the types: ";
loop s:=s + ", ".separate!(tup_str(cur.elt!)) end;
prog.err(s) end;
end; -- class IMPL_TBL
-------------------------------------------------------------------
class IMPL_INCLUDE is
-- Information for handling an `include' clause.
attr tp:TP_CLASS; -- The type with the include clause.
attr tr:TR_INCLUDE_CLAUSE; -- The include clause.
attr itp:TP_CLASS; -- The included type.
attr impl:IMPL; -- The implementation of `itp'.
attr used_mods:FSET{TR_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;
create(tp:TP_CLASS, tr:TR_INCLUDE_CLAUSE):SAME
-- Compute the "include" information corresponding to the clause
-- `tr' within the definition of the type `tp'. If there
-- is an error, return void.
pre ~void(tp) and ~void(tr) is
r::=new; r.tp:=tp; r.tr:=tr;
r.itp:=r.included_tp;
if void(r.itp) then return void end;
if tp.prog.show_include then
#OUT + "(Including " + r.itp.str + " in " +
tp.str + ") " end;
r.impl:=r.included_impl;
if void(r.impl) then return void end;
if r.test_array_err then return void end;
if r.test_duplicate_feat_mod_err then return void end;
r.elt_tbl:=r.included_elt_tbl;
if void(r.elt_tbl) then return void end;
return r end;
included_tp:TP_CLASS is
-- Compute the type which is included by the clause `tr' in
-- the type `tp'. Print an error and return void if the included
-- type is external, bound, or a type parameter.
con:TP_CONTEXT:=prog.tp_context_for(tp);
if con.type_spec_is_param(tr.tp) then
param_include_err(tr); return void end;
r::=con.tp_of(tr.tp);
typecase r
when TP_CLASS then
if r.is_abstract then
prog.err_loc(tr);
prog.err("Classes may not include abstract types.");
return void end;
if prog.tp_kind(r)=TP_KIND::ext_tp then
include_ext_err(tr); return void end;
return r
when TP_ROUT then
include_bound_err(tr); return void
when TP_ITER then
-- include_bound_err(tr); return void end end; -- NLP
include_bound_err(tr); return void end; return void; end; -- NLP
param_include_err(t:$TR_CLASS_ELT) is
prog.err_loc(t);
prog.err("Type specifiers in include clauses may not be class "
"parameters.") end;
include_ext_err(t:$TR_CLASS_ELT) is
prog.err_loc(t);
prog.err("Classes may not include external types.") end;
include_bound_err(t:$TR_CLASS_ELT) is
-- Print an error message about including bound types.
prog.err_loc(t);
prog.err("Classes may not include bound types.") end;
included_impl:IMPL is
-- Compute the implementation `impl' of the included
-- type. Set the location for reporting an error in case a loop
-- is found.
prog.err_loc(tr); return prog.impl_tbl.impl_of(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:=prog.tp_kind(tp);
if void(impl.arr) then return false end;
if k=TP_KIND::val_tp and
impl.arr.name=prog.ident_builtin.AREF_ident then
prog.err_loc(tr);
prog.err("The value type " + tp.str +
" may not have an include path to the reference array type " +
impl.arr.str + '.');
return true
elsif k=TP_KIND::ref_tp and
impl.arr.name=prog.ident_builtin.AVAL_ident then
prog.err_loc(tr);
prog.err("The reference type " + tp.str +
" may not have an include path to the value array type " +
impl.arr.str + '.');
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::=tr.mods;
loop until!(void(m1));
m2::=tr.mods;
loop until!(void(m2));
if ~SYS::ob_eq(m1,m2) and m1.name=m2.name then
prog.err_loc(m1);
prog.err("There are two feature modifiers for the name: " +
m1.name.str + ".");
return true end;
m2:=m2.next end;
m1:=m1.next end;
return false end;
modifier_for_name(i:IDENT):TR_FEAT_MOD is
-- Return the feature modifier in `tr' for the name `i', or
-- void, if there isn't one for that name.
e::=tr.mods;
loop until!(void(e)); if e.name=i then
used_mods:=used_mods.insert(e); return e end;
e:=e.next end;
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);
if ~void(en) then
f::=r.elt_conflicting_with(en);
if ~void(f) then include_conflict_err(en,f)
else r:=r.insert(en) end end end;
if used_mods.size/=tr.mods.size then
m::=tr.mods;
loop until!(void(m));
if ~used_mods.test(m) then unused_mod_err(m) end;
m:=m.next end end;
return r end;
include_conflict_err(en,f:ELT) is
prog.err_loc(tr);
prog.err("Two of the included signatures conflict: " +
en.sig.str + " and " + f.sig.str + ".") end;
unused_mod_err(t:TR_FEAT_MOD) is
prog.err_loc(t);
prog.err("There are no features with the name: " + t.name.str
+ ".") end;
modify_elt(e:ELT):ELT
-- Make a new element from `e' by changing its name by the
-- modifiers in `tr', 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) is
con::=#TP_CONTEXT(tp, e.con.pnames, e.con.ptypes, prog);
if void(con) then return void end;
name:IDENT; read_pri:BOOL; write_pri:BOOL;
m::=modifier_for_name(e.name);
if ~void(m) then -- Have a matching modifier.
if m.new_name=#IDENT(void) then return void end; -- Feat undef.
name:=m.new_name;
read_pri:=m.is_private;
write_pri:=m.is_private or m.is_readonly;
else name:=e.name;
read_pri:=tr.is_private or e.is_private;
write_pri:=read_pri end;
sig:SIG; pri:BOOL;
etr::=e.tr; typecase etr
when TR_CONST_DEF then
sig:=SIG::const_reader_sig(etr,name,con); pri:=read_pri;
when TR_SHARED_DEF then
if e.is_shared_writer then
sig:=SIG::shared_writer_sig(etr,name,con); pri:=write_pri;
else
sig:=SIG::shared_reader_sig(etr,name,con); pri:=read_pri end;
when TR_ATTR_DEF then
if e.is_attr_writer then
sig:=SIG::attr_writer_sig(etr,name,con); pri:=write_pri;
else
sig:=SIG::attr_reader_sig(etr,name,con); pri:=read_pri end;
when TR_ROUT_DEF then
sig:=SIG::rout_sig(etr,name,con); pri:=read_pri
end;
if void(sig) then return void end;
return ELT::create(sig, e.srcsig, e.tr, con, pri) end;
end; -- class IMPL_INCLUDE
-------------------------------------------------------------------
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 tr:TR_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.
impl_of(t:TP_CLASS):IMPL
-- Compute the implementation of the type `t'.
pre ~void(t) is
if t.prog.show_impl_create then
#OUT + "(Impl create " + t.str + ") " end;
ic:IMPL_CREATE:=new; ic.tp:=t;
ic.is_external:=(t.prog.tp_kind(t)=TP_KIND::ext_tp);
ic.con:=ic.prog.tp_context_for(t);
if void(ic.con) then return void end;
ic.tr:=ic.prog.tree_for(t.name,t.params.size);
if void(ic.tr) then return void end;
ic.class_elts:=ic.explicit_class_elts;
ic.do_incs;
r::=#IMPL; r.tp:=t;
r.arr:=ic.get_arr;
r.elts:=ic.elt_tbl;
r.ifc:=r.elts.public_ifc;
if void(r.ifc) then r.ifc:=IFC::create(void,t) end;
return r end;
prog:PROG is
-- The program this belongs to.
return tp.prog end;
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:$TR_CLASS_ELT:=tr.body; r:ELT_TBL;
loop while!(~void(t));
er:ELT:=reader_elt_for(t);
if ~void(er) then
if is_external then
f:ELT:=r.elt_same_name_as(er);
if ~void(f) then ext_conflict_err(er,f)
else r:=r.insert(er) end;
else
f:ELT:=r.elt_conflicting_with(er);
if ~void(f) then reader_conflict_err(er,f)
else r:=r.insert(er) end end end;
ew:ELT:=writer_elt_for(t);
if ~void(ew) then
f:ELT:=r.elt_conflicting_with(ew);
if ~void(f) then writer_conflict_err(ew,f)
else r:=r.insert(ew) end end;
t:=t.next;
end;
return r end;
reader_conflict_err(er,f:ELT) is
prog.err_loc(er.tr);
prog.err("The signature: " + er.sig.str +
" of the reader routine for this feature conflicts with "
"the earlier feature signature: " + f.sig.str + '.') end;
ext_conflict_err(er,f:ELT) is
prog.err_loc(er.tr);
prog.err("The signature: " + er.sig.str +
" has the same name as the earlier feature signature: " +
f.sig.str + " in an external class.") end;
writer_conflict_err(ew,f:ELT) is
prog.err_loc(ew.tr);
prog.err("The signature: " + ew.sig.str +
" of the writer routine for this feature conflicts with "
"the earlier feature signature: " + f.sig.str + '.') end;
reader_elt_for(t:$TR_CLASS_ELT):ELT
-- The "reader" elt corresponding to `t' if there is one,
-- void if not.
pre ~void(t) is
sig:SIG; r:ELT;
typecase t
when TR_CONST_DEF then
if is_external then prog.err_loc(t);
prog.err("External classes may not define constants.");
return void end;
sig:=SIG::const_reader_sig(t,t.name,con)
when TR_SHARED_DEF then
if is_external then prog.err_loc(t);
prog.err("External classes may not define shareds.");
return void end;
sig:=SIG::shared_reader_sig(t,t.name,con)
when TR_ATTR_DEF then
if is_external then prog.err_loc(t);
prog.err("External classes may not define attributes.");
return void end;
sig:=SIG::attr_reader_sig(t,t.name,con)
when TR_ROUT_DEF then
sig:=SIG::rout_sig(t,t.name,con);
if t.is_abstract then
if is_external then
if ~sig.is_legal_ext_abs then return void end;
r:=ELT::create(sig,sig,t,con,t.is_private);
r.is_external:=true; return r
else prog.err_loc(t);
prog.err("Only external classes may have routines "
"without bodies."); return void end;
elsif is_external then
if ~sig.is_legal_ext_bod then return void end;
r:=#ELT(sig,sig,t,con,t.is_private);
r.is_external:=true; return r end;
else return void end; -- Nothing for includes
if void(sig) then return void end;
r:=#ELT(sig,sig,t,con,t.is_private);
return r end;
writer_elt_for(t:$TR_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.
typecase t
when TR_SHARED_DEF then
sig:=SIG::shared_writer_sig(t,t.name,con);
pri:=t.is_private or t.is_readonly;
when TR_ATTR_DEF then
sig:=SIG::attr_writer_sig(t,t.name,con);
pri:=t.is_private or t.is_readonly;
else return void end;
if void(sig) then return void end;
return ELT::create(sig,sig,t,con,pri) end;
do_incs is
-- Compute and fill in `incs' with information computed from
-- each include statement in `tp'.
e:$TR_CLASS_ELT:=tr.body;
loop while!(~void(e));
typecase e
when TR_INCLUDE_CLAUSE then
if is_external then prog.err_loc(e);
prog.err("External classes may not have include clauses.");
else
ii::=IMPL_INCLUDE::create(tp, e);
if ~void(ii) then incs:=incs.push(ii) end end;
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=prog.ident_builtin.AREF_ident and tp.params.size=1 then
return tp end;
if tp.name=prog.ident_builtin.AVAL_ident and tp.params.size=1 then
return tp end;
r:TP_CLASS;
loop inc::=incs.elt!; a::=inc.impl.arr;
if ~void(a) then
if void(r) then r:=a;
elsif r=a then -- They agree.
else
array_conflict_err(inc,r,a) end end end;
return r end;
array_conflict_err(inc:IMPL_INCLUDE, a1,a2:TP_CLASS) is
prog.err_loc(inc.tr);
prog.err("This class has include paths to the array types: " +
a1.str + " and " + a2.str + '.') end;
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;
loop while!(incs.is_empty.not); inc::=incs.pop;
loop e::=inc.elt_tbl.elt!;
f::=r.elt_conflicting_with(e);
-- DPS: added "and ~f.is_attr_access" below
if ~void(f) and e.is_attr_access and ~f.is_attr_access then
attr_conflict_err(e,f,inc) end;
if void(f) and (~e.is_abstract or tp.is_abstract) then
-- Abstract routines don't go into non-abstract classes
-- and also aren't tested for conflict in this case.
loop inc2::=incs.elt!;
g::=inc2.elt_tbl.elt_conflicting_with(e);
if ~void(g) then include_conflict_err(inc,inc2,e,g) end;
end;
r:=r.insert(e) end end end;
return r end;
attr_conflict_err(e,f:ELT, inc:IMPL_INCLUDE) is
prog.err_loc(f.tr);
prog.err("This explicitly defined routine conflicts with "
"the attribute access routine: " + e.sig.str +
" which is included from " + inc.itp.str + ".") end;
include_conflict_err(inc,inc2:IMPL_INCLUDE, e,g:ELT) is
prog.err_loc(inc.tr);
prog.err("This includes the feature: " + e.sig.str +
" which conflicts with: " + g.sig.str +
" which is included from: " + inc2.itp.str + ".") end;
end; -- class IMPL_CREATE
-------------------------------------------------------------------