misc.sa

 
---------------------------> Sather 1.1 source file <--------------------------
-- Copyright (C) International Computer Science Institute, 1994.  COPYRIGHT  --
-- NOTICE: This code is provided "AS IS" WITHOUT ANY WARRANTY and is subject --
-- to the terms of the SATHER LIBRARY GENERAL PUBLIC LICENSE contained in    --
-- the file "Doc/License" of the Sather distribution.  The license is also   --
-- available from ICSI, 1947 Center St., Suite 600, Berkeley CA 94704, USA.  --
--------> Please email comments to sather-bugs@icsi.berkeley.edu. <----------


abstract class $OB 
abstract class $OB is
   -- Just a stub.  Everything subtypes from $OB, but this may not
   -- be explicitly indicated in the compiler/browser type graph
   
end; -- type $OB


class EXT_OB 
class EXT_OB is
   -- External objects.
end; -- class EXT_OB


class CAST{T} 
class CAST{T} is
   -- Narrow down from $OB to type T. A useful substitute for the
   -- one line typecase statement.
   --   Usage:
   --    a: $OB := 3;
   --    b: INT := CAST{INT}::from(a);
   -- 
   
   create: SAME is return new end;
   -- Used to get the class name (won't work with void?)
   
   from(o: $OB): T is 
      -- Cast from o:$OB "o" to be of type T.
      -- Raise the exception CAST_EXC if "o" is not of type T
      -- 
      -- Usage:
      --    a: $OB := 3;
      --    b: INT := CAST{INT}::from(a);
      typecase o 
      when T then return o 
      else raise #CAST_EXC(o,#SAME);   end;
   end;
   
end;


class CAST_EXC < $STR 
class CAST_EXC < $STR is
   -- Exception that is raised when a CAST{T}::from call fails

   readonly attr ob: $OB;
   readonly attr caster: $OB;	-- Mainly so that we can find out the 
   -- class name of the cast for error reporting.
   
   create(ob: $OB,caster: $OB): SAME is
      res ::= new;
      res.ob := ob;
      res.caster := caster;
      return res;
   end;
   
   str: STR is 
      caster_tp::= SYS::tp(caster);
      caster_name::= SYS::str_for_tp(caster_tp);
      res ::= "Typecasing using:"+caster_name+" ";
      if void(ob) then res := res+" attempted to typecase a void object";
      else 
	 ob_tp ::= SYS::tp(ob);
	 ob_classname ::= SYS::str_for_tp(ob_tp);
	 res := res + " tried an invalid typecase from:"+ob_classname;
      end;
      return res;
   end;
   
end;


partial class ID 
partial class ID is
   -- ID is meant to be included by types that wish to provide object 
   -- equality as their natural, immutable
   -- identity relation
      is_eq(arg:$OB):BOOL is return SYS::ob_eq(self,arg) end;
      -- is_lt and hash fail for value types
      is_lt(arg:$OB):BOOL is return SYS::id(self) < SYS::id(arg) end;
      hash:INT is return SYS::id(self).hash end;
   end;
-------------------------------------------------------------------+