home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / sa104os2.zip / SATHR104.ZIP / SATHER / COMPILER / TP.SA < prev    next >
Text File  |  1995-02-13  |  35KB  |  905 lines
  1. -- Copyright (C) International Computer Science Institute, 1994.  COPYRIGHT  --
  2. -- NOTICE: This code is provided "AS IS" WITHOUT ANY WARRANTY and is subject --
  3. -- to the terms of the SATHER LIBRARY GENERAL PUBLIC LICENSE contained in    --
  4. -- the file "Doc/License" of the Sather distribution.  The license is also   --
  5. -- available from ICSI, 1947 Center St., Suite 600, Berkeley CA 94704, USA.  --
  6. --------> Please email comments to "sather-bugs@icsi.berkeley.edu". <----------
  7.  
  8. -- tp.sa: Classes relating to types in the Sather compiler.
  9. -------------------------------------------------------------------
  10. -- $TP: Abstract interface to Sather types.
  11. -- TP_CLASS: Reference, value, abstract, or external types.
  12. -- TP_ROUT: Bound routine types.
  13. -- TP_ITER: Bound iter types.
  14. -- TP_CONTEXT: Context for TR_TYPE_SPEC -> $TP conversion.
  15. -- TP_TBL: Table of all types.
  16. -- TP_CLASS_TBL: Table of class types.
  17. -- TP_ROUT_TBL: Table of bound routine types.
  18. -- TP_ITER_TBL: Table of bound iter types. 
  19. -- TP_GRAPH: Computes the type graph.
  20. -- TP_GRAPH_ANC: Computes a type's '>' ancestors.   
  21. -- TP_GRAPH_DES: Computes a type's '<' descendants.      
  22. -- TP_BUILTIN: Cache of the type objects for builtin types.
  23. -------------------------------------------------------------------
  24. type $TP < $CALL_TP is
  25.    -- Abstract interface to classes representing Sather types.
  26.    -- Descendants are TP_CLASS, TP_ROUT, and TP_ITER.
  27.  
  28.    prog:PROG;            -- This type's program object.
  29.  
  30.    str:STR;            -- The string representation of self.
  31.       -- Uses no whitespace, eg: "FOO{A,B{C},D}".
  32.  
  33.    is_abstract:BOOL;        -- True if self is abstract.
  34.    
  35.    is_value:BOOL;        -- True is self is a value type.
  36.  
  37.    is_atomic:BOOL;        -- Does the implementation use pointers
  38.                 -- that may affect garbage collection?
  39.  
  40.    is_bound:BOOL;        -- True if self is a bound type.
  41.  
  42.    is_subtype(t:$TP):BOOL;    -- True if self is a subtype of `t'.
  43.    
  44.    is_eq(t:$TP):BOOL;        -- Equality test.
  45.    
  46.    is_neq(t:$TP):BOOL;        -- Inequality test.
  47.    
  48.    hash:INT;            -- Hash value.
  49.    
  50.    kind:INT;            -- One of TP_KIND::missing_tp, 
  51.       -- TP_KIND::val_tp, TP_KIND::ref_tp, TP_KIND::abs_tp, 
  52.       -- TP_KIND::ext_tp, TP_KIND::rout_tp, TP_KIND::iter_tp.
  53.  
  54. end; -- type $TP
  55.    
  56. -------------------------------------------------------------------
  57. class TP_KIND is
  58.    -- A set of constants defining the different kinds of types. 
  59.    const missing_tp, 
  60.    val_tp,            -- Value types.
  61.    ref_tp,            -- Reference types.
  62.    abs_tp,            -- Abstract types.
  63.    ext_tp,            -- External types.
  64.    rout_tp,            -- Bound routine types.
  65.    iter_tp;            -- Bound iter types. 
  66.  
  67. end; -- class TP_KIND
  68. -------------------------------------------------------------------   
  69. class TP is
  70.    -- Implementation to be included by $TP objects.
  71.    attr prog:PROG;        -- This type's program object.   
  72.  
  73.    is_value:BOOL is
  74.       -- True if a value type.
  75.       return kind=TP_KIND::val_tp; end;
  76.  
  77.    is_atomic:BOOL is
  78.        -- Conservative answer
  79.        return false;
  80.    end;
  81.  
  82.    kind:INT is
  83.       raise "kind is expected to be redefined"; end;
  84.  
  85.    is_eq(t:$TP):BOOL is
  86.       -- True if self equals `t'.
  87.       return SYS::ob_eq(self,t) end;
  88.  
  89.    is_neq(t:$TP):BOOL is
  90.       -- True if self is not equal to `t'.
  91.       return ~SYS::ob_eq(self,t) end;
  92.    
  93.    hash:INT is
  94.       -- A hash value for this type.
  95.       return SYS::id(self) end;
  96.    
  97. end; -- class TP
  98.    
  99. -------------------------------------------------------------------
  100. class TP_CLASS < $TP is
  101.    -- Representation of reference, value, abstract, and external types.
  102.    include TP;
  103.    
  104.    attr name:IDENT;        -- The name of the type.
  105.    attr params:ARRAY{$TP};    -- Specifiers for the type
  106.       -- parameters in order, void if none.
  107.       
  108.    private attr str_cache:STR;    -- Cache for string representation.
  109.    private attr kind_cache:INT;    -- Cache for the kind of class this is
  110.    private attr atomic_cache:BOOL;
  111.    private attr use_cached_atomic:BOOL;
  112.  
  113.  
  114.    create(name:IDENT, params:ARRAY{$TP}, prog:PROG):SAME is
  115.       -- A class type object with the specified attributes.
  116.       r::=new; r.name:=name; r.params:=params; r.prog:=prog;
  117.       r.kind_cache:=TP_KIND::missing_tp;
  118.       r.use_cached_atomic:=false;
  119.       return r end;
  120.  
  121.    str:STR is
  122.       -- The string version of the type represented by self. Uses no
  123.       -- whitespace, eg: "FOO{A,B{C},D}".
  124.       if ~void(str_cache) then return str_cache end;
  125.       if void(self) then return "void" end;
  126.       if void(params) then str_cache:=name.str 
  127.       else s::=#FSTR + name.str + '{'; 
  128.      loop s:=s+",".separate!(params.elt!.str) end;
  129.      s:=s+'}'; str_cache:=s.str end;
  130.       return str_cache end;
  131.  
  132.    is_abstract:BOOL is 
  133.       -- True if self is abstract.
  134.       if void(self) then return false end;
  135.       return name.str[0]='$' end;   
  136.    
  137.    is_bound:BOOL is
  138.       -- Returns false.
  139.       return false end;
  140.    
  141.    is_subtype(t:$TP):BOOL is
  142.       -- True if self is a subtype of `t'.         
  143.       if void(self) then return false end;      
  144.       if self=t then return true 
  145.       else
  146.      typecase t
  147.      when TP_CLASS then 
  148.         if t.is_abstract then return prog.abs_subtype_test(self,t)
  149.         else return false end;
  150. --       else return false end end end;                                         -- NLP
  151.          else; end; end; return false; end;                                     -- NLP
  152.  
  153.    kind:INT is 
  154.       -- One of TP_KIND::missing_tp, TP_KIND::val_tp, TP_KIND::ref_tp,
  155.       -- TP_KIND::abs_tp, TP_KIND::ext_tp, TP_KIND::rout_tp, 
  156.       -- TP_KIND::iter_tp. 
  157.       if kind_cache=TP_KIND::missing_tp then
  158.       kind_cache:=prog.tp_kind(self);
  159.       end;
  160.       return kind_cache end;
  161.  
  162.     private is_atomic_implementation:BOOL is
  163.        -- figure out if we can be allocated atomically.
  164.        builtin ::= prog.tp_builtin;
  165.        if self = builtin.bool then
  166.         return true;
  167.        elsif self = builtin.char then
  168.         return true;
  169.        elsif self = builtin.int then
  170.         return true;
  171.        elsif self = builtin.flt then
  172.         return true
  173.        elsif self = builtin.fltd then
  174.         return true
  175.        elsif self = builtin.fltx then
  176.         return true
  177.        elsif self = builtin.fltx then
  178.         return true
  179.        elsif self = builtin.fltdx then
  180.         return true;
  181.        elsif self = builtin.flti then
  182.         return true;
  183.        elsif self = builtin.str then
  184.         return true;
  185.        elsif self = builtin.sys then
  186.         return false;
  187.        elsif self = builtin.str then
  188.         return true;
  189.        elsif self = builtin.ext_ob then
  190.         return false;
  191.        elsif self = builtin.dollar_ob then
  192.         return false;
  193.        end;
  194.        imp ::= prog.impl_tbl.impl_of(self);
  195.        return imp.is_atomic;
  196.     end;
  197.  
  198.     is_atomic:BOOL is
  199.        -- mbk
  200.        if void(self) then return false end; -- 
  201.        if ~use_cached_atomic then
  202.         atomic_cache := is_atomic_implementation;
  203.         use_cached_atomic := true;
  204.        end;
  205.        return atomic_cache;
  206.     end;
  207.    
  208. end; -- class TP_CLASS
  209.  
  210. -------------------------------------------------------------------
  211. class TP_ROUT < $TP is
  212.    -- Representation of bound routine types.
  213.    include TP;
  214.    
  215.    attr args:ARRAY{$TP};    -- Specifiers for the argument types
  216.       -- in order, void if none.
  217.    attr ret:$TP;        -- The return type, void if none.
  218.  
  219.    create(args:ARRAY{$TP}, ret:$TP, prog:PROG):SAME is
  220.       -- A bound routine type object with the specified attributes.
  221.       r::=new; r.args:=args; r.ret:=ret; r.prog:=prog; return r end;      
  222.  
  223.    private attr str_cache:STR;    -- Cache for string representation.   
  224.    
  225.    str:STR is
  226.       -- The string version of the type represented by self. Uses no
  227.       -- whitespace, eg: "ROUT{A,B{C},D}:E".
  228.       if void(self) then return "void" end;
  229.       if ~void(str_cache) then    -- Don't need to do anything.
  230.       elsif void(args) and void(ret) then str_cache:="ROUT"
  231.       else s::=#FSTR + "ROUT";
  232.      if ~void(args) then
  233.         s:=s + '{'; 
  234.         loop s:=s+",".separate!(args.elt!.str) end;
  235.         s:=s + '}' end;
  236.      if ~void(ret) then s:=s + ':' + ret.str end;
  237.      str_cache:=s.str end;
  238.       return str_cache end;
  239.    
  240.    is_abstract:BOOL is
  241.       -- Returns false.
  242.       return false end;            
  243.  
  244.    is_bound:BOOL is
  245.       -- Returns true.
  246.       return true end;
  247.    
  248.    is_subtype(t:$TP):BOOL is
  249.       -- True if self is a subtype of `t'. 
  250.       if void(self) then return false end;
  251.       typecase t
  252.       when TP_CLASS then 
  253.      if ~t.is_abstract then return false
  254.      else return prog.abs_subtype_test(self,t) end;
  255.       when TP_ROUT then
  256.      -- Test for contravariant conformance. This means:
  257.      -- 1) Self and `t' have the same number of arguments.
  258.      -- 2) The type of each argument of `t' must conform to the 
  259.      --    corresponding argument of self.
  260.      -- 3) Both have a return value or both do not.
  261.      -- 4) The return type of self msut conform to that of `t' if 
  262.      --    they do.
  263.      if args.size/=t.args.size then return false end;
  264.      loop 
  265.         if ~t.args.elt!.is_subtype(args.elt!)
  266.         then return false end end;
  267.      if has_ret/=t.has_ret then return false end;
  268.      if has_ret and ~ret.is_subtype(t.ret) then return false end;
  269.      return true
  270. --    else return false end end;                                                -- NLP
  271.       else; end; return false; end;                                             -- NLP
  272.    
  273.    has_ret:BOOL is
  274.       -- True if self has a return value.
  275.       return ~void(ret) end;
  276.  
  277.    kind:INT is
  278.       -- The kind of this type.
  279.       return TP_KIND::rout_tp end;
  280.    
  281. end; -- class TP_ROUT
  282.    
  283. -------------------------------------------------------------------
  284. class TP_ITER < $TP is
  285.    -- Representation of bound iter types.
  286.    include TP;
  287.    
  288.    attr args:ARRAY{$TP};    -- Specifiers for the argument types
  289.       -- in order, void if none.
  290.    attr hot:ARRAY{BOOL};    -- Treu for each arg which is marked 
  291.       -- with a "!". None are hot if this array is void.
  292.    attr ret:$TP;        -- The return type, void if none.
  293.  
  294.    create(args:ARRAY{$TP}, hot:ARRAY{BOOL}, ret:$TP, prog:PROG):SAME is
  295.       -- A bound routine type object with the specified attributes.
  296.       r::=new; r.args:=args; r.hot:=hot; r.ret:=ret; r.prog:=prog; 
  297.       return r end;
  298.    
  299.    attr str_cache:STR;    -- Cache for string representation.   
  300.  
  301.    str:STR is
  302.       -- The string version of the type represented by self. Uses no
  303.       -- whitespace, eg: "ITER{A!,B{C},D}:E".
  304.       -- If self is void, returns "void".
  305.       if void(self) then return "void" end;
  306.       if ~void(str_cache) then    -- Don't need to do anything.
  307.       elsif void(args) and void(ret) then str_cache:="ITER"
  308.       else s::=#FSTR + "ITER";
  309.       if ~void(args) then
  310.         s:=s + '{'; 
  311.         loop s:=s+",".separate!(args.elt!.str);
  312.            if ~void(hot) and hot.elt! then s:=s + '!' end end;
  313.         s:=s + '}' end;
  314.      if ~void(ret) then s:=s + ':' + ret.str end;
  315.      str_cache:=s.str end;
  316.       return str_cache end;
  317.    
  318.    is_abstract:BOOL is
  319.       -- Returns false.
  320.       return false end;      
  321.  
  322.    is_bound:BOOL is
  323.       -- Returns true.
  324.       return true end;
  325.    
  326.    is_subtype(t:$TP):BOOL is
  327.       -- True if self is a subtype of `t'. 
  328.       if void(self) then return false end;      
  329.       typecase t
  330.       when TP_CLASS then 
  331.      if ~t.is_abstract then return false
  332.      else return prog.abs_subtype_test(self,t) end;
  333.       when TP_ITER then
  334.      -- Test for contravariant conformance. This means:
  335.      -- 1) Self and `t' have the same number of arguments.
  336.      -- 2) The type of each argument of `t' must conform to the 
  337.      --    corresponding argument of self.
  338.      -- 3) Corresponding args must either both be hot or both not.
  339.      -- 4) Both have a return value or both do not.
  340.      -- 5) The return type of self msut conform to that of `t' if 
  341.      --    they do.
  342.      if args.size/=t.args.size then return false end;
  343.      loop 
  344.         if ~t.args.elt!.is_subtype(args.elt!)
  345.         then return false end end;
  346.      if hot.size/=t.hot.size then return false end;
  347.      loop 
  348.         if hot.elt!/=t.hot.elt! then return false end end;
  349.      if has_ret/=t.has_ret then return false end;
  350.      if has_ret and ~ret.is_subtype(t.ret) then
  351.         return false end;
  352.      return true
  353. --    else return false end end;                                                -- NLP
  354.       else; end; return false; end;                                             -- NLP
  355.  
  356.    has_ret:BOOL is
  357.       -- True if self has a return value.
  358.       if void(self) then return false end;      
  359.       return ~void(ret) end;
  360.    
  361.    kind:INT is 
  362.       -- The kind of this type.
  363.       return TP_KIND::iter_tp end;
  364.    
  365. end; -- class TP_ITER
  366.  
  367. -------------------------------------------------------------------
  368. class TP_CONTEXT is
  369.    -- A context for converting TR_TYPE_SPEC trees into $TP objects.
  370.    
  371.    attr same:TP_CLASS;        -- The type that replaces "SAME",
  372.    attr pnames:ARRAY{IDENT};    -- Type parameter names, if any.
  373.    attr ptypes:ARRAY{$TP};    -- Type parameter values, if any.
  374.    attr is_abs:BOOL;        -- True if in an abstract class.
  375.    attr prog:PROG;        -- The program this is for.
  376.    
  377.    create(same:TP_CLASS, pnames:ARRAY{IDENT}, ptypes:ARRAY{$TP},
  378.           prog:PROG):SAME is
  379.       -- A type context object with the specified attributes.
  380.       r::=new; r.same:=same; r.pnames:=pnames; r.ptypes:=ptypes;
  381.       r.prog:=prog; return r end;
  382.  
  383.    value_of_param(s:IDENT):$TP is
  384.       -- The value of the parameter named by `s'. If `s' doesn't
  385.       -- name a parameter, returns void.
  386.       if void(pnames) then return void end;
  387.       loop i::=pnames.ind!; 
  388.      if s=pnames[i] then return ptypes[i] end end;
  389.       return void end;
  390.    
  391.    tp_of(t:TR_TYPE_SPEC):$TP is
  392.       -- The type object corresponding to the type specifier `t' in
  393.       -- this context. Void if `t' is void. 
  394.       if void(t) then return void end;      
  395.       case t.kind
  396.       when TR_TYPE_SPEC::ord then return tp_class_of(t)
  397.       when TR_TYPE_SPEC::rt then return tp_rout_of(t)
  398.       when TR_TYPE_SPEC::it then return tp_iter_of(t)
  399.       when TR_TYPE_SPEC::same then 
  400.      if is_abs then prog.err_loc(t); 
  401.         prog.err("SAME is not allowed in abstract classes.") end;
  402. --       return same end end;                                                   -- NLP
  403.          return same; end; return void; end;                                    -- NLP
  404.  
  405.    tp_class_of(t:TR_TYPE_SPEC):$TP
  406.       -- The type object corresponding to the class type specifier 
  407.       -- `t' in this context. 
  408.       pre ~void(t) and t.kind=t.ord and void(t.ret) is
  409.       if void(t.params) then 
  410.      pv::=value_of_param(t.name); 
  411.      if ~void(pv) then return pv end; -- A parameter reference. 
  412.      return prog.tp_tbl.tp_class_for(t.name, void) end;
  413.       ptps::=#ARRAY{$TP}(t.params.size);
  414.       tpe::=t.params;
  415.       loop until!(void(tpe)); ptps.set!(tp_of(tpe)); tpe:=tpe.next end;
  416.       return prog.tp_tbl.tp_class_for(t.name, ptps) end;
  417.  
  418.    tp_rout_of(t:TR_TYPE_SPEC):$TP
  419.       -- The type object corresponding to the bound routine type
  420.       -- specifier `t' in this context. 
  421.       pre ~void(t) and t.kind=t.rt is
  422.       if void(t.params) then
  423.      return prog.tp_tbl.tp_rout_for(void, tp_of(t.ret)) end;
  424.       args::=#ARRAY{$TP}(t.params.size);
  425.       tpe::=t.params;
  426.       loop until!(void(tpe)); args.set!(tp_of(tpe)); tpe:=tpe.next end;
  427.       return prog.tp_tbl.tp_rout_for(args, tp_of(t.ret)) end;
  428.  
  429.    tp_iter_of(t:TR_TYPE_SPEC):$TP
  430.       -- The type object corresponding to the bound iter type
  431.       -- specifier `t' in this context. 
  432.       pre ~void(t) and t.kind=t.it is
  433.       if void(t.params) then
  434.      return prog.tp_tbl.tp_iter_for(void, void, tp_of(t.ret)) end;
  435.       args::=#ARRAY{$TP}(t.params.size);
  436.       tpa::=t.params;
  437.       loop until!(void(tpa)); args.set!(tp_of(tpa)); tpa:=tpa.next end; 
  438.       hot::=#ARRAY{BOOL}(args.size);
  439.       tpa:=t.params;
  440.       loop until!(void(tpa)); hot.set!(tpa.is_hot); tpa:=tpa.next end;
  441.       if ~hot.contains(true) then hot:=void end;
  442.       return prog.tp_tbl.tp_iter_for(args, hot, tp_of(t.ret)) end;
  443.  
  444.    type_spec_has_same(t:TR_TYPE_SPEC):BOOL 
  445.       -- True if the type spec `t' contains "SAME".
  446.       pre ~void(t) is
  447.       if t.kind=t.same then return true end;
  448.       p::=t.params;
  449.       loop while!(~void(p));
  450.      if type_spec_has_same(p) then return true end;
  451.      p:=p.next end;
  452.       if type_spec_has_same(t.ret) then return true end;
  453.       return false end;
  454.  
  455.    type_spec_is_param(t:TR_TYPE_SPEC):BOOL 
  456.       -- True if `t' is a type specifier which is just a type 
  457.       -- parameter. 
  458.       pre ~void(t) is
  459.       if t.kind/=t.ord or ~void(t.params) then return false end;
  460.       return pnames.contains(t.name) end;
  461.    
  462. end; -- class TP_CONTEXT
  463.  
  464. -------------------------------------------------------------------
  465. class TP_TBL is
  466.    -- A table of types in a program. This ensures that each type 
  467.    -- is only represented by a single object so that object 
  468.    -- equality can be used to test for type equality.
  469.  
  470.    attr prog:PROG;        -- The program this belongs to.
  471.    attr class_tbl:TP_CLASS_TBL; -- Types defined by classes.
  472.    attr rout_tbl:TP_ROUT_TBL;    -- Bound routine types.
  473.    attr iter_tbl:TP_ITER_TBL;    -- Bound iter types.
  474.  
  475.    create(prog:PROG):SAME is
  476.       -- A table of type for the program `prog'.
  477.       r::=new; r.prog:=prog; return r end;      
  478.  
  479.    tp_class_for(name:IDENT, params:ARRAY{$TP}):TP_CLASS is
  480.       -- Return the class type object for the name `name' and the
  481.       -- parameters (if any) `params'. If this has already been
  482.       -- accessed, return the old object, otherwise create a new
  483.       -- one using the array `params'.
  484.       r::=class_tbl.get_query(#(name,params));
  485.       if void(r) then r:=#(name,params,prog);
  486.      class_tbl:=class_tbl.insert(r) end;
  487.       return r end;
  488.    
  489.    tp_rout_for(args:ARRAY{$TP}, ret:$TP):TP_ROUT is
  490.       -- Return the bound routine type object for the argument
  491.       -- types `args' (if any) and the return type `ret' (if any).
  492.       -- If this has already been accessed, return the old object, 
  493.       -- otherwise create a new one using the array `args'.
  494.       r::=rout_tbl.get_query(#(args,ret));
  495.       if void(r) then r:=#(args,ret,prog);
  496.      rout_tbl:=rout_tbl.insert(r) end;
  497.       return r end;
  498.  
  499.    tp_iter_for(args:ARRAY{$TP}, hot:ARRAY{BOOL}, ret:$TP):TP_ITER is
  500.       -- Return the bound iter type object for the argument
  501.       -- types `args' (if any), marked according to `hot' (if any)
  502.       -- and with return type `ret' (if any). If this has already
  503.       -- been accessed, return the old object, otherwise create a
  504.       -- new one using the arrays `args' and `hot'.
  505.       r::=iter_tbl.get_query(#(args,hot,ret));
  506.       if void(r) then r:=#(args,hot,ret,prog);
  507.      iter_tbl:=iter_tbl.insert(r) end;
  508.       return r end;
  509.    
  510.    test(t:$TP):BOOL is
  511.       -- True if the type `t' is in the table.
  512.       typecase t
  513.       when TP_CLASS then return class_tbl.test(t)
  514.       when TP_ROUT then return rout_tbl.test(t)
  515. --    when TP_ITER then return iter_tbl.test(t) end end;                        -- NLP
  516.       when TP_ITER then return iter_tbl.test(t); end; return false; end;        -- NLP
  517.    
  518.    insert(t:$TP) is
  519.       -- Insert the type `t' into the table. 
  520.       typecase t
  521.       when TP_CLASS then class_tbl:=class_tbl.insert(t)
  522.       when TP_ROUT then rout_tbl:=rout_tbl.insert(t)
  523.       when TP_ITER then iter_tbl:=iter_tbl.insert(t) end end;
  524.  
  525.    delete(t:$TP) is
  526.       -- Delete the type `t' from the table.
  527.       typecase t
  528.       when TP_CLASS then class_tbl:=class_tbl.delete(t)
  529.       when TP_ROUT then rout_tbl:=rout_tbl.delete(t)
  530.       when TP_ITER then iter_tbl:=iter_tbl.delete(t) end end;
  531.    
  532. end; -- class TP_TBL
  533.  
  534. -------------------------------------------------------------------
  535. class TP_CLASS_TBL is
  536.    -- Table of types defined by classes: abstract, reference, 
  537.    -- value, and external types. 
  538.    -- 
  539.    -- `get_query(TUP{IDENT,ARRAY{$TP}}):TP_CLASS' looks up a type.
  540.    -- `test(TP_CLASS):BOOL' tests for a type.   
  541.    -- `insert(TP_CLASS):SAME' inserts a type.
  542.    -- `delete(TP_CLASS):SAME' deletes a type.
  543.    
  544.    include FQSET{TUP{IDENT,ARRAY{$TP}},TP_CLASS};
  545.  
  546.    query_test(q:TUP{IDENT,ARRAY{$TP}}, t:TP_CLASS):BOOL is
  547.       -- True if `t' is the type described by `q'.
  548.       if void(t) then return false end;
  549.       if q.t1/=t.name then return false end;
  550.       if q.t2.size/=t.params.size then return false end;
  551.       loop if q.t2.elt!/=t.params.elt! then return false end end;
  552.       return true end;
  553.  
  554.    query_hash(q:TUP{IDENT,ARRAY{$TP}}):INT is
  555.       -- A hash value computed from the query types.
  556.       s::=3; 
  557.       r::=q.t1.hash;        -- Make depend on name.
  558.       loop s:=s+98; r:=r.bxor(SYS::id(q.t2.elt!)*s) end; -- And on params.
  559.       return r end;
  560.  
  561.    elt_hash(e:TP_CLASS):INT is
  562.       -- Hash on the types in `e'.
  563.       s::=3; 
  564.       r::=e.name.hash;        -- Make depend on name.
  565.       loop s:=s+98; r:=r.bxor(SYS::id(e.params.elt!)*s) end; -- On params.
  566.       return r end;
  567.    
  568. end; -- class TP_CLASS_TBL
  569.  
  570. -------------------------------------------------------------------   
  571. class TP_ROUT_TBL is
  572.    -- Tables of bound routine types.
  573.    -- 
  574.    -- `get_query(TUP{ARRAY{$TP},$TP}):TP_ROUT' look up a type.
  575.    -- `test(TP_ROUT):BOOL' tests for a type.   
  576.    -- `insert(TP_ROUT):SAME' inserts a type.
  577.    -- `delete(TP_ROUT):SAME' deletes a type.
  578.    
  579.    include FQSET{TUP{ARRAY{$TP},$TP}, TP_ROUT};
  580.  
  581.    query_test(q:TUP{ARRAY{$TP},$TP}, t:TP_ROUT):BOOL is
  582.       -- True if `t' is a bound routine with arg and return types as
  583.       -- listed in `q'.
  584.       if void(t) then return false end;
  585.       if void(q.t2) then if ~void(t.ret) then return false end
  586.       elsif q.t2/=t.ret then return false end;
  587.       if q.t1.size/=t.args.size then return false end;
  588.       loop if q.t1.elt!/=t.args.elt! then return false end end;
  589.       return true end;
  590.  
  591.    query_hash(q:TUP{ARRAY{$TP},$TP}):INT is
  592.       -- A hash value computed from the query types.
  593.       s::=3; 
  594.       r::=0;
  595.       if ~void(q.t2) then r:=SYS::id(q.t2); end; -- Make depend on return type.
  596.       loop r:=r.bxor(SYS::id(q.t1.elt!)*s); s:=s+98 end; -- Arg types.
  597.       return r end;
  598.  
  599.    elt_hash(e:TP_ROUT):INT is
  600.       -- Hash on the types in `e'.
  601.       s::=3; 
  602.       r::=0;
  603.       if ~void(e.ret) then r:=SYS::id(e.ret); end;-- Make depend on return type.
  604.       loop r:=r.bxor(SYS::id(e.args.elt!)*s); s:=s+98 end; -- Arg types.
  605.       return r end;
  606.    
  607. end; -- class TP_ROUT_TBL
  608.  
  609. -------------------------------------------------------------------
  610. class TP_ITER_TBL is
  611.    -- Tables of bound iter types.
  612.    -- 
  613.    -- `get_query(TUP{ARRAY{$TP},ARRAY{BOOL},$TP}):TP_ITER' look up a type.
  614.    -- `test(TP_ITER):BOOL' tests for a type.   
  615.    -- `insert(TP_ITER):SAME' inserts a type.
  616.    -- `delete(TP_ITER):SAME' deletes a type.
  617.    
  618.    include FQSET{TUP{ARRAY{$TP},ARRAY{BOOL},$TP}, TP_ITER};
  619.  
  620.    query_test(q:TUP{ARRAY{$TP},ARRAY{BOOL},$TP}, t:TP_ITER):BOOL is
  621.       -- True if `t' is a bound iter with arg types, arg hotness and
  622.       -- return type as listed in `q'.
  623.       if void(t) then return false end;
  624.       if q.t3/=t.ret then return false end;
  625.       if q.t1.size/=t.args.size then return false end;
  626.       loop if q.t1.elt!/=t.args.elt! then return false end end;
  627.       if q.t2.size/=t.hot.size then return false end;      
  628.       loop if q.t2.elt!/=t.hot.elt! then return false end end;
  629.       return true end;
  630.  
  631.    query_hash(q:TUP{ARRAY{$TP},ARRAY{BOOL},$TP}):INT is
  632.       -- A hash value computed from the query types.
  633.       s::=3; 
  634.       r::=SYS::id(q.t3);    -- Make depend on return type.
  635.       loop r:=r.bxor(SYS::id(q.t1.elt!)*s); s:=s+98 end; -- Arg types.
  636.       loop r:=r.bxor(SYS::id(q.t2.elt!)*s); s:=s+98 end; -- Hotness.
  637.       return r end;
  638.  
  639.    elt_hash(e:TP_ITER):INT is
  640.       -- Hash on the types in `e'.
  641.       s::=3; 
  642.       r::=SYS::id(e.ret);    -- Make depend on return type.
  643.       loop r:=r.bxor(SYS::id(e.args.elt!)*s); s:=s+98 end; -- Arg types.
  644.       loop r:=r.bxor(SYS::id(e.hot.elt!)*s); s:=s+98 end; -- Hotness.      
  645.       return r end;
  646.    
  647. end; -- class TP_ITER_TBL
  648.    
  649. -------------------------------------------------------------------
  650. class TP_GRAPH is
  651.    -- Objects which represent Sather type graphs. 
  652.    -- The tables do not explicitly represent the edges between 
  653.    -- bound objects and they separately represent edges due to
  654.    -- "subtype" ("<") and "supertype" (">") clauses. 
  655.  
  656.    attr prog:PROG;
  657.    attr anc:TP_GRAPH_ANC; -- Table of '<' ancestors.
  658.    attr des:TP_GRAPH_DES; -- Table of '>' descendants.
  659.    
  660.    create(prog:PROG):SAME is
  661.       -- A type graph for the program `prog'.
  662.       r::=new; r.prog:=prog; r.anc:=#(prog); r.des:=#(prog);
  663.       return r end;
  664.  
  665.    abs_subtype_test(t:$TP, at:TP_CLASS):BOOL
  666.       -- True if the type `t' is a subtype of the abstract type `at'.
  667.       pre at.is_abstract is
  668.       if t=at or at=prog.tp_builtin.dollar_ob then return true end;
  669.       typecase t 
  670.       when TP_CLASS then 
  671.      if anc.get_anc(t).test(at) then return true end;
  672.       else end;
  673.       if des.get_des(at).test(t) then return true end;
  674.       return false end;
  675.    
  676. end; -- class TP_GRAPH
  677.  
  678. -------------------------------------------------------------------
  679. class TP_GRAPH_ANC is
  680.    -- Table of "<" ancestors for each class type.
  681.    
  682.    attr prog:PROG;        -- The program this table belongs to.   
  683.    attr par_tbl:FMAP{TP_CLASS,FSET{TP_CLASS}}; -- Map from each class 
  684.       -- type to the direct supertypes (from the "<" clause).
  685.    attr anc_tbl:FMAP{TP_CLASS,FSET{TP_CLASS}}; -- Map from each class
  686.       -- type to its ancestors due to "<".
  687.    attr cur:FSET{TUP{IDENT,INT}}; -- The set of type names 
  688.       -- and number of parameters which are in the process of 
  689.       -- determining their ancestors. Used to detect loops.
  690.    
  691.    create(prog:PROG):SAME is
  692.       -- An ancestor table for the program `prog'.
  693.       r::=new; r.prog:=prog; return r end;
  694.    
  695.    get_parents(t:TP_CLASS):FSET{TP_CLASS} is
  696.       -- The set of "<" parents for `t', void if none. Don't modify
  697.       -- the returned list.
  698.       p::=par_tbl.get_pair(t); if ~void(p.t1) then return p.t2 end;
  699.       tr::=prog.tree_head_for(t.name, t.params.size);     
  700.       if void(tr) or void(tr.under) then return void end;
  701.       con::=prog.tp_context_for(t); r:FSET{TP_CLASS};
  702.       ts::=tr.under;
  703.       loop until!(void(ts)); prog.err_loc(ts); tp::=con.tp_of(ts);
  704.      typecase tp
  705.      when TP_CLASS then
  706.         if ~tp.is_abstract then 
  707.            prog.err("In type " + t.str + " the type " + tp.str + 
  708.            " appears in the supertype list but is not abstract.") 
  709.         else r:=r.insert(tp) end;
  710.      else prog.err("In type " + t.str + " the type " + tp.str + 
  711.         " appears in the supertype list but is a bound type.") end;
  712.      ts:=ts.next end;
  713.       par_tbl:=par_tbl.insert(t,r); return r end;
  714.  
  715.    tup_str(t:TUP{IDENT,INT}):STR is
  716.       -- A string for the specified type of the form "FOO{_,_,_}".
  717.       r::=t.t1.str;
  718.       if t.t2=0 then return r end;
  719.       r:=r+"{";
  720.       loop t.t2.times!; r:=r+",".separate!("_") end;
  721.       r:=r+"}"; return r end;
  722.    
  723.    get_anc(t:TP_CLASS):FSET{TP_CLASS} is
  724.       -- The set of "<" ancestors for `t'. Void if none. $OB is not
  725.       -- explicitly included. Do not modify the returned table.      
  726.       -- Reports an error if there is a loop. All returned types 
  727.       -- should be abstract.
  728.       p::=anc_tbl.get_pair(t); if ~void(p.t1) then return p.t2 end;
  729.       par::=get_parents(t); 
  730.       if void(par) then return void end;
  731.       cq::=#TUP{IDENT,INT}(t.name,t.params.size);
  732.       if cur.test(cq) then 
  733.      tr::=prog.tree_head_for(t.name, t.params.size);          
  734.      prog.err_loc(tr); 
  735.      s::=#FSTR + "Subtype cycle detected involving the types: ";
  736.      loop s:=s+", ".separate!(tup_str(cur.elt!)) end;
  737.      prog.err(s.str); 
  738.      anc_tbl:=anc_tbl.insert(t,void); cur:=cur.delete(cq); 
  739.      return void end;
  740.       r:FSET{TP_CLASS}; cur:=cur.insert(cq); 
  741.       loop t2::=par.elt!; 
  742.      r:=r.insert(t2); r:=r.to_union(get_anc(t2)) end;
  743.       anc_tbl:=anc_tbl.insert(t,r); cur:=cur.delete(cq); return r end;
  744.  
  745. end; -- class TP_GRAPH_ANC
  746.    
  747. -------------------------------------------------------------------
  748. class TP_GRAPH_DES is
  749.    -- Table of ">" descendants for each abstract type. 
  750.  
  751.    attr prog:PROG;        -- The program this table belongs to.   
  752.    attr child_tbl:FMAP{TP_CLASS,FSET{$TP}}; -- Map from each abstract
  753.       -- type to any explicit children due to ">".
  754.    attr des_tbl:FMAP{TP_CLASS,FSET{$TP}}; -- Table of ">" descendants 
  755.       -- for each abstract type.   
  756.    attr cur:FSET{TUP{IDENT,INT}}; -- The set of types which are 
  757.       -- in the process of determining their "descendants". Used to
  758.       -- detect loops.
  759.  
  760.    create(prog:PROG):SAME is
  761.       -- A descendant table for the program `prog'.
  762.       r::=new; r.prog:=prog; return r end;
  763.    
  764.    get_children(t:TP_CLASS):FSET{$TP} is
  765.       -- The set of ">" children for `t', void if none. Don't modify
  766.       -- the returned table.
  767.       r:FSET{$TP};
  768.       if ~t.is_abstract then return void end; -- Non-abstract
  769.      -- types don't have explicit subtypes.
  770.       p::=child_tbl.get_pair(t); if ~void(p.t1) then return p.t2 end;
  771.       tr::=prog.tree_head_for(t.name, t.params.size);     
  772.       if void(tr) or void(tr.over) then return void end;
  773.       con::=prog.tp_context_for(t); 
  774.       ts::=tr.over;
  775.       loop until!(void(ts)); prog.err_loc(ts); tp::=con.tp_of(ts);
  776.      typecase tp when TP_CLASS then
  777.         if prog.tp_kind(tp)=TP_KIND::ext_tp then 
  778.            prog.err("The type " + t.str + 
  779.            " lists the external type " +
  780.            tp.str + " in its subtype list.")
  781.         else r:=r.insert(tp) end 
  782.      else r:=r.insert(tp) end;
  783.      ts:=ts.next end;
  784.       child_tbl:=child_tbl.insert(t,r); return r end;
  785.  
  786.    tup_str(t:TUP{IDENT,INT}):STR is
  787.       -- A string for the specified type of the form "FOO{_,_,_}".
  788.       r::=t.t1.str;
  789.       if t.t2=0 then return r end;
  790.       r:=r+"{";
  791.       loop t.t2.times!; r:=r+",".separate!("_") end;
  792.       r:=r+"}"; return r end;
  793.    
  794.    get_des(t:TP_CLASS):FSET{$TP} is
  795.       -- The set of ">" descendants for `t'. Void if none.
  796.       -- Do not modify the returned table. Reports an error if there
  797.       -- is a loop.
  798.       p::=des_tbl.get_pair(t); if ~void(p.t1) then return p.t2 end;
  799.       cld::=get_children(t); if void(cld) then return void end;
  800.       cq::=#TUP{IDENT,INT}(t.name,t.params.size);
  801.       if cur.test(cq) then 
  802.      tr::=prog.tree_head_for(t.name, t.params.size);          
  803.      prog.err_loc(tr); 
  804.      s::=#FSTR + "Supertype cycle detected involving the types with "
  805.      "the following names and number of parameters: ";
  806.      loop s:=s+", ".separate!(tup_str(cur.elt!)) end;
  807.      prog.err(s.str); 
  808.      des_tbl:=des_tbl.insert(t,void); cur:=cur.delete(cq); 
  809.      return void end;
  810.       r:FSET{$TP}; cur:=cur.insert(cq); 
  811.       loop t2::=cld.elt!; 
  812.      r:=r.insert(t2); 
  813.      typecase t2
  814.      when TP_CLASS then r:=r.to_union(get_des(t2))
  815.      else end end;
  816.       des_tbl:=des_tbl.insert(t,r); cur:=cur.delete(cq); return r end;
  817.    
  818. end; -- class TP_GRAPH_DES
  819.  
  820. -------------------------------------------------------------------
  821. class TP_GRAPH_ABS_DES is
  822.    -- Table of all concrete descendants of abstract types. 
  823.    
  824.    attr prog:PROG;        -- The program this table belongs to.   
  825.    attr tbl:FMAP{TP_CLASS,FSET{$TP}}; -- Table of concrete descendants 
  826.       -- of each abstract type.   
  827.  
  828.    create(prog:PROG):SAME is
  829.       -- Compute an abstract descendant table for the program `prog', 
  830.       -- from the explicit ancestor and descendant tables `anc' and
  831.       -- `des'.
  832.       r::=new; r.prog:=prog; return r end;
  833.    
  834.    do_tbl is
  835.       -- Compute the table assuming that `prog.tp_graph' and 
  836.       -- `prog.find_types' are done.
  837.       do_dollar_ob; do_anc; do_des end;
  838.    
  839.    do_dollar_ob is
  840.       -- Put in all concrete types under $OB.
  841.       dob:TP_CLASS:=prog.tp_builtin.dollar_ob;
  842.       tt:FSET{$TP}:=prog.prog_find_types.tp_done;
  843.       if void(tt) then return end;
  844.       loop tp::=tt.elt!; 
  845.      if ~tp.is_abstract then add(dob,tp) end end end;
  846.       
  847.    do_anc is
  848.       -- Put entries in the table based on the subtype edges.
  849.       loop p::=prog.tp_graph.anc.anc_tbl.pairs!; 
  850.      if ~p.t1.is_abstract then
  851.         loop add(p.t2.elt!,p.t1) end end end end; 
  852.    
  853.    do_des is
  854.       -- Put entries in the table based on the supertype edges.
  855.       loop p::=prog.tp_graph.des.des_tbl.pairs!; 
  856.      loop ct::=p.t2.elt!;
  857.         if ~ct.is_abstract then add(p.t1,ct) end end end end;
  858.  
  859.    add(at:TP_CLASS,ct:$TP) is
  860.       -- Add the concrete type `ct' as one of the descendants of the
  861.       -- abstract type `at'.
  862.       s::=tbl.get(at); s:=s.insert(ct); tbl:=tbl.insert(at,s) end;
  863.       
  864.    des_of(tp:TP_CLASS):FSET{$TP} is
  865.       -- A table of the concrete descendants of the abstract type
  866.       -- `tp'. Void if none.
  867.       return tbl.get(tp) end;
  868.    
  869. end; -- class TP_GRAPH_ABS_DES
  870.    
  871. -------------------------------------------------------------------
  872. class TP_BUILTIN is
  873.    -- Cache for quick access to the type objects for builtin types.
  874.  
  875.    attr dollar_ob, bool, char, int, inti, flt, fltd, fltx, fltdx, flti,
  876.       str, sys, ext_ob, dollar_rehash, arr_of_str:TP_CLASS;
  877.    attr rout:TP_ROUT;
  878.       -- The type objects representing the named types.
  879.  
  880.    create(prog:PROG):SAME is
  881.       -- A table of builtin types for the program `prog'.
  882.       t:TP_TBL:=prog.tp_tbl;
  883.       r::=new;
  884.       r.dollar_ob:=t.tp_class_for(prog.ident_for("$OB"),void);
  885.       r.bool:=t.tp_class_for(prog.ident_for("BOOL"),void);      
  886.       r.char:=t.tp_class_for(prog.ident_for("CHAR"),void);            
  887.       r.int:=t.tp_class_for(prog.ident_for("INT"),void);         
  888.       r.inti:=t.tp_class_for(prog.ident_for("INTI"),void);   
  889.       r.flt:=t.tp_class_for(prog.ident_for("FLT"),void);   
  890.       r.fltd:=t.tp_class_for(prog.ident_for("FLTD"),void);   
  891.       r.fltx:=t.tp_class_for(prog.ident_for("FLTX"),void);   
  892.       r.fltdx:=t.tp_class_for(prog.ident_for("FLTDX"),void);   
  893.       r.flti:=t.tp_class_for(prog.ident_for("FLTI"),void);   
  894.       r.str:=t.tp_class_for(prog.ident_for("STR"),void);   
  895.       r.sys:=t.tp_class_for(prog.ident_for("SYS"),void);   
  896.       r.ext_ob:=t.tp_class_for(prog.ident_for("EXT_OB"),void);
  897.       r.dollar_rehash:=t.tp_class_for(prog.ident_for("$REHASH"),void);
  898.       r.rout:=t.tp_rout_for(void,void); -- ROUT
  899.       arr:ARRAY{$TP}:=ARRAY{$TP}::create(1); arr[0]:=r.str;
  900.       r.arr_of_str:=t.tp_class_for(prog.ident_for("ARRAY"),arr);
  901.       return r end;
  902.    
  903. end; -- class TP_BUILTIN
  904. -------------------------------------------------------------------
  905.