------------------------->  GNU Sather - sourcefile  <-------------------------
-- Copyright (C) 199x by International Computer Science Institute            --
-- This file is part of the GNU Sather library. It is free software; you may --
-- redistribute  and/or modify it under the terms of the GNU Library General --
-- Public  License (LGPL)  as published  by the  Free  Software  Foundation; --
-- either version 2 of the license, or (at your option) any later version.   --
-- This  library  is distributed  in the  hope that it will  be  useful, but --
-- WITHOUT ANY WARRANTY without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See Doc/LGPL for more details.       --
-- The license text is also available from:  Free Software Foundation, Inc., --
-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA                     --
-------------->  Please email comments to <bug-sather@gnu.org>  <--------------

-----------------------------------------------------------------------
-- REFLECTION -  Version 1.0, by CMF (fleiner@icsi.berkeley.edu)
--                Modified&documented by BAG (gomes@icsi.berkeley.edu)
--  
-- !! DANGER - some of these classes can gravely violate encapsualtion
--     Use at your own risk for extra-linguistic support
--     and not for standard code.
-- 
-- Using the classes below could expose your program to the forces of
-- the dark side, where pointers are untyped and encapsulation is an
-- illusion.  Besides, these functions might disappear from future
-- Sather releaes with neither warning nor apology.  Of the 3 classes
-- below, REFLECT_INCLUDE is least likely to disappear.
-- 
-- They were created by CMF (fleiner@icsi), because they are neat and
-- extremely useful.  Their use (aside from REFLECT_INCLUDE) should
-- probably be confined to tools. Our initial inclination was to not
-- document these classes at all, to discourage usage, but we fear
-- that they are too useful to be ignored.
-- 
-- Of the classes below:
-- REFLECT_INCLUDE may be used in a relatively safe manner
--    to expose the internals of particular classes that include it.
-- REFLECT can be used to break all typesafety and encapsulation.
--       by exposing the internals of any arbitrary classes.
-- META_OBJECT is a wrapper for REFLECT.
-- 
-- Once again: These classes VIOLATE ALL SATHER GUARANTEES and should
-- be used with great care.
-- 
-- -----------------------------------------------------------------
class REFLECT_INCLUDE is
   -- REFLECT_INCLUDE, unlike the other reflection classes, can be used with
   -- relative safety. It is used by inclusion and all its routines
   -- are, by default, private.  
   -- Nevertheless, this is still is an *undocumented language extension*.
   -- Use the compiler option -reflect in order to access these functions.
   -- 
   -- Encapsulation: Its routines *cannot* be used to break the
   -- encapsulation of arbitrary other classes.  However, if a class
   -- chooses to include REFLECT_INCLUDE and make the interface
   -- public, it looses all its encapsulation.  
   -- 
   -- Type-safety: Calling the set_attrib routine inappropriately can
   -- result in run-time type errors (which are currently not
   -- checked), but this is no worse than a typical typecase.  
   -- 
   -- Usage:
   --    class FOO is include REFLECT_INCLUDE;
   --       -- all functions are still private
   -- 
   --    copy: SAME is
   --        res::= new;
   --        loop a:$OB := attrib!;  name: STR := attrib_name!;
   --           typecase a
   --           when $COPY then  res.set_attrib!(a.attrib!); 
   --           else #OUT+"Could not copy:"+name+"\n"; end;
   --         end;
   --         return res;
   --     end;
   -- When used in the above manner, these functions  cannot break the
   -- encapsulation of any *other* classes in the system.
   
   private n_attribs:INT pre ~void(self) is 
	return REFLECT::n_attribs(self); 
   end;
   private attrib_name(i:INT):STR pre ~void(self) is 
	return REFLECT::attrib_name(self,i); 
   end;
   private attrib(i:INT):$OB pre ~void(self) is 
	return REFLECT::attrib(self,i); 
   end;
   private set_attrib(i:INT,n:$OB) pre ~void(self) is 
	REFLECT::set_attrib(self,i,n); 
   end;

   private attrib!:$OB pre ~void(self) is
      loop yield(REFLECT::attrib(self,0.upto!(n_attribs-1))); end;
   end;

   private attrib_name!:STR pre ~void(self) is
      loop yield(REFLECT::attrib_name(self,0.upto!(n_attribs-1))); end;
   end;

   private array_size:INT pre ~void(self) is 
	return REFLECT::array_size(self); 
   end;
   private array_element(i:INT):$OB pre ~void(self) is 
	return REFLECT::array_element(self,i); 
   end;
   private set_array_element(i:INT,n:$OB) pre ~void(self) is 
	REFLECT::set_array_element(self,i,n); 
   end;

end;
-----------------------------------------------------------------------
class REFLECT is
   -- Avoid using this class. Use REFLECT_INCLUDE, instead, if
   -- possible. REFLECT is the most dangerous of the reflection
   -- classes, and permits arbitrary breakage of encapsulation and
   -- type-safety in any class.  It allows you to create, inspect and
   -- modify (including private attributes) objects of any type.
   -- 
   --   "There are wonderous things out here.  Treasures to satiate
   --  your every desire, both subtle and gross"  -- Q ,from Star Trek
   -- 
   -- Warning! This class is *not* part of the specification.
   -- and should *ONLY* be used for writing extra-linguistic tools.
   -- such as debugging or persistance. Not for standard libraries.
   -- 
   -- Usage:
   --    b ::= #FOO; n_attrs_in_b: INT := REFLECT::n_attribs(o)


   create_object(i:INT):$OB pre i/=0 is 
      -- Create a new object whose type tag is "i"
      o:$OB;
      SYS::inlined_C("#o=(OB)create_object(#i,0);");
      return o;
   end;

   create_object(i:INT,asize:INT):$OB pre i/=0 is
      -- Create a new array object of arbitrary type (i specifies the type tag)
      o:$OB;
      SYS::inlined_C("#o=(OB)create_object(#i,#asize);");
      return o;
   end;

   tp_for_str(class_name: STR): INT is
      -- Returns the type tag associated with the class name "class_name"
      -- Returns 0 if no such tag exists (0 is never a valid tag)
      -- This function should be in SYS, but is only possible with the
      -- reflection information
      tp: INT := C_REFLECT::tp_for_str(class_name);
      return tp;
   end;
   
   n_attribs(o:$OB):INT pre ~void(o) is
      -- Return the number of attributes of object"o"
      r:INT;
      SYS::inlined_C("#r=get_attrs(#o);");
      return r;
   end;

   attrib(o:$OB,i:INT):$OB pre ok_attrib(o,i) is
      -- Return the "i" th attribute of object "o"
      r:$OB;
      SYS::inlined_C("#r=(OB)get_attr(#o,#i);");
      return r;
   end;

   attrib_name(o:$OB,i:INT):STR pre ok_attrib(o,i) is
      -- Return the name of the "i"th attribute of object "o"
      r:EXT_OB;
      SYS::inlined_C("#r=(void *)get_attr_name(#o,#i);");
      return STR::create_from_c_string(r);
   end;

   set_attrib(o:$OB,i:INT,n:$OB) pre ok_attrib(o,i) is
      -- Set the "i"th attribute of object "o" to "n"
      SYS::inlined_C("set_attr(#o,#i,#n);");
   end;

   array_size(o:$OB):INT pre ~void(o) is
      r:INT;
      SYS::inlined_C("#r=get_array_size(#o);");
      return r;
   end;

   array_element(o:$OB,i:INT):$OB pre ok_array_elt(o,i) is
      r:$OB;
      SYS::inlined_C("#r=(OB)get_array_element(#o,#i);");
      return r;
   end;

   set_array_element(o:$OB,i:INT,n:$OB) pre ok_array_elt(o,i) is
      SYS::inlined_C("set_array_element(#o,#i,#n);");
   end;

   private ok_attrib(ob: $OB, i: INT): BOOL is
      if ~void(ob) then  return i < n_attribs(ob); else return false; end;
   end;

   private ok_array_elt(o: $OB,i: INT): BOOL is
      if ~void(o) then return i < array_size(o) else return false end;
   end;

end;
------------------------------------------------------------------------
class META_OBJECT is
   -- META_OBJECT is another convenient way to obtain the reflection
   -- functionality for an arbitrary object, A, of any type. Instead
   -- of repeatedly providing A as the first argument to the functions
   -- in REFLECT, you can create a META_OBJECT which holds a pointer
   -- to A, and supplies it as the first argument.
   -- Use REFLECT_INCLUDE instead of this class, if possible
   -- 
   -- Warning! This class is *not* part of the language specification.
   -- and should *ONLY* be used for writing extra-linguistic tools.
   -- such as debugging or persistance. Not for standard library code.
   -- 
   -- Usage: 
   --     b ::= #FOO; 
   --     meta_object_for_b := #META_OBJECT(b);
   --     n_attrs_in_b: INT := meta_object_for_b.n_attribs;
   -- 

   
   private include REFLECT;

   readonly attr object:$OB;

   create(o:$OB):SAME is
      r::=new;
      r.object:=o;
      return r;
   end;

   n_attribs:INT pre is_ok is return n_attribs(object); end;
   attrib_name(i:INT):STR pre is_ok is return attrib_name(object,i); end;
   attrib(i:INT):$OB pre is_ok is return attrib(object,i); end;
   set_attrib(i:INT,n:$OB) pre is_ok is set_attrib(object,i,n); end;

   array_size:INT pre is_ok is return array_size(object); end;
   array_element(i:INT):$OB pre is_ok is return array_element(object,i); end;
   set_array_element(i:INT,n:$OB) pre is_ok is 
	set_array_element(object,i,n); 
   end;

   attrib!:$OB pre is_ok is
      loop i::=0.upto!(n_attribs-1); yield(attrib(object,i));  end;
   end;

   attrib_name!:STR pre is_ok is
      loop i::=0.upto!(n_attribs-1); yield(attrib_name(object,i)); end;
   end;

   private is_ok: BOOL is return ~void(self) and ~void(object) end;

end;
-----------------------------------------------------------------------
external class C_REFLECT is
   -- External C class for the reflection routines.

   -- (ben) Shouldn't all those inlined C things be in external routines too?
   -- (Claudio) Yes, but the language interface between C and Sather does
   --           not allow arbitrary Sather objects as arguments.
   
   tp_for_str(s: STR): INT;
   -- Return the tp associated with the string "s"
   -- Returns 0 if no type match is found
   
end;
-----------------------------------------------------------------------
