tp.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, 1995. 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. <----------
-- tp.sa: Classes relating to types in the Sather compiler.
-- $TP: Abstract interface to Sather types.
-- TP_CLASS: Reference, immutable, abstract, or external types.
-- TP_ROUT: Bound routine types.
-- TP_ITER: Bound iter types.
-- TP_CONTEXT: Context for AS_TYPE_SPEC -> $TP conversion.
-- TP_TBL: Table of all types.
-- TP_CLASS_TBL: Table of class types.
-- TP_ROUT_TBL: Table of bound routine types.
-- TP_ITER_TBL: Table of bound iter types.
-- TP_GRAPH: Computes the type graph.
-- TP_GRAPH_ABS_DES: Table of all concrete decendants of a given type.
-- TP_BUILTIN: Cache of the type objects for builtin types.
abstract class $TP < $CALL_TP, $IS_LT{$TP}, $STR, $HASH
abstract class $TP < $CALL_TP, $IS_LT{$TP}, $STR, $HASH is
-- Abstract interface to classes representing Sather types.
-- Descendants are TP_CLASS, TP_ROUT, and TP_ITER.
prog:PROG; -- This type's program object.
str:STR; -- The string representation of self.
-- Uses no whitespace, eg: "FOO{A,B{C},D}".
is_abstract:BOOL; -- True if self is abstract.
is_immutable:BOOL; -- True is self is an immutable type.
is_partial:BOOL; -- True if self is a partial class
is_external:BOOL; -- True is self is one of external types
is_atomic:BOOL; -- True if an assignment to self is atomic
-- used only for pSather
is_reference_free:BOOL; -- Does the implementation use pointers
-- that may affect garbage collection?
is_builtin:BOOL; -- True if self is a builtin type
is_bound:BOOL; -- True if self is a bound type.
is_subtype(t:$CALL_TP):BOOL; -- True if self is a subtype of `t'.
is_eq(t:$OB):BOOL; -- Equality test.
is_neq(t:$OB):BOOL; -- Inequality test.
hash:INT; -- Hash function
is_lt(t:$TP):BOOL; -- Canonical ordering.
kind:INT; -- One of TP_KIND::missing_tp,
-- TP_KIND::val_tp, TP_KIND::ref_tp, TP_KIND::abs_tp,
-- TP_KIND::part_tp, TP_KIND::ext_c_tp, TP_kind::ext_fortran_tp,
-- pSather: TP_KIND::spr_tp,
-- TP_KIND::rout_tp, TP_KIND::iter_tp.
as:AS_TYPE_SPEC; -- construct AS_TYPE_SPEC for self;
impl: IMPL; -- Returns the implementation of the type.
-- Produces error, if the type cannot have any implementation.
ifc: IFC; -- Returns the interface of the type. If neccessary
-- the interface will be computed.
end; -- type $TP
class TP_KIND
class TP_KIND is
-- A set of constants defining the different kinds of types.
const missing_tp,
val_tp, -- Value types.-- INT::plus
ref_tp, -- Reference types.-- INT::plus
abs_tp, -- Abstract types.-- INT::plus
part_tp, -- Partial type.-- INT::plus
ext_c_tp, -- External C types.-- INT::plus
ext_fortran_tp, -- External Fortran types.-- INT::plus
--pSather
spr_tp, -- Spread types.-- INT::plus
rout_tp, -- Bound routine types.-- INT::plus
iter_tp; -- Bound iter types. -- INT::plus
end; -- class TP_KIND
class TP
class TP is
-- Implementation to be included by $TP objects.
attr prog:PROG; -- This type's program object.
private attr my_ifc: IFC;
is_immutable:BOOL
-- True if an immutable type.
is
return kind=TP_KIND::val_tp;-- TP_CLASS::kind INT::is_eq TP_KIND::val_tp
end;
is_partial:BOOL
-- True if partial class
is
return kind=TP_KIND::part_tp;-- TP_CLASS::kind INT::is_eq TP_KIND::part_tp
end;
is_external:BOOL
-- True if one of external types
is
return kind=TP_KIND::ext_c_tp or kind=TP_KIND::ext_fortran_tp;-- TP_CLASS::kind INT::is_eq TP_KIND::ext_c_tp TP_CLASS::kind INT::is_eq TP_KIND::ext_fortran_tp
end;
is_builtin:BOOL
-- Conservative answer
is
return false;
end;
is_atomic:BOOL
-- Conservative answer
is
return false;
end;
is_reference_free:BOOL
-- Conservative answer
is
return false;
end;
kind:INT
is
raise "kind is expected to be redefined";
end;
hash:INT
is
return SYS::id(self).hash;-- SYS::id INT::hash
end;
is_eq(t:$OB):BOOL
-- Equality note: changed from $CALL_TP
-- True if self equals `t'.
is
return SYS::ob_eq(self,t)-- SYS::ob_eq
end;
is_neq(t:$OB):BOOL
-- Equality note: changed from $CALL_TP
-- True if self is not equal to `t'.
is
return ~SYS::ob_eq(self,t)
end;
is_lt(t:$CALL_TP):BOOL
-- True if self is less than `t' in a canonical (arbitrary) ordering.
is
return str<t.str-- TP_CLASS::str STR::is_lt
end;
as:AS_TYPE_SPEC
-- construct AS_TYPE_SPEC for self;`
is
return void;
end;
str:STR is raise "TP::Str not implemented."; end;
impl:IMPL is return void; end;
ifc:IFC is return void; end;
end; -- class TP
class TP_CLASS < $TP
class TP_CLASS < $TP is
-- Representation of reference, immutable, abstract, and external types.
include TP;
attr name:IDENT; -- The name of the type.
attr params:ARRAY{$TP}; -- Specifiers for the type
-- parameters in order, void if none.
private attr my_impl: IMPL; -- The implementation of this type.
private attr sas_cache:STR; -- Cache for string representation.
private attr kind_cache:INT; -- Cache for the kind of class this is
readonly attr is_builtin:BOOL;
readonly attr is_atomic:BOOL;
create(name:IDENT, params:ARRAY{$TP}, prog:PROG):SAME
-- A class type object with the specified attributes.
is
r::=new;
r.name:=name; r.params:=params; r.prog:=prog;-- TP_CLASS::name TP_CLASS::params TP_CLASS::prog
r.kind_cache:=TP_KIND::missing_tp;-- TP_CLASS::kind_cache TP_KIND::missing_tp
d::=prog.config.get_def("BUILTIN_CLASSES");-- PROG::config CONFIG_TBL::get_def
loop
e::=d.elt!;-- CONFIG_DEF::elt!
loop
if e.elt!=r.str then r.is_builtin:=true; break!; end;-- ARRAY{1}::elt! STR::is_eq TP_CLASS::str TP_CLASS::is_builtin
end;
until!(r.is_builtin);-- TP_CLASS::is_builtin
end;
-- if prog.psather then -- this test is bogus, as the flag
-- is only set after some builtin types have
-- already been created.
d := prog.config.get_def("ATOMIC_CLASSES");-- PROG::config CONFIG_TBL::get_def
loop
e::=d.elt!;-- CONFIG_DEF::elt!
loop
if e.elt!=r.str then -- ARRAY{1}::elt! STR::is_eq TP_CLASS::str
r.is_atomic:=true; -- TP_CLASS::is_atomic
break!;
end;
end;
until!(r.is_atomic);-- TP_CLASS::is_atomic
end;
-- end;
return r
end;
str:STR
-- The string version of the type represented by self. Uses no
-- whitespace, eg: "FOO{A,B{C},D}".
is
if ~void(sas_cache) then return sas_cache end;-- TP_CLASS::sas_cache BOOL::not TP_CLASS::sas_cache
if void(self) then return "void" end;
if void(params) then-- TP_CLASS::params
sas_cache:=name.str -- TP_CLASS::sas_cache TP_CLASS::name IDENT::str
else
s::=#FSTR + name.str + '{'; -- FSTR::create TP_CLASS::name IDENT::str FSTR::plus
loop s:=s+",".separate!(params.elt!.str) end;-- FSTR::plus STR::separate! TP_CLASS::params ARRAY{1}::elt!
s:=s+'}';-- FSTR::plus
sas_cache:=s.str-- TP_CLASS::sas_cache FSTR::str
end;
return sas_cache-- TP_CLASS::sas_cache
end; -- str
is_abstract:BOOL
-- True if self is abstract.
is
if void(self) then return false end;
return name.str[0]='$'-- TP_CLASS::name IDENT::str STR::aget CHAR::is_eq
end;
is_bound:BOOL
-- Returns false.
is
return false
end;
is_subtype(t:$CALL_TP):BOOL
-- True if self is a subtype of `t'.
is
if void(self) then return false end;
if self=t then-- TP_CLASS::is_eq
return true
else
typecase t
when CALL_TP_UNDERSCORE then
if ~void(t.tp) then-- CALL_TP_UNDERSCORE::tp BOOL::not
return is_subtype(t.tp);-- TP_CLASS::is_subtype CALL_TP_UNDERSCORE::tp
else
-- everything is a subtype of untyped underscore
return true;
end;
when TP_CLASS then
if t.is_abstract then-- TP_CLASS::is_abstract
return prog.tp_graph.abs_subtype_test(self,t)-- TP_CLASS::prog PROG::tp_graph TP_GRAPH::abs_subtype_test
else
return false
end;
else
return false
end
end
end; -- is_subtype
kind:INT
-- One of TP_KIND::missing_tp, TP_KIND::val_tp, TP_KIND::ref_tp,
-- TP_KIND::abs_tp, TP_KIND::ext_c_tp, TP_KIND::ext_fortran_tp,
-- pSather: AS_KIND::spr_tp
-- TP_KIND::rout_tp, TP_KIND::iter_tp.
is
if kind_cache=TP_KIND::missing_tp then-- TP_CLASS::kind_cache INT::is_eq TP_KIND::missing_tp
as:AS_CLASS_DEF:=prog.parse.tree_for(name,params.size);-- TP_CLASS::prog PROG::parse TP_CLASS::name TP_CLASS::params ARRAY{1}::size
if ~void(as) then-- BOOL::not
kind_cache:=as.kind;-- TP_CLASS::kind_cache AS_CLASS_DEF::kind
end;
end;
return kind_cache-- TP_CLASS::kind_cache
end;
is_reference_free:BOOL
-- mbk
is
if void(self) then return false end;
return impl.is_reference_free;-- TP_CLASS::impl IMPL::is_reference_free
end;
as:AS_TYPE_SPEC
is
ret ::= #AS_TYPE_SPEC;-- AS_TYPE_SPEC::create
ret.name := name;-- AS_TYPE_SPEC::name TP_CLASS::name
-- deal with params
asp : AS_TYPE_SPEC;
loop
paramtp ::= params.elt!;-- TP_CLASS::params ARRAY{1}::elt!
as0 ::= paramtp.as;
if void(asp) then asp := as0; else asp.append(as0); end;-- AS_TYPE_SPEC::append
end;
ret.params := asp;-- AS_TYPE_SPEC::params
return ret;
end;
private pnames:ARRAY{IDENT}
-- An array of the parameter names for the type `self'. Void if none.
pre ~void(self)
is-- BOOL::not
as ::= prog.parse.tree_for(self.name,self.params.size);-- TP_CLASS::prog PROG::parse TP_CLASS::name TP_CLASS::params ARRAY{1}::size
if void(as) then return void end;
if void(as.params) then return void end;-- AS_CLASS_DEF::params
r ::= #ARRAY{IDENT}(as.params.size);-- ARRAY{1}::create AS_CLASS_DEF::params AS_PARAM_DEC::size
pd:AS_PARAM_DEC := as.params;-- AS_CLASS_DEF::params
i:INT:=0;
loop until!(void(pd)); r.set!(pd.name); pd:=pd.next end;-- ARRAY{1}::set! AS_PARAM_DEC::name AS_PARAM_DEC::next
return r
end;
--attr my_context: TP_CONTEXT;
-- Quickfix
tp_context_for:TP_CONTEXT
-- The type context appropriate for the body of `self'. Void if
-- `self' is not a known type.
pre ~void(self)
is-- BOOL::not
--if ~void(my_context) then return my_context end;
pn:ARRAY{IDENT}:=pnames;-- TP_CLASS::pnames
ps:INT;
if ~void(pn) then ps:=pn.asize end;-- BOOL::not ARRAY{1}::asize
if ps/=self.params.size then return void end;-- INT::is_eq TP_CLASS::params ARRAY{1}::size BOOL::not
r::=#TP_CONTEXT(self, pn, params, prog);-- TP_CONTEXT::create TP_CLASS::params TP_CLASS::prog
if is_abstract then r.is_abs:=true end;-- TP_CLASS::is_abstract TP_CONTEXT::is_abs
--my_context := r;
return r
end;
impl: IMPL
-- Creates the implementation of this class. Does nothing if
-- already computed. Test for cyclic implementation contruction
-- with include clauses.
is
if void(my_impl) then-- TP_CLASS::my_impl
my_impl := IMPL_CREATE::create_for_tp_class(self);-- TP_CLASS::my_impl IMPL_CREATE::create_for_tp_class
end;
return my_impl-- TP_CLASS::my_impl
end;
ifc: IFC
is
if void(my_ifc) then my_ifc := IFC::ifc_for_class(self); end;-- TP_CLASS::my_ifc TP_CLASS::my_ifc IFC::ifc_for_class
return my_ifc-- TP_CLASS::my_ifc
end;
end; -- TP_CLASS
class TP_ROUT < $TP
class TP_ROUT < $TP is
-- Representation of bound routine types.
include TP;
attr args:ARRAY{ARG}; -- Specifiers for the arguments
-- in order, void if none.
attr ret:$TP; -- The return type, void if none.
attr is_remote:BOOL; -- used by pSather for remote
-- proc. calls
create(args:ARRAY{ARG}, ret:$TP, prog:PROG):SAME
-- A bound routine type object with the specified attributes.
is
r::=new; r.args:=args; r.ret:=ret; r.prog:=prog;-- TP_ROUT::args TP_ROUT::ret TP_ROUT::prog
return r
end;
private attr sas_cache:STR; -- Cache for string representation.
str:STR
-- The string version of the type represented by self. Uses no
-- whitespace, eg: "ROUT{A,B{C},outD}:E".
is
if void(self) then return "void" end;
if ~void(sas_cache) then-- TP_ROUT::sas_cache BOOL::not
-- Don't need to do anything.
elsif void(args) and void(ret) then-- TP_ROUT::args TP_ROUT::ret
sas_cache:="ROUT"-- TP_ROUT::sas_cache
else
s::=#FSTR + "ROUT";-- FSTR::create FSTR::plus
if ~void(args) then-- TP_ROUT::args BOOL::not
s:=s + '{'; -- FSTR::plus
loop
arg ::= args.elt!;-- TP_ROUT::args ARRAY{1}::elt!
s := s+",".separate!(arg.mode.str+arg.tp.str)-- FSTR::plus STR::separate! ARG::mode STR::plus ARG::tp
end;
s:=s + '}'-- FSTR::plus
end;
if ~void(ret) then s:=s + ':' + ret.str end;-- TP_ROUT::ret BOOL::not FSTR::plus TP_ROUT::ret
sas_cache:=s.str-- TP_ROUT::sas_cache FSTR::str
end;
return sas_cache-- TP_ROUT::sas_cache
end;
is_abstract:BOOL is return false end;
is_bound:BOOL is return true end;
is_subtype(t:$CALL_TP):BOOL
-- True if self is a subtype of `t'.
is
if void(self) then return false end;
typecase t
when TP_CLASS then
if ~t.is_abstract then-- TP_CLASS::is_abstract BOOL::not
return false
else
return prog.tp_graph.abs_subtype_test(self,t)-- TP_ROUT::prog PROG::tp_graph TP_GRAPH::abs_subtype_test
end;
when TP_ROUT then
-- Test for contravariant conformance. This means:
-- 1) Self and `t' have the same number of arguments.
-- 2) Both have a return value or both do not.
-- 3) The mode of each argument is the same.
-- 4) for any in arguments, the type in t is a subtype
-- of a type in self;
-- for any inout arguments, the type in self is the same
-- as the type in t;
-- for any out arguments, the type in self is a subtype of
-- of the type in t;
-- 5) The return type of self must be a subtype of the return
-- type of t, if present
if args.size/=t.args.size then return false end;-- TP_ROUT::args ARRAY{1}::size INT::is_eq TP_ROUT::args ARRAY{1}::size BOOL::not
if has_ret/=t.has_ret then return false end;-- TP_ROUT::has_ret BOOL::is_eq TP_ROUT::has_ret BOOL::not
loop
if args.elt!.mode /= t.args.elt!.mode then return false; end;-- TP_ROUT::args ARRAY{1}::elt! ARG::mode TP_ROUT::args ARRAY{1}::elt! ARG::mode BOOL::not
end;
loop
self_arg ::= args.elt!; t_arg ::= t.args.elt!;-- TP_ROUT::args ARRAY{1}::elt! TP_ROUT::args ARRAY{1}::elt!
case self_arg.mode-- ARG::mode
when MODES::in_mode then-- MODES::in_mode
if ~t_arg.tp.is_subtype(self_arg.tp) then -- ARG::tp ARG::tp BOOL::not
return false;
end;
when MODES::out_mode then-- MODES::out_mode
if ~self_arg.tp.is_subtype(t_arg.tp) then -- ARG::tp ARG::tp BOOL::not
return false;
end;
when MODES::inout_mode then-- MODES::inout_mode
if self_arg.tp /= t_arg.tp then -- ARG::tp ARG::tp BOOL::not
return false;
end;
when MODES::once_mode then -- aj ?? there are no once here-- MODES::once_mode
if ~t_arg.tp.is_subtype(self_arg.tp) then -- ARG::tp ARG::tp BOOL::not
return false;
end;
end;
end;
-- well, unfortunately, dispatched ROUTs are not implemented
-- yet, so make sure things match exactly. When they are
-- finally implemented, loop below should be deleted
loop
if args.elt!.tp /= t.args.elt!.tp then -- TP_ROUT::args ARRAY{1}::elt! ARG::tp TP_ROUT::args ARRAY{1}::elt! ARG::tp BOOL::not
prog.err(-- TP_ROUT::prog PROG::err
"Dispatched bound routines are not implemented yet, check argument types");
return false;
end;
end;
-- same accounts for return value
-- foo(R:ROUT:$STR) may, so far, only be called with
-- a bound routine of type ROUT:$STR.
-- note NOT with a type of ROUT:INT
if has_ret and ret /= t.ret then-- TP_ROUT::has_ret TP_ROUT::ret TP_ROUT::ret BOOL::not
prog.err(-- TP_ROUT::prog PROG::err
"Dispatched bound routines are not implemented yet, check return types.");
return false;
end;
-- once its fixed do the following:
--if has_ret and ~ret.is_subtype(t.ret) then return false end;
return true
else
return false
end; -- typecase t
end; -- is_subtype
has_ret:BOOL
-- True if self has a return value.
is
return ~void(ret)-- TP_ROUT::ret
end;-- BOOL::not
kind:INT
-- The kind of this type.
is
return TP_KIND::rout_tp-- TP_KIND::rout_tp
end;
as:AS_TYPE_SPEC
is
r ::= #AS_TYPE_SPEC;-- AS_TYPE_SPEC::create
r.kind := AS_TYPE_SPEC::rt;-- AS_TYPE_SPEC::kind AS_TYPE_SPEC::rt
asp : AS_TYPE_SPEC;
loop
arg ::= args.elt!;-- TP_ROUT::args ARRAY{1}::elt!
paramtp ::= arg.tp;-- ARG::tp
as0 ::= paramtp.as;
if void(asp) then asp := as0; else asp.append(as0); end;-- AS_TYPE_SPEC::append
end;
r.params := asp;-- AS_TYPE_SPEC::params
if ~void(ret) then-- TP_ROUT::ret BOOL::not
r.ret := ret.as;-- AS_TYPE_SPEC::ret TP_ROUT::ret
end;
return r;
end;
ifc: IFC
is
if void(my_ifc) then my_ifc := IFC::ifc_for_rout(self) end;-- TP_ROUT::my_ifc TP_ROUT::my_ifc IFC::ifc_for_rout
return my_ifc-- TP_ROUT::my_ifc
end;
end; -- class TP_ROUT
class TP_ITER < $TP
class TP_ITER < $TP is
-- Representation of bound iter types.
include TP;
attr args:ARRAY{ARG}; -- Specifiers for the argument types
-- in order, void if none.
attr hot:ARRAY{BOOL}; -- Treu for each arg which is marked
-- with a "!". None are hot if this array is void.
attr ret:$TP; -- The return type, void if none.
create(args:ARRAY{ARG}, hot:ARRAY{BOOL}, ret:$TP, prog:PROG):SAME
-- A bound iter type object with the specified attributes.
is
r::=new; r.args:=args; r.hot:=hot; r.ret:=ret; r.prog:=prog; -- TP_ITER::args TP_ITER::hot TP_ITER::ret TP_ITER::prog
return r
end;
attr sas_cache:STR; -- Cache for string representation.
str:STR
-- The string version of the type represented by self. Uses no
-- whitespace, eg: "ITER{A!,B{C},D}:E".
-- If self is void, returns "void".
is
if void(self) then return "void" end;
if ~void(sas_cache) then-- TP_ITER::sas_cache BOOL::not
-- Don't need to do anything.
elsif void(args) and void(ret) then-- TP_ITER::args TP_ITER::ret
sas_cache:="ITER"-- TP_ITER::sas_cache
else
s::=#FSTR + "ITER";-- FSTR::create FSTR::plus
if ~void(args) then-- TP_ITER::args BOOL::not
s:=s + '{'; -- FSTR::plus
loop
arg ::= args.elt!;-- TP_ITER::args ARRAY{1}::elt!
s:=s+",".separate!(arg.mode.str+arg.tp.str);-- FSTR::plus STR::separate! ARG::mode STR::plus ARG::tp
if ~void(hot) and hot.elt! then s:=s + '!' end-- TP_ITER::hot BOOL::not TP_ITER::hot ARRAY{1}::elt! FSTR::plus
end;
s:=s + '}'-- FSTR::plus
end;
if ~void(ret) then s:=s + ':' + ret.str end;-- TP_ITER::ret BOOL::not FSTR::plus TP_ITER::ret
sas_cache:=s.str-- TP_ITER::sas_cache FSTR::str
end;
return sas_cache -- TP_ITER::sas_cache
end; -- str
is_abstract:BOOL is
-- Returns false.
return false end;
is_bound:BOOL is
-- Returns true.
return true end;
is_subtype(t:$CALL_TP):BOOL is
-- True if self is a subtype of `t'.
if void(self) then return false end;
typecase t
when TP_CLASS then
if ~t.is_abstract then return false-- TP_CLASS::is_abstract BOOL::not
else return prog.tp_graph.abs_subtype_test(self,t) end;-- TP_ITER::prog PROG::tp_graph TP_GRAPH::abs_subtype_test
when TP_ITER then
-- Test for contravariant conformance. This means:
-- 1) Self and `t' have the same number of arguments.
-- 2) Both have a return value or both do not.
-- 3) The mode of each argument is the same
-- 4) for any in arguments, the type in t is a subtype
-- of a type in self;
-- for any inout arguments, the type in self is the same
-- as the type in t;
-- for any out arguments, the type in self is a subtype of
-- of the type in t;
-- 5) The return type of self must be a subtype of the return
-- type of t, if present
if args.size/=t.args.size then return false end;-- TP_ITER::args ARRAY{1}::size INT::is_eq TP_ITER::args ARRAY{1}::size BOOL::not
loop
sar ::= args.elt!;-- TP_ITER::args ARRAY{1}::elt!
tar ::= t.args.elt!;-- TP_ITER::args ARRAY{1}::elt!
sar_tp ::= sar.tp;-- ARG::tp
typecase sar_tp
when CALL_TP_UNDERSCORE then
-- modes do not need to match
sar.mode := tar.mode;-- ARG::mode ARG::mode
else
if (sar.mode /= tar.mode) then-- ARG::mode ARG::mode BOOL::not
return false;
end
end;
end;
loop
self_arg ::= args.elt!; t_arg ::= t.args.elt!;-- TP_ITER::args ARRAY{1}::elt! TP_ITER::args ARRAY{1}::elt!
case self_arg.mode-- ARG::mode
when MODES::in_mode then-- MODES::in_mode
if ~t_arg.tp.is_subtype(self_arg.tp) then -- ARG::tp ARG::tp BOOL::not
return false;
end;
when MODES::out_mode then-- MODES::out_mode
if ~self_arg.tp.is_subtype(t_arg.tp) then -- ARG::tp ARG::tp BOOL::not
return false;
end;
when MODES::inout_mode then-- MODES::inout_mode
if self_arg.tp /= t_arg.tp then -- ARG::tp ARG::tp BOOL::not
return false;
end;
when MODES::once_mode then-- MODES::once_mode
if ~t_arg.tp.is_subtype(self_arg.tp) then -- ARG::tp ARG::tp BOOL::not
return false;
end;
end;
end;
-- well, unfortunately, dispatched ITERs are not implemented
-- yet, so make sure things match exactly. When they are
-- finally implemented, loop below should be deleted
loop
if args.elt!.tp /= t.args.elt!.tp then -- TP_ITER::args ARRAY{1}::elt! ARG::tp TP_ITER::args ARRAY{1}::elt! ARG::tp BOOL::not
prog.err("Dispatched bound iterators are not implemented yet, check argument types.");-- TP_ITER::prog PROG::err
return false;
end;
end;
if hot.size/=t.hot.size then return false end;-- TP_ITER::hot ARRAY{1}::size INT::is_eq TP_ITER::hot ARRAY{1}::size BOOL::not
loop
if hot.elt!/=t.hot.elt! then -- TP_ITER::hot ARRAY{1}::elt! BOOL::is_eq TP_ITER::hot ARRAY{1}::elt! BOOL::not
#OUT + "hot mismatch\n";-- OUT::create OUT::plus
return false;
end;
end;
if has_ret/=t.has_ret then return false end;-- TP_ITER::has_ret BOOL::is_eq TP_ITER::has_ret BOOL::not
-- same accounts for return value
-- foo(R:ITER:$STR) may, so far, only be called with
-- a bound routine of type ITER:$STR.
-- note NOT with a type of ITER:INT
if has_ret and ret /= t.ret then-- TP_ITER::has_ret TP_ITER::ret TP_ITER::ret BOOL::not
prog.err(-- TP_ITER::prog PROG::err
"Dispatched bound iterators are not implemented yet, check return types.");
return false;
end;
-- once its fixed do the following:
-- if has_ret and ~ret.is_subtype(t.ret) then
-- return false
-- end;
return true;
else
return false
end; -- ends typecase
end;
has_ret:BOOL
-- True if self has a return value.
is
if void(self) then return false end;
return ~void(ret)-- TP_ITER::ret
end;-- BOOL::not
kind:INT
-- The kind of this type.
is
return TP_KIND::iter_tp-- TP_KIND::iter_tp
end;
as:AS_TYPE_SPEC
is
r ::= #AS_TYPE_SPEC;-- AS_TYPE_SPEC::create
r.kind := AS_TYPE_SPEC::it;-- AS_TYPE_SPEC::kind AS_TYPE_SPEC::it
asp : AS_TYPE_SPEC;
loop
arg ::= args.elt!;-- TP_ITER::args ARRAY{1}::elt!
paramtp ::= arg.tp; -- ARG::tp
i::=0.up!;-- INT::up!
as0 ::= paramtp.as;
if ~void(hot) then-- TP_ITER::hot BOOL::not
as0.is_hot := hot[i];-- AS_TYPE_SPEC::is_hot TP_ITER::hot ARRAY{1}::aget
end;
if void(asp) then asp := as0; else asp.append(as0); end;-- AS_TYPE_SPEC::append
end;
r.params := asp;-- AS_TYPE_SPEC::params
-- ben - caused the browser to crash and seemed to require the void
-- test
if ~void(ret) then r.ret := ret.as; end;-- TP_ITER::ret BOOL::not AS_TYPE_SPEC::ret TP_ITER::ret
return r;
end;
ifc: IFC
is
if void(my_ifc) then my_ifc := IFC::ifc_for_iter(self) end;-- TP_ITER::my_ifc TP_ITER::my_ifc IFC::ifc_for_iter
return my_ifc;-- TP_ITER::my_ifc
end;
end; -- class TP_ITER
class TP_CONTEXT
class TP_CONTEXT is
-- A context for converting AS_TYPE_SPEC trees into $TP objects.
attr same:TP_CLASS; -- The type that replaces "SAME",
attr pnames:ARRAY{IDENT}; -- Type parameter names, if any.
attr ptypes:ARRAY{$TP}; -- Type parameter values, if any.
attr is_abs:BOOL; -- True if in an abstract class.
attr prog:PROG; -- The program this is for.
create(same:TP_CLASS, pnames:ARRAY{IDENT}, ptypes:ARRAY{$TP},
prog:PROG):SAME
-- A type context object with the specified attributes.
is
r::=new;
r.same:=same; r.pnames:=pnames; r.ptypes:=ptypes; r.prog:=prog;-- TP_CONTEXT::same TP_CONTEXT::pnames TP_CONTEXT::ptypes TP_CONTEXT::prog
return r
end;
value_of_param(s:IDENT):$TP
-- The value of the parameter named by `s'. If `s' doesn't
-- name a parameter, returns void.
is
if void(pnames) then return void end;-- TP_CONTEXT::pnames
loop
i::=pnames.ind!; -- TP_CONTEXT::pnames ARRAY{1}::ind!
if s=pnames[i] then return ptypes[i] end-- TP_CONTEXT::pnames ARRAY{1}::aget TP_CONTEXT::ptypes ARRAY{1}::aget
end;
return void
end;
tp_of(t:AS_TYPE_SPEC): $TP is return tp_of(t,true) end;-- TP_CONTEXT::tp_of
tp_of(t:AS_TYPE_SPEC,memorize:BOOL):$TP
-- The type object corresponding to the type specifier `t' in
-- this context. Void if `t' is void.
-- If memorize is false to not write this type into the global
-- type table.
is
if void(t) then return void end;
case t.kind-- AS_TYPE_SPEC::kind
when AS_TYPE_SPEC::ord then return tp_class_of(t,memorize)-- AS_TYPE_SPEC::ord TP_CONTEXT::tp_class_of
when AS_TYPE_SPEC::rt then return tp_rout_of(t)-- AS_TYPE_SPEC::rt TP_CONTEXT::tp_rout_of
when AS_TYPE_SPEC::it then return tp_iter_of(t)-- AS_TYPE_SPEC::it TP_CONTEXT::tp_iter_of
when AS_TYPE_SPEC::same then -- AS_TYPE_SPEC::same
--*H*
--if is_abs then prog.err_loc(t);
-- prog.err("SAME is not allowed in abstract classes.") end;
return same-- TP_CONTEXT::same
end
end; -- tp_of
str: STR
-- For debugging
is
res ::= "(" + same.str + ";";-- TP_CONTEXT::same TP_CLASS::str STR::plus
if ~void(pnames) and pnames.size > 0 then-- TP_CONTEXT::pnames BOOL::not TP_CONTEXT::pnames ARRAY{1}::size INT::is_lt
loop
res:=res+",".separate!(pnames.elt!.str+"->"+ptypes.elt!.str);-- STR::plus STR::separate! TP_CONTEXT::pnames ARRAY{1}::elt! IDENT::str STR::plus TP_CONTEXT::ptypes ARRAY{1}::elt!
end
end;
return res + ")";-- STR::plus
end;
tp_class_of(t:AS_TYPE_SPEC,memorize:BOOL):$TP
-- The type object corresponding to the class type specifier
-- `t' in this context.
pre ~void(t) and t.kind=t.ord and void(t.ret)-- BOOL::not AS_TYPE_SPEC::kind INT::is_eq AS_TYPE_SPEC::ord AS_TYPE_SPEC::ret
is
-- SAME is not allowed in parametrizations of abstract classes
if t.name.str[0]='$' then-- AS_TYPE_SPEC::name IDENT::str STR::aget CHAR::is_eq
if type_spec_params_have_same(t) then-- TP_CONTEXT::type_spec_params_have_same
prog.err_loc(t);-- TP_CONTEXT::prog PROG::err_loc
prog.err("SAME is allowed only inside bodies of concrete classes.");-- TP_CONTEXT::prog PROG::err
end;
end;
if void(t.params) then -- AS_TYPE_SPEC::params
pv::=value_of_param(t.name); -- TP_CONTEXT::value_of_param AS_TYPE_SPEC::name
if ~void(pv) then return pv end; -- A parameter reference. -- BOOL::not
if ~void(t.name) then-- AS_TYPE_SPEC::name BOOL::not
return prog.tp_tbl.tp_class_for(t.name, void, memorize)-- TP_CONTEXT::prog PROG::tp_tbl TP_TBL::tp_class_for AS_TYPE_SPEC::name
end;
end;
ptps::=#ARRAY{$TP}(t.params.size);-- ARRAY{1}::create AS_TYPE_SPEC::params AS_TYPE_SPEC::size
tpe::=t.params;-- AS_TYPE_SPEC::params
loop until!(void(tpe)); ptps.set!(tp_of(tpe)); tpe:=tpe.next end;-- ARRAY{1}::set! TP_CONTEXT::tp_of AS_TYPE_SPEC::next
if ~void(t.name)-- AS_TYPE_SPEC::name
then-- BOOL::not
return prog.tp_tbl.tp_class_for(t.name, ptps, memorize);-- TP_CONTEXT::prog PROG::tp_tbl TP_TBL::tp_class_for AS_TYPE_SPEC::name
else
return void;
end;
end;
tp_rout_of(t:AS_TYPE_SPEC):$TP
-- The type object corresponding to the bound routine type
-- specifier `t' in this context.
pre ~void(t) and t.kind=t.rt-- BOOL::not AS_TYPE_SPEC::kind INT::is_eq AS_TYPE_SPEC::rt
is
if void(t.params) then-- AS_TYPE_SPEC::params
return prog.tp_tbl.tp_rout_for(void, tp_of(t.ret))-- TP_CONTEXT::prog PROG::tp_tbl TP_TBL::tp_rout_for TP_CONTEXT::tp_of AS_TYPE_SPEC::ret
end;
args ::= #ARRAY{ARG}(t.params.size);-- ARRAY{1}::create AS_TYPE_SPEC::params AS_TYPE_SPEC::size
tpe ::= t.params;-- AS_TYPE_SPEC::params
loop
until!(void(tpe));
i ::= 0.up!;-- INT::up!
args[i] := #(tp_of(tpe), MODE::create_from_as(tpe.mode));-- ARRAY{1}::aset ARG::create TP_CONTEXT::tp_of MODE::create_from_as AS_TYPE_SPEC::mode
tpe:=tpe.next -- AS_TYPE_SPEC::next
end;
-- currently, no overloading on modes is allowed
return prog.tp_tbl.tp_rout_for(args, tp_of(t.ret)) -- TP_CONTEXT::prog PROG::tp_tbl TP_TBL::tp_rout_for TP_CONTEXT::tp_of AS_TYPE_SPEC::ret
end;
tp_iter_of(t:AS_TYPE_SPEC):$TP
-- The type object corresponding to the bound iter type
-- specifier `t' in this context.
pre ~void(t) and t.kind=t.it-- BOOL::not AS_TYPE_SPEC::kind INT::is_eq AS_TYPE_SPEC::it
is
if void(t.params) then-- AS_TYPE_SPEC::params
return prog.tp_tbl.tp_iter_for(void, void, tp_of(t.ret)) end;-- TP_CONTEXT::prog PROG::tp_tbl TP_TBL::tp_iter_for TP_CONTEXT::tp_of AS_TYPE_SPEC::ret
args::=#ARRAY{ARG}(t.params.size);-- ARRAY{1}::create AS_TYPE_SPEC::params AS_TYPE_SPEC::size
tpa::=t.params;-- AS_TYPE_SPEC::params
loop
until!(void(tpa));
i ::= 0.up!;-- INT::up!
args[i] := #(tp_of(tpa), MODE::create_from_as(tpa.mode));-- ARRAY{1}::aset ARG::create TP_CONTEXT::tp_of MODE::create_from_as AS_TYPE_SPEC::mode
tpa:=tpa.next -- AS_TYPE_SPEC::next
end;
hot::=#ARRAY{BOOL}(args.size);-- ARRAY{1}::create ARRAY{1}::size
tpa:=t.params;-- AS_TYPE_SPEC::params
-- to be eliminated (Boris)
loop until!(void(tpa)); hot.set!(tpa.is_hot); tpa:=tpa.next end;-- ARRAY{1}::set! AS_TYPE_SPEC::is_hot AS_TYPE_SPEC::next
if ~hot.contains(true) then hot:=void end;-- ARRAY{1}::contains BOOL::not
-- currently, no overloading based on arg modes is allowed
return prog.tp_tbl.tp_iter_for(args, hot, tp_of(t.ret)) -- TP_CONTEXT::prog PROG::tp_tbl TP_TBL::tp_iter_for TP_CONTEXT::tp_of AS_TYPE_SPEC::ret
end;
type_spec_has_same(t:AS_TYPE_SPEC):BOOL
-- True if the type spec `t' contains "SAME".
pre ~void(t)
is-- BOOL::not
if t.kind=t.same then return true; end;-- AS_TYPE_SPEC::kind INT::is_eq AS_TYPE_SPEC::same
if type_spec_params_have_same(t) then return true end;-- TP_CONTEXT::type_spec_params_have_same
if ~void(t.ret) then -- AS_TYPE_SPEC::ret BOOL::not
return type_spec_has_same(t.ret); -- TP_CONTEXT::type_spec_has_same AS_TYPE_SPEC::ret
else
return false;
end;
end;
type_spec_params_have_same(t:AS_TYPE_SPEC):BOOL
-- True if the type spec `t' contains "SAME".
pre ~void(t)
is-- BOOL::not
p::=t.params;-- AS_TYPE_SPEC::params
loop
while!(~void(p));-- BOOL::not
if type_spec_has_same(p) then return true end;-- TP_CONTEXT::type_spec_has_same
p:=p.next-- AS_TYPE_SPEC::next
end;
return false
end;
type_spec_is_param(t:AS_TYPE_SPEC):BOOL
-- True if `t' is a type specifier which is just a type
-- parameter.
pre ~void(t)
is-- BOOL::not
if t.kind/=t.ord or ~void(t.params) then return false end;-- AS_TYPE_SPEC::kind INT::is_eq AS_TYPE_SPEC::ord BOOL::not AS_TYPE_SPEC::params BOOL::not
return pnames.contains(t.name)-- TP_CONTEXT::pnames ARRAY{1}::contains AS_TYPE_SPEC::name
end;
end; -- class TP_CONTEXT
class TP_TBL
class TP_TBL is
-- A table of types in a program. This ensures that each type
-- is only represented by a single object so that object
-- equality can be used to test for type equality.
attr prog:PROG; -- The program this belongs to.
attr class_tbl:TP_CLASS_TBL; -- Types defined by classes.
attr included_classes:TP_CLASS_TBL;
-- Types defined by include clauses.
attr rout_tbl:TP_ROUT_TBL; -- Bound routine types.
attr iter_tbl:TP_ITER_TBL; -- Bound iter types.
create(prog:PROG):SAME
-- A table of type for the program `prog'.
is
r::=new;
r.prog:=prog;-- TP_TBL::prog
TP_BUILTIN::initialize(r);-- TP_BUILTIN::initialize
return r;
end;
private tp_class_for(s:STR,inout i:INT):TP_CLASS
-- converts a string representation of a type to tp.
-- reads only as many characters as needed. Returns
-- the number of characters in i, and starts to read
-- the string at pos i
is
params:ARRAY{$TP};
cl:STR;
if s[i]='$' then-- STR::aget CHAR::is_eq
cl:=cl+s[i];-- STR::plus STR::aget
i:=i+1;-- INT::plus
end;
loop
while!(i<s.size and (s[i].is_upper or s[i]='_' or s[i].is_digit));-- INT::is_lt STR::size STR::aget CHAR::is_upper STR::aget CHAR::is_eq STR::aget CHAR::is_digit
cl:=cl+s[i];-- STR::plus STR::aget
i:=i+1;-- INT::plus
end;
if i=0 then -- INT::is_eq
prog.barf("syntax error in tp string '"+s+"'");-- TP_TBL::prog PROG::barf STR::plus STR::plus
end;
if i<s.size then-- INT::is_lt STR::size
if s[i]='{' then-- STR::aget CHAR::is_eq
i:=i+1;-- INT::plus
j::=0;
p:ARRAY{$TP}:=#(50); -- not more than 50 args-- ARRAY{1}::create
loop
p[j]:=tp_class_for(s,inout i);-- ARRAY{1}::aset TP_TBL::tp_class_for
j:=j+1;-- INT::plus
if s[i]='}' then-- STR::aget CHAR::is_eq
i:=i+1;-- INT::plus
break!;
elsif s[i]=',' then-- STR::aget CHAR::is_eq
i:=i+1;-- INT::plus
else
prog.barf("syntax error in tp string '"+s+"', expected ',' or '}', got '"+s[i]+"'");-- TP_TBL::prog PROG::barf STR::plus STR::plus STR::plus STR::aget STR::plus
end;
end;
params:=#(j);-- ARRAY{1}::create
params.copy(p);-- ARRAY{1}::copy
else
if s[i]/='}' and s[i]/=',' then-- STR::aget CHAR::is_eq BOOL::not STR::aget CHAR::is_eq BOOL::not
prog.barf("syntax error in tp string '"+s+"', expected '{' or ',', got '"+s[i]+"'");-- TP_TBL::prog PROG::barf STR::plus STR::plus STR::plus STR::aget STR::plus
end;
end;
end;
return tp_class_for(#IDENT(cl),params);-- TP_TBL::tp_class_for IDENT::create
end;
tp_class_for(s:STR):TP_CLASS
is
i::=0;
return tp_class_for(s,inout i);-- TP_TBL::tp_class_for
end;
tp_class_for(name:IDENT, params:ARRAY{$TP}): TP_CLASS
is
return tp_class_for(name,params,true);-- TP_TBL::tp_class_for
end;
tp_class_for(name:IDENT, params:ARRAY{$TP}, memorize:BOOL ):TP_CLASS
-- Return the class type object for the name `name' and the
-- parameters (if any) `params'. If this has already been
-- accessed, return the old object, otherwise create a new
-- one using the array `params'.
is
query ::= #TUP{IDENT,ARRAY{$TP}}(name,params);-- TUP{2}::create
r::=class_tbl.get_query(query);-- TP_TBL::class_tbl TP_CLASS_TBL::get_query
if void(r) then
r := included_classes.get_query(query);-- TP_TBL::included_classes TP_CLASS_TBL::get_query
if void(r) then
-- assert ~ prog.no_new_types;
r := #TP_CLASS(name,params,prog);-- TP_CLASS::create TP_TBL::prog
included_classes := included_classes.insert(r);-- TP_TBL::included_classes TP_TBL::included_classes TP_CLASS_TBL::insert
end;
if memorize then
-- assert ~ prog.no_new_types;
class_tbl := class_tbl.insert(r);-- TP_TBL::class_tbl TP_TBL::class_tbl TP_CLASS_TBL::insert
end;
end;
return r
end;
tp_rout_for(args:ARRAY{ARG}, ret:$TP):TP_ROUT
-- Return the bound routine type object for the argument
-- `args' (if any) and the return type `ret' (if any).
-- If this has already been accessed, return the old object,
-- otherwise create a new one using the array `args'.
is
r::=rout_tbl.get_query(#(args,ret));-- TP_TBL::rout_tbl TP_ROUT_TBL::get_query TUP{2}::create
if void(r) then r:=#(args,ret,prog);-- TP_ROUT::create TP_TBL::prog
rout_tbl:=rout_tbl.insert(r)-- TP_TBL::rout_tbl TP_TBL::rout_tbl TP_ROUT_TBL::insert
end;
return r
end;
tp_iter_for(args:ARRAY{ARG}, hot:ARRAY{BOOL}, ret:$TP):TP_ITER is
-- Return the bound iter type object for the argument
-- types `args' (if any), marked according to `hot' (if any)
-- and with return type `ret' (if any). If this has already
-- been accessed, return the old object, otherwise create a
-- new one using the arrays `args' and `hot'.
r::=iter_tbl.get_query(#(args,hot,ret)); -- might be buggy aj-- TP_TBL::iter_tbl TP_ITER_TBL::get_query TUP{3}::create
if void(r) then r:=#(args,hot,ret,prog);-- TP_ITER::create TP_TBL::prog
iter_tbl:=iter_tbl.insert(r)-- TP_TBL::iter_tbl TP_TBL::iter_tbl TP_ITER_TBL::insert
end;
return r
end;
test(t:$TP):BOOL
-- True if the type `t' is in the table.
is
typecase t
when TP_CLASS then return class_tbl.test(t)
when TP_ROUT then return rout_tbl.test(t)
when TP_ITER then return iter_tbl.test(t)
end
end;
insert(t:$TP)
-- Insert the type `t' into the table.
is
typecase t
when TP_CLASS then class_tbl:=class_tbl.insert(t)
when TP_ROUT then
rout_tbl:=rout_tbl.insert(t);
when TP_ITER then
iter_tbl:=iter_tbl.insert(t);
end
end;
delete(t:$TP)
-- Delete the type `t' from the table.
is
typecase t
when TP_CLASS then class_tbl:=class_tbl.delete(t)
when TP_ROUT then rout_tbl:=rout_tbl.delete(t)
when TP_ITER then iter_tbl:=iter_tbl.delete(t)
end
end;
end; -- class TP_TBL
class TP_CLASS_TBL
class TP_CLASS_TBL is
-- Table of types defined by classes: abstract, reference,
-- immutable, and external types.
--
-- `get_query(TUP{IDENT,ARRAY{$TP}}):TP_CLASS' looks up a type.
-- `test(TP_CLASS):BOOL' tests for a type.
-- `insert(TP_CLASS):SAME' inserts a type.
-- `delete(TP_CLASS):SAME' deletes a type.
include FQSET{TUP{IDENT,ARRAY{$TP}},TP_CLASS};
query_test(q:TUP{IDENT,ARRAY{$TP}}, t:TP_CLASS):BOOL
-- True if `t' is the type described by `q'.
is
if void(t) then return false end;
if q.t1/=t.name then return false end;-- TUP{2}::t1 IDENT::is_eq TP_CLASS::name BOOL::not
if q.t2.size/=t.params.size then return false end;-- TUP{2}::t2 ARRAY{1}::size INT::is_eq TP_CLASS::params ARRAY{1}::size BOOL::not
loop
if q.t2.elt!/=t.params.elt! then return false end-- TUP{2}::t2 ARRAY{1}::elt! TP_CLASS::params ARRAY{1}::elt! BOOL::not
end;
return true
end;
query_hash(q:TUP{IDENT,ARRAY{$TP}}):INT
-- A hash value computed from the query types.
is
r::=q.t1.hash; -- Make depend on name.-- TUP{2}::t1 IDENT::hash
loop
i::=q.t2.ind!;-- TUP{2}::t2 ARRAY{1}::ind!
r:=r.mplus(SYS::id(q.t2[i])).mplus(i).mtimes(19);-- INT::mplus SYS::id TUP{2}::t2 ARRAY{1}::aget INT::mplus INT::mtimes
end; -- And on params.
return r.hash; -- INT::hash
end;
elt_hash(e:TP_CLASS):INT
-- Hash on the types in `e'.
is
r::=e.name.hash; -- Make depend on name.-- TP_CLASS::name IDENT::hash
loop
i::=e.params.ind!;-- TP_CLASS::params ARRAY{1}::ind!
r:=r.mplus(SYS::id(e.params[i])).mplus(i).mtimes(19);-- INT::mplus SYS::id TP_CLASS::params ARRAY{1}::aget INT::mplus INT::mtimes
end; -- And on params.
return r.hash; -- INT::hash
end;
end; -- class TP_CLASS_TBL
class TP_ROUT_TBL
class TP_ROUT_TBL is
-- Tables of bound routine types.
--
-- `get_query(TUP{ARRAY{ARG},$TP}):TP_ROUT' look up a type.
-- `test(TP_ROUT):BOOL' tests for a type.
-- `insert(TP_ROUT):SAME' inserts a type.
-- `delete(TP_ROUT):SAME' deletes a type.
include FQSET{TUP{ARRAY{ARG},$TP}, TP_ROUT};
query_test(q:TUP{ARRAY{ARG},$TP}, t:TP_ROUT):BOOL
-- True if `t' is a bound routine with arg and return types as
-- listed in `q'.
is
if void(t) then return false end;
if void(q.t2) then if ~void(t.ret) then return false end-- TUP{2}::t2 TP_ROUT::ret BOOL::not
elsif q.t2/=t.ret then return false end;-- TUP{2}::t2 TP_ROUT::ret BOOL::not
if q.t1.size/=t.args.size then return false end;-- TUP{2}::t1 ARRAY{1}::size INT::is_eq TP_ROUT::args ARRAY{1}::size BOOL::not
loop if q.t1.elt!/=t.args.elt! then return false end end;-- TUP{2}::t1 ARRAY{1}::elt! ARG::is_eq TP_ROUT::args ARRAY{1}::elt! BOOL::not
return true
end;
query_hash(q:TUP{ARRAY{ARG},$TP}):INT
-- A hash value computed from the query types.
is
r::=0;
-- Make depend on return type.
if ~void(q.t2) then r:=SYS::id(q.t2).hash; end;-- TUP{2}::t2 BOOL::not SYS::id TUP{2}::t2 INT::hash
-- And arg types.
loop
i::=q.t1.ind!;-- TUP{2}::t1 ARRAY{1}::ind!
r:=r.mplus(SYS::id(q.t1[i].tp)).mplus(i).mtimes(19);-- INT::mplus SYS::id TUP{2}::t1 ARRAY{1}::aget ARG::tp INT::mplus INT::mtimes
end;
return r.hash-- INT::hash
end;
elt_hash(e:TP_ROUT):INT
-- A hash value computed from the query types.
is
r::=0;
-- Make depend on return type.
if ~void(e.ret) then r:=SYS::id(e.ret).hash; end;-- TP_ROUT::ret BOOL::not SYS::id TP_ROUT::ret INT::hash
-- And arg types.
loop
i::=e.args.ind!;-- TP_ROUT::args ARRAY{1}::ind!
r:=r.mplus(SYS::id(e.args[i].tp)).mplus(i).mtimes(19);-- INT::mplus SYS::id TP_ROUT::args ARRAY{1}::aget ARG::tp INT::mplus INT::mtimes
end;
return r.hash-- INT::hash
end;
end; -- class TP_ROUT_TBL
class TP_ITER_TBL
class TP_ITER_TBL is
-- Tables of bound iter types.
--
-- `get_query(TUP{ARRAY{ARG},ARRAY{BOOL},$TP}):TP_ITER' look up a type.
-- `test(TP_ITER):BOOL' tests for a type.
-- `insert(TP_ITER):SAME' inserts a type.
-- `delete(TP_ITER):SAME' deletes a type.
include FQSET{TUP{ARRAY{ARG},ARRAY{BOOL},$TP}, TP_ITER};
query_test(q:TUP{ARRAY{ARG},ARRAY{BOOL},$TP}, t:TP_ITER):BOOL
-- True if `t' is a bound iter with arg types, arg hotness and
-- return type as listed in `q'.
is
if void(t) then return false end;
if void(q.t3) then -- TUP{3}::t3
if ~void(t.ret) then return false end;-- TP_ITER::ret BOOL::not
elsif q.t3 /= t.ret then return false end; -- TUP{3}::t3 TP_ITER::ret BOOL::not
if q.t1.size/=t.args.size then return false end;-- TUP{3}::t1 ARRAY{1}::size INT::is_eq TP_ITER::args ARRAY{1}::size BOOL::not
loop if q.t1.elt!/=t.args.elt! then return false end end;-- TUP{3}::t1 ARRAY{1}::elt! ARG::is_eq TP_ITER::args ARRAY{1}::elt! BOOL::not
if q.t2.size/=t.hot.size then return false end; -- TUP{3}::t2 ARRAY{1}::size INT::is_eq TP_ITER::hot ARRAY{1}::size BOOL::not
loop if q.t2.elt!/=t.hot.elt! then return false end end;-- TUP{3}::t2 ARRAY{1}::elt! BOOL::is_eq TP_ITER::hot ARRAY{1}::elt! BOOL::not
return true
end;
query_hash(q:TUP{ARRAY{ARG},ARRAY{BOOL},$TP}):INT is
-- A hash value computed from the query types.
r::=0;
-- Make depend on return type.
if ~void(q.t3) then r:=SYS::id(q.t3).hash; end;-- TUP{3}::t3 BOOL::not SYS::id TUP{3}::t3 INT::hash
-- And arg types.
loop
i::=q.t1.ind!;-- TUP{3}::t1 ARRAY{1}::ind!
r:=r.mplus(SYS::id(q.t1[i].tp)).mplus(i).mtimes(19);-- INT::mplus SYS::id TUP{3}::t1 ARRAY{1}::aget ARG::tp INT::mplus INT::mtimes
end;
-- leav out hotness for now
return r.hash -- INT::hash
end;
elt_hash(e:TP_ITER):INT is
-- A hash value computed from the query types.
r::=0;
-- Make depend on return type.
if ~void(e.ret) then r:=SYS::id(e.ret).hash; end;-- TP_ITER::ret BOOL::not SYS::id TP_ITER::ret INT::hash
-- And arg types.
loop
i::=e.args.ind!;-- TP_ITER::args ARRAY{1}::ind!
r:=r.mplus(SYS::id(e.args[i].tp)).mplus(i).mtimes(19);-- INT::mplus SYS::id TP_ITER::args ARRAY{1}::aget ARG::tp INT::mplus INT::mtimes
end;
-- ignore hotness for now
return r.hash -- INT::hash
end;
end; -- class TP_ITER_TBL
class TP_GRAPH
class TP_GRAPH is
-- Objects which represent Sather type graphs.
-- The tables do not explicitly represent the edges between
-- bound objects
attr prog:PROG;
attr par_tbl:FMAP{TP_CLASS,FSET{TP_CLASS}};
-- Map from each class type to the direct supertypes
attr anc_tbl:FMAP{TP_CLASS,FSET{TP_CLASS}};
-- Map from each class type to its ancestors
attr child_tbl:FMAP{TP_CLASS,FSET{$TP}};
-- Map from each abstract type to any explicit children
attr des_tbl:FMAP{TP_CLASS,FSET{$TP}};
-- Table of descendants for each abstract type.
attr cur:FSET{TUP{IDENT,INT}};
-- The set of type names and number of parameters which are in
-- the process of determining their ancestors. Used to detect loops.
create(prog:PROG):SAME
-- A type graph for the program `prog'.
is
r::=new; r.prog:=prog; -- TP_GRAPH::prog
return r
end;
abs_subtype_test(t:$TP, at:TP_CLASS):BOOL
-- True if the type `t' is a subtype of the abstract type `at'.
pre at.is_abstract-- TP_CLASS::is_abstract
is
if t=at or at=TP_BUILTIN::dollar_ob then return true end;-- TP_CLASS::is_eq TP_BUILTIN::dollar_ob
typecase t
when TP_CLASS then
if get_anc(t).test(at) then return true end;-- TP_GRAPH::get_anc FSET{1}::test
else
end;
if get_des(at).test(t) then return true end;-- TP_GRAPH::get_des FSET{1}::test
return false
end;
tup_str(t:TUP{IDENT,INT}):STR
-- A string for the specified type of the form "FOO{_,_,_}".
is
return t.t1.str(t.t2);-- TUP{2}::t1 IDENT::str TUP{2}::t2
end;
get_parents(tp:TP_CLASS):FSET{TP_CLASS} is
return par_tbl.get(tp);-- TP_GRAPH::par_tbl FMAP{2}::get
end;
get_children(tp:TP_CLASS):FSET{$TP} is
return child_tbl.get(tp);-- TP_GRAPH::child_tbl FMAP{2}::get
end;
make_family_members is
-- compute parents and children information for all classes
-- using both subtyping ``>'' and supertyping ``<''
children:FSET{$TP};
parents:FSET{TP_CLASS};
loop
t:$TP:=prog.tp_done.elt!;-- TP_GRAPH::prog PROG::tp_done FSET{1}::elt!
typecase t
when TP_CLASS then
as ::= prog.parse.tree_for(t.name, t.params.size); -- TP_GRAPH::prog PROG::parse TP_CLASS::name TP_CLASS::params ARRAY{1}::size
if ~void(as) then -- BOOL::not
con ::= t.tp_context_for;-- TP_CLASS::tp_context_for
if ~void(as.under) then-- AS_CLASS_DEF::under BOOL::not
parents := #;-- FSET{1}::create
children := #;-- FSET{1}::create
ts ::= as.under;-- AS_CLASS_DEF::under
loop
until!(void(ts));
tp ::= con.tp_of(ts);-- TP_CONTEXT::tp_of
typecase tp
when TP_CLASS then
if ~tp.is_abstract then -- TP_CLASS::is_abstract BOOL::not
prog.err("In type " + t.str + " the type " + tp.str + -- TP_GRAPH::prog PROG::err STR::plus TP_CLASS::str STR::plus STR::plus TP_CLASS::str
" appears in the supertype list but is not abstract.") -- STR::plus
else
parents := parents.insert(tp);-- FSET{1}::insert
children := child_tbl.get(tp);-- TP_GRAPH::child_tbl FMAP{2}::get
children := children.insert(t);-- FSET{1}::insert
child_tbl := child_tbl.insert(tp, children);-- TP_GRAPH::child_tbl TP_GRAPH::child_tbl FMAP{2}::insert
end;
else
prog.err("In type " + t.str + " the type " + tp.str-- TP_GRAPH::prog PROG::err STR::plus TP_CLASS::str STR::plus STR::plus
+ " appears in the supertype list but is a bound type.")-- STR::plus
end;
ts := ts.next;-- AS_TYPE_SPEC::next
end;
parents := par_tbl.get(t).to_union(parents);-- TP_GRAPH::par_tbl FMAP{2}::get FSET{1}::to_union
par_tbl := par_tbl.insert(t, parents);-- TP_GRAPH::par_tbl TP_GRAPH::par_tbl FMAP{2}::insert
end;
if ~void(as.over) then-- AS_CLASS_DEF::over BOOL::not
parents := #;-- FSET{1}::create
children := #; -- FSET{1}::create
ts ::= as.over;-- AS_CLASS_DEF::over
loop
until!(void(ts));
tp ::= con.tp_of(ts);-- TP_CONTEXT::tp_of
typecase tp
when TP_CLASS then
if tp.is_external then -- TP_CLASS::is_external
prog.err("The type " + t.str + " lists the external type "-- TP_GRAPH::prog PROG::err STR::plus TP_CLASS::str
+ tp.str + " in its subtype list.")-- STR::plus STR::plus TP_CLASS::str STR::plus
else
children := children.insert(tp);-- FSET{1}::insert
parents := par_tbl.get(tp);-- TP_GRAPH::par_tbl FMAP{2}::get
parents := parents.insert(t);-- FSET{1}::insert
par_tbl := par_tbl.insert(tp, parents);-- TP_GRAPH::par_tbl TP_GRAPH::par_tbl FMAP{2}::insert
end;
end;
ts := ts.next;-- AS_TYPE_SPEC::next
end;
children := child_tbl.get(t).to_union(children);-- TP_GRAPH::child_tbl FMAP{2}::get FSET{1}::to_union
child_tbl := child_tbl.insert(t, children);-- TP_GRAPH::child_tbl TP_GRAPH::child_tbl FMAP{2}::insert
end;
end;
else
end;
end;
end;
get_anc(t:TP_CLASS):FSET{TP_CLASS}
-- The set of "<" ancestors for `t'. Void if none. $OB is not
-- explicitly included. Do not modify the returned table.
-- Reports an error if there is a loop. All returned types
-- should be abstract.
is
p ::= anc_tbl.get_pair(t);-- TP_GRAPH::anc_tbl FMAP{2}::get_pair
if ~void(p.t1) then return p.t2 end;-- TUP{2}::t1 BOOL::not TUP{2}::t2
-- parents ::= get_parents(t);
parents ::= par_tbl.get(t); -- TP_GRAPH::par_tbl FMAP{2}::get
if void(parents) then return void end;
cq ::= #TUP{IDENT,INT}(t.name,t.params.size);-- TUP{2}::create TP_CLASS::name TP_CLASS::params ARRAY{1}::size
if cur.test(cq) then -- TP_GRAPH::cur FSET{1}::test
as ::= prog.parse.tree_for(t.name, t.params.size); -- TP_GRAPH::prog PROG::parse TP_CLASS::name TP_CLASS::params ARRAY{1}::size
prog.err_loc(as); -- TP_GRAPH::prog PROG::err_loc
s ::= #FSTR + "Subtype cycle detected involving the types: ";-- FSTR::create FSTR::plus
loop s:=s+", ".separate!(tup_str(cur.elt!)) end;-- FSTR::plus STR::separate! TP_GRAPH::cur FSET{1}::elt!
prog.err(s.str); -- TP_GRAPH::prog PROG::err FSTR::str
anc_tbl := anc_tbl.insert(t,void);-- TP_GRAPH::anc_tbl TP_GRAPH::anc_tbl FMAP{2}::insert
cur := cur.delete(cq); -- TP_GRAPH::cur TP_GRAPH::cur FSET{1}::delete
return void
end;
r:FSET{TP_CLASS};
cur:=cur.insert(cq); -- TP_GRAPH::cur TP_GRAPH::cur FSET{1}::insert
loop
t2 ::= parents.elt!; -- FSET{1}::elt!
r := r.insert(t2); r := r.to_union(get_anc(t2))-- FSET{1}::insert FSET{1}::to_union TP_GRAPH::get_anc
end;
anc_tbl := anc_tbl.insert(t,r); cur:=cur.delete(cq);-- TP_GRAPH::anc_tbl TP_GRAPH::anc_tbl FMAP{2}::insert TP_GRAPH::cur TP_GRAPH::cur FSET{1}::delete
return r
end; -- get_anc
get_des(t:TP_CLASS):FSET{$TP}
-- The set of ">" descendants for `t'. Void if none.
-- Do not modify the returned table. Reports an error if there
-- is a loop.
is
r:FSET{$TP};
p ::= des_tbl.get_pair(t);-- TP_GRAPH::des_tbl FMAP{2}::get_pair
if ~void(p.t1) then return p.t2 end;-- TUP{2}::t1 BOOL::not TUP{2}::t2
cld ::= child_tbl.get(t);-- TP_GRAPH::child_tbl FMAP{2}::get
if void(cld) then return void end;
cq ::= #TUP{IDENT,INT}(t.name,t.params.size);-- TUP{2}::create TP_CLASS::name TP_CLASS::params ARRAY{1}::size
if cur.test(cq) then -- TP_GRAPH::cur FSET{1}::test
as ::= prog.parse.tree_for(t.name, t.params.size); -- TP_GRAPH::prog PROG::parse TP_CLASS::name TP_CLASS::params ARRAY{1}::size
prog.err_loc(as); -- TP_GRAPH::prog PROG::err_loc
s ::= #FSTR + "Supertype cycle detected involving the types with "-- FSTR::create
"the following names and number of parameters: ";-- FSTR::plus
loop s:=s+", ".separate!(tup_str(cur.elt!)) end;-- FSTR::plus STR::separate! TP_GRAPH::cur FSET{1}::elt!
prog.err(s.str); -- TP_GRAPH::prog PROG::err FSTR::str
des_tbl := des_tbl.insert(t,void);-- TP_GRAPH::des_tbl TP_GRAPH::des_tbl FMAP{2}::insert
cur:=cur.delete(cq); -- TP_GRAPH::cur TP_GRAPH::cur FSET{1}::delete
return void
end;
cur:=cur.insert(cq); -- TP_GRAPH::cur TP_GRAPH::cur FSET{1}::insert
loop
t2 ::= cld.elt!; -- FSET{1}::elt!
r := r.insert(t2); -- FSET{1}::insert
typecase t2
when TP_CLASS then r:=r.to_union(get_des(t2))-- FSET{1}::to_union TP_GRAPH::get_des
else end
end;
des_tbl := des_tbl.insert(t,r);-- TP_GRAPH::des_tbl TP_GRAPH::des_tbl FMAP{2}::insert
cur:=cur.delete(cq);-- TP_GRAPH::cur TP_GRAPH::cur FSET{1}::delete
return r
end; -- get_des
end; -- class TP_GRAPH
class TP_GRAPH_ABS_DES
class TP_GRAPH_ABS_DES is
-- Table of all concrete descendants of abstract types.
--pSather
attr gate, mutex, dollar_lock:TP_CLASS;
attr prog:PROG; -- The program this table belongs to.
attr tbl:FMAP{TP_CLASS,FSET{$TP}}; -- Table of concrete descendants
-- of each abstract type.
create(prog:PROG):SAME is
-- Compute an abstract descendant table for the program `prog',
-- from the explicit ancestor and descendant tables `anc' and
-- `des'.
r::=new; r.prog:=prog; return r end;-- TP_GRAPH_ABS_DES::prog
do_tbl is
-- Compute the table assuming that `prog.tp_graph' and
-- `prog.find_types' are done.
do_dollar_ob; do_anc; do_des end;-- TP_GRAPH_ABS_DES::do_dollar_ob TP_GRAPH_ABS_DES::do_anc TP_GRAPH_ABS_DES::do_des
do_dollar_ob is
-- Put in all concrete types under $OB.
dob:TP_CLASS:=TP_BUILTIN::dollar_ob;-- TP_BUILTIN::dollar_ob
tt:FSET{$TP}:=prog.tp_done;-- TP_GRAPH_ABS_DES::prog PROG::tp_done
if void(tt) then return end;
loop tp::=tt.elt!; -- FSET{1}::elt!
if ~tp.is_abstract then add(dob,tp) end end end;-- BOOL::not TP_GRAPH_ABS_DES::add
do_anc is
-- Put entries in the table based on the subtype edges.
loop p::=prog.tp_graph.anc_tbl.pairs!; -- TP_GRAPH_ABS_DES::prog PROG::tp_graph TP_GRAPH::anc_tbl FMAP{2}::pairs!
if ~p.t1.is_abstract then-- TUP{2}::t1 TP_CLASS::is_abstract BOOL::not
loop add(p.t2.elt!,p.t1) end end end end; -- TP_GRAPH_ABS_DES::add TUP{2}::t2 FSET{1}::elt! TUP{2}::t1
do_des is
-- Put entries in the table based on the supertype edges.
loop p::=prog.tp_graph.des_tbl.pairs!; -- TP_GRAPH_ABS_DES::prog PROG::tp_graph TP_GRAPH::des_tbl FMAP{2}::pairs!
loop ct::=p.t2.elt!;-- TUP{2}::t2 FSET{1}::elt!
if ~ct.is_abstract then add(p.t1,ct) end end end end;-- BOOL::not TP_GRAPH_ABS_DES::add TUP{2}::t1
add(at:TP_CLASS,ct:$TP) is
-- Add the concrete type `ct' as one of the descendants of the
-- abstract type `at'.
s::=tbl.get(at); s:=s.insert(ct); tbl:=tbl.insert(at,s) end;-- TP_GRAPH_ABS_DES::tbl FMAP{2}::get FSET{1}::insert TP_GRAPH_ABS_DES::tbl TP_GRAPH_ABS_DES::tbl FMAP{2}::insert
des_of(tp:TP_CLASS):FSET{$TP} is
-- A table of the concrete descendants of the abstract type
-- `tp'. Void if none.
return tbl.get(tp) end;-- TP_GRAPH_ABS_DES::tbl FMAP{2}::get
end; -- class TP_GRAPH_ABS_DES
class TP_BUILTIN
class TP_BUILTIN is
-- Cache for quick access to the type objects for builtin types.
readonly shared
dollar_ob, bool, char, int, inti, flt, fltd, fltx, fltdx, flti,
f_integer, f_real, f_integer_arr, f_real_arr, attach, str, sys,
ext_ob, arr_of_str,fstr,prefetch, runtime, c_unix: TP_CLASS;
readonly shared rout:TP_ROUT;
--pSather
readonly shared gate, mutex, dollar_lock:TP_CLASS;
initialize(t:TP_TBL)
-- A table of builtin types for the program `prog'.
is
dollar_ob:=t.tp_class_for(#IDENT("$OB"),void);-- TP_BUILTIN::dollar_ob TP_TBL::tp_class_for IDENT::create
bool:=t.tp_class_for(#IDENT("BOOL"),void); -- TP_BUILTIN::bool TP_TBL::tp_class_for IDENT::create
char:=t.tp_class_for(#IDENT("CHAR"),void); -- TP_BUILTIN::char TP_TBL::tp_class_for IDENT::create
int:=t.tp_class_for(#IDENT("INT"),void); -- TP_BUILTIN::int TP_TBL::tp_class_for IDENT::create
inti:=t.tp_class_for(#IDENT("INTI"),void); -- TP_BUILTIN::inti TP_TBL::tp_class_for IDENT::create
flt:=t.tp_class_for(#IDENT("FLT"),void); -- TP_BUILTIN::flt TP_TBL::tp_class_for IDENT::create
fltd:=t.tp_class_for(#IDENT("FLTD"),void); -- TP_BUILTIN::fltd TP_TBL::tp_class_for IDENT::create
fltx:=t.tp_class_for(#IDENT("FLTX"),void); -- TP_BUILTIN::fltx TP_TBL::tp_class_for IDENT::create
fltdx:=t.tp_class_for(#IDENT("FLTDX"),void); -- TP_BUILTIN::fltdx TP_TBL::tp_class_for IDENT::create
flti:=t.tp_class_for(#IDENT("FLTI"),void); -- TP_BUILTIN::flti TP_TBL::tp_class_for IDENT::create
str:=t.tp_class_for(#IDENT("STR"),void); -- TP_BUILTIN::str TP_TBL::tp_class_for IDENT::create
fstr:=t.tp_class_for(#IDENT("FSTR"),void); -- TP_BUILTIN::fstr TP_TBL::tp_class_for IDENT::create
attach:=t.tp_class_for(#IDENT("$ATTACH"),void); -- TP_BUILTIN::attach TP_TBL::tp_class_for IDENT::create
sys:=t.tp_class_for(#IDENT("SYS"),void); -- TP_BUILTIN::sys TP_TBL::tp_class_for IDENT::create
ext_ob:=t.tp_class_for(#IDENT("EXT_OB"),void);-- TP_BUILTIN::ext_ob TP_TBL::tp_class_for IDENT::create
prefetch:=t.tp_class_for(#IDENT("PREFETCH"),void);-- TP_BUILTIN::prefetch TP_TBL::tp_class_for IDENT::create
rout:=t.tp_rout_for(void,void); -- ROUT-- TP_BUILTIN::rout TP_TBL::tp_rout_for
arr:ARRAY{$TP}:=ARRAY{$TP}::create(1); arr[0]:=str;-- ARRAY{1}::create ARRAY{1}::aset TP_BUILTIN::str
arr_of_str:=t.tp_class_for(#IDENT("ARRAY"),arr);-- TP_BUILTIN::arr_of_str TP_TBL::tp_class_for IDENT::create
runtime:=t.tp_class_for(#IDENT("RUNTIME"),void);-- TP_BUILTIN::runtime TP_TBL::tp_class_for IDENT::create
c_unix:=t.tp_class_for(#IDENT("C_UNIX"),void);-- TP_BUILTIN::c_unix TP_TBL::tp_class_for IDENT::create
-- external FORTRAN types
f_integer:=t.tp_class_for(#IDENT("F_INTEGER"),void);-- TP_BUILTIN::f_integer TP_TBL::tp_class_for IDENT::create
f_real:=t.tp_class_for(#IDENT("F_REAL"),void); -- TP_BUILTIN::f_real TP_TBL::tp_class_for IDENT::create
-- f_integer_arr:=t.tp_class_for(#IDENT("F_INTEGER_ARR"),void);
-- f_real_arr:=t.tp_class_for(#IDENT("F_REAL_ARR"),void);
--pSather
dollar_lock:=t.tp_class_for(#IDENT("$LOCK"),void);-- TP_BUILTIN::dollar_lock TP_TBL::tp_class_for IDENT::create
end;
end; -- class TP_BUILTIN